pax_global_header00006660000000000000000000000064125512731510014514gustar00rootroot0000000000000052 comment=7f81ecdac36820b5f249008e0d55f6556d98e780 buildapp-release-1.5.5/000077500000000000000000000000001255127315100147425ustar00rootroot00000000000000buildapp-release-1.5.5/Makefile000066400000000000000000000011071255127315100164010ustar00rootroot00000000000000DESTDIR = /usr/local LISP := sbcl ifeq ($(LISP),sbcl) FLAGS=--noinform --no-userinit --no-sysinit --disable-debugger else FLAGS=--quiet --no-init endif buildapp: command-line.lisp utils.lisp buildapp.lisp dumper.lisp package.lisp $(LISP) $(FLAGS) \ --eval "(require 'asdf)" \ --eval "(push \"$$(pwd)/\" asdf:*central-registry*)" \ --eval "(require 'buildapp)" \ --eval "(buildapp::build-buildapp)" \ --eval "#+sbcl (exit) #+ccl (quit)" clean: rm -f buildapp *~ *.fasl *.lx32fsl install: buildapp install -c -m 555 buildapp ${DESTDIR}/bin/buildapp buildapp-release-1.5.5/README000066400000000000000000000005131255127315100156210ustar00rootroot00000000000000Buildapp is an application for SBCL and CCL that configures and saves an executable Common Lisp image or non-executable core. It was created by Zach Beane and is available under a BSD license; see the file LICENSE for details. For full documentation, see http://www.xach.com/lisp/buildapp/ or doc/index.html. buildapp-release-1.5.5/asdf-files.lisp000066400000000000000000000032161255127315100176520ustar00rootroot00000000000000;;;; asdf-files.lisp (in-package #:buildapp) (defun manifest-file-files (file) "Return a list of all system files contained in FILE. The syntax is one namestring per line. Relative namestrings are resolved relative to the truename of FILE." (let ((truename (truename file))) (remove-if #'null (mapcar (lambda (namestring) (probe-file (merge-pathnames namestring truename))) (file-lines file))))) (defun asdf-path-files (pathname) (directory (merge-pathnames "*.asd" pathname))) (defun asdf-tree-files (pathname) (directory (merge-pathnames "**/*.asd" pathname))) (defun asdf-directive-files (directive-list) "Convert a list of directives to a list of pathnames. No two pathnames in th eresult have the same pathname-name. A directive should be a list of a symbol and a pathname. The directive can be one of :MANIFEST-FILE, :ASDF-PATH, or :ASDF-TREE." (let ((result '()) (table (make-hash-table :test 'equalp))) (flet ((add-files (files) (dolist (file files) (unless (gethash (pathname-name file) table) (setf (gethash (pathname-name file) table) file) (push file result))))) (loop for (directive pathname) in directive-list do (ecase directive (:manifest-file (add-files (manifest-file-files pathname))) (:asdf-path (add-files (asdf-path-files pathname))) (:asdf-tree (add-files (asdf-tree-files pathname))))) (nreverse result)))) buildapp-release-1.5.5/buildapp.asd000066400000000000000000000035251255127315100172400ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; buildapp.asd (asdf:defsystem #:buildapp :description "Buildapp is an application for SBCL and CCL that configures and saves an executable Common Lisp image or non-executable core." :author "Zach Beane " :version "1.5.5" :license "BSD" :serial t :components ((:file "package") (:file "utils") (:file "asdf-files") (:file "dumper") (:file "command-line") (:file "buildapp"))) buildapp-release-1.5.5/buildapp.lisp000066400000000000000000000436551255127315100174500ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; buildapp.lisp (in-package #:buildapp) (defparameter *output-type-pathname* #+sbcl (let* ((runtime-symbol (find-symbol "*RUNTIME-PATHNAME*" '#:sb-ext)) (template (if runtime-symbol (symbol-value runtime-symbol) #p"buildapp"))) (make-pathname :type (pathname-type template))) #+ccl (make-pathname :type #+windows #p"buildapp.exe" #-windows nil) "This pathname is merged with the output parameter to produce the final output executable name. It's meant to automatically include the executable suffix .EXE on Windows.") (defparameter *short-usage* "Usage: buildapp --output OUTPUT-FILE [--flag1 value1 ...] For more usage info, try `buildapp --help' ") (defparameter *usage* (concatenate 'string "Usage: buildapp --output OUTPUT-FILE [--flag1 value1 ...] Required flags: --output OUTPUT-FILE Use OUTPUT-FILE as the name of the executable to create Entry-point flags: --entry NAME Use the function identified by NAME as the executable's toplevel function. Called with " #+sbcl "SB-EXT:*POSIX-ARGV*" #+ccl "(ccl::command-line-arguments)" " as its only argument. If NAME has a colon, it is treated as a package separator, otherwise CL-USER is the implied package. --dispatched-entry DNAME Specify one possible entry function, depending on the name of the file that is used to start the application. The syntax of DNAME is APPLICATION-NAME/ENTRY-NAME. If the name used to start the executable matches APPLICATION-NAME, use ENTRY-NAME as the entry point. This can be used to choose one of many possible entry points by e.g. symlinking names to the application executable. If APPLICATION-NAME is empty, the specified ENTRY-NAME is used as a default if no other application names match. There may be any number of dispatched entry points, but only one default. Action flags: --load FILE Load FILE. CL:*PACKAGE* is bound to the CL-USER package before loading --load-system NAME Load an ASDF system identified by NAME --require NAME Use CL:REQUIRE to load NAME --eval CODE Use CL:EVAL to evaulate CODE. The code is read with CL:READ-FROM-STRING in the CL-USER package There may be any number of load/load-system/require/eval flags. Each is executed in command-line order before creating an executable. Load path flags: --load-path DIRECTORY When handling a --load, search DIRECTORY for files to load --asdf-path DIRECTORY When handling a --load-system, search DIRECTORY for ASDF system files to load --asdf-tree DIRECTORY When handling a --load-system, search DIRECTORY and all its subdirectories for ASDF system files to load --manifest-file FILE When handling a --load-system, read a list of ASDF system file pathnames from FILE as possible matching systems. There may be any number of load-path/asdf-path/asdf-tree/manifest-file flags. They take priority in command-line order. Other flags:" #+sbcl " --compress-core Compress the core or executable; requires configuration support in SBCL" " --core-only Make a core file only, not an executable" #+sbcl " --dynamic-space-size MB Pass a --dynamic-space-size option to SBCL when building; value is megabytes" " --help Show this usage message --logfile FILE Log compilation and load output to FILE" #+sbcl " --sbcl PATH-TO-SBCL Use PATH-TO-SBCL instead of the sbcl program found in your PATH environment variable" #+ccl " --ccl PATH-TO-CCL Use PATH-TO-CCL instead of the ccl program found in your PATH environment variable" " For the latest documentation, see http://www.xach.com/lisp/buildapp/ ")) (define-condition silent-exit-error (error) ()) (defparameter *system-load-output* *standard-output*) (defparameter *logfile-output* (make-broadcast-stream)) (dumpable check-pseudosymbol (defun check-pseudosymbol (package-name symbol-name pretty-name) (let ((package (find-package package-name))) (unless package (error "Entry function ~A package ~A not found" pretty-name package-name)) (let ((symbol (find-symbol symbol-name package))) (unless symbol (error "Entry function ~A not found in package ~A" pretty-name package-name)) (unless (fboundp symbol) (error "Entry function ~A is not fbound" pretty-name)))))) (defun pseudosymbol-check-form (pseudosymbol) `(check-pseudosymbol ,(string-upcase (package-string pseudosymbol)) ,(string-upcase (symbol-string pseudosymbol)) ,(princ-to-string pseudosymbol))) (dumpable debugger (defun dump-file-debugger (condition previous-hook) "The function to call if there are errors when loading the dump file." (declare (ignore previous-hook)) (format *system-load-output* "~&Fatal ~A:~% ~A~%" (type-of condition) condition) (print (macroexpand-1 '(backtrace-as-list)) *logfile-output*) #+sbcl (sb-ext:exit :code 111) #+ccl (ccl:quit 111))) (defun command-line-debugger (condition previous-hook) "The function to call if there are errors in the command-line buildapp application." (declare (ignore previous-hook)) (unless (typep condition 'silent-exit-error) (format *error-output* "~&Fatal ~A: ~% ~A~%" (type-of condition) condition) (when (typep condition 'command-line-error) (terpri *error-output*) (write-string *short-usage* *error-output*))) (print (backtrace-as-list) *logfile-output*) (quit 1)) (dumpable asdf-ops (progn (defun system-search-table (&rest pathnames) (let ((table (make-hash-table :test 'equalp))) (dolist (pathname pathnames table) (setf (gethash (pathname-name pathname) table) (probe-file pathname))))) (defvar *asdf-systems-table*) (defun system-search-function (name) (gethash name *asdf-systems-table*)) (defun load-system (name) "Load ASDF system identified by NAME." (let ((*standard-output* *logfile-output*) (*error-output* *logfile-output*) (*compile-verbose* t) (*compile-print* t)) (handler-bind ((warning (lambda (condition) (when *compile-file-truename* (unless (typep condition 'style-warning) (error "Compilation failed: ~A in ~A" condition *compile-file-truename*)))))) (format *system-load-output* ";; loading system ~S~%" name) (asdf:oos 'asdf:load-op name) t))) )) (dumpable file-ops (progn (defparameter *load-search-paths* (list *default-pathname-defaults*)) (defun load-file (file) "Search for FILE in *LOAD-SEARCH-PATHS* and, if found, load it. If an exact filename is not found, file.lisp is also tried." (dolist (path *load-search-paths*) ;; Try the exact name first, .lisp second (let* ((p1 (merge-pathnames file path)) (p2 (merge-pathnames (make-pathname :type "lisp" :defaults file) path)) (truename (or (probe-file p1) (probe-file p2)))) (when truename (format *system-load-output* ";; loading file ~S~%" truename) (return-from load-file (let ((*standard-output* *logfile-output*) (*package* (find-package '#:cl-user))) (load truename :verbose t :print t)))))) (error "File ~S not found" file)))) (defun dumper-action-forms (dumper) "Return a list of forms to implement DUMPER's actions, i.e. the --load, --load-system, --require, and --eval arguments." (loop for (type object) in (reverse (actions dumper)) collect (ecase type (:eval `(eval (let ((*package* (find-package '#:cl-user))) (read-from-string ,object)))) (:load `(load-file ,object)) (:load-system `(load-system ,object)) (:require `(require ',(make-symbol (string-upcase object))))))) (defun invoke-debugger-hook-wrapper (form) `(let ((previous-hook #+sbcl sb-ext:*invoke-debugger-hook* #+ccl ccl::*debugger-hook*) #+sbcl (sb-ext:*invoke-debugger-hook* sb-ext:*invoke-debugger-hook*) #+ccl (ccl::*debugger-hook* ccl::*debugger-hook*)) (progn ,form) #+sbcl (unless (eql sb-ext:*invoke-debugger-hook* previous-hook) (setf *post-invoke-debugger-hook* sb-ext:*invoke-debugger-hook*)) #+ccl (unless (eql ccl::*debugger-hook* previous-hook) (setf *post-invoke-debugger-hook* ccl::*debugger-hook*)))) (defun dumper-action-form (dumper) (let ((forms (mapcar 'invoke-debugger-hook-wrapper (dumper-action-forms dumper)))) `(let ((*package* (find-package "CL-USER"))) ,@forms))) (defun dumpfile-forms (dumper) "Return a list of forms to be saved to a dumpfile." (let* ((package (package dumper)) (output (merge-pathnames (output dumper) *output-type-pathname*)) (entry-function-form (entry-function-form dumper)) (asdf (needs-asdf-p dumper))) `((cl:defpackage ,package (:use #:cl)) (cl:in-package ,package) (defparameter *post-invoke-debugger-hook* nil) (defparameter *system-load-output* *standard-output*) (defvar *logfile-output*) ,(dump-form 'debugger) (setf #+sbcl sb-ext:*invoke-debugger-hook* #+ccl ccl::*debugger-hook* 'dump-file-debugger) ,@(if (logfile dumper) `((defparameter *logfile-output* (open ,(logfile dumper) :direction :output :if-exists :supersede)) (setf *system-load-output* (make-broadcast-stream *standard-output* *logfile-output*))) '((defparameter *logfile-output* (make-broadcast-stream)))) ;; Check that S-L-A-D will work as needed #+sbcl (unless (find-symbol "SAVE-RUNTIME-OPTIONS" '#:sb-impl) (error "This SBCL, ~A, does not support :SAVE-RUNTIME-OPTIONS" (lisp-implementation-version))) ,@(when (compress-core dumper) `((unless (member :sb-core-compression *features*) (error "This SBCL does not support core compression")))) ;; Check for writability to the output file (with-open-file (stream ,(output dumper) :direction :output :if-does-not-exist :create :if-exists :append) (write-line "buildapp write check" stream)) (delete-file ,(output dumper)) ,@(when asdf `((require '#:asdf) ,(dump-form 'asdf-ops) (setf *asdf-systems-table* (system-search-table ,@(asdf-system-files dumper))) (push 'system-search-function asdf:*system-definition-search-functions*))) ,(dump-form 'file-ops) ,@(mapcar (lambda (path) `(push ,(directorize path) *load-search-paths*)) (load-paths dumper)) ,(dumper-action-form dumper) ,@(when entry-function-form (list (dump-form 'check-pseudosymbol) (entry-function-check-form dumper))) (ignore-errors (close *logfile-output*)) ;; Remove buildapp artifacts from the system (setf #+sbcl sb-ext:*invoke-debugger-hook* #+ccl ccl::*debugger-hook* *post-invoke-debugger-hook*) ,@(when asdf '((setf asdf:*system-definition-search-functions* (remove 'system-search-function asdf:*system-definition-search-functions*)))) (in-package #:cl-user) (delete-package ',package) #+sbcl (sb-ext:gc :full t) #+ccl (ccl:gc) #+sbcl (sb-ext:save-lisp-and-die ,output ,@(unless (core-only dumper) '(:executable t :save-runtime-options t)) ,@(when (compress-core dumper) '(:compression t)) ,@(when entry-function-form (list :toplevel entry-function-form))) #+ccl (ccl:save-application ,output ;; currently :native may not be supplied with :prepend-kernel ,@(unless (core-only dumper) '(:prepend-kernel t)) ,@(when entry-function-form (list :toplevel-function entry-function-form)) :purify t ;; The :application-class option must be supplied for the ;; :error-handler option to have any effect. See ;; http://trac.clozure.com/ccl/ticket/1039. :application-class 'ccl::application :error-handler :quit)))) (defun write-dumpfile (dumper stream) (with-standard-io-syntax (let ((*print-case* :downcase) (*package* (find-package '#:buildapp))) (dolist (form (dumpfile-forms dumper)) (print form stream))))) (defun dump-to-file (dumper file) "Save the forms of DUMPER to FILE." (with-open-file (stream file :direction :output :if-exists :supersede) (let ((*print-case* :downcase)) (write-dumpfile dumper stream)))) (defun main (argv) "Create an executable from the command-line arguments provided in ARGV. See *USAGE* for details." (when (string-equal (second argv) "--help") (write-string *usage* *standard-output*) (quit)) (let* ((dumper (command-line-dumper (rest argv))) (*package* (find-package :buildapp)) #+sbcl (dynamic-space-size (dynamic-space-size dumper))) (with-tempfile (stream ("dumper.lisp" file)) (write-dumpfile dumper stream) (force-output stream) (when (dumpfile-copy dumper) (copy-file file (dumpfile-copy dumper))) (let ((process (run-program #+sbcl (sbcl dumper) #+ccl (ccl dumper) (flatten (list #+sbcl (when dynamic-space-size (list "--dynamic-space-size" (princ-to-string dynamic-space-size))) #+sbcl "--noinform" #+ccl "--quiet" #+sbcl "--disable-debugger" #+sbcl "--no-userinit" #+sbcl "--no-sysinit" #+ccl "--no-init" "--load" (native-namestring (probe-file file))))))) (if (zerop #+sbcl (sb-ext:process-exit-code process) #+ccl (ccl::external-process-%exit-code process)) (probe-file (output dumper)) (error 'silent-exit-error)))))) (defun build-buildapp (&optional (executable "buildapp")) (let ((full-output (merge-pathnames executable))) (main (list "sbcl" "--asdf-path" (native-namestring (asdf:system-relative-pathname :buildapp "./")) "--load-system" "buildapp" "--entry" "buildapp:main" "--output" (native-namestring full-output))))) (defun buildapp-init () (setf #+sbcl sb-ext:*invoke-debugger-hook* #+ccl ccl::*debugger-hook* 'command-line-debugger)) #+sbcl (pushnew 'buildapp-init sb-ext:*init-hooks*) buildapp-release-1.5.5/command-line.lisp000066400000000000000000000142561255127315100202060ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; command-line.lisp (in-package #:buildapp) (define-condition command-line-error (error) ()) (define-condition odd-number-of-arguments (command-line-error) () (:report "Odd number of arguments -- all arguments are in \"--flag value\" pairs")) (define-condition provided-argument-error (command-line-error) ((flag :initarg :flag :accessor argument-error-flag) (description :initarg :description :accessor argument-error-description) (extra-info :initarg :extra-info :accessor argument-error-extra-info)) (:default-initargs :flag nil :description "Argument error on" :extra-info nil) (:report (lambda (condition stream) (format stream "~A ~A~@[~A~]" (argument-error-description condition) (argument-error-flag condition) (argument-error-extra-info condition))))) (define-condition required-argument-missing (provided-argument-error) () (:default-initargs :description "Required argument" :extra-info " not provided")) (define-condition unknown-argument (provided-argument-error) () (:default-initargs :description "Unknown argument")) (define-condition missing-output-argument (required-argument-missing) () (:default-initargs :flag "--output")) (define-condition duplicate-argument (provided-argument-error) () (:default-initargs :description "Duplicate argument" :extra-info " -- must be provided at most once")) (define-condition duplicate-default-dispatched-entry (duplicate-argument) () (:default-initargs :description "Duplicate default dispatched entry" :extra-info " -- only one default dispatched entry is allowed")) (define-condition entry-and-dispatched-entry (provided-argument-error) () (:report "Cannot specify both --entry and --dispatched-entry")) (defun argument-keyword (argument) "Convert a command-line argument to a keyword symbol." (find-symbol (string-upcase (subseq argument 2)) :keyword)) (defmacro popflag (flag args) (let ((flag- (gensym)) (value (gensym))) `(let ((,flag- ,flag)) (let ((,value (find ,flag- ,args :test 'string-equal))) (when ,value (setf ,args (remove ,flag- ,args :Test 'string-equal)) t))))) (defun command-line-dumper (args) (let ((plan (make-instance 'dumper)) (default-dispatched-entry nil)) (when (popflag "--compress-core" args) (setf (compress-core plan) t)) (when (popflag "--core-only" args) (setf (core-only plan) t)) (when (oddp (length args)) (error 'odd-number-of-arguments)) (loop (when (endp args) (unless (output plan) (error 'missing-output-argument)) (setf (asdf-directives plan) (reverse (asdf-directives plan))) (return plan)) (let* ((argument (pop args)) (value (pop args)) (keyword (argument-keyword argument))) (unless value (error 'missing-argument)) (case keyword ((:load :load-system :require :eval) (push (list keyword value) (actions plan))) ((:manifest-file :asdf-path :asdf-tree) (let ((pathname (probe-file value))) (unless pathname (error "Invalid pathname given to ~A -- ~S" argument value)) (push (list keyword value) (asdf-directives plan)))) (:load-path (push value (load-paths plan))) (:output (when (output plan) (error 'duplicate-argument :flag argument)) (setf (output plan) value)) (:logfile (when (logfile plan) (error 'duplicate-argument :flag argument)) (setf (logfile plan) value)) (:dumpfile-copy (setf (dumpfile-copy plan) value)) (:sbcl (when (sbcl plan) (setf (sbcl plan) value))) (:ccl (when (ccl plan) (setf (ccl plan) value))) (:entry (when (dispatched-entries plan) (error 'entry-and-dispatched-entry)) (when (entry plan) (error 'duplicate-argument :flag argument)) (setf (entry plan) (make-pseudosymbol value))) (:dispatched-entry (when (entry plan) (error 'entry-and-dispatched-entry)) (let ((entry (make-dispatched-entry value))) (when (default-entry-p entry) (if default-dispatched-entry (error 'duplicate-default-dispatched-entry :flag (format nil "~A ~A" argument value)) (setf default-dispatched-entry entry))) (push entry (dispatched-entries plan)))) (:dynamic-space-size (setf (dynamic-space-size plan) (parse-integer value))) (t (error 'unknown-argument :flag argument))))))) buildapp-release-1.5.5/doc/000077500000000000000000000000001255127315100155075ustar00rootroot00000000000000buildapp-release-1.5.5/doc/LICENSE000066400000000000000000000025551255127315100165230ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; buildapp-release-1.5.5/doc/index.html000066400000000000000000000452251255127315100175140ustar00rootroot00000000000000 Buildapp - Create executables with SBCL or CCL

Buildapp - Create executables with SBCL or CCL

Buildapp is an application for SBCL or CCL that configures and saves an executable Common Lisp image. It is similar to cl-launch and hu.dwim.build. Buildapp is available under a BSD-style license. The latest version is 1.5.5, released on July 14th, 2015.

Download shortcut: http://www.xach.com/lisp/buildapp.tgz

Contents

Installation

Buildapp does not require any libraries. To compile it with SBCL you simply run make install. To compile with a different lisp, just specify it after the make command: make install LISP=<my_favorite_lisp>. For example, you wanted to compile it under CCL you'd say make install LISP=ccl By default, it is installed in /usr/local/bin; to use another location, use make DESTDIR=/path install.

You can also create the buildapp binary by loading the buildapp system with asdf and running (buildapp:build-buildapp).

Example Use

Here's a small application: 

$ buildapp \
    --eval '(defun main (argv) (declare (ignore argv)) (write-line "Hello, world"))' \
    --entry main \
    --output hello-world
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into hello-world:
writing 6352 bytes from the read-only space at 0x20000000
writing 4064 bytes from the static space at 0x20100000
writing 44834816 bytes from the dynamic space at 0x1000000000
done]

$ ./hello-world
Hello, world

The following creates a toy curl-like application. (It's not quite practical, because any errors will land you in the interactive debugger.) 

$ buildapp --output lisp-curl --asdf-path ~/src/clbuild/systems/ \
    --load-system drakma \
    --eval '(defun main (args) (write-string (drakma:http-request (second args))))' \
    --entry main
;; loading system sb-grovel (needed by drakma)
;;  from /usr/local/lib/sbcl/sb-grovel/
;; loading system sb-posix (needed by cl+ssl)
;;  from /usr/local/lib/sbcl/sb-posix/
;; loading system trivial-gray-streams (needed by chunga, cl+ssl, flexi-streams)
;;  from /home/xach/src/clbuild/source/trivial-gray-streams/
;; loading system flexi-streams (needed by drakma, cl+ssl)
;;  from /home/xach/src/clbuild/source/flexi-streams/
;; loading system alexandria (needed by cffi, babel)
;;  from /home/xach/src/clbuild/source/alexandria/
;; loading system trivial-features (needed by cffi, babel)
;;  from /home/xach/src/clbuild/source/trivial-features/
;; loading system babel (needed by cffi)
;;  from /home/xach/src/clbuild/source/babel/
;; loading system cffi (needed by cl+ssl)
;;  from /home/xach/src/clbuild/source/cffi/
;; loading system cl+ssl (needed by drakma)
;;  from /home/xach/src/clbuild/source/cl+ssl/
;; loading system sb-bsd-sockets (needed by usocket)
;;  from /usr/local/lib/sbcl/sb-bsd-sockets/
;; loading system usocket (needed by drakma)
;;  from /home/xach/src/clbuild/source/usocket/
;; loading system chunga (needed by drakma)
;;  from /home/xach/src/clbuild/source/chunga/
;; loading system cl-base64 (needed by drakma)
;;  from /home/xach/src/clbuild/source/cl-base64/
;; loading system puri (needed by drakma)
;;  from /home/xach/src/clbuild/source/puri/
;; loading system drakma 
;;  from /home/xach/src/clbuild/source/drakma/
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into lisp-curl:
writing 6352 bytes from the read-only space at 0x20000000
writing 5472 bytes from the static space at 0x20100000
writing 61722624 bytes from the dynamic space at 0x1000000000
done]

$ ./lisp-curl http://xach.com/
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"
       "http://www.w3.org/TR/REC-html40/loose.dtd">
<HTML>
<HEAD>
<TITLE>www.xach.com</TITLE>
</HEAD>
...

Here's how the l1sp.org redirection service application is built: 

$ make
buildapp --output l1sp --entry redirector:main \
                 --asdf-path /opt/l1sp/systems \
                 --require sb-aclrepl \
                 --eval '(pushnew :hunchentoot-no-ssl *features*)' \
                 --load-system swank \
                 --eval '(setf swank:*log-output* nil)' \
                 --load-system redirector
;; loading system sb-grovel
;;  from /usr/local/lib/sbcl/sb-grovel/
;; loading system sb-bsd-sockets
;;  from /usr/local/lib/sbcl/sb-bsd-sockets/
;; loading system sb-introspect
;;  from /usr/local/lib/sbcl/sb-introspect/
;; loading system sb-posix
;;  from /usr/local/lib/sbcl/sb-posix/
;; loading system sb-cltl2
;;  from /usr/local/lib/sbcl/sb-cltl2/
;; loading system swank
;;  from /opt/l1sp/src/slime/
;; loading system html-template (needed by redirector)
;;  from /opt/l1sp/src/html-template-0.9.1/
;; loading system sb-rotate-byte (needed by sb-md5)
;;  from /usr/local/lib/sbcl/sb-rotate-byte/
;; loading system sb-md5 (needed by redirector)
;;  from /usr/local/lib/sbcl/sb-md5/
;; loading system cl-who (needed by redirector)
;;  from /opt/l1sp/src/cl-who-0.11.1/
;; loading system cl-ppcre (needed by hunchentoot, redirector)
;;  from /opt/l1sp/src/cl-ppcre-2.0.0/
;; loading system url-rewrite (needed by hunchentoot)
;;  from /opt/l1sp/src/url-rewrite-0.1.1/
;; loading system rfc2388 (needed by hunchentoot)
;;  from /opt/l1sp/src/rfc2388/
;; loading system md5 (needed by hunchentoot)
;;  from /opt/l1sp/src/md5-1.8.5/
;; loading system cl-fad (needed by hunchentoot)
;;  from /opt/l1sp/src/cl-fad-0.6.2/
;; loading system cl-base64 (needed by hunchentoot)
;;  from /opt/l1sp/src/cl-base64-3.3.2/
;; loading system trivial-gray-streams (needed by flexi-streams)
;;  from /opt/l1sp/src/trivial-gray-streams-2006-09-16/
;; loading system flexi-streams (needed by chunga)
;;  from /opt/l1sp/src/flexi-streams-1.0.7/
;; loading system chunga (needed by hunchentoot)
;;  from /opt/l1sp/src/chunga-0.4.3/
;; loading system hunchentoot (needed by redirector)
;;  from /opt/l1sp/src/hunchentoot-0.15.7/
;; loading system redirector
;;  from /opt/l1sp/src/redirector/
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into l1sp:
writing 6176 bytes from the read-only space at 0x20000000
writing 4064 bytes from the static space at 0x20100000
writing 61042688 bytes from the dynamic space at 0x1000000000
done]

