darcs - smoke

1 (in-package :smoke)

3 (defun strip-foreign-libraries-path ()

4 (dolist (library sb-alien::*shared-objects*)

5 (setf (slot-value library 'namestring)

6 (file-namestring (slot-value library 'pathname)))))

8 (defun make-temporary-directory ()

9 (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX")

10 "/")))

12 (defmacro with-temporary-directory ((directory) &body body)

13 "Binds DIRECTORY to the pathname of a temporary directory and executes body:"

14 `(let ((,directory (make-temporary-directory)))

15 (unwind-protect (progn ,@body)

16 (unless (zerop

17 (sb-ext:process-exit-code

18 (sb-ext:run-program "/bin/rm"

19 (list "-r" (namestring ,directory)))))

20 (cerror "ignore"

21 "could not remove temporary directory ~A"

22 ,directory)))))

24 (defun save-image (file-name &rest options &key &allow-other-keys)

25 "Save the lisp image in FILE-NAME."

26 (let ((pid (sb-posix:fork)))

27 (if (= 0 pid)

28 (progn

29 (strip-foreign-libraries-path)

30 (apply #'sb-ext:save-lisp-and-die file-name :executable t

31 options))

32 (sb-posix:waitpid pid 0))))

34 (defun write-shell-wrapper (pathname core-name)

35 (with-open-file (stream pathname :direction :output)

36 (format stream "#!/bin/sh

37 cd `dirname \"$0\"`

38 LD_LIBRARY_PATH=./ exec -a \"$0\" ./~A $@

39 " core-name))

40 (sb-posix:chmod pathname #o0755))

42 (defun makeself (run-directory directory-name file-name label

43 &optional (startup-script "") &rest args)

44 "Make self-extractable archives on Unix

45 http://megastep.org/makeself/"

46 ;; make an absolute pathname sine we change the directory.

47 (let ((file-name (merge-pathnames file-name)))

48 (flet ((arguments (&rest args)

49 (format nil "~{~A ~}" args)))

50 (unless (zerop

51 (sb-ext:process-exit-code

52 (sb-ext:run-program

53 "/bin/sh"

54 (list "-c"

55 (apply #'arguments

56 "cd " (namestring run-directory) " && "

57 "makeself --nox11" (namestring directory-name)

58 (namestring file-name) label

59 startup-script args)))))

60 (error "Create ~A failed." file-name)))))

62 (defun save-bundle (file-name &optional extra-files &rest options &key &allow-other-keys)

63 "Creates a FILE-NAME.tar.bz2 in the current directory.

64 This bundle contains a dumped image, the wrapper libraries and a

65 script to run in. OPTIONS is passed to SB-EXT:SAVE-LISP-AND-DIE."

66 (with-temporary-directory (dir)

67 (let ((bundle-dir (merge-pathnames (make-pathname :directory

68 (list :relative file-name))

69 dir)))

70 (sb-posix:mkdir bundle-dir #o0755)

71 (dolist (library sb-alien::*shared-objects*)

72 (sb-ext:run-program

73 "/bin/cp" (list (namestring (slot-value library 'pathname))

74 (namestring bundle-dir))))

75 (apply #'save-image (namestring (make-pathname :name "sbcl-core"

76 :defaults bundle-dir))

77 options)

78 (write-shell-wrapper (make-pathname :defaults bundle-dir

79 :name "run"

80 :type "sh")

81 "sbcl-core")

82 (dolist (file extra-files)

83 (copy-file file (merge-pathnames bundle-dir file)))

84 (makeself dir bundle-dir file-name "sbcl-bundle"

85 "./run.sh"))))