(in-package :smoke)

(defun strip-foreign-libraries-path ()
  (dolist (library sb-alien::*shared-objects*)
    (setf (slot-value library 'namestring)
          (file-namestring (slot-value library 'pathname)))))

(defun make-temporary-directory ()
  (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX")
                         "/")))

(defmacro with-temporary-directory ((directory) &body body)
  "Binds DIRECTORY to the pathname of a temporary directory and executes body:"
  `(let ((,directory (make-temporary-directory)))
     (unwind-protect (progn ,@body)
       (unless (zerop
                (sb-ext:process-exit-code
                 (sb-ext:run-program "/bin/rm"
                                     (list "-r" (namestring ,directory)))))
         (cerror "ignore"
                 "could not remove temporary directory ~A"
                 ,directory)))))
  
(defun save-image (file-name &rest options &key &allow-other-keys)
  "Save the lisp image in FILE-NAME."
  (let ((pid (sb-posix:fork)))
    (if (= 0 pid)
        (progn
          (strip-foreign-libraries-path)
          (apply #'sb-ext:save-lisp-and-die file-name :executable t
                 options))
        (sb-posix:waitpid pid 0))))

(defun write-shell-wrapper (pathname core-name)
  (with-open-file (stream pathname :direction :output)
   (format stream "#!/bin/sh
cd `dirname \"$0\"`
LD_LIBRARY_PATH=./ exec -a \"$0\" ./~A $@
" core-name))
  (sb-posix:chmod pathname #o0755))

(defun makeself (run-directory directory-name file-name label 
                 &optional (startup-script "") &rest args)
  "Make self-extractable archives on Unix
http://megastep.org/makeself/"
  ;; make an absolute pathname sine we change the directory.
  (let ((file-name (merge-pathnames file-name)))
    (flet ((arguments (&rest args)
             (format nil "~{~A ~}" args)))
      (unless (zerop
               (sb-ext:process-exit-code
                (sb-ext:run-program
                 "/bin/sh"
                 (list "-c"
                       (apply #'arguments
                              "cd " (namestring run-directory) " && "
                              "makeself --nox11" (namestring directory-name)
                              (namestring file-name) label
                              startup-script args)))))
        (error "Create ~A failed." file-name)))))

(defun save-bundle (file-name &optional extra-files &rest options &key &allow-other-keys)
  "Creates a FILE-NAME.tar.bz2 in the current directory.
This bundle contains a dumped image, the wrapper libraries and a
script to run in. OPTIONS is passed to SB-EXT:SAVE-LISP-AND-DIE."
  (with-temporary-directory (dir)
    (let ((bundle-dir (merge-pathnames (make-pathname :directory
                                                      (list :relative file-name))
                                       dir)))
      (sb-posix:mkdir bundle-dir #o0755)
      (dolist (library sb-alien::*shared-objects*)
        (sb-ext:run-program
         "/bin/cp" (list (namestring (slot-value library 'pathname))
                         (namestring bundle-dir))))
      (apply #'save-image (namestring (make-pathname :name "sbcl-core"
                                             :defaults bundle-dir))
                  options)
      (write-shell-wrapper (make-pathname :defaults bundle-dir
                                          :name "run"
                                          :type "sh")
                           "sbcl-core")
      (dolist (file extra-files)
        (copy-file file (merge-pathnames bundle-dir file)))
      (makeself dir bundle-dir file-name "sbcl-bundle"
                "./run.sh"))))