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)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (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                         initial-function)
  32   "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"
  33   (with-open-file (out output-file
  34                        :direction :output
  35                        :if-exists :supersede
  36                        :element-type '(unsigned-byte 8))
  37     (write-sequence (map 'vector #'char-code
  38                          (format nil *exec-header* runtime-flags
  39                                  (or initial-function 'values))) out)
  40     (dolist (input-file (if (listp fasls) fasls (list fasls)))
  41       (with-open-file (in (merge-pathnames input-file
  42                                            (make-pathname :type "fasl"))
  43                           :element-type '(unsigned-byte 8))
  44         (copy-stream in out))))
  45   (let* (;; FIXME: use OUT as the pathname designator
  46          (out-name (namestring (translate-logical-pathname output-file)))
  47          (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3)))
  48     (if prot
  49         (sb-unix::void-syscall ("chmod" c-string int)
  50                                out-name
  51                                (logior prot
  52                                        (if (logand prot #o400) #o100)
  53                                        (if (logand prot  #o40)  #o10)
  54                                        (if (logand prot   #o4)   #o1)))
  55         (error "stat() call failed"))))
  56
  57 (provide 'sb-executable)