;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- ;;; $Revision: 1.11 $ ;;; Copyright 1999-2010 Paul Foley (mycroft@actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this Software to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; provided that the above copyright notice and this permission notice ;;; are included in all copies or substantial portions of the Software. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. (ext:file-comment "$Header: src/code/intl.lisp $") (in-package "INTL") (eval-when (:compile-toplevel :execute) (defparameter intl::*default-domain* "cmucl") (unless (and (fboundp 'intl:read-translatable-string) (eq (get-macro-character #\_) (fdefinition 'intl:read-translatable-string))) (set-macro-character #\_ (lambda (stream char) (declare (ignore char)) (case (peek-char nil stream nil nil t) (#\" (values)) (#\N (read-char stream t nil t) (values)) (otherwise '_))) t))) (in-package "INTL") (defvar *locale-directories* '(#p"library:locale/" #p"/usr/share/locale/" #p"target:i18n/locale/")) (defvar *locale* "C") (defvar *default-domain* nil "The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT. Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.") (defvar *loaded-domains* (make-hash-table :test 'equal)) (defvar *locale-aliases* (make-hash-table :test 'equal)) (defstruct domain-entry (domain "" :type simple-base-string) (locale "" :type simple-base-string) (file #p"" :type pathname) (plurals nil :type (or null function)) (hash (make-hash-table :test 'equal) :type hash-table) (encoding nil) (readfn #'identity :type function)) (declaim (ftype (function (stream) (unsigned-byte 32)) read-lelong)) (defun read-lelong (stream) (declare #+(or)(optimize (speed 3) (space 2) (safety 0) #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn (+ (the (unsigned-byte 8) (read-byte stream)) (ash (the (unsigned-byte 8) (read-byte stream)) 8) (ash (the (unsigned-byte 8) (read-byte stream)) 16) (ash (the (unsigned-byte 8) (read-byte stream)) 24))) (declaim (ftype (function (stream) (unsigned-byte 32)) read-belong)) (defun read-belong (stream) (declare #+(or)(optimize (speed 3) (space 2) (safety 0) #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn (+ (ash (the (unsigned-byte 8) (read-byte stream)) 24) (ash (the (unsigned-byte 8) (read-byte stream)) 16) (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) (defun locate-domain-file (domain locale locale-dir) ;; The default locale-dir includes search lists. If we get called ;; before the search lists are initialized, we lose. The search ;; lists are initialized in environment-init, which sets ;; *environment-list-initialized*. This way, we return NIL to ;; indicate there's no domain file to use. (when lisp::*environment-list-initialized* (flet ((path (locale base) (merge-pathnames (make-pathname :directory (list :relative locale "LC_MESSAGES") :name domain :type "mo") base))) (let ((locale (or (gethash locale *locale-aliases*) locale))) (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) (let ((probe (or (probe-file (path locale base)) (let ((dot (position #\. locale))) (and dot (probe-file (path (subseq locale 0 dot) base)))) (let ((at (position #\@ locale))) (and at (probe-file (path (subseq locale 0 at) base)))) (let ((us (position #\_ locale))) (and us (probe-file (path (subseq locale 0 us) base))))))) (when probe (return probe)))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain)) (setf (domain-entry-encoding domain) :iso8859-1) ;; Domain lookup can call the compiler, so set the locale to "C" ;; so things work. (let* ((*locale* "C") (header (domain-lookup "" domain)) (ctype (search "Content-Type: " header)) (eoln (and ctype (position #\Newline header :start ctype))) (charset (and ctype (search "; charset=" header :start2 ctype :end2 eoln)))) (when charset (incf charset 10) (loop for i upfrom charset below eoln as c = (char header i) while (or (alphanumericp c) (eql c #\-)) finally (setf (domain-entry-encoding domain) (intern (nstring-upcase (subseq header charset i)) "KEYWORD")))))) domain) (defun parse-plurals (domain) (let* ((header (domain-lookup "" domain)) (plurals (search "Plural-Forms: " header)) (default (lambda (n) (if (= n 1) 0 1)))) (if (and plurals (> (length header) (+ plurals 36)) (string= header "nplurals=" :start1 (+ plurals 14) :end1 (+ plurals 23))) (let ((nplurals (parse-integer header :start (+ plurals 23) :junk-allowed t)) (point (+ (position #\; header :start (+ plurals 23)) 2))) (if (and (> (length header) (+ point 10)) (string= header "plural=" :start1 point :end1 (+ point 7))) (values (parse-expr header (+ point 7)) nplurals) (values default 2))) (values default 2)))) (defun parse-expr (string pos) (labels ((next () (loop while (member (char string pos) '(#\Space #\Tab #\Newline)) do (incf pos)) (case (char string (1- (incf pos))) (#\n 'n) (#\? 'IF) (#\: 'THEN) (#\( 'LPAR) (#\) 'RPAR) (#\^ 'LOGXOR) (#\+ 'ADD) (#\- 'SUB) (#\* 'MUL) (#\/ 'FLOOR) (#\% 'MOD) (#\~ 'LOGNOT32) (#\; 'END) (#\| (if (char= (char string pos) #\|) (progn (incf pos) 'COR) 'LOGIOR)) (#\& (if (char= (char string pos) #\&) (progn (incf pos) 'CAND) 'LOGAND)) (#\= (if (char= (char string pos) #\=) (progn (incf pos) 'CMP=) (error (intl:gettext "Encountered illegal token: =")))) (#\! (if (char= (char string pos) #\=) (progn (incf pos) 'CMP/=) 'NOT)) (#\< (case (char string pos) (#\= (incf pos) 'CMP<=) (#\< (incf pos) 'SHL) (otherwise 'CMP<))) (#\> (case (char string pos) (#\= (incf pos) 'CMP>=) (#\> (incf pos) 'SHR) (otherwise 'CMP>))) (otherwise (let ((n (digit-char-p (char string (1- pos))))) (if n (loop for nx = (digit-char-p (char string pos)) while nx do (setq n (+ (* n 10) nx)) (incf pos) finally (return n)) (error (intl:gettext "Encountered illegal token: ~C") (char string (1- pos)))))))) (conditional (tok &aux tree) (multiple-value-setq (tree tok) (logical-or tok)) (when (eql tok 'IF) (multiple-value-bind (right next) (logical-or (next)) (unless (eql next 'THEN) (error (intl:gettext "Expected : in ?: construct"))) (multiple-value-bind (else next) (conditional (next)) (setq tree (list tok (list 'zerop tree) else right) tok next)))) (values tree tok)) (logical-or (tok &aux tree) (multiple-value-setq (tree tok) (logical-and tok)) (loop while (eql tok 'COR) do (multiple-value-bind (right next) (logical-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (logical-and (tok &aux tree) (multiple-value-setq (tree tok) (inclusive-or tok)) (loop while (eql tok 'CAND) do (multiple-value-bind (right next) (inclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (inclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (exclusive-or tok)) (loop while (eql tok 'LOGIOR) do (multiple-value-bind (right next) (exclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (exclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (bitwise-and tok)) (loop while (eql tok 'LOGXOR) do (multiple-value-bind (right next) (bitwise-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (bitwise-and (tok &aux tree) (multiple-value-setq (tree tok) (equality tok)) (loop while (eql tok 'LOGAND) do (multiple-value-bind (right next) (equality (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (equality (tok &aux tree) (multiple-value-setq (tree tok) (relational tok)) (loop while (member tok '(CMP= CMP/=)) do (multiple-value-bind (right next) (relational (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (relational (tok &aux tree) (multiple-value-setq (tree tok) (shift tok)) (loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do (multiple-value-bind (right next) (shift (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (shift (tok &aux tree) (multiple-value-setq (tree tok) (additive tok)) (loop while (member tok '(SHL SHR)) do (multiple-value-bind (right next) (additive (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (additive (tok &aux tree) (multiple-value-setq (tree tok) (multiplicative tok)) (loop while (member tok '(ADD SUB)) do (multiple-value-bind (right next) (multiplicative (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (multiplicative (tok &aux tree) (multiple-value-setq (tree tok) (unary tok)) (loop while (member tok '(MUL FLOOR MOD)) do (multiple-value-bind (right next) (unary (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (unary (tok &aux tree) (cond ((eq tok 'LPAR) (multiple-value-setq (tree tok) (conditional (next))) (unless (eq tok 'RPAR) (error (intl:gettext "Expected close-paren."))) (values tree (next))) ((numberp tok) (values tok (next))) ((eql tok 'n) (values tok (next))) ((eql tok 'ADD) (unary (next))) ((eql tok 'SUB) (multiple-value-setq (tree tok) (unary (next))) (values (list '- tree) tok)) ((eql tok 'LOGNOT32) (multiple-value-setq (tree tok) (unary (next))) (values (list 'LOGNOT32 tree) tok)) ((eql tok 'NOT) (multiple-value-setq (tree tok) (unary (next))) (values (list 'CNOT tree) tok)) (t (error (intl:gettext "Unexpected token: ~S.") tok))))) (multiple-value-bind (tree end) (conditional (next)) (unless (eq end 'END) (error (intl:gettext "Expecting end of expression. ~S.") end)) (let ((*compile-print* nil)) (compile nil `(lambda (n) (declare (type (unsigned-byte 32) n) (optimize (space 3))) (flet ((add (a b) (ldb (byte 32 0) (+ a b))) (sub (a b) (ldb (byte 32 0) (- a b))) (mul (a b) (ldb (byte 32 0) (* a b))) (shl (a b) (ldb (byte 32 0) (ash a b))) (shr (a b) (ash a (- b))) (cmp= (a b) (if (= a b) 1 0)) (cmp/= (a b) (if (/= a b) 1 0)) (cmp< (a b) (if (< a b) 1 0)) (cmp<= (a b) (if (<= a b) 1 0)) (cmp> (a b) (if (> a b) 1 0)) (cmp>= (a b) (if (>= a b) 1 0)) (cand (a b) (if (or (zerop a) (zerop b)) 0 1)) (cor (a b) (if (and (zerop a) (zerop b)) 0 1)) (cnot (a) (if a 0 1)) (lognot32 (a) (ldb (byte 32 0) (lognot a)))) (declare (ignorable #'add #'sub #'mul #'shr #'shl #'cmp= #'cmp/= #'cmp< #'cmp<= #'cmp> #'cmp>= #'cand #'cor #'cnot #'lognot32)) ,tree))))))) (defun load-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((file (locate-domain-file domain locale locale-dir)) (read #'read-lelong)) (unless file (let ((entry (make-domain-entry :domain domain :locale locale :hash (make-hash-table :size 0 :test 'equal)))) (setf (gethash domain *loaded-domains*) entry) (return-from load-domain entry))) (with-open-file (stream file :direction :input :if-does-not-exist nil :element-type '(unsigned-byte 8)) (unless stream (return-from load-domain nil)) (let ((magic (read-lelong stream))) (cond ((= magic #x950412de) (setq read #'read-lelong)) ((= magic #xde120495) (setq read #'read-belong)) (t ;; DON'T translate this! If we can't load the domain, ;; we can't print this message, Which causes an error ;; that causes use to do a domain lookup again, which ;; fails which cause an error message which ... (warn "Bad magic number in \"~A.mo\"." domain) (return-from load-domain nil)))) (let ((version (funcall read stream)) (messages (funcall read stream)) (master (funcall read stream)) (translation (funcall read stream)) (entry (make-domain-entry))) (declare (ignore version)) (setf (domain-entry-readfn entry) read) (setf (domain-entry-domain entry) domain) (setf (domain-entry-locale entry) locale) (setf (domain-entry-file entry) file) (dotimes (msg messages) (file-position stream (+ master (* 8 msg))) (let ((length (funcall read stream)) (start (funcall read stream))) (setf (gethash length (domain-entry-hash entry)) (acons start (+ translation (* 8 msg)) (gethash length (domain-entry-hash entry)))))) (setf (gethash domain *loaded-domains*) entry) (find-encoding entry))))) (defun find-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((found (gethash domain *loaded-domains*))) (if (and found (string= (domain-entry-locale found) locale)) found (load-domain domain locale locale-dir)))) (declaim (inline string-to-octets)) (defun string-to-octets (string encoding) (declare (ignorable encoding)) #+(and CMU Unicode) (ext:string-to-octets string :external-format encoding) #+Allegro (excl:string-to-octets string :external-format encoding :null-terminate nil) #+SBCL (sb-ext:string-to-octets string :external-format encoding :null-terminate nil) #+CLISP ;;@@ Not sure if encoding keyword is OK here (ext:convert-string-to-bytes string encoding) ;;@@ add other implementations #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) (map-into (make-array (length string) :element-type '(unsigned-byte 8)) #'char-code string)) (declaim (inline octets-to-string)) (defun octets-to-string (octets encoding) (declare (ignorable encoding)) #+(and CMU Unicode) (ext:octets-to-string octets :external-format encoding) #+Allegro (excl:octets-to-string octets :external-format encoding :end (length octets)) #+SBCL (sb-ext:octets-to-string octets :external-format encoding) #+CLISP ;;@@ Not sure if encoding keyword is OK here (ext:convert-string-from-bytes octets encoding) ;;@@ add other implementations #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) (map-into (make-string (length octets)) #'code-char octets)) (defun octets= (a b &key (start1 0) (end1 (length a)) (start2 0) (end2 (length b))) (declare (type (simple-array (unsigned-byte 8) (*)) a b) (type (integer 0 #.array-dimension-limit) start1 end1 start2 end2) #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0))) (when (and (< start1 end1) (< start2 end2)) (loop (unless (= (aref a start1) (aref b start2)) (return nil)) (when (or (= (incf start1) end1) (= (incf start2) end2)) (return t))))) (defun search-domain (octets domain pos) (declare (type (simple-array (unsigned-byte 8) (*)) octets) (type domain-entry domain) (type list pos) #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0) #+CMU (ext:inhibit-warnings 3))) ; quiet about boxing (when pos (let ((temp (make-array 120 :element-type '(unsigned-byte 8))) (length (length octets))) (with-open-file (stream (domain-entry-file domain) :direction :input :element-type '(unsigned-byte 8)) (dolist (entry pos) (file-position stream (car entry)) (let ((off 0) (end (read-sequence temp stream :end (min 120 length)))) (declare (type (integer 0 #.array-dimension-limit) off end)) (loop while (octets= octets temp :start1 off :end1 (min (+ off 120) length) :end2 end) do (incf off end) (when (< off length) (setf end (read-sequence temp stream :end (min 120 (- length off)))))) (when (= off length) (file-position stream (cdr entry)) (let* ((len (funcall (domain-entry-readfn domain) stream)) (off (funcall (domain-entry-readfn domain) stream)) (tmp (make-array len :element-type '(unsigned-byte 8)))) (file-position stream off) (read-sequence tmp stream) (return (values tmp entry)))))))))) (defun domain-lookup (string domain) (declare (type string string) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) (or (if (null (domain-entry-encoding domain)) string) (gethash string (domain-entry-hash domain)) (let* ((octets (string-to-octets string (domain-entry-encoding domain))) (length (length octets)) (pos (gethash length (domain-entry-hash domain)))) (declare (type (simple-array (unsigned-byte 8) (*)) octets)) (multiple-value-bind (tmp entry) (search-domain octets domain pos) (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) (when tmp (let ((temp (delete entry pos :test #'eq))) (if temp (setf (gethash length (domain-entry-hash domain)) temp) (remhash length (domain-entry-hash domain)))) (setf (gethash (copy-seq string) (domain-entry-hash domain)) (octets-to-string tmp (domain-entry-encoding domain)))))))) (defun domain-lookup-plural (singular plural domain) (declare (type string singular plural) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) (when (domain-entry-encoding domain) (or (gethash (cons singular plural) (domain-entry-hash domain)) (let* ((octets (let* ((a (string-to-octets singular (domain-entry-encoding domain))) (b (string-to-octets plural (domain-entry-encoding domain))) (c (make-array (+ (length a) (length b) 1) :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (*)) a b c)) (replace c a) (setf (aref c (length a)) 0) (replace c b :start1 (+ (length a) 1)) c)) (length (length octets)) (pos (gethash length (domain-entry-hash domain)))) (declare (type (simple-array (unsigned-byte 8) (*)) octets) (type list pos)) (multiple-value-bind (tmp entry) (search-domain octets domain pos) (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) (when tmp (prog1 (setf (gethash (cons (copy-seq singular) (copy-seq plural)) (domain-entry-hash domain)) (loop for i = 0 then (1+ j) as j = (position 0 tmp :start i) collect (octets-to-string (subseq tmp i j) (domain-entry-encoding domain)) while j)) (let ((temp (delete entry pos :test #'eq))) (if temp (setf (gethash length (domain-entry-hash domain)) temp) (remhash length (domain-entry-hash domain)))) (when (null (domain-entry-plurals domain)) (setf (domain-entry-plurals domain) (parse-plurals domain)))))))))) (declaim (inline getenv) (ftype (function (string) (or null string)) getenv)) (defun getenv (var) (let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD") ext:*environment-list*)) #+SBCL (sb-ext:posix-getenv var) #+Allegro (system:getenv var) #+LispWorks (hcl:getenv var) #+clisp (ext:getenv var) #+(or openmcl mcl) (ccl::getenv var) #+(or gcl ecl) (si::getenv var))) (if (equal val "") nil val))) (defun setlocale (&optional locale) (setf *locale* (or locale (getenv "LANGUAGE") (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG") *locale*))) (defmacro textdomain (domain) `(eval-when (:compile-toplevel :execute) (setf *default-domain* ,domain))) ;; Set the textdomain to New-Domain for the body and then restore the ;; domain to the original. (defmacro with-textdomain ((old-domain new-domain) &body body) `(progn (intl:textdomain ,new-domain) ,@body (intl:textdomain ,old-domain))) (defmacro gettext (string) "Look up STRING in the current message domain and return its translation." `(dgettext ,*default-domain* ,string)) (defmacro ngettext (singular plural n) "Look up the singular or plural form of a message in the current domain." `(dngettext ,*default-domain* ,singular ,plural ,n)) (declaim (inline dgettext)) (defun dgettext (domain string) "Look up STRING in the specified message domain and return its translation." #+(or)(declare (optimize (speed 3) (space 2) (safety 0))) (let ((domain (and domain (find-domain domain *locale*)))) (or (and domain (domain-lookup string domain)) string))) (defun dngettext (domain singular plural n) "Look up the singular or plural form of a message in the specified domain." (declare (type integer n) #+(or)(optimize (speed 3) (space 2) (safety 0))) (let* ((domain (and domain (find-domain domain *locale*))) (list (and domain (domain-lookup-plural singular plural domain)))) (if list (nth (the integer (funcall (the function (domain-entry-plurals domain)) n)) list) (if (= n 1) singular plural)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #-runtime (defvar *translator-comment* nil) #-runtime (defvar *translations* nil) #-runtime (defun translation-enable () (setq *translations* (or *translations* (make-hash-table :test 'equal))) t) #-runtime (defun translation-disable () (setq *translations* nil)) #-runtime (defun note-translatable (domain string &optional plural) (when (and domain *translations*) (let* ((hash (or (gethash domain *translations*) (setf (gethash domain *translations*) (make-hash-table :test 'equal)))) (key (if plural (cons string plural) string)) (val (or (gethash key hash) (cons nil nil)))) (pushnew *translator-comment* (car val) :test #'equal) (pushnew (and *compile-file-truename* (enough-namestring *compile-file-truename*)) (cdr val) :test #'equal) ;; FIXME: How does this happen? Need to figure this out and get ;; rid of this! (unless key (warn "Translate error with null key. domain = ~S string = ~S~%" domain string)) (setf (gethash key hash) val))) (setq *translator-comment* nil)) (define-compiler-macro dgettext (&whole form domain string) #-runtime (when (and (stringp domain) (stringp string)) (note-translatable domain string)) form) (define-compiler-macro dngettext (&whole form domain singular plural n) (declare (ignore n)) #-runtime (when (and (stringp domain) (stringp singular) (stringp plural)) (note-translatable domain singular plural)) form) (defun read-translatable-string (stream char) (declare (ignore char)) (case (peek-char nil stream nil nil t) (#\" (let* ((*read-suppress* nil) (string (read stream t nil t))) (note-translatable *default-domain* string) `(gettext ,string))) (#\N (read-char stream t nil t) (let* ((*read-suppress* nil) (string (read stream t nil t))) #-runtime (note-translatable *default-domain* string) string)) (#\@ (error _"_@ is a reserved reader macro prefix.")) (otherwise (let ((fn (get-macro-character #\_ nil))) (if fn (funcall fn stream #\_) '_))))) ;; Process comments as usual, but look for lines that begin with ;; "TRANSLATORS: ". These lines are saved and written out as a ;; translator comment for the next translatable string. #-runtime (defun read-comment (stream char) (declare (optimize (speed 0) (space 3) #-gcl (debug 0)) (ignore char)) (do ((state 0) (index 0) (text nil) (char (read-char stream nil nil t) (read-char stream nil nil t))) ((or (not char) (char= char #\Newline)) (when text (setq *translator-comment* (copy-seq text)))) (cond ((and (= state 0) (char= char #\Space)) (setq state 1)) ((and (= state 0) (char= char #\T)) (setq state 1 index 1)) ((and (= state 0) (char/= char #\;)) (setq state 2)) ((and (= state 1) (= index 0) (char= char #\Space)) #|ignore|#) ((= state 1) (if (char= char (char "TRANSLATORS: " index)) (when (= (incf index) 13) (setq state 3)) (setq state 2))) ((= state 3) (when (null text) (setq text (make-array 50 :element-type 'character :adjustable t :fill-pointer 0))) (vector-push-extend char text)))) (values)) #-runtime (defun read-nested-comment (stream subchar arg) (declare (ignore subchar arg) (optimize (speed 0) (space 3) #-gcl (debug 0))) (do ((level 1) (state 0) (index 0) (text nil) (prev (read-char stream t nil t) char) (char (read-char stream t nil t) (read-char stream t nil t))) (()) (cond ((and (char= prev #\|) (char= char #\#)) (when (zerop (decf level)) (when text (setq *translator-comment* (string-right-trim '(#\Space #\Newline) text))) (return))) ((and (char= prev #\#) (char= char #\|)) (setq state 2) (incf level)) ((and (= state 0) (char= prev #\Space)) (setq state 1)) ((and (= state 0) (char= prev #\T)) (setq state 1 index 1)) ((= state 0) (setq state 2)) ((and (= state 1) (= index 0) (char= prev #\Space)) #| ignore |#) ((= state 1) (if (char= prev (char "TRANSLATORS: " index)) (when (= (incf index) 13) (setq state 3)) (setq state 2))) ((= state 3) (when (null text) (setq text (make-array 50 :element-type 'character :adjustable t :fill-pointer 0))) (vector-push-extend prev text)))) (values)) (defun install (&optional (rt *readtable*)) (set-macro-character #\_ #'read-translatable-string t rt) #-runtime (set-macro-character #\; #'read-comment nil rt) #-runtime (set-dispatch-macro-character #\# #\| #'read-nested-comment rt) t) ;; Dump the translatable strings. The output is written to a file in ;; the directory OUTPUT-DIRECTORY and its name is the domain. #-runtime (defun dump-pot-files (&key copyright output-directory) ;;(declare (optimize (speed 0) (space 3) #-gcl (debug 1))) (labels ((b (key data) (format t "~@[~{~&#. ~A~}~%~]" (delete nil (car data))) (format t "~@[~&~<#: ~@;~@{~A~^ ~}~:@>~%~]" (delete nil (cdr data))) (cond ((consp key) (format t "~&msgid ") (str (car key) 6 0) (format t "~&msgid_plural ") (str (cdr key) 13 0) (format t "~&msgstr[0] \"\"~2%")) (t (cond (key (format t "~&msgid ") (str key 6 0) (format t "~&msgstr \"\"~2%")) (t (format *error-output* "Skipping NIL key~%")))))) (str (string col start) (when (and (plusp col) (> (length string) (- 76 col))) (format t "\"\"~%")) (let ((nl (position #\Newline string :start start))) (cond ((and nl (< (- nl start) 76)) (write-char #\") (wstr string start nl) (format t "\\n\"~%") (str string 0 (1+ nl))) ((< (- (length string) start) 76) (write-char #\") (wstr string start (length string)) (write-char #\")) (t (let* ((a (+ start 1)) (b (+ start 76)) (b1 (position #\Space string :start a :end b :from-end t)) (b2 (position-if (lambda (x) (position x ";:,?!)]}")) string :start a :end b :from-end t)) (b3 (position-if (lambda (x) (position x "\"'-")) string :start a :end b :from-end t)) (b4 (position-if #'digit-char-p string :start a :end b :from-end t)) (b5 (position-if #'alpha-char-p string :start a :end b :from-end t)) (g1 (if b1 (* (- b b1) (- b b1) .03) 10000)) (g2 (if b2 (* (- b b2) (- b b2) .20) 10000)) (g3 (if b3 (* (- b b3) (- b b3) .97) 10000)) (g4 (if b4 (* (- b b4) (- b b4) 1.3) 10000)) (g5 (if b5 (* (- b b5) (- b b5) 2.0) 10000)) (g (min g1 g2 g3 g4 g5)) (end (1+ (cond ((> g 750) b) ((= g g1) b1) ((= g g2) b2) ((= g g3) b3) ((= g g4) b4) ((= g g5) b5))))) #+(or) (progn (format t "~&Splitting ~S:~%" (subseq string start b)) (format t "~{~& b~D=~D; goodness=~F~}~%" (list 1 b1 g1 2 b2 g2 3 b3 g3 4 b4 g4 5 b5 g5 6 b 10000)) (format t "~& best=~F == ~D~%" g end) (format t "~& Part1=~S~% Part2=~S~%" (subseq string start end) (subseq string end b))) (write-char #\") (wstr string start end) (write-char #\") (terpri) (str string 0 end)))))) (wstr (string start end) (loop while (< start end) do (let ((i (position-if (lambda (x) (or (char= x #\") (char= x #\\))) string :start start :end end))) (write-string string nil :start start :end (or i end)) (when i (write-char #\\ nil) (write-char (char string i) nil)) (setq start (if i (1+ i) end))))) (a (domain hash) (format t _"~&Dumping ~D messages for domain ~S~%" (hash-table-count hash) domain) (with-open-file (*standard-output* (merge-pathnames (make-pathname :name domain :type "pot") output-directory) :direction :output :if-exists :supersede :external-format :iso8859-1 ) (format t "~&#@ ~A~2%" domain) (format t "~&# SOME DESCRIPTIVE TITLE~%") (format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright) (format t "~&# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR~%") (format t "~&#~%#, fuzzy~%msgid \"\"~%msgstr \"\"~%") (format t "~&\"Project-Id-Version: PACKAGE VERSION\\n\"~%") (format t "~&\"Report-Msgid-Bugs-To: \\n\"~%") (format t "~&\"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"~%") (format t "~&\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"~%") (format t "~&\"Language-Team: LANGUAGE <LL@li.org>\\n\"~%") (format t "~&\"MIME-Version: 1.0\\n\"~%") (format t "~&\"Content-Type: text/plain; charset=UTF-8\\n\"~%") (format t "~&\"Content-Transfer-Encoding: 8bit\\n\"~2%") (maphash #'b hash)))) (maphash #'a *translations*) #+(or) (clrhash *translations*)) nil) (eval-when (:compile-toplevel :execute) (setq *default-domain* nil) (unless (and (fboundp 'intl:read-translatable-string) (eq (get-macro-character #\_) (fdefinition 'intl:read-translatable-string))) (set-syntax-from-char #\_ #\_))) ;; Don't install the reader macros by default. #+(or) (install)