GitLab

at 2025-02-15T15:34:50+00:00

Fix #379: Support GNU-style command line option names

Merge branch 'issue-379-gnu-style-options' into 'master'

Fix #379: Support GNU-style command line option names

Closes #379

See merge request cmucl/cmucl!266
Fix #382:  Make command-line options be case-sensitive instead of case-insenstive

Merge branch 'issue-382-command-line-options-case-sensitive' into 'master'

Fix #382:  Make command-line options be case-sensitive instead of case-insenstive

Closes #382

See merge request cmucl/cmucl!267
Fix #375:  Return the name of the temp file or directory

Merge branch 'issue-375-mkstemp-return-filename' into 'master'

Fix #375:  Return the name of the temp file or directory

Closes #375

See merge request cmucl/cmucl!265
Merge branch 'master' into issue-365-add-strerror

 	(return (setf *command-line-switches*

 		      (nreverse *command-line-switches*))))

       (let* ((position (position #\= (the simple-string str) :test #'char=))

-	     (switch (subseq (the simple-string str) 1 position))

+	     ;; Extract the name of the switch.  The actual arg can be

+	     ;; "-switch" or "--switch".

+	     (switch (subseq (the simple-string str)

+			     (position-if-not #'(lambda (c)

+						  (char= c #\-))

+					      str)

+			     position))

 	     (value (if position

 			(subseq (the simple-string str) (1+ position)

 				(length (the simple-string str))))))

   the switch.  If no value was specified, then any following words are

   returned.  If there are no following words, then t is returned.  If

   the switch was not specified, then nil is returned."

-  (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))

+  (let* ((posn (position-if-not #'(lambda (ch)

+				    (char= ch #\-))

+				sname))

+	 ;; Strip up to 2 leading "-" to get the switch name.

+	 ;; Otherwise, return the entire switch name.

+	 (name (if (and posn (<= posn 2))

+		   (subseq sname posn)

+		   sname))

 	 (switch (find name *command-line-switches*

 		       :test #'string-equal

 		       :key #'cmd-switch-name)))

 					 (demons *command-switch-demons*))

   (flet ((invoke-demon (switch)

 	   (let* ((name (cmd-switch-name switch))

-		  (demon (cdr (assoc name demons :test #'string-equal))))

+		  (demon (cdr (assoc name demons :test #'string=))))

 	     (cond (demon (funcall demon switch))

-		   ((or (member name *legal-cmd-line-switches* :test #'string-equal :key #'car)

+		   ((or (member name *legal-cmd-line-switches* :test #'string= :key #'car)

 			(not *complain-about-illegal-switches*)))

 		   (t (warn (intl:gettext "~S is an illegal switch") switch)))

 	     (lisp::finish-standard-output-streams))))

     ;; We want to process -help (or --help) first, if it's given.

     ;; Since we're asking for help, we don't want to process any of

     ;; the other switches.

-    (let ((maybe-help (or (find "help" switches :key #'cmd-switch-name :test #'string-equal)

-			  (find "-help" switches :key #'cmd-switch-name :test #'string-equal))))

+    (let ((maybe-help (or (find "help" switches :key #'cmd-switch-name :test #'string=)

+			  (find "-help" switches :key #'cmd-switch-name :test #'string=))))

       (if maybe-help

 	(invoke-demon maybe-help)

 	(dolist (switch switches t)

 	(lisp::finish-standard-output-streams)

 	(setf start next)))))

-;; Docstrings should have lines longer than 72 characters so that we

-;; can print out the docstrings nicely on one line for help.

-;;                                                                     | <-- char 72

+;; Docstrings MUST consist of simple text and punctuation and

+;; newlines; no special markup is allowed.  When help is printed, the

+;; help string is automatically filled and wrapped to 80 columns.

 (defswitch "eval" #'eval-switch-demon

   "Evaluate the specified Lisp expression during the start up

-  sequence.  the value of the form will not be printed unless it is

+  sequence.  The value of the form will not be printed unless it is

   wrapped in a form that does output."

   "expression")

 (defswitch "quiet" nil

   "Causes Lisp to start up silently, disabling printing of the herald

-  and causing most unnecessary noise, like GC messages,load messages,

+  and causing most unnecessary noise, like GC messages, load messages,

   etc. to be suppressed.")

 (defswitch "debug-lisp-search" nil

 (defun help-switch-demon (switch)

   (declare (ignore switch))

-  (format t (intl:gettext "~&Usage: ~A <options>~2%") *command-line-utility-name*)

+  (format t (intl:gettext "~&Usage: ~A <options> [-- [app-args]*]~2%")

+	  *command-line-utility-name*)

   (flet

       ((get-words (s)

 	 (declare (string s))

 		     :key #'car))

       (destructuring-bind (name doc arg)

 	  s

-	(format t "    -~A ~@[~A~]~%" name (if arg (intl:gettext arg)))

+	;; Print both -switch and --switch, and the optional arg

+	;; value.

+	(format t "    -~A|--~A   ~@[~A~]~%"

+		name name

+		(if arg (intl:gettext arg)))

+

 	;; Poor man's formatting of the help string

 	(let ((*print-right-margin* 80))

 	  ;; Extract all the words from the string and print them out

 (defswitch "help" #'help-switch-demon

   "Print out the command line options and exit")

-(defswitch "-help" #'help-switch-demon

-  "Same as -help.")

-

 (defun version-switch-demon (switch)

   (declare (ignore switch))

   (format t "~A~%" (lisp-implementation-version))

 ;; it out so the user knows about it.

 (defswitch "version" #'version-switch-demon

   "Prints the cmucl version and exits, without loading the lisp core.")
-

-;; Make --version work for the benefit of those who are accustomed to

-;; GNU software.

-(defswitch "-version" #'version-switch-demon

-  "Prints the cmucl version and exits; same as -version")
 (defun unix-mkstemp (template)

   _N"Generates a unique temporary file name from TEMPLATE, and creates

   and opens the file.  On success, the corresponding file descriptor

-  and name of the file is returned.

-

- The last six characters of the template must be \"XXXXXX\"."

-  ;; Hope this buffer is large enough!

-  (let ((octets (%name->file template)))

-    (syscall ("mkstemp" c-call:c-string)

+  and name of the file is returned.  Otherwise, NIL and the UNIX error

+  code is returned."

+  (let* ((format (if (eql *filename-encoding* :null)

+		     :iso8859-1

+		     *filename-encoding*))

+	 ;; Convert the string to octets using the

+	 ;; *FILENAME-ENCODING*.  Should we signal an error if the

+	 ;; string can't be encoded?

+	 (octets (stream:string-to-octets template

+					  :external-format format))

+	 (length (length octets)))

+    (with-alien ((buffer (* c-call:unsigned-char)))

+      (setf buffer (make-alien c-call:unsigned-char (1+ length)))

+      ;; Copy the octets from OCTETS to the null-terminated array BUFFER.

+      (system:without-gcing

+	  (kernel:system-area-copy (vector-sap octets) 0

+				   (alien-sap buffer) 0

+				   (* length vm:byte-bits)))

+      (setf (deref buffer length) 0)

+

+      (syscall ("mkstemp" (* c-call:char))

 	       (values result

-		       ;; Convert the file name back to a Lisp string.

-		       (%file->name octets))

-	       octets)))

+		       (progn

+			 ;; Copy out the alien bytes and convert back

+			 ;; to a lisp string.

+			 (system:without-gcing

+			     (kernel:system-area-copy (alien-sap buffer) 0

+						      (vector-sap octets) 0

+						      (* length vm:byte-bits)))

+			 (stream:octets-to-string octets

+						  :external-format format)))

+	       (cast buffer (* c-call:char))))))

 (defun unix-mkdtemp (template)

-  _N"Generate a uniquely named temporary directory from Template,

-  which must have \"XXXXXX\" as the last six characters.  The

+  _N"Generate a uniquely named temporary directory from Template.  The

   directory is created with permissions 0700.  The name of the

-  directory is returned."

-  (let* ((octets (%name->file template))

-	 (result (alien-funcall

-		  (extern-alien "mkdtemp"

-				(function (* char)

-					  c-call:c-string))

-		  octets)))

-    (if (null-alien result)

-	(values nil (unix-errno))

-	(%file->name octets))))

+  directory is returned.

+

+  If the directory cannot be created NIL and the UNIX error code is

+  returned."

+  (let* ((format (if (eql *filename-encoding* :null)

+		     :iso8859-1

+		     *filename-encoding*))

+	 ;; Encode the string using the appropriate

+	 ;; *filename-encoding*.  Should we signal an error if the

+	 ;; string can't be encoded in that format?

+	 (octets (stream:string-to-octets template

+					  :external-format format))

+	 (length (length octets)))

+    (with-alien ((buffer (* c-call:unsigned-char)))

+      (setf buffer (make-alien c-call:unsigned-char (1+ length)))

+      ;; Copy the octets from OCTETS to the null-terminated array BUFFER.

+      (system:without-gcing

+	  (kernel:system-area-copy (vector-sap octets) 0

+				   (alien-sap buffer) 0

+				   (* length vm:byte-bits)))

+      (setf (deref buffer length) 0)

+

+      (let ((result (alien-funcall

+		     (extern-alien "mkdtemp"

+				   (function (* char)

+					     (* char)))

+		     (cast buffer (* char)))))

+	;; If mkdtemp worked, a non-NIL value is returned, return the

+	;; resulting name.  Otherwise, return NIL and the errno.

+	(if (null-alien result)

+	    (values nil (unix-errno))

+	    (%file->name (cast result c-call:c-string)))))))

 (defun unix-strerror (errno)

   _N"Returns a string that describes the error code Errno"

     * ~~#364~~ Add interface to `mkdtemp` and `mkstemp`

     * ~~#367~~ Add stream:string-count-octets to count octets in a string

     * ~~#369~~ Improve docstring for `unix::unix-setlocale`

+    * ~~#379~~ Support GNU-style command-line option names

   * Other changes:

   * Improvements to the PCL implementation of CLOS:

   * Changes to building procedure:

 msgid ""

 "Generates a unique temporary file name from TEMPLATE, and creates\n"

 "  and opens the file.  On success, the corresponding file descriptor\n"

-"  and name of the file is returned.\n"

-"\n"

-" The last six characters of the template must be \"XXXXXX\"."

+"  and name of the file is returned.  Otherwise, NIL and the UNIX error\n"

+"  code is returned."

 msgstr ""

 #: src/code/unix.lisp

 msgid ""

-"Generate a uniquely named temporary directory from Template,\n"

-"  which must have \"XXXXXX\" as the last six characters.  The\n"

+"Generate a uniquely named temporary directory from Template.  The\n"

 "  directory is created with permissions 0700.  The name of the\n"

-"  directory is returned."

+"  directory is returned.\n"

+"\n"

+"  If the directory cannot be created NIL and the UNIX error code is\n"

+"  returned."

 msgstr ""

 #: src/code/unix.lisp

 #: src/code/commandline.lisp

 msgid ""

 "Evaluate the specified Lisp expression during the start up\n"

-"  sequence.  the value of the form will not be printed unless it is\n"

+"  sequence.  The value of the form will not be printed unless it is\n"

 "  wrapped in a form that does output."

 msgstr ""

 #: src/code/commandline.lisp

 msgid ""

 "Causes Lisp to start up silently, disabling printing of the herald\n"

-"  and causing most unnecessary noise, like GC messages,load messages,\n"

+"  and causing most unnecessary noise, like GC messages, load messages,\n"

 "  etc. to be suppressed."

 msgstr ""

 msgstr ""

 #: src/code/commandline.lisp

-msgid "~&Usage: ~A <options>~2%"

+msgid "~&Usage: ~A <options> [-- [app-args]*]~2%"

 msgstr ""

 #: src/code/commandline.lisp

 msgid "Print out the command line options and exit"

 msgstr ""

-#: src/code/commandline.lisp

-msgid "Same as -help."

-msgstr ""

-

 #: src/code/commandline.lisp

 msgid "Prints the cmucl version and exits, without loading the lisp core."

 msgstr ""

-#: src/code/commandline.lisp

-msgid "Prints the cmucl version and exits; same as -version"

-msgstr ""

-

 #: src/code/env-access.lisp

 msgid ""

 "Returns information about the symbol VAR in the lexical environment ENV.\n"

     exit(1);

 }

+/*

+ * Match the actual command line option "arg" with the arg name in

+ * "argname".  The option matches if it is exacty the arg name

+ * prefixed by either one or two "-" characters.

+ *

+ * Returns non-zero if it matches.

+ */

+int match_option(const char* arg, const char* argname)

+{

+    if ((strlen(arg) < 2) || strlen(argname) < 1) {

+	/*

+	 * The actual arg must be at least 2 characters.  The argname

+	 * must have at least 1.

+	 */

+	return 0;

+    }

+

+    /* Must start with a "-" */

+    if (arg[0] != '-') {

+	return 0;

+    }

+

+    if (strcmp(arg + 1, argname) == 0) {

+	/* We have "-" followed by the argname.  That's a match. */

+	return 1;

+    }

+    

+    if ((arg[1] == '-') && (strcmp(arg + 2, argname) == 0)) {

+	/* We have "--" followed by the argname.  That's a match. */

+	return 1;

+    }

+

+    return 0;

+}

+    

 int

 main(int argc, const char *argv[], const char *envp[])

 {

     argptr = argv;

     while ((arg = *++argptr) != NULL) {

-	if (strcmp(arg, "-core") == 0) {

+	if (match_option(arg, "core")) {

 	    if (builtin_image_flag) {

 		fprintf(stderr,

 			"Warning:  specifying a core file with an executable image is unusual,\nbut should work.\n");

 	    core = *++argptr;

 	    if (core == NULL) {

 		fprintf(stderr,

-			"-core must be followed by the name of the core file to use.\n");

+			"%s must be followed by the name of the core file to use.\n",

+			arg);

 		exit(1);

 	    }

-	} else if (strcmp(arg, "-lib") == 0) {

+	} else if (match_option(arg, "lib")) {

 	    lib = *++argptr;

 	    if (lib == NULL) {

 		fprintf(stderr,

-			"-lib must be followed by a string denoting the CMUCL library path.\n");

+			"%s must be followed by a string denoting the CMUCL library path.\n",

+			arg);

 		exit(1);

 	    }

-        } else if (strcmp(arg, "-read-only-space-size") == 0) {

+        } else if (match_option(arg, "read-only-space-size")) {

             const char *str = *++argptr;

             if (str == NULL) {

                 fprintf(stderr,

-                        "-read-only-space-size must be followed by the size in MBytes.\n");

+                        "%s must be followed by the size in MBytes.\n",

+			arg);

                 exit(1);

             }

             read_only_space_size = atoi(str) * 1024 * 1024;

             if (read_only_space_size > READ_ONLY_SPACE_SIZE) {

                 fprintf(stderr,

-                        "-read-only-space-size must be no greater than %lu MBytes.\n",

+                        "%s must be no greater than %lu MBytes.\n",

+			arg,

                         READ_ONLY_SPACE_SIZE / (1024 * 1024UL));

                 fprintf(stderr, "  Continuing with default size.\n");

                 read_only_space_size = READ_ONLY_SPACE_SIZE;

             }

-        } else if (strcmp(arg, "-static-space-size") == 0) {

+        } else if (match_option(arg, "static-space-size")) {

             const char *str = *++argptr;

             if (str == NULL) {

                 fprintf(stderr,

-                        "-static-space-size must be followed by the size in MBytes.\n");

+                        "%s must be followed by the size in MBytes.\n",

+			arg);

                 exit(1);

             }

             static_space_size = atoi(str) * 1024 * 1024;

             if (static_space_size > STATIC_SPACE_SIZE) {

                 fprintf(stderr,

-                        "-static-space-size must be no greater than %lu MBytes.\n",

+                        "%s must be no greater than %lu MBytes.\n",

+			arg,

                         STATIC_SPACE_SIZE / (1024 * 1024UL));

                 fprintf(stderr, "  Continuing with default size.\n");

                 static_space_size = STATIC_SPACE_SIZE;

             }

-        } else if (strcmp(arg, "-binding-stack-size") == 0) {

+        } else if (match_option(arg, "binding-stack-size")) {

             const char *str = *++argptr;

             if (str == NULL) {

                 fprintf(stderr,

-                        "-binding-stack-size must be followed by the size in MBytes.\n");

+                        "%s must be followed by the size in MBytes.\n",

+			arg);

                 exit(1);

             }

             binding_stack_size = atoi(str) * 1024 * 1024;

             if (binding_stack_size > BINDING_STACK_SIZE) {

                 fprintf(stderr,

-                        "-binding-stack-size must be no greater than %lu MBytes.\n",

+                        "%s must be no greater than %lu MBytes.\n",

+			arg,

                         BINDING_STACK_SIZE / (1024 * 1024UL));

                 fprintf(stderr, "  Continuing with default size.\n");

                 binding_stack_size = BINDING_STACK_SIZE;

             }

-        } else if (strcmp(arg, "-control-stack-size") == 0) {

+        } else if (match_option(arg, "control-stack-size")) {

             const char *str = *++argptr;

             if (str == NULL) {

                 fprintf(stderr,

-                        "-control-stack-size must be followed by the size in MBytes.\n");

+                        "%s must be followed by the size in MBytes.\n",

+			arg);

                 exit(1);

             }

             control_stack_size = atoi(str) * 1024 * 1024;

             if (control_stack_size > CONTROL_STACK_SIZE) {

                 fprintf(stderr,

-                        "-control-stack-size must be no greater than %lu MBytes.\n",

+                        "%s must be no greater than %lu MBytes.\n",

+			arg,

                         CONTROL_STACK_SIZE / (1024 * 1024UL));

                 fprintf(stderr, "  Continuing with default size.\n");

                 control_stack_size = CONTROL_STACK_SIZE;

             }

-	} else if (strcmp(arg, "-dynamic-space-size") == 0) {

+	} else if (match_option(arg, "dynamic-space-size")) {

 	    const char *str;

 	    str = *++argptr;

 	    if (str == NULL) {

 		fprintf(stderr,

-			"-dynamic-space-size must be followed by the size to use in MBytes.\n");

+			"%s must be followed by the size to use in MBytes.\n",

+			arg);

 		exit(1);

 	    }

 #ifndef sparc

 #endif

 	    if (dynamic_space_size > DYNAMIC_SPACE_SIZE) {

 		fprintf(stderr,

-			"-dynamic-space-size must be no greater than %lu MBytes.\n",

+			"%s must be no greater than %lu MBytes.\n",

+			arg,

 			DYNAMIC_SPACE_SIZE / (1024 * 1024UL));

 		exit(1);

 	    }

-	} else if (strcmp(arg, "-monitor") == 0) {

+	} else if (match_option(arg, "monitor")) {

 	    monitor = TRUE;

-	} else if (strcmp(arg, "-debug-lisp-search") == 0) {

+	} else if (match_option(arg, "debug-lisp-search")) {

 	    debug_lisp_search = TRUE;

-        } else if (strcmp(arg, "-unidata") == 0) {

+        } else if (match_option(arg, "unidata")) {

           unidata = *++argptr;

         } else if ((strcmp(arg, "-version") == 0) ||

 		   (strcmp(arg, "--version") == 0)) {

     argptr = argv;

     while ((arg = *++argptr) != NULL) {

-	if (strcmp(arg, "-batch") == 0)

+	if (match_option(arg, "batch"))

 	    SetSymbolValue(BATCH_MODE, T);

     }

+;;; Tests for the unix interface

+

+(defpackage :unix-tests

+  (:use :cl :lisp-unit))

+

+(in-package "UNIX-TESTS")

+

+(define-test mkstemp.name-returned

+  (:tag :issues)

+  (let (fd filename)

+    (unwind-protect

+	 (progn

+	   (let ((template "test-XXXXXX"))

+	     (multiple-value-setq (fd filename)

+	       (unix::unix-mkstemp (copy-seq template)))

+	     (assert-true fd)

+	     (assert-true (equalp (length filename) (length template)))

+	     (assert-false (equalp filename template))

+	     (assert-true (>= 5 (mismatch filename template))))))

+      (when fd

+	(unix:unix-unlink filename)))))

+

+(define-test mkstemp.non-ascii-name-returned

+  (:tag :issues)

+  (let ((unix::*filename-encoding* :utf-8)

+	fd name)

+    (unwind-protect

+	 (progn

+	   ;; Temp name starts with a lower case alpha character.

+	   (let* ((template (concatenate 'string (string #\u+3b1)

+					 "test-XXXXXX"))

+		  (x-posn (position #\X template)))

+	     (multiple-value-setq (fd name)

+	       (unix::unix-mkstemp template))

+	     (assert-true fd)

+	     (assert-false (search "XXXXXX" name)

+			   name)

+	     (assert-true (string= name template :end1 x-posn :end2 x-posn)

+			  name)))

+      (when fd

+	(unix:unix-unlink name)))))

+

+(define-test mkstemp.bad-path

+  (:tag :issues)

+  (multiple-value-bind (fd errno)

+      ;; Assumes that the directory "random-dir" doesn't exist

+      (unix::unix-mkstemp "random-dir/test-XXXXXX")

+    ;; Can't create and open the file so the FD should be NIL, and a

+    ;; positive Unix errno value should be returned.

+    (assert-false fd)

+    (assert-true (and (integerp errno) (plusp errno)))))

+

+(define-test mkdtemp.name-returned

+  (:tag :issues)

+  (let (name)

+    (unwind-protect

+	 (progn

+	   (setf name (unix::unix-mkdtemp "dir-XXXXXX"))

+	   ;; Verify that the dir name no longer has X's.

+	   (assert-true (stringp name))

+	   (assert-false (search "XXXXXX" name)))

+      (when name

+	(unix:unix-rmdir name)))))

+

+(define-test mkdtemp.non-ascii-name-returned

+  (:tag :issues)

+  (let ((unix::*filename-encoding* :utf-8)

+	name)

+    (unwind-protect

+	 (progn

+	   ;; Temp name starts with a lower case alpha character.

+	   (let* ((template (concatenate 'string (string #\u+3b1)

+					 "dir-XXXXXX"))

+		  (x-posn (position #\X template)))

+	     (setf name (unix::unix-mkdtemp template))

+	     ;; Verify that the dir name no longer has X's.

+	     (assert-true (stringp name))

+	     (assert-false (search "XXXXXX" name))

+	     (assert-true (string= name template :end1 x-posn :end2 x-posn)

+			  name x-posn)))

+      (when name

+	(unix:unix-rmdir name)))))

+

+(define-test mkdtemp.bad-path

+  (:tag :issues)

+  (multiple-value-bind (result errno)

+      (unix::unix-mkdtemp "random-dir/dir-XXXXXX")

+    (assert-false result)

+    (assert-true (and (integerp errno) (plusp errno)))))

+

+

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl

Commits:

7 changed files:

Changes: