0.pre8.103:
[sbcl.git] / contrib / sb-executable / sb-executable.lisp
1 (cl:defpackage :sb-executable
2   (:use :cl :sb-ext :sb-alien)
3   (:export :make-executable :copy-stream)
4   ;; (what else should we be exporting?)
5   )
6
7 (cl:in-package :sb-executable)
8
9 (defvar *stream-buffer-size* 8192)
10 (defun copy-stream (from to)
11   "Copy into TO from FROM until end of the input stream, in blocks of
12 *stream-buffer-size*.  The streams should have the same element type."
13   (unless (subtypep (stream-element-type to) (stream-element-type from))
14     (error "Incompatible streams ~A and ~A." from to))
15   (let ((buf (make-array *stream-buffer-size*
16                          :element-type (stream-element-type from))))
17     (loop
18      (let ((pos (read-sequence buf from)))
19        (when (zerop pos) (return))
20        (write-sequence buf to :end pos)))))
21
22 (defvar *exec-header*
23   "#!/bin/sh --
24 exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (read-line i) (read-line i) (load i) (quit))\" --end-toplevel-options ${1+\"$@\"}
25 ")
26
27 (defun make-executable (output-file fasls
28                         &key (runtime-flags '("--disable-debugger"
29                                               "--userinit /dev/null"
30                                               "--sysinit /dev/null")))
31   "Write an executable called OUTPUT-FILE which can be run from the shell, by 'linking' together code from FASLS.  Actually works by concatenating them and prepending a #! header"
32   (with-open-file (out output-file :direction :output
33                        :element-type '(unsigned-byte 8))
34     (write-sequence (map 'vector #'char-code
35                          (format nil *exec-header* runtime-flags)) out)
36     (dolist (input-file (if (listp fasls) fasls (list fasls)))
37       (with-open-file (in (merge-pathnames input-file
38                                            (make-pathname :type "fasl"))
39                           :element-type '(unsigned-byte 8))
40         (copy-stream in out))))
41   (let* ((out-name (namestring output-file))
42          (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3)))
43     (sb-unix::void-syscall ("chmod" c-string int)
44                            out-name
45                            (logior prot
46                                    (if (logand prot #o400) #o100)
47                                    (if (logand prot  #o40)  #o10)
48                                    (if (logand prot   #o4)   #o1)))))
49                          
50