GitLab

at 2022-11-03T04:47:09+00:00

Fix #149:  Call setlocale(3C) on startup

Merge branch 'issue-149-add-setlocale' into 'master'

Fix #149:  Call setlocale(3C) on startup

Closes #149

See merge request cmucl/cmucl!105
Fix #155: Wrap help strings neatly

Merge branch 'issue-155-wrap-help-strings' into 'master'

Fix #155: Wrap help strings neatly

Closes #155

See merge request cmucl/cmucl!107
Fix #141: Use setlocale to handle localization settings

Merge branch 'issue-141-locale' into 'master'

Fix #141: Use setlocale to handle localization settings

Closes #141, #136, #142, #146, #134, and #132

See merge request cmucl/cmucl!101
Merge branch 'master' into issue-140-stream-element-type-two-way-stream

 (defun help-switch-demon (switch)

   (declare (ignore switch))

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

-  (dolist (s (sort *legal-cmd-line-switches* #'string<

-		   :key #'car))

-    (destructuring-bind (name doc arg)

-	s

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

-      ;; Poor man's formatting of the help string

-      (with-input-from-string (stream (intl:gettext doc))

-	(loop for line = (read-line stream nil nil)

-	   while line

-	   do (format t "~8T~A~%" line)))))

+  (flet

+      ((get-words (s)

+	 (declare (string s))

+	 ;; Return a list of all the words from S.  A word is defined

+	 ;; as any sequence of characters separated from others by

+	 ;; whitespace consisting of space, newline, tab, formfeed, or

+	 ;; carriage return.

+	 (let ((end (length s)))

+	   (loop for left = 0 then (+ right 1)

+		 for right = (or

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

+					       (member c

+						       '(#\space #\newline #\tab #\ff #\cr)))

+					   s

+					   :start left)

+			      end)

+		 ;; Collect the word bounded by left and right in a list.

+		 unless (and (= right left))

+		   collect (subseq s left right) into subseqs

+		 ;; Keep going until we reach the end of the string.

+		 until (>= right end)

+		 finally (return subseqs)))))

+

+    (dolist (s (sort *legal-cmd-line-switches* #'string<

+		     :key #'car))

+      (destructuring-bind (name doc arg)

+	  s

+	(format t "    -~A ~@[~A~]~%" 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

+	  ;; one by one with a space between each, wrapping the output

+	  ;; if needed.  Each line is indented by 8 spaces.

+	  ;;

+	  ;; "~@<       ~@;"

+	  ;;    per-line prefix of spaces and pass the whole arg list

+	  ;;    to this directive.

+	  ;;

+	  ;; "~{~A~^ ~}"

+	  ;;    loop over each word and print out the word followed by

+	  ;;    a space.

+	  ;;

+	  ;; "~:@>"

+	  ;;    No suffix, and insert conditional newline after each

+	  ;;    group of blanks if needed.

+	  (format t "~@<        ~@;~{~A~^ ~}~:@>"

+		  (get-words (intl:gettext doc))))

+	(terpri))))

   (ext:quit))

   

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

 

 (defun setlocale (&optional locale)

   (setf *locale* (or locale

-		     (getenv "LANGUAGE")

-		     (getenv "LC_ALL")

-		     (getenv "LC_MESSAGES")

-		     (getenv "LANG")

+		     (unix::unix-get-lc-messages)

 		     *locale*)))

 

 (defmacro textdomain (domain)

 	     (reinit)

 	     (environment-init)

 	     (dolist (f *after-save-initializations*) (funcall f))

+	     ;; Set the runtime locale

+	     (unless (zerop (unix::unix-setlocale))

+	       (warn "os_setlocale failed"))

+	     ;; Set the locale for lisp

 	     (intl::setlocale)

 	     (ext::process-command-strings process-command-line)

 	     (setf *editor-lisp-p* nil)

    of the child in the parent if it works, or NIL and an error number if it

    doesn't work."

   (int-syscall ("fork")))

+

+(defun unix-setlocale ()

+  _N"Call setlocale(3c) with fixed args.  Returns 0 on success."

+  (alien:alien-funcall

+   (alien:extern-alien "os_setlocale"

+		       (function c-call:int))))

+

+(defun unix-get-lc-messages ()

+  _N"Get LC_MESSAGES from the current locale.  If we can't, return

+  NIL.  A call to UNIX-SETLOCALE must have been done previously before

+  calling this so that the correct locale is returned."

+  (with-alien ((buf (array c-call:char 256)))

+    (let ((result

+	    (alien-funcall

+	     (extern-alien "os_get_lc_messages"

+			   (function c-call:int

+				     (* c-call:char)

+				     c-call:int))

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

+	     256)))

+      (when (zerop result)

+	(cast buf c-call:c-string)))))
     * ~~#136~~ `ensure-directories-exist` should return the given pathspec

     * #139 `*default-external-format*` defaults to `:utf-8`

     * ~~#140~~ External format of `two-way-stream`

+    * ~~#141~~ Disallow locales that are pathnames to a localedef file

     * ~~#142~~ `(random 0)` signals incorrect error

-    * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` 

+    * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream`

+    * ~~#149~~ Call setlocale(3C) on startup

+    * ~~#155~~ Wrap help strings neatly

   * Other changes:

   * Improvements to the PCL implementation of CLOS:

   * Changes to building procedure:

 "   doesn't work."

 msgstr ""

 

+#: src/code/unix.lisp

+msgid "Call setlocale(3c) with fixed args.  Returns 0 on success."

+msgstr ""

+

+#: src/code/unix.lisp

+msgid ""

+"Get LC_MESSAGES from the current locale.  If we can't, return\n"

+"  NIL.  A call to UNIX-SETLOCALE must have been done previously before\n"

+"  calling this so that the correct locale is returned."

+msgstr ""

+
 

 #include <assert.h>

 #include <errno.h>

+#include <locale.h>

 #include <math.h>

 #include <netdb.h>

 #include <pwd.h>

     

     return result;

 }

+

+int

+os_setlocale(void)

+{

+    char *result = setlocale(LC_ALL, "");

+

+    /* Return 0 if setlocale suceeded; otherwise -1. */

+    return result != NULL ? 0 : -1;

+}

+

+int

+os_get_lc_messages(char *buf, int len)

+{

+    char *locale = setlocale(LC_MESSAGES, NULL);

+    if (locale) {

+        strncpy(buf, locale, len - 1);

+        buf[len - 1] = '\0';

+    }

+

+    /* Return -1 if setlocale failed. */

+    return locale ? 0 : -1;

+}

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl

Commits:

7 changed files:

Changes: