;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: driver.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; A lisp driver similar to gcc.
;;;;
;;;; Right, that's silly. But some non-lispers may be lured into
;;;; lisp by it.
;;;;
;;;;USAGE:
;;;;
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-07-01 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (copy-readtable nil)))
(defpackage "COM.INFORMATIMAGO.DRIVER"
(:use "COMMON-LISP")
(:export "COMPILE-FILES"
"GENERATE-LIBRARY"
"GENERATE-EXECUTABLE"))
(in-package "COM.INFORMATIMAGO.DRIVER")
"
plc -c -Iincludes_dir -o file.o file.lisp…
Compiles the possibly multiple source files file.lisp into
an object file.o.
The directories specified with -I are searched by LOAD,
REQUIRE, and ASDF.
The object files generated by plc are not necessarily
compatible with gcc or ld.
plc -o libfile.a -static file.lisp|file.o …
plc -o executable file.lisp|file.o …
Loads the files specified (sources or object), link-edit
them, and generate an executable. In all those files,
there should be a function named CL-USER::MAIN, which will
be called when the executable is run, with as arguments
all the command line arguments (as strings).
The environment variables are accessible thru the accessor
CL-USER::GETENV.
CL-USER::EXIT is a function taking 0 or 1 argument, a
status code to be returned by the command.
-c
Compile or assemble the source files, but do not link. The
linking stage simply is not done. The ultimate output is
in the form of an object file for each source file.
-o file
Place output in file file. This applies regardless to
whatever sort of output is being produced, whether it be an
executable file, an object file, an assembler file or
preprocessed C code.
If -o is not specified, the default is to put an executable
file in a.out, the object file for source.suffix in source.o.
-v
Print (on standard error output) the commands executed to run
the stages of compilation. Also print the version number of
the compiler driver program and of the preprocessor and the
compiler proper.
-version, --version
Display the version number and copyrights of the invoked plc.
-ansi
Ensures that strict Ansi Common Lisp is used. This is the default.
-traditional
Do not enfore strict Ansi Common Lisp.
-g
Produce debugging information.
You can use -g with -O, but this may give strange results.
speed space debug safety
-O, -O0, -O1, -O2, -O3
Optimize. -O is equivalent to -O1
no -Os ==> (space 0)
-Os ==> (space 3) (speed 2)
-O# ==> (speed #)
no -Ofast ==> (safety 3)
-Ofast ==> (safety 0)
-g ==> (debug 3)
no -g ==> (debug 0)
-fsingle-precision-constant ==> (setf *read-default-float-format* 'single-float)
no -fsingle-precision-constant ==> (setf *read-default-float-format* 'double-float)
-Dname ==> (push :name *features*)
-Dname=definition ==> (define-symbol-macro cl-user::name definition) (-D-register 'cl-user::name 'definition)
-Uname ==> (setf *features* (remove :name *features*)) (-D-unregister 'cl-user::name) (unintern 'cl-user::name)
-Idir, -I dir
Add the directory dir to the list of directories to be searched for
lisp files. Directories named by -I are searched before the
standard system include directories.
-dM Dumps *features*
-dD Prints the -Dname=definition definitions. (-D-definitions)
-Ldir, -L dir
Add directory dir to the list of directories to be searched for -l.
-llibrary, -l library
library names a lisp library, created with lpc -static, which will
be loaded before compiling or linking the program.
-static
produces a library containing the compiled code of all the input
source files.
library is the name of an asdf or quicklisp system, which is
loaded before compiling.
-Bimplementation
Specifies what implementation to use. It is the name of a Common
Lisp implementation executable, or its full path. Examples:
-Bclisp -B/opt/local/bin/sbcl
--sysroot=dir
Specifies the quicklisp directory.
-print-search-dirs
Print the name of the configured installation directory and a list
of program and library directories plc will search---and don't do
anything else.
-print-sysroot
Print the target sysroot directory that will be used during
compilation. This is the target sysroot specified either at
configure time or using the --sysroot option. If no target
sysroot is specified, the default is ~/quicklisp/.
-dumpmachine
Print the compiler's target machine (for example,
i686-pc-linux-gnu)---and don't do anything else.
(machine-type)
-dumpversion
Print the compiler version (for example, 3.0)---and don't do
anything else.
(lisp-implementation-version)
-A predicate=answer
Evaluates: (assert (equal predicate answer))
"
(in-package "COMMON-LISP-USER")
(setf #+clisp ext:*load-echo* #+clisp *verbose*
*load-verbose* *verbose*
*compile-verbose* *verbose*)
(when *ansi*
(dolist (used-package (package-use-list "COMMON-LISP-USER"))
(unless (eq (package-name used-package (find-package "COMMON-LISP")))
(unuse-package package "COMMON-LISP-USER"))))
(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.DRIVER.SCRIPT"
(:use "COMMON-LISP")
(:export "*VERBOSE*" "*DEBUG*"
"*DEFAULT-PROGRAM-NAME*" "*PROGRAM-NAME*" "*PROGRAM-PATH*" "*ARGUMENTS*"
"WITHOUT-OUTPUT" "WITH-PAGER"
"REDIRECTING-STDOUT-TO-STDERR"
"RELAUCH-WITH-KFULL-LINKSET-IF-NEEDED"
;; I/O
"PERROR" "PMESSAGE" "PQUERY"
;; Options
"DEFINE-OPTION" "CALL-OPTION-FUNCTION"
"PARSE-OPTIONS" "MAIN"
"SET-DOCUMENTATION-TEXT"
"*BASH-COMPLETION-HOOK*"
;; Utilities:
"FIND-DIRECTORIES"
"CONCAT" "MAPCONCAT"
"GETPID" "SHELL-QUOTE-ARGUMENT" "SHELL" "EXECUTE" "RUN-PROGRAM"
"UNAME" "COPY-FILE" "MAKE-SYMBOLIC-LINK" "MAKE-DIRECTORY"
;; Exit codes:
"EX--BASE" "EX--MAX" "EX-CANTCREAT" "EX-CONFIG"
"EX-DATAERR" "EX-IOERR" "EX-NOHOST" "EX-NOINPUT"
"EX-NOPERM" "EX-NOUSER" "EX-OK" "EX-OSERR" "EX-OSFILE"
"EX-PROTOCOL" "EX-SOFTWARE" "EX-TEMPFAIL" "EX-UNAVAILABLE"
"EX-USAGE"
"EXIT"))
(in-package "COM.INFORMATIMAGO.DRIVER.SCRIPT")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(defvar *default-program-name* "untitled")
(defun program-path ()
(let* ((argv (ext:argv))
(largv (length argv))
(args ext:*args*)
(largs (length args))
(index (- largv largs 1))
(path (and (<= 0 index largv) (elt argv index))))
(cond
(path
path)
((and *load-truename*
(string/= (file-namestring *load-truename*) "script.lisp"))
(namestring *load-truename*))
(t
*default-program-name*))))
(defvar *program-path* (program-path)
"A namestring of the path to the program.
This may be a relative pathname, when it's obtained from argv[0].
If available we use the actual program name (from (EXT:ARGV) or
*LOAD-TRUENAME*), otherwise we fallback to *DEFAULT-PROGRAM-NAME*.")
(defvar *program-name* (file-namestring *program-path*)
"Name of the program.")
(defvar *arguments* ext:*args*
"A list of command line arguments (strings).")
(defvar *verbose* nil
"Adds some trace output.")
(defvar *debug* nil
"Errors break into the debugger.")
#-(or use-ppcre use-regexp) (push #-(and) :use-ppcre
#+(and) :use-regexp
*features*)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(defun relauch-with-kfull-linkset-if-needed (thunk)
;; If the version of clisp requires -Kfull to have linux, then let's call it with -Kfull…
(multiple-value-bind (res err) (ignore-errors (funcall thunk))
(when err
(if (find "-Kfull" (ext:argv) :test (function string=))
(error err)
(ext:exit
(or (ext:run-program "/usr/bin/clisp"
:arguments (append '("-ansi" "-q" "-E" "utf-8" "-Kfull")
(cons *program-path* *arguments*))
:wait t
#+linux :may-exec #+linux t
#+win32 :indirectp #+win32 nil)
0))))))
#-linux (when (find "linux" *modules* :test (function string=))
(push :linux *features*))
#-(or linux macos win32 #|what else is not linux?|#)
(relauch-with-kfull-linkset-if-needed (lambda () (require "linux")))
(defmacro redirecting-stdout-to-stderr (&body body)
(let ((verror (gensym))
(voutput (gensym)))
`(let* ((,verror nil)
(,voutput (with-output-to-string (stream)
(let ((*standard-output* stream)
(*error-output* stream)
(*trace-output* stream))
(handler-case (progn ,@body)
(error (err) (setf ,verror err)))))))
(when ,verror
(terpri *error-output*)
(princ ,voutput *error-output*)
(terpri *error-output*)
(princ ,verror *error-output*)
(terpri *error-output*)
(terpri *error-output*)
#-testing-script (exit ex-software)))))
(defun getpid ()
(or (ignore-errors (find-symbol "getpid" "LINUX"))
(ignore-errors (find-symbol "PROCESS-ID" "OS"))
(ignore-errors (find-symbol "PROCESS-ID" "SYSTEM"))))
(defun report-the-error (err string-stream)
(let ((log-path (format nil "/tmp/~A.~D.errors" *program-name*
(let ((getpid (getpid)))
(if getpid
(funcall getpid)
"nopid")))))
(with-open-file (log-stream log-path
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format log-stream "~A GOT AN ERROR: ~A~%~80,,,'-<~>~%~A~%"
*program-name* err (get-output-stream-string string-stream)))
(format *error-output* "~A: ~A~% See ~A~%" *program-name* err log-path)
(finish-output *error-output*)
(exit ex-software)))
(defmacro without-output (&body body)
`(prog1 (values)
(with-output-to-string (net)
(handler-case
(let ((*standard-output* net)
(*error-output* net)
(*trace-output* net))
,@body)
(error (err) (report-the-error err net))))))
(defmacro with-pager ((&key lines) &body body)
"
Executes the BODY, redirecting *STANDARD-OUTPUT* to a pager.
If no option is given, use the system pager obtained from the
environment variable PAGER. If none is defined, then no pager is
used.
The following is NOT IMPLEMENTED YET:
If an option is given, then it defines a local pager.
LINES Number of line to output in a single chunk.
After this number of line has been written,
some user input is required to further display lines.
"
(when lines
(error "~S: Sorry :LINES is not implemented yet." 'with-pager))
;; (print (list (version:clisp-version)
;; (version:rt-version<= "2.48" (version:clisp-version))))
#+#.(version:rt-version<= "2.44" (version:clisp-version))
`(progn ,@body)
#-#.(version:rt-version<= "2.44" (version:clisp-version))
(let ((pager (ext:getenv "PAGER")))
(if pager
(let ((pager-stream (gensym)))
`(let ((,pager-stream (ext:make-pipe-output-stream
,pager
:external-format charset:utf-8
:buffered nil)
;; (ext:run-program ,pager
;; :input :stream
;; :output :terminal
;; :wait nil)
))
(unwind-protect
(let ((*standard-output* ,pager-stream))
,@body)
(close ,pager-stream))))
`(progn ,@body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(defun shell-quote-argument (argument)
"Quote ARGUMENT for passing as argument to an inferior shell."
#+(or MSWINDOWS WIN32)
;; Quote using double quotes, but escape any existing quotes in
;; the argument with backslashes.
(let ((result "")
(start 0)
(end)
(match-beginning)
(match-end))
(when (or (null (setf match-end (position #\" argument)))
(< match-end (length argument)))
(loop
:while (setf match-beginning (position #\" argument :start start))
:do (setf end (1+ match-beginning)
result (concatenate 'string result (subseq argument start end)
"\\" (subseq argument end (1+ end)))
start (1+ end))))
(concatenate 'string "\"" result (subseq argument start) "\""))
#-(or MSWINDOWS WIN32)
(if (equal argument "")
"''"
;; Quote everything except POSIX filename characters.
;; This should be safe enough even for really weird shells.
(let ((result "")
(start 0)
(end)
(match-beginning)
(match-end))
(loop
:while (setf match-end (position-if-not (lambda (ch) (or (alphanumericp ch) (position ch "-_./"))) argument :start start))
:do (setf end match-end
result (concatenate 'string result (subseq argument start end)
"\\" (subseq argument end (1+ end)))
start (1+ end)))
(concatenate 'string result (subseq argument start)))))
(defun shell (command)
"
SEE ALSO: EXECUTE.
"
(ext:shell command))
(defun execute (&rest command)
"
RETURN: The status returned by the command.
SEE ALSO: SHELL
"
(ext:run-program (car command)
:arguments (cdr command)
:input :terminal :output :terminal))
(defun copy-file (file newname &optional ok-if-already-exists keep-time)
"
IMPLEMENTATION: The optional argument is not implemented.
Copy FILE to NEWNAME. Both args must be strings.
If NEWNAME names a directory, copy FILE there.
Signals a `file-already-exists' error if file NEWNAME already exists,
unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
A number as third arg means request confirmation if NEWNAME already exists.
This is what happens in interactive use with M-x.
Fourth arg KEEP-TIME non-nil means give the new file the same
last-modified time as the old one. (This works on only some systems.)
A prefix arg makes KEEP-TIME non-nil.
"
(declare (ignore ok-if-already-exists keep-time))
(execute "cp" (shell-quote-argument file) (shell-quote-argument newname)))
#+linux ;; Should probably move away.
(defun make-symbolic-link (filename linkname &optional ok-if-already-exists)
"
IMPLEMENTATION: The optional argument is not implemented.
Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
Signals a `file-already-exists' error if a file LINKNAME already exists
unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
A number as third arg means request confirmation if LINKNAME already exists.
"
(declare (ignore ok-if-already-exists))
(/= 0 (linux:|symlink| filename linkname)))
#+linux ;; Should probably move away.
(defun make-directory (*path* &optional (parents nil))
"
Create the directory *PATH* and any optionally nonexistent parents dirs.
The second (optional) argument PARENTS says whether
to create parents directories if they don't exist.
"
(if parents
(ensure-directories-exist (concatenate 'string *path* "/.") :verbose nil)
(linux:|mkdir| *path* 511 #| #o777 |# ))
(ext:probe-directory (if (char= (char *path* (1- (length *path*)))
(character "/"))
*path* (concatenate 'string *path* "/"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun perror (format-string &rest args)
"
DO: Writes a message on the error output in the name of the script.
"
(format *error-output* "~&~A: ~?" *program-name* format-string args)
(finish-output *error-output*))
(defun pmessage (format-string &rest args)
"
DO: Writes a message on the standard output in the name of the script.
"
(format *standard-output* "~&~A: ~?" *program-name* format-string args)
(finish-output *standard-output*))
(defun pquery (format-string &rest args)
"
DO: Writes a message on the query I/O in the name of the script, and
read a response line.
RETURN: A string containing the response line.
"
(format *query-io* "~&~A: ~?" *program-name* format-string args)
(finish-output *query-io*)
(read-line *query-io*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; From /usr/include/sysexits.h (Linux)
;;;
(defconstant ex-ok 0 "successful termination")
(defconstant ex--base 64 "base value for error messages")
(defconstant ex-usage 64 "command line usage error
The command was used incorrectly, e.g., with
the wrong number of arguments, a bad flag, a bad
syntax in a parameter, or whatever.") ;;EX-USAGE
(defconstant ex-dataerr 65 "data format error
The input data was incorrect in some way.
This should only be used for user's data & not
system files.") ;;EX-DATAERR
(defconstant ex-noinput 66 "cannot open input
An input file (not a system file) did not
exist or was not readable. This could also include
errors like \"No message\" to a mailer (if it cared
to catch it).") ;;EX-NOINPUT
(defconstant ex-nouser 67 "addressee unknown
The user specified did not exist. This might
be used for mail addresses or remote logins.
") ;;EX-NOUSER
(defconstant ex-nohost 68 "host name unknown
The host specified did not exist. This is used
in mail addresses or network requests.") ;;EX-NOHOST
(defconstant ex-unavailable 69 "service unavailable
A service is unavailable. This can occur
if a support program or file does not exist. This
can also be used as a catchall message when something
you wanted to do doesn't work, but you don't know
why.") ;;EX-UNAVAILABLE
(defconstant ex-software 70 "internal software error
An internal software error has been detected.
This should be limited to non-operating system related
errors as possible.") ;;EX-SOFTWARE
(defconstant ex-oserr 71 "system error (e.g., can't fork)
An operating system error has been detected.
This is intended to be used for such things as \"cannot
fork\", \"cannot create pipe\", or the like. It includes
things like getuid returning a user that does not
exist in the passwd file.") ;;EX-OSERR
(defconstant ex-osfile 72 "critical OS file missing
Some system file (e.g., /etc/passwd, /etc/utmp,
etc.) does not exist, cannot be opened, or has some
sort of error (e.g., syntax error).") ;;EX-OSFILE
(defconstant ex-cantcreat 73 "can't create (user) output file
A (user specified) output file cannot be created.") ;;EX-CANTCREAT
(defconstant ex-ioerr 74 "input/output error
An error occurred while doing I/O on some file.") ;;EX-IOERR
(defconstant ex-tempfail 75 "temp failure; user is invited to retry
temporary failure, indicating something that
is not really an error. In sendmail, this means
that a mailer (e.g.) could not create a connection,
and the request should be reattempted later.") ;;EX-TEMPFAIL
(defconstant ex-protocol 76 "remote error in protocol
the remote system returned something that
was \"not possible\" during a protocol exchange.") ;;EX-PROTOCOL
(defconstant ex-noperm 77 "permission denied
You did not have sufficient permission to
perform the operation. This is not intended for
file system problems, which should use NOINPUT or
CANTCREAT, but rather for higher level permissions.") ;;EX-NOPERM
(defconstant ex-config 78 "configuration error")
(defconstant ex--max 78 "maximum listed value")
(defun exit (&optional (code ex-ok))
(ext:exit code))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; OPTIONS PROCESSING
;;;
(defparameter *options*
(make-hash-table :test (function equal))
"The dictionary of options.")
(defstruct option
keys arguments documentation function)
(defun split-string (string &optional (separators " "))
"
NOTE: current implementation only accepts as separators
a string containing literal characters.
"
(unless (simple-string-p string) (setq string (copy-seq string)))
(unless (simple-string-p separators) (setq separators (copy-seq separators)))
(let ((chunks '())
(position 0)
(nextpos 0)
(strlen (length string)) )
(declare (type simple-string string separators))
(loop :while (< position strlen) :do
(loop :while (and (< nextpos strlen) (not (position (char string nextpos) separators))) :do
(setq nextpos (1+ nextpos)))
(push (subseq string position nextpos) chunks)
(setf position (1+ nextpos)
nextpos position))
(nreverse chunks)))
(defun q&d-parse-parameters (parameters)
"Parses (mandatory &optional optionals... &rest rest &key key...)"
(loop
:with mandatories = '()
:with optionals = '()
:with rest = nil
:with keys = '()
:with state = :mandatory
:with params = parameters
:for param = (first params)
:while params
:do (ecase state
((:mandatory)
(case param
((&optional) (setf state :optional))
((&rest) (setf state :rest))
((&key) (setf state :key))
(otherwise (push param mandatories)))
(pop params))
((:optional)
(case param
((&optional) (error "&OPTIONAL given more than once in ~S" parameters))
((&rest) (setf state :rest))
((&key) (setf state :key))
(otherwise (push param optionals)))
(pop params))
((:rest)
(case param
((&optional) (error "&OPTIONAL given after &REST in ~S" parameters))
((&rest) (error "&REST given twice in ~S" parameters))
((&key) (setf state :key))
(otherwise (setf state :after-rest
rest param)))
(pop params))
((:after-rest)
(case param
((&optional) (error "&OPTIONAL given after &REST in ~S" parameters))
((&rest) (error "&REST given after &REST in ~S" parameters))
((&key) (setf state :key))
(otherwise (error "Several &REST parameters given in ~S" parameters)))
(pop params))
((:key)
(case param
((&optional) (error "&OPTIONAL given after &KEY in ~S" parameters))
((&rest) (error "&REST given after &KEY in ~S" parameters))
((&key) (setf state :key))
(otherwise (push param keys)))
(pop params)))
:finally (return (values (nreverse mandatories)
(nreverse optionals)
rest
(nreverse keys)))))
(defun keywordize (string-designator)
(intern (string string-designator) (load-time-value (find-package "KEYWORD"))))
(defun q&d-arguments (mandatories optionals rest keys)
"
BUG: when the optionals or keys have a present indicator,
we just ignore it and build a list that will pass
the default value anyways...
"
(assert (every (function symbolp) mandatories))
(append mandatories
(mapcar (lambda (opt)
(etypecase opt
(cons (first opt))
(symbol opt)))
optionals)
(when rest (list rest))
(mapcan (lambda (key)
(etypecase key
(cons (etypecase (first key)
(symbol (list (keywordize (first key)) (first key)))
(cons (list (second (first key)) (first (first key))))))
(symbol (list (keywordize key) key))))
keys)))
(defun wrap-option-function (keys option-arguments docstring option-function)
(let ((vargs (gensym)))
(multiple-value-bind (mandatories optionals rest keys-args) (q&d-parse-parameters option-arguments)
(setf *print-circle* nil)
(make-option
:keys keys
:arguments option-arguments
:function (compile (make-symbol (format nil "~:@(~A-WRAPPER~)" (first keys)))
`(lambda (option-key ,vargs)
(let ((nargs (length ,vargs)))
(if (<= ,(length mandatories) nargs)
,(cond
(rest
`(destructuring-bind ,option-arguments ,vargs
(funcall ',option-function ,@(q&d-arguments mandatories
optionals
rest
keys-args))
nil))
(keys-args
(error "An option cannot have &key parameters without a &rest parameter. ~@
Invalid option parameters: ~S" option-arguments))
(t
(let ((vremaining (gensym)))
`(destructuring-bind (,@option-arguments &rest ,vremaining) ,vargs
(funcall ',option-function ,@(q&d-arguments mandatories
optionals
rest
keys-args))
,vremaining))))
(let ((missing-count (- ,(length mandatories) nargs))
(missing-args (subseq ',mandatories nargs)))
(error "option ~A is missing ~:[an ~*~;~A ~]argument~:*~p: ~{~A ~}"
option-key
(< 1 missing-count) missing-count
missing-args))))))
:documentation (split-string docstring (string #\newline))))))
(defun call-option-function (option-key arguments &optional undefined-argument)
(let* ((option (gethash option-key *options*)))
(cond
(option (funcall (option-function option) option-key arguments))
(undefined-argument (funcall undefined-argument option-key arguments))
(t (error "Unknown option ~A ; try: ~A help" option-key *program-name*)))))
(defmacro define-option (names parameters &body body)
"
DO: Define a new option for the scirpt.
NAMES: A list designator of option names (strings
such as \"-a\" \"--always\").
PARAMETERS: A list of option parameters. The names of
these parameters must be descriptive as they
are used to build the usage help text.
BODY: The code implementing this option.
RETURN: The lisp-name of the option (this is a symbol
named for the first option name).
"
(let* ((main-name (if (listp names)
(first names)
names))
(other-names (if (listp names)
(rest names)
'()))
(lisp-name (intern (string-upcase main-name)))
(docstring (if (and (stringp (first body)) (rest body))
(first body)
nil))
(body (if (and (stringp (first body)) (rest body))
(rest body)
body)))
`(progn
(setf (gethash ',main-name *options*)
(wrap-option-function ',(cons main-name other-names)
',parameters
',docstring
(lambda ,(remove '&rest parameters)
,docstring
(block ,lisp-name
,@body))))
,@(mapcar (lambda (other-name)
`(setf (gethash ',other-name *options*) (gethash ',main-name *options*)))
other-names)
',lisp-name)))
(defvar *documentation-text* "")
(defun set-documentation-text (text)
(setf *documentation-text* text))
(defun option-list ()
(let ((options '()))
(maphash (lambda (key option)
(declare (ignore key))
(pushnew option options))
*options*)
options))
(define-option ("help" "-h" "--help") ()
"Give this help."
(with-pager ()
(let ((options (option-list)))
(format t "~2%~A options:~2%" *program-name*)
(dolist (option (sort options (function string<)
:key (lambda (option) (first (option-keys option)))))
(format t " ~{~A~^ | ~} ~:@(~{~A ~}~)~%~@[~{~% ~A~}~]~2%"
(option-keys option)
(option-arguments option)
(option-documentation option)))
(format t "~A~%" *documentation-text*))))
;; TODO: See if we couldn't simplify it, perhaps with complete -C.
(defun list-all-option-keys ()
(let ((keys '()))
(dolist (option (option-list))
(dolist (key (option-keys option))
(push key keys)))
keys))
(defun completion-option-prefix (prefix)
(dolist (key (remove-if-not (lambda (key)
(and (<= (length prefix) (length key))
(string= prefix key :end2 (length prefix))))
(list-all-option-keys)))
(format t "~A~%" key))
(finish-output))
(defun completion-all-options ()
(dolist (key (list-all-option-keys))
(format t "~A~%" key))
(finish-output))
(defvar *bash-completion-hook* nil
"A function (lambda (index words) ...)
that will print the completion and return true, or do nothing and return nil.")
(define-option ("--bash-completions") (index &rest words)
"Implement the auto-completion of arguments.
This option is designed to be invoked from the function generated by
the '--bash-completion-function' option. There should be no need to
use directly.
"
(let ((index (parse-integer index :junk-allowed t)))
(unless (and *bash-completion-hook*
(funcall *bash-completion-hook* index words))
(if index
(completion-option-prefix (elt words index))
(completion-all-options))))
(exit 0))
(define-option ("--bash-completion-function") ()
"Write two bash commands (separated by a semi-colon) to create a
bash function used to do auto-completion of command arguments.
Use it with:
eval $($COMMAND --bash-completion-function)
and then typing TAB on the command line after the command name will
autocomplete argument prefixes.
"
(format t "function completion_~A(){ ~
COMPREPLY=( $(~:*~A --bash-completions \"$COMP_CWORD\" \"${COMP_WORDS[@]}\") ) ; } ;~
complete -F completion_~:*~A ~:*~A~%"
*program-name*)
(exit 0))
(defun parse-options (arguments &optional default undefined-argument)
(flet ((process-arguments ()
(cond
(arguments
(loop
:while arguments
:do (setf arguments (call-option-function (pop arguments) arguments undefined-argument))))
(default
(funcall default)))))
(if *debug*
(process-arguments)
(handler-case (process-arguments)
(error (err)
(format *error-output* "~%ERROR: ~A~%" err)
;; TODO: select different sysexits codes depending on the error class.
(return-from parse-options ex-software)))))
0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(defun not-implemented-here (function-name)
(error "How to implement ~S in ~S"
function-name
(lisp-implementation-type)))
(defun prepare-options (options)
(mapcar (lambda (option)
(typecase option
(keyword (format nil "-~(~A~)" option))
(symbol (string-downcase option))
(string option)
(t (prin1-to-string option))))
options))
(defun shell (command &rest arguments)
#+clisp (ext:shell (format nil command arguments))
#-clisp (not-implemented-here 'shell))
(defun run-program (program arguments &key (input :terminal) (output :terminal)
(if-output-exists :error) (wait t))
"
RETURN: The status returned by the command.
SEE ALSO: SHELL
"
#+clisp (ext:run-program program
:arguments arguments
:input input :output output
:if-output-exists if-output-exists
:wait wait)
#-clisp (not-implemented-here 'run-program))
(defun uname (&rest options)
"Without OPTIONS, return a keyword naming the system (:LINUX, :DARWIN, etc).
With options, returns the first line output by uname(1)."
(with-open-stream (uname (run-program "uname" (prepare-options options)
:input nil
:output :stream
:wait t))
(values (if options
(read-line uname)
(intern (string-upcase (read-line uname))
"KEYWORD")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Some emacs style functions.
;;;
(defun find-directories (rootpath)
"Return a list of recursive subdirectories starting from ROOTPATH
that are accessible by the user."
(directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
:name nil :type nil :version nil)
rootpath nil)))
(defun concat (&rest items)
(with-output-to-string (*standard-output*)
(dolist (item items)
(typecase item
(string (write-string item *standard-output*))
(sequence (write-sequence item *standard-output*))
(t (with-standard-io-syntax (format *standard-output* "~A" item)))))))
(defun mapconcat (function sequence separator)
(etypecase sequence
(list
(if sequence
(let* ((items (mapcar (lambda (item)
(let ((sitem (funcall function item)))
(if (stringp sitem)
sitem
(princ-to-string sitem))))
sequence))
(ssepa (if (stringp separator)
separator
(princ-to-string separator)))
(size (+ (reduce (function +) items :key (function length))
(* (length ssepa) (1- (length items)))))
(result (make-array size :element-type 'character))
(start 0))
(replace result (first items) :start1 start)
(incf start (length (first items)))
(dolist (item (rest items))
(replace result ssepa :start1 start) (incf start (length ssepa))
(replace result item :start1 start) (incf start (length item)))
result)
""))
(vector
(if (plusp (length sequence))
(let* ((items (map 'vector (lambda (item)
(let ((sitem (funcall function item)))
(if (stringp sitem)
sitem
(princ-to-string sitem))))
sequence))
(ssepa (if (stringp separator)
separator
(princ-to-string separator)))
(size (+ (reduce (function +) items :key (function length))
(* (length ssepa) (1- (length items)))))
(result (make-array size :element-type 'character))
(start 0))
(replace result (aref items 0) :start1 start) (incf start (length (aref items 0)))
(loop
:for i :from 1 :below (length items)
:do (replace result ssepa :start1 start) (incf start (length ssepa))
(replace result (aref items i) :start1 start) (incf start (length (aref items i))))
result)
""))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;
;; ;;; The main program, definition of the options
;; ;;;
;;
;;
;; (in-package "COMMON-LISP-USER")
;; (load (make-pathname :name "SCRIPT" :type "LISP" :version NIL :case :common
;; :defaults *load-pathname*))
;; (use-package "SCRIPT")
;;
;; ;; (redirecting-stdout-to-stderr (load #p"/etc/gentoo-init.lisp"))
;; (redirecting-stdout-to-stderr
;; (let ((*load-verbose* nil)
;; (*compile-verbose* nil))
;; (load (make-pathname :name ".clisprc" :type "lisp" :case :local
;; :defaults (user-homedir-pathname)))
;; ;; (setf *features* (delete :testing-script *features*))
;; ))
;; (redirecting-stdout-to-stderr (asdf:oos 'asdf:load-op :split-sequence)
;; (asdf:oos 'asdf:load-op :cl-ppcre))
;;
;; ;; #-testing-script
;; (exit (main ext:*args*))
;;;; THE END ;;;;