Commit ab81cc87 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

4.1.1.1: buildapp-like --dispatch-entry

parent d37c6149
(defsystem "cl-launch-dispatch"
:depends-on (#-asdf3.1 (:version "uiop" "3.1"))
:components ((:file "dispatch")))
#!/bin/sh
#| cl-launch.sh -- shell wrapper for Common Lisp -*- Lisp -*-
CL_LAUNCH_VERSION='4.1.1'
CL_LAUNCH_VERSION='4.1.1.1'
license_information () {
AUTHOR_NOTE="\
# Please send your improvements to the author:
......@@ -54,7 +54,7 @@ unset \
EXEC_LISP DO_LISP DUMP LOAD_IMAGE RESTART RESTART_PACKAGE IMAGE IMAGE_OPT \
EXTRA_CONFIG_VARIABLES \
EXECUTABLE_IMAGE STANDALONE_EXECUTABLE CL_LAUNCH_STANDALONE \
CL_LAUNCH_FILE __CL_ARGV0 IS_X_SCRIPT \
CL_LAUNCH_FILE __CL_ARGV0 IS_X_SCRIPT DISPATCH_ENTRY_P \
TEST_SHELLS TORIG IMPL
LISPS="$DEFAULT_LISPS"
......@@ -138,6 +138,7 @@ Software specification
--require MODULE require MODULE while building
-r FUNC --restart FUNC restart from build by calling (FUNC)
-E FUNC --entry FUNC restart from build by calling (FUNC argv)
-DE N/F --dispatched-entry N/F if exec'ed as N, restart from (F argv)
-i FORM --init FORM evaluate FORM after restart
-ip FORM --print FORM evaluate and princ FORM after restart
-iw FORM --write FORM evaluate and write FORM after restart
......@@ -313,6 +314,20 @@ at which point it happens when you invoke the executable output file:
the primary return value of result is generalized boolean true, and
with status 1 if this value is \`NIL\`.
See documentation for \`UIOP:RESTORE-IMAGE\` for details.
* If option `-DE --dispatch-entry` is used, then the next argument must follow
the format `NAME/ENTRY`, where `NAME` is a name that the program may be
invoked as (the basename of the `uiop:argv0` argument), and `ENTRY` is
a function to be invoked as if by --entry when that is the case.
Support for option `-DE --dispatch-entry` is delegated to a dispatch library,
distributed with `cl-launch` but not part of `cl-launch` itself, by
(1) registering a dependency on the dispatch library as if
`--system cl-launch-dispatch` had been specified (if not already)
(2) if neither `--restart` nor `--entry` was specified yet, registering a
default entry function as if by `--entry cl-launch-dispatch:dispatch-entry'.
(3) registering an init-form that registers the dispatch entry as if
`(cl-launch-dispatch:register-name/entry "NAME/ENTRY" :PACKAGE)` had been
specified where PACKAGE is the current package.
See the documentation of said library for further details.
The current package can be controlled by option \`-p --package\` and its variant
\`-sp --system-package\` that also behaves like \`-s --system\`.
......@@ -1096,6 +1111,16 @@ process_options () {
set_restart "$1" ; shift ;;
-E|--entry)
set_restart "(lambda()($1 uiop:*command-line-arguments*))" ; shift ;;
-DE|--dispatch-entry)
if [ -z "$DISPATCH_ENTRY_P" ] ; then
add_build_form "(:load-system \"cl-launch-dispatch\")"
DISPATCH_ENTRY_P=t
fi
if [ -z "$RESTART" ] ; then
set_entry "cl-launch-dispatch:dispatch-entry"
fi
add_init_form "(cl-launch-dispatch:register-name/entry \"$(kwote "$1")\" :$PACKAGE)"
shift ;;
-B|--backdoor)
"$@" ; exit ;;
--)
......@@ -1151,6 +1176,9 @@ in_package () {
set_restart () {
RESTART="$1" RESTART_PACKAGE="$PACKAGE"
}
set_entry () {
set_restart "(cl:lambda()($1 uiop:*command-line-arguments*))"
}
add_build_form () {
SOFTWARE_BUILD_FORMS="$SOFTWARE_BUILD_FORMS${SOFTWARE_BUILD_FORMS+
}$1"
......
......@@ -43,7 +43,8 @@ install: build
dh_clean
dh_installdirs -p ${debpkg} $(include_dir) $(doc-dir)
dh_install -i cl-launch usr/bin
dh_install -i launcher.lisp wrapper.sh cl-launch.asd build.xcvb ${include_dir}
dh_install -i launcher.lisp wrapper.sh cl-launch.asd build.xcvb \
cl-launch-dispatch.asd dispatch.lisp ${include_dir}
dh_installman -i debian/*.1
......
(defpackage :cl-launch-dispatch
(:use :uiop :cl)
(:export #:dispatch-entry #:get-entry
#:register-name/entry #:register-entry
#:dispatch-entry-error #:get-name #:basename #:all-entry-names
#:dispatcher #:not-found))
(in-package :cl-launch-dispatch)
(defvar *default-behavior* 'dispatcher
"the default behavior if the argv0 invocation name is not recognized.")
(defvar *entries* (make-hash-table :test 'equal)
"a table of entries, associating strings (basename of a command) to entry")
(define-condition dispatch-entry-error (simple-error) ())
(defun dispatch-entry-error (format &rest arguments)
(error 'dispatch-entry-error :format-control format :format-arguments arguments))
(defun split-name/entry (name/entry &optional (package *package*))
"split name and entry from a name-entry specification"
(if-let ((slash (position #\/ name/entry)))
(values (let ((name (subseq name/entry 0 slash)))
(and (not (emptyp name)) name))
(ensure-function (subseq name/entry (1+ slash)) :package package))
(dispatch-entry-error "malformed entry ~S" name/entry)))
(defun register-entry (name entry)
(if name
(setf (gethash name *entries*) entry)
(setf *default-behavior* entry)))
(defun register-name/entry (name/entry &optional (package *package*))
(multiple-value-call 'register-entry (split-name/entry name/entry)))
(defun get-entry (name)
"Given a string NAME, return the dispatch entry registered for that NAME.
If NAME is NIL, return the value of *DEFAULT-BEHAVIOR*."
(if name
(gethash name *entries*)
*default-behavior*))
(defun basename (name)
(let ((base
(if-let ((slash (position #\/ name :from-end t)))
(subseq name (1+ slash))
name)))
(and (not (emptyp base)) base)))
(defun get-name ()
(basename (uiop:argv0)))
(defun all-entry-names ()
(sort (loop :for k :being :the :hash-keys :of *entries* :collect k) 'string<))
(defun dispatcher (argv)
(if (null argv)
(die 2 "~A available commands: ~{~A~^ ~}"
(get-name) (all-entry-names))
(dispatch-entry (rest argv) (first argv))))
(defun not-found (argv)
(declare (ignore argv))
(if-let ((name (get-name)))
(die 3 "~A command not found." (get-name))
(die 4 "could not determine command name")))
(defun dispatch-entry (argv &optional (name (get-name)))
(funcall (or (get-entry name) *default-behavior*) argv))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment