lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / clisp / script.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;*****************************************************************************
3 ;;;;FILE:             script.lisp
4 ;;;;LANGUAGE:         Common-Lisp
5 ;;;;SYSTEM:           clisp
6 ;;;;USER-INTERFACE:   clisp
7 ;;;;DESCRIPTION
8 ;;;;
9 ;;;;    This module exports some functions usefull when writting clisp scripts.
10 ;;;;
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2003-01-29 <PJB> Creation.
15 ;;;;BUGS
16 ;;;;LEGAL
17 ;;;;    AGPL3
18 ;;;;    
19 ;;;;    Copyright Pascal J. Bourguignon 2003 - 2012
20 ;;;;    
21 ;;;;    This program is free software: you can redistribute it and/or modify
22 ;;;;    it under the terms of the GNU Affero General Public License as published by
23 ;;;;    the Free Software Foundation, either version 3 of the License, or
24 ;;;;    (at your option) any later version.
25 ;;;;    
26 ;;;;    This program is distributed in the hope that it will be useful,
27 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;;;    GNU Affero General Public License for more details.
30 ;;;;    
31 ;;;;    You should have received a copy of the GNU Affero General Public License
32 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
33 ;;;;*****************************************************************************
34 (in-package "COMMON-LISP-USER")
35 (declaim (declaration also-use-packages))
36 (declaim (also-use-packages "SYS" "EXT"))
37 (defpackage "COM.INFORMATIMAGO.CLISP.SCRIPT"
38   (:documentation
39    "This package exports script functions.")
40   (:use "COMMON-LISP"
41         "COM.INFORMATIMAGO.CLISP.STRING")
42   (:export  "INITIALIZE"
43             "PERROR" "PMESSAGE" "PQUERY"
44             "*INITIAL-WORKING-DIRECTORY*" "IS-RUNNING"
45             "*PATH*" "*NAME*" "*ARGUMENTS*" "*TESTING*" "PID"
46             "SHELL" "SHELL-QUOTE-ARGUMENT" "EXECUTE"
47             "MAKE-DIRECTORY" "MAKE-SYMBOLIC-LINK" "COPY-FILE"
48             "EXIT" "EX-OK" "EX--BASE" "EX-USAGE"
49             "EX-DATAERR" "EX-NOINPUT" "EX-NOUSER" "EX-NOHOST"
50             "EX-UNAVAILABLE" "EX-SOFTWARE" "EX-OSERR" "EX-OSFILE"
51             "EX-CANTCREAT" "EX-IOERR" "EX-TEMPFAIL" "EX-PROTOCOL"
52             "EX-NOPERM" "EX-CONFIG" "EX--MAX" ))
53 (in-package "COM.INFORMATIMAGO.CLISP.SCRIPT")
54
55 ;; egrep '([d]efun' pjb-script.lisp | sed -e 's/(defun/;;/' | sort
56
57
58 ;;----------------------------------------------------------------------
59
60 (defparameter *initial-working-directory*  nil
61   "
62 The path to the initial working directory.
63 BUG: This is the value of (EXT:CD) when INITIALIZE is called.
64 ")
65
66
67 (defparameter *path*     nil
68   "
69 The *path* of the script.  Possibly this is not the absolute *path*, but only a
70 relative *path* from the INITIAL-WORKING-DIRECTORY.
71 BUG: This is the value of *LOAD-PATHNAME* when INITIALIZE is called.
72 ")
73
74
75 (defparameter *name*     nil
76   "
77 The name of the script.
78 BUG: It's derived from the value of *LOAD-PATHNAME* when INITIALIZE is called.
79 ")
80
81
82 (defparameter *arguments* ext:*args*
83   "
84 The list of strings containing the arguments passed to the script.
85 ")
86
87
88 (defparameter *testing*   nil
89   "
90 Whether we're only testing the script.
91 In this package, this will make END-WITH-STATUS THROW :EXIT instead of exiting.
92 NOTE:   This variable can be set by the client script (for example,
93         from a --test option).
94 ")
95
96
97 (defun initialize ()
98   "
99 DO:     Initialize this package.
100         This function MUST be called from the  script itself to get the
101         correct PNAME.
102 "
103   (setq *initial-working-directory* (ext:cd)
104         *path* *load-pathname*
105         *name* (file-namestring *load-pathname*)
106         *arguments* (copy-seq ext:*args*)))
107   
108
109
110
111
112 (defun perror (format-string &rest args)
113   "
114 DO:     Writes a message on the error output in the name of the script.
115 "
116   (format *error-output* "~&~A: " *name*)
117   (apply (function format) *error-output* format-string args)
118   (finish-output *error-output*))
119
120
121 (defun pmessage (format-string &rest args)
122   "
123 DO:     Writes a message on the standard output in the name of the script.
124 "
125   (format *standard-output* "~&~A: " *name*)
126   (apply (function format) *standard-output* format-string args)
127   (finish-output *standard-output*))
128
129
130 (defun pquery (format-string &rest args)
131   "
132 DO:     Writes a message on the query I/O in the name of the script, and
133         read a response line.
134 RETURN: A string containing the response line.
135 "
136   (format *query-io* "~&~A: " *name*)
137   (apply (function format) *query-io* format-string args)
138   (finish-output *query-io*)
139   (read-line *query-io*))
140
141
142
143
144 ;; Awfull trick for pjb-script:is-running; put this in ~/.clisprc.lisp
145 ;; (DEFUN EXECUTABLE-READER (A B C) (SYS::UNIX-EXECUTABLE-READER A B C))
146 ;; (SET-DISPATCH-MACRO-CHARACTER #\# #\! #EXECUTABLE-READER)
147
148 (defun is-running ()
149   "
150 RETURN:  Whether we're running as a script. (Otherwise, we're just loading).
151 "
152   (eq (get-dispatch-macro-character #\# #\!) #'sys::unix-executable-reader))
153
154
155 (defun pid ()
156   (linux:|getpid|))
157
158
159
160 (defun shell-quote-argument (argument)
161   "
162 DO:      Quote an argument for passing as argument to an inferior shell.
163 RETURN:  A string containing the quoted argument.
164 "
165   (do ((i 0 (1+ i))
166        (ch)
167        (result '()))
168       ((<= (length argument) i) (coerce (nreverse result) 'string))
169     (setq ch (char argument i))
170     (unless (or (char= (character "-") ch)
171                 (char= (character ".") ch)
172                 (char= (character "/") ch)
173                 (and (char<= (character "A") ch) (char<= ch (character "Z")))
174                 (and (char<= (character "a") ch) (char<= ch (character "z")))
175                 (and (char<= (character "0") ch) (char<= ch (character "9"))))
176       (push (character "\\") result))
177     (push ch result)))
178
179
180 (defun shell   (command)
181   "
182 SEE ALSO:    EXECUTE.
183 "
184   (ext:shell command))
185
186
187
188
189 (defun execute (&rest command)
190   "
191 RETURN:     The status returned by the command.
192 SEE ALSO:   SHELL
193 "
194   (ext:run-program (car command)
195     :arguments (cdr command)
196     :input :terminal :output :terminal))
197
198
199
200 (defun copy-file (file newname &optional ok-if-already-exists keep-time)
201   "
202 IMPLEMENTATION: The optional argument is not implemented.
203
204 Copy FILE to NEWNAME.  Both args must be strings.
205 If NEWNAME names a directory, copy FILE there.
206 Signals a `file-already-exists' error if file NEWNAME already exists,
207 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
208 A number as third arg means request confirmation if NEWNAME already exists.
209 This is what happens in interactive use with M-x.
210 Fourth arg KEEP-TIME non-nil means give the new file the same
211 last-modified time as the old one.  (This works on only some systems.)
212 A prefix arg makes KEEP-TIME non-nil.
213 "
214   (declare (ignore ok-if-already-exists keep-time))
215   (execute "cp" (shell-quote-argument file)  (shell-quote-argument newname)))
216
217
218 (defun make-symbolic-link (filename linkname &optional ok-if-already-exists)
219   "
220 IMPLEMENTATION: The optional argument is not implemented.
221
222 Make a symbolic link to FILENAME, named LINKNAME.  Both args strings.
223 Signals a `file-already-exists' error if a file LINKNAME already exists
224 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
225 A number as third arg means request confirmation if LINKNAME already exists.
226 "
227   (declare (ignore ok-if-already-exists))
228   (/= 0 (linux:|symlink| filename linkname)))
229
230
231 (defun make-directory (*path* &optional (parents nil))
232   "
233 Create the directory *PATH* and any optionally nonexistent parents dirs.
234 The second (optional) argument PARENTS says whether
235 to create parents directories if they don't exist.
236 "
237   (if parents
238       (ensure-directories-exist (concatenate 'string *path* "/.") :verbose nil)
239       (linux:|mkdir| *path*  511 #| #o777 |# ))
240   (ext:probe-directory (if (char= (char *path* (1- (length *path*)))
241                                   (character "/"))
242                            *path* (concatenate 'string *path* "/"))))
243
244
245
246
247 ;; From /usr/include/sysexists.h (Linux)
248
249 (defconstant ex-ok            0   "successful termination")
250
251
252 (defconstant ex--base         64  "base value for error messages")
253
254
255 (defconstant ex-usage         64  "command line usage error
256     The command was used incorrectly, e.g., with
257     the wrong number of arguments, a bad flag, a bad
258     syntax in a parameter, or whatever.")
259
260 (defconstant ex-dataerr       65  "data format error
261     The input data was incorrect in some way.
262     This should only be used for user's data & not
263     system files.")
264
265 (defconstant ex-noinput       66  "cannot open input
266     An input file (not a system file) did not
267     exist or was not readable.  This could also include
268     errors like \"No message\" to a mailer (if it cared
269     to catch it).")
270
271 (defconstant ex-nouser        67  "addressee unknown
272     The user specified did not exist.  This might
273     be used for mail addresses or remote logins.
274     ")
275
276 (defconstant ex-nohost        68  "host name unknown
277     The host specified did not exist.  This is used
278     in mail addresses or network requests.")
279
280 (defconstant ex-unavailable   69  "service unavailable
281     A service is unavailable.  This can occur
282     if a support program or file does not exist.  This
283     can also be used as a catchall message when something
284     you wanted to do doesn't work, but you don't know
285     why.")
286
287 (defconstant ex-software      70  "internal software error
288     An internal software error has been detected.
289     This should be limited to non-operating system related
290     errors as possible.")
291
292 (defconstant ex-oserr         71  "system error (e.g., can't fork)
293     An operating system error has been detected.
294     This is intended to be used for such things as \"cannot
295     fork\", \"cannot create pipe\", or the like.  It includes
296     things like getuid returning a user that does not
297     exist in the passwd file.")
298
299 (defconstant ex-osfile        72  "critical OS file missing
300     Some system file (e.g., /etc/passwd, /etc/utmp,
301     etc.) does not exist, cannot be opened, or has some
302     sort of error (e.g., syntax error).")
303
304 (defconstant ex-cantcreat     73  "can't create (user) output file
305     A (user specified) output file cannot be created.")
306
307 (defconstant ex-ioerr         74  "input/output error
308      An error occurred while doing I/O on some file.")
309
310 (defconstant ex-tempfail      75  "temp failure; user is invited to retry
311     temporary failure, indicating something that
312     is not really an error.  In sendmail, this means
313     that a mailer (e.g.) could not create a connection,
314     and the request should be reattempted later.")
315
316 (defconstant ex-protocol      76  "remote error in protocol
317     the remote system returned something that
318     was \"not possible\" during a protocol exchange.")
319
320 (defconstant ex-noperm        77  "permission denied
321     You did not have sufficient permission to
322     perform the operation.  This is not intended for
323     file system problems, which should use NOINPUT or
324     CANTCREAT, but rather for higher level permissions.")
325
326 (defconstant ex-config        78  "configuration error")
327
328
329 (defconstant ex--max          78  "maximum listed value")
330
331
332
333 (defun exit (&optional (status 0))
334   "
335 DO:      Exit the script.
336          If we are testing, then use throw to jump back to the caller.
337 "
338   (when (is-running)
339     (if *testing*
340         (throw :exit status)
341         (ext:exit status))))
342 ;; when loading, we don't exit, could we?
343
344 ;;;; THE END ;;;;