$ ./l1sp
;; Swank started at port: 7717.
CL-USER(1):

The (setf swank:*log-output* nil) eval is needed to avoid problems when the image restarts.

redirector::main looks like this: 

(defun main (argv)
  (declare (ignore argv))
  (load "/opt/l1sp/etc/init.lisp")
  (sb-impl::toplevel-repl nil))

Here's an example of the --dispatched-entry option, which was inspired by the desire to have a dozen different small utilities embedded in one big executable and called based on the binary name. First, the support files: 

;;;; utils.lisp

(defpackage #:utils
  (:use #:cl))

(in-package #:utils)

(defun main (argv)
  (let ((name (pathname-name (first argv))))
    (format *error-output*
            "Unknown binary name ~S, try using cl-echo, cl-ls, or cl-true~%"
            name)
    (sb-ext:quit :unix-status 1)))

;;;; ls.lisp

(defpackage #:ls
  (:use #:cl))

(in-package #:ls)

(defun main (argv)
  (declare (ignore argv))
  (dolist (file (directory "*.*"))
    (write-line (namestring file))))

;;;; echo.lisp

(defpackage #:echo
  (:use #:cl))

(in-package #:echo)

(defun main (argv)
  (format t "~{~A~^ ~}~%" (rest argv)))

;;;; true.lisp

(defpackage #:true
  (:use #:cl))

(in-package #:true)

(defun main (argv)
  (declare (ignore argv))
  (sb-ext:quit :unix-status 0))

Buliding it all together looks like this: 

$ buildapp --output utils \
   --load utils.lisp --dispatched-entry /utils:main \
   --load ls.lisp --dispatched-entry cl-ls/ls:main \
   --load echo.lisp --dispatched-entry cl-echo/echo:main \
   --load true.lisp --dispatched-entry cl-true/true:main
;; loading file #P"/tmp/demo/utils.lisp"
;; loading file #P"/tmp/demo/ls.lisp"
;; loading file #P"/tmp/demo/echo.lisp"
;; loading file #P"/tmp/demo/true.lisp"
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into utils:
writing 6352 bytes from the read-only space at 0x20000000
writing 4064 bytes from the static space at 0x20100000
writing 45223936 bytes from the dynamic space at 0x1000000000
done]

$ ln -sf utils cl-ls

$ ln -sf utils cl-echo

$ ln -sf utils cl-true

$ ./cl-ls
/tmp/demo/cl-true
/tmp/demo/echo.lisp
/tmp/demo/ls.lisp
/tmp/demo/true.lisp
/tmp/demo/utils
/tmp/demo/utils.lisp

$ ./cl-echo Hello world
Hello world

$ ./cl-true && echo $?
0

Overview

Here is the usage output of buildapp: 

Usage: buildapp --output OUTPUT-FILE [--flag1 value1 ...]

Required flags:
  --output OUTPUT-FILE      Use OUTPUT-FILE as the name of the executable
                              to create

Entry-point flags:
  --entry NAME              Use the function identified by NAME as the
                              executable's toplevel function. Called
                              with SB-EXT:*POSIX-ARGV* as its only
                              argument. If NAME has a colon, it is
                              treated as a package separator,
                              otherwise CL-USER is the implied
                              package.
  --dispatched-entry DNAME  Specify one possible entry function, depending
                              on the name of the file that is used to
                              start the application. The syntax of
                              DNAME is APPLICATION-NAME/ENTRY-NAME. If the
                              name used to start the executable matches
                              APPLICATION-NAME, use ENTRY-NAME as the
                              entry point. This can be used to choose
                              one of many possible entry points by
                              e.g. symlinking names to the application
                              executable. If APPLICATION-NAME is empty, the
                              specified ENTRY-NAME is used as a default
                              if no other application names match. There
                              may be any number of dispatched entry points,
                              but only one default.

Action flags:
  --load FILE               Load FILE. CL:*PACKAGE* is bound to the CL-USER
                              package before loading
  --load-system NAME        Load an ASDF system identified by NAME
  --require NAME            Use CL:REQUIRE to load NAME
  --eval CODE               Use CL:EVAL to evaulate CODE. The code is read
                              with CL:READ-FROM-STRING in the CL-USER package

There may be any number of load/load-system/require/eval flags. Each
is executed in command-line order before creating an executable.

Load path flags:
  --load-path DIRECTORY     When handling a --load, search DIRECTORY for
                              files to load
  --asdf-path DIRECTORY     When handling a --load-system, search DIRECTORY
                              for ASDF system files to load
  --asdf-tree DIRECTORY     When handling a --load-system, search DIRECTORY
                              and all its subdirectories for ASDF system
                              files to load
  --manifest-file FILE      When handling a --load-system, read a list of
                              ASDF system file pathnames from FILE as
                              possible matching systems.

There may be any number of load-path/asdf-path/asdf-tree/manifest-file
flags. They take priority in command-line order.

Other flags:
  --compress-core           Compress the core or executable; requires
                              configuration support in SBCL
  --core-only               Make a core file only, not an executable
  --dynamic-space-size MB   Pass a --dynamic-space-size option to SBCL
                              when building; value is megabytes
  --help                    Show this usage message
  --logfile FILE            Log compilation and load output to FILE
  --sbcl PATH-TO-SBCL       Use PATH-TO-SBCL instead of the sbcl program
                              found in your PATH environment variable

For the latest documentation, see http://www.xach.com/lisp/buildapp/

Limitations

Buildapp is limited in scope. It aims to make the following steps easy:

  • Define an application environment by loading files, loading ASDF systems, evaluating code, and using CL:REQUIRE
  • Dump an executable image with an arbitrary startup function

By design, it does not handle the following tasks:

Implementation

Buildapp works like this:

  1. It processes the command-line and creates an object that captures the command-line requirements: the output file, any eval/load/load-system/require actions, the entry function, etc.
  2. It creates a new Lisp file (the dumpfile) with all the commands needed to implement the command-line options.
  3. It runs either "sbcl" with sb-ext:run-program or "ccl" with ccl:run-program. In either case lisp is invoked with no init files (it doesn't read user or system rc files) and loads the dumpfile:
    1. The first few commands of the dumpfile establish a specialized loading environment:
      • The debugger is changed with *invoke-debugger-hook* to simply quit with a special exit code instead of entering the normal debugger (in CCL the same behavior is accomplished using the :application and :error-handler arguments to ccl:save-application)
      • Most output (ASDF system compilation output, low-level error messages, etc) is redirected to a log stream; that stream can be directed to a file with the --logfile argument
      • Stale compiled files are automatically recompiled with an :around method on asdf:perform
    2. There are some sanity checks: Is the output file writable? Does this version of sbcl support the required :save-runtime-options argument?
    3. The dumpfile performs the eval/load/load-system/require actions. Each operation is evaluated in the cl-user package and with a fresh binding of sb-ext:*invoke-debugger-hook* in sbcl or ccl::*debugger-hook* in ccl to the buildapp debugger function. If the binding is modified, the new value is saved.
    4. The dumpfile clears itself out of the environment:
      • Remove extra ASDF methods with remove-method
      • Reset the debugger hook to the saved value or NIL if no value was saved.
      • Delete the dumpfile package with delete-package
    5. The dumpfile then creates an executable with save-lisp-and-die in sbcl or ccl:save-application in ccl. This ends the lisp subprocess.
  4. It deletes the dumpfile.

The ASDF central registry is temporarily extended with the --asdf-path and --asdf-tree arguments at load time, and reverts back to the default central registry value after that. To avoid conflicts with this behavior, changes to the central registry should be done at startup time instead of application load time.

Feedback

If you have any questions or comments about buildapp, please email me, Zach Beane.

License

Copyright © 2010 Zachary Beane, All Rights Reserved

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

  • Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
  • Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. buildapp-release-1.5.5/doc/style.css000066400000000000000000000022201255127315100173550ustar00rootroot00000000000000#content { max-width: 50em; margin-left: auto; margin-right: auto; font-family: sans-serif; line-height: 1.4em; background-color: white; padding: 0.25em 1em 0.25em 1em; } body { background-color: #f4eecf; } p.copyright { font-size: 75%; font-weight: bold; } h2, h3 { //margin-bottom: 0em; //margin-top: 2em; } p.html { margin-left: 1em; font-family: monospace; } .type { color: #999; } .signature { color: #A01; margin-left: 1em; } .signature span.result { color: black; } .signature code.llkw { font-family: monospace; } .signature span.result var { color: #A01; } div.signature { margin-left: 1.5em; text-indent: -1.5em; } .signature code.name { font-weight: bold; } .signature code { font-family: sans-serif; } blockquote.description { margin-left: 1em; } a[href] { text-decoration: none; border-bottom: dotted 1px #CCC; color: #600; } a:hover[href] { text-decoration: none; border-bottom: solid 1px #F00; color: #F00; } pre.code { border: solid 1px #DDD; padding: 0.5em; background: #EEE; } #summary { padding-left: 2em; } buildapp-release-1.5.5/dumper.lisp000066400000000000000000000121231255127315100171260ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; dumper.lisp (in-package #:buildapp) (defclass dumper () ((package :initarg :package :accessor package :initform (gensym "DUMPER")) (actions :initarg :actions :accessor actions :initform nil) (entry :initarg :entry :accessor entry :initform nil) (dispatched-entries :initarg :dispatched-entries :accessor dispatched-entries :initform nil) (asdf-directives :initarg :asdf-directives :accessor asdf-directives :initform nil) (load-paths :initarg :load-paths :accessor load-paths :initform nil) (sbcl :initarg :sbcl :accessor sbcl :initform "sbcl") (ccl :initarg :ccl :accessor ccl :initform "ccl") (output :initarg :output :accessor output :initform nil) (logfile :initarg :logfile :accessor logfile :initform nil) (dumpfile-copy :initarg :dumpfile-copy :accessor dumpfile-copy :initform nil) (core-only :initarg :core-only :accessor core-only :initform nil) (compress-core :initarg :compress-core :accessor compress-core :initform nil) (dynamic-space-size :initarg :dynamic-space-size :accessor dynamic-space-size :initform nil))) (defgeneric needs-asdf-p (dumper) (:method (dumper) (or (find :load-system (actions dumper) :key 'first) (asdf-directives dumper)))) (defmethod print-object ((dumper dumper) stream) (print-unreadable-object (dumper stream :type t) (format stream "~A~@[ ~A~]" (output dumper) (entry dumper)))) (defgeneric asdf-system-files (dumper) (:method (dumper) (asdf-directive-files (asdf-directives dumper)))) (defun dispatched-entry-form (dispatched-entries) (let ((default nil)) (flet ((one-clause (entry) (let* ((binary-name (binary-name entry)) (entry-function (entry entry)) (call `(,entry-function ,(get-args)))) (if (default-entry-p entry) (progn (setf default entry) nil) (list `((string= binary-name ,binary-name) (return ,call))))))) `(with-simple-restart (abort "Exit application") (lambda () (block nil (let ((binary-name (pathname-name (pathname (first ,(get-args)))))) (cond ,@(mapcan #'one-clause dispatched-entries)) ,@(if default (list `(,(entry default) ,(get-args))) (list `(format *error-output* "Unknown dispatch name '~A', quitting~%" binary-name) (macroexpand-1 (quit 1))))))))))) (defgeneric entry-function-form (dumper) (:method (dumper) (cond ((entry dumper) `(lambda () (with-simple-restart (abort "Exit application") (,(entry dumper) ,(get-args))))) ((dispatched-entries dumper) (dispatched-entry-form (dispatched-entries dumper)))))) (defgeneric entry-function-check-form (dumper) (:method (dumper) (cond ((entry dumper) (pseudosymbol-check-form (entry dumper))) ((dispatched-entries dumper) `(progn ,@(mapcar (lambda (dentry) (pseudosymbol-check-form (entry dentry))) (dispatched-entries dumper))))))) ;;; Dumpable forms are both evaluated and saved away for later use in ;;; the dumper file. (defparameter *dumpable-forms* (make-hash-table)) (defmacro dumpable (name &body body) (assert (not (cdr body))) `(progn (setf (gethash ',name *dumpable-forms*) ',(first body)) ,@body)) (defun dump-form (name) (gethash name *dumpable-forms*)) buildapp-release-1.5.5/package.lisp000066400000000000000000000027641255127315100172370ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; package.lisp (defpackage #:buildapp (:use #:cl) (:shadow #:package) (:export #:build-buildapp)) (in-package #:buildapp) buildapp-release-1.5.5/utils.lisp000066400000000000000000000170161255127315100170000ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2010 Zachary Beane, All Rights Reserved ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; ;;;; * Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; * Redistributions in binary form must reproduce the above ;;;; copyright notice, this list of conditions and the following ;;;; disclaimer in the documentation and/or other materials ;;;; provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; utils.lisp (in-package #:buildapp) ;;; interoperability (defun get-args () #+sbcl 'sb-ext:*posix-argv* #+ccl '(ccl::command-line-arguments)) (defmacro backtrace-as-list () #+sbcl '(sb-debug:backtrace-as-list) #+ccl '(ccl::backtrace-as-list)) (defmacro quit (&optional (errno 0)) #+sbcl `(sb-ext:exit :code ,errno) #+ccl `(ccl:quit ,errno)) (defmacro run-program (program args) (let ((func #+sbcl 'sb-ext:run-program #+ccl 'ccl:run-program) (search #+sbcl '(:search t))) `(,func ,program ,args :input nil :output *standard-output* ,@search))) (defun native-namestring (namestring) (let ((p (pathname namestring))) #+sbcl (sb-ext:native-namestring p) #+ccl (ccl:native-translated-namestring p))) (defparameter *alphabet* (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "0123456789" "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (defun random-string (length) "Return a random string with LENGTH characters." (let ((string (make-string length))) (map-into string (lambda (char) (declare (ignore char)) (aref *alphabet* (random (length *alphabet*)))) string))) (defun call-with-temporary-open-file (template fun &rest open-args &key element-type external-format) "Call FUN with two arguments: an open output stream and a file name. When it returns, the file is deleted. TEMPLATE should be a pathname that can be used as a basis for the temporary file's location." (declare (ignorable element-type external-format)) (flet ((new-name () (make-pathname :name (concatenate 'string (pathname-name template) "-" (random-string 8)) :defaults template))) (let (try stream) (tagbody :retry (setf try (new-name)) (unwind-protect (progn (setf stream (apply #'open try :if-exists nil :direction :output open-args)) (unless stream (go :retry)) (funcall fun stream try)) (when stream (close stream) (ignore-errors (delete-file try)))))))) (defmacro with-tempfile ((stream (template file) &rest open-args) &body body) `(call-with-temporary-open-file ,template (lambda (,stream ,file) ,@body) ,@open-args)) (defclass pseudosymbol () ((package-string :initarg :package-string :accessor package-string) (symbol-string :initarg :symbol-string :accessor symbol-string))) (defmethod print-object ((pseudosymbol pseudosymbol) stream) (format stream "~A::~A" (package-string pseudosymbol) (symbol-string pseudosymbol))) (defun make-pseudosymbol (string) (let* ((package-start 0) (package-end (position #\: string)) (symbol-start (and package-end (position #\: string :start package-end :test-not #'eql))) (package (if package-end (subseq string package-start package-end) "cl-user")) (symbol (if symbol-start (subseq string symbol-start) string))) (make-instance 'pseudosymbol :package-string package :symbol-string symbol))) (defclass dispatched-entry () ((binary-name :initarg :binary-name :accessor binary-name :initform nil) (entry :initarg :entry :accessor entry :initform "")) (:documentation "A dispatched entry is used to select an entry point depending on the name of the binary that invoked the application. If the binary name is empty, it is considered the default entry if no match is found.")) (defmethod print-object ((dispatched-entry dispatched-entry) stream) (print-unreadable-object (dispatched-entry stream :type t) (format stream "~A/~A" (binary-name dispatched-entry) (entry dispatched-entry)))) (define-condition malformed-dispatch-entry (error) ()) (defun make-dispatched-entry (string) (let ((slash (position #\/ string))) (unless slash (error 'malformed-dispatch-entry)) (let ((binary-name (subseq string 0 slash)) (entry (make-pseudosymbol (subseq string (1+ slash))))) (make-instance 'dispatched-entry :binary-name binary-name :entry entry)))) (defun default-entry-p (dispatch-entry) (zerop (length (binary-name dispatch-entry)))) (defun directorize (namestring) (concatenate 'string (string-right-trim "/" namestring) "/")) (defun all-asdf-directories (root) "Return a list of all ASDF files in the directory tree at ROOT." (remove-duplicates (mapcar #'directory-namestring (directory (merge-pathnames "**/*.asd" (pathname (directorize root))))) :test #'string=)) (defun copy-file (input output &key (if-exists :supersede)) (with-open-file (input-stream input) (with-open-file (output-stream output :direction :output :if-exists if-exists) (loop for char = (read-char input-stream nil) while char do (write-char char output-stream))))) (defun file-lines (file) (with-open-file (stream file) (loop for line = (read-line stream nil) while line collect line))) ;; Cribbed from alexandria (defun flatten (tree) "Traverses the tree in order, collecting non-null leaves into a list." (let (list) (labels ((traverse (subtree) (when subtree (if (consp subtree) (progn (traverse (car subtree)) (traverse (cdr subtree))) (push subtree list))))) (traverse tree)) (nreverse list)))