source: project/release/4/free-gettext/trunk/free-gettext.scm @ 27250

Last change on this file since 27250 was 27250, checked in by Alex Shinn, 9 years ago

Supporting .mo files without a header (guessing utf8).

File size: 27.4 KB
Line 
1;; gettext.scm -- gettext superset implemented in Scheme
2;;
3;; Copyright (c) 2003-2012 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;; Modifications for CHICKEN 4 by Thomas Chust (2010)
7
8;; This is *not* gettext, nor does it use the C gettext library.
9;;
10;; This is a full gettext superset written in pure Scheme from reading
11;; the gettext documentation - I have never looked at the gettext source
12;; code, so this may be used under a more liberal BSD-style license as
13;; above.
14;;
15;; This library includes various extensions, including the ability to
16;; support multiple domains, locales and search paths; the ability to
17;; read both .po and .mo files directly as message catalogs; and a more
18;; Schemeish dispatch interface.
19;;
20;; The multiple domain interface is useful because it allows multiple
21;; applications to share message catalogs while still extending their
22;; own messages.  Many applications use many of the same messages, such
23;; as those for menu names, and these messages can easily be leveraged
24;; in Scheme as follows:
25;;
26;;   (textdomain '("myapp" "gimp"))  ; search 1st myapp, then gimp
27;;   (gettext "/File/Close")         ; "Close" from gimp unless overridden
28;;
29;; Multiple locales can be useful while translations are still in
30;; progress.  It is not fair to assume that English (or whatever the
31;; native source uses) is the best alternative for a message that has
32;; not yet been translated, so the locale may also be a list:
33;;
34;;   (textdomain "myapp" '("ru" "uk"))  ; search 1st Russian then Ukranian,
35;;   (gettext "Hello, World!")          ; which are somewhat similar
36;;
37;; Note in both cases the domain and locale may be either a single
38;; string (as in the C gettext) or a list of strings in order of
39;; decreasing priority.  Also TEXTDOMAIN takes locale as an optional 2nd
40;; parameter (to override the Unix environment variable), and in fact
41;; the full parameter list is as follows:
42;;
43;;   (textdomain domain [locale] [dirs] [cdir] [cached?] [lookup-cached?])
44;;
45;; DOMAIN is a string or list of strings specifying the domain (name of
46;; .mo or .po files) as in C gettext.
47;;
48;; LOCALE is a string or list of strings in the standard Unix format of
49;; LANG[_REGION][.ENCODING]
50;;
51;; DIRS is the search path of directories which should hold the
52;; LOCALE/CDIR/ directories which contain the actual message catalogs.
53;; This is always appended with the system default, e.g.
54;; "/usr/share/locale", and may also inherit from the GETTEXT_PATH
55;; colon-delimited environment variable.
56;;
57;; CDIR is the catagory directory, defaulting to either the LC_CATEGORY
58;; environment variable or the appropriate system default
59;; (e.g. LC_MESSAGES).  You generally won't need this.
60;;
61;; CACHED? means to cache individual messages, and defaults to #t.
62;;
63;; LOOKUP-CACHED? means to cache the lookup dispatch generated by these
64;; parameters, and defaults to #t.
65;;
66;; TEXTDOMAIN just passes these parameters to the internal MAKE-GETTEXT,
67;; and binds the result to the global dispatch used by GETTEXT.  You may
68;; build these closures manually for convenience in using multiple
69;; separate domains or locales at once (useful for server environments):
70;;
71;;  (define my-gettext (make-gettext "myapp"))
72;;  (define _ (my-gettext 'getter))
73;;  (_"Hello, World!")
74
75(require-library
76 extras data-structures regex ports files posix
77 srfi-1 srfi-13 srfi-69
78 charconv)
79
80(module free-gettext
81  (;; standard gettext interface
82   gettext textdomain dgettext dcgettext bindtextdomain
83   ngettext dngettext dcngettext
84   ;; the parameter for the standard interface
85   default-gettext-lookup
86   ;; more flexible interface for building lookups
87   make-gettext
88   ;; gfile accessors
89   gfile? gfile-filename gfile-locale gfile-encoding
90   gfile-properties gfile-type gfile-plural-index
91   make-gettext-file
92   ;; low-level parsers
93   lookup-po-message lookup-mo-message)
94  (import
95   scheme chicken extras data-structures regex ports files posix
96   srfi-1 srfi-13 srfi-69
97   charconv)
98
99;; ^^^ Non-SRFI imports:
100;;
101;; WITH-INPUT-FROM-ENCODED-FILE, CES-CONVERT and DETECT-FILE-ENCODING
102;;   from charconv (Gauche compatible API)
103;; GET-ENVIRONMENT-VARIABLE and FILE-READ-ACCESS? from posix
104;; RFC822-HEADER->LIST from mime (port from Gauche)
105;; LET-OPTIONALS* from Shivers' SRFIs
106;; STRING-SPLIT from Chicken and Gauche
107;; CALL-WITH-INPUT-STRING and WITH-INPUT-FROM-STRING (almost ubiquitous)
108;; CONDITION-CASE from SRFI-12
109;; WARNING (like error, but diagnostic only)
110;; SET-FILE-POSITION! (ftell)
111;; READ-STRING (READ-BLOCK in Gauche, reads N chars)
112;; READ-LINE
113
114;; Other portability issues:
115;;   * assumes strings can contain arbitrary binary data
116;;   * assumes CHAR->INTEGER and INTEGER->CHAR are ASCII
117;;   * uses (EVAL ... (SCHEME-REPORT-ENVIRONMENT 5))
118;;     in one place on simple arithmetic expressions
119
120;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121;; this bit isn't portable
122
123(define null-ch (integer->char 0))
124(define null-str (string (integer->char 0)))
125
126;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127;; list utils (from Gauche's util.combinations)
128
129(define (cartesian-product lol)
130  (if (null? lol)
131    (list '())
132    (let ((l (car lol))
133          (rest (cartesian-product (cdr lol))))
134      (append-map
135       (lambda (x)
136         (map (lambda (sub-prod) (cons x sub-prod)) rest))
137       l))))
138
139;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140;; mime utils (from hato)
141
142(define (rfc822-read-headers in)
143  (let more ([line (read-line in)])
144    (cond
145     ((or (eof-object? line) (string-null? line))
146      '())
147     ((let ([cont (peek-char in)])
148        (and (not (memv cont '(#\return #\newline #!eof)))
149             (char-whitespace? cont)))
150      (more (string-append line (read-line in))))
151     ((string-match "(.*?)\\s*:\\s*(.*)" line)
152      => (lambda (match)
153           (cons (cons (string-downcase! (string-trim (cadr match)))
154                       (cddr match))
155                 (rfc822-read-headers in))))
156     (else
157      (rfc822-read-headers in)))))
158
159(define (mime-split-name+value s)
160  (let ((i (string-index s #\=)))
161    (if i
162        (cons (string-downcase (string-trim-both (substring s 0 i)))
163              (if (= i (string-length s))
164                  ""
165                  (if (eqv? #\" (string-ref s (+ i 1)))
166                      (substring/shared s (+ i 2) (- (string-length s) 2))
167                      (substring/shared s (+ i 1)))))
168        (cons (string-downcase (string-trim-both s)) #f))))
169
170(define (mime-parse-content-type str)
171  (map mime-split-name+value (string-split str ";")))
172
173;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174;; binary I/O utils (from SRFI-56)
175
176(define (read-binary-uint32-le . o)
177  (let* ((in (if (pair? o) (car o) (current-input-port)))
178         (b1 (read-byte in))
179         (b2 (read-byte in))
180         (b3 (read-byte in))
181         (b4 (read-byte in)))
182    (if (eof-object? b4)
183        b4
184        (+ (arithmetic-shift b4 24)
185           (arithmetic-shift b3 16)
186           (arithmetic-shift b2 8)
187           b1))))
188
189(define (read-binary-uint32-be . o)
190  (let* ((in (if (pair? o) (car o) (current-input-port)))
191         (b1 (read-byte in))
192         (b2 (read-byte in))
193         (b3 (read-byte in))
194         (b4 (read-byte in)))
195    (if (eof-object? b4)
196        b4
197        (+ (arithmetic-shift b1 24)
198           (arithmetic-shift b2 16)
199           (arithmetic-shift b3 8)
200           b4))))
201
202;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203;; Customize this to the appropriate value for your system:
204
205(define message-path (list (make-pathname (repository-path) "locale")))
206
207;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208;; store meta info for gettext files
209
210(define-record-type gfile
211  (%make-gfile filename locale encoding properties type plural-index)
212  gfile?
213  (filename gfile-filename)  ;; these are all immutable
214  (locale gfile-locale)
215  (encoding gfile-encoding)
216  (properties gfile-properties)
217  (type gfile-type)
218  (plural-index gfile-plural-index)
219  )
220
221(define (make-gettext-file filename locale)
222  (let* ((file-type (if (string-suffix? ".mo" filename) 'mo 'po))
223         (property-msg (lookup-message filename "" "utf8"))
224         (properties (if property-msg
225                         (call-with-input-string property-msg
226                           rfc822-read-headers)
227                         '()))
228         (content-type
229          (mime-parse-content-type
230           (cond ((assoc "content-type" properties) => cadr)
231                 (else ""))))
232         (encoding
233          (cond ((assoc "charset" content-type) => cdr)
234                (else (or (detect-file-encoding filename locale) "utf8"))))
235         (plural-index
236          (cond
237            ((assoc "plural-forms" properties)
238             => (lambda (x)
239                  (cond
240                    ((assoc "plural" (mime-parse-content-type (cadr x)))
241                     => (lambda (x) (C->Scheme (cdr x))))
242                    (else (lambda (n) 0)))))
243            (else (lambda (n) 0)))))
244    (%make-gfile filename locale encoding properties file-type plural-index)))
245
246;; take a list or a single argument which is interpretted as a one
247;; element list
248(define (listify arg)
249  (if (or (pair? arg) (null? arg)) arg (list arg)))
250
251;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252;; the default gettext lookup
253
254(define domain-message-paths (make-hash-table))
255
256(define default-gettext-lookup (make-parameter #f))
257
258(define (gettext msgid)
259  ((default-gettext-lookup) 'get msgid))
260(define (dgettext domain msgid)
261  ((make-gettext domain) 'get msgid))
262(define (dcgettext domain msgid locale)
263  ((make-gettext domain (list locale)) 'get msgid))
264
265;; plural forms
266(define (ngettext . opt)
267  (apply (default-gettext-lookup) 'nget opt))
268(define (dngettext domain . opt)
269  (apply (make-gettext domain) 'nget opt))
270(define (dcngettext domain msgid locale . opt)
271  (apply (make-gettext domain (list locale)) 'nget msgid opt))
272
273;; bind the default domain
274(define (textdomain . opt)
275  (if (pair? opt)
276    (let ((accessor (apply make-gettext opt)))
277      (default-gettext-lookup accessor)
278      accessor)
279    ((default-gettext-lookup) 'domain)))
280
281(define (bindtextdomain domain dirs)
282  (hash-table-set! domain-message-paths domain (listify dirs)))
283
284;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
285;; The gettext .po parser.
286;;   We sequentially scan all the .po msgstr entries until the one
287;;   matching the msg string is found.  This is slow but only meant
288;;   for development, so that you can quickly test your message
289;;   files without compiling them to .mo files.
290
291(define (lookup-po-message file msg msg2 encoding)
292  ;; resisting jokes about indigent messages...
293
294  ;; grab the 2nd scheme object in a string
295  (define (tail-str str)
296    (call-with-input-string str (lambda (p) (read p) (read p))))
297
298  ;; read a sequence of lines in "" starting w/ an initial string.
299  ;; doesn't affect trailing lines.
300  (define (read-str default)
301    (let reader ((res (list default)))
302      (cond
303        ((and-let* ((ch (peek-char))
304                    ((eqv? ch #\"))
305                    (line (string-trim-both (read-line)))
306                    (len (string-length line))
307                    ((and (>= len 2)
308                          (eqv? #\" (string-ref line 0))
309                          (eqv? #\" (string-ref line (- len 1))))))
310           (call-with-input-string line read))
311         => (lambda (str) (reader (cons str res))))
312        (else (string-concatenate-reverse res)))))
313
314  (define (read-plural default)
315    (let reader ((res (list default)))
316      (cond
317        ((and-let* (((eqv? (peek-char) #\m))
318                    (line (read-line))
319                    (len (string-length line))
320                    ((>= len 10))
321                    ((string-prefix? "msgstr[" line))
322                    (i (string-index line #\] 7))
323                    (n (string->number (substring line 7 i)))
324                    (str (call-with-input-string
325                             (substring/shared line (+ i 1))
326                           read))
327                    ((string? str)))
328           (cons n (read-str str)))
329         => (lambda (x) (reader (cons x res))))
330        (else (reverse res)))))
331
332  ;; read from the file if it exists
333  (and
334   (file-read-access? file)
335   (condition-case
336       (with-input-from-encoded-file file encoding
337         (lambda ()
338           (let search ((line (read-line)))
339             (cond ((eof-object? line) #f)
340                   ((string-prefix? "msgid " line)
341                    (let ((msgid (read-str (tail-str line))))
342                      (cond ((string=? msgid msg)
343                             (let lp ((line (read-line)))
344                               (cond ((eof-object? line) #f)
345                                     ((string-prefix? "msgid_plural " line)
346                                      (read-plural (read-str (tail-str line))))
347                                     ((string-prefix? "msgstr " line)
348                                      (read-str (tail-str line)))
349                                     (else (lp (read-line))))))
350                            (else (search (read-line))))))
351                   (else (search (read-line)))))))
352     (exn ()
353          (print-error-message exn (current-error-port)
354                               "Warning: lookup-po-message")
355          ;;(print-call-chain (current-error-port))
356          #f))))
357
358;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359;; The gettext binary .mo file parser.
360;;   The format is well described in the GNU gettext documentation.
361;;   Essentially it's an index of source strings with offsets to their
362;;   translation string, and we binary search the index.
363
364(define (lookup-mo-message file msg msg2 encoding)
365  (and
366   (file-read-access? file)
367   (condition-case
368       (with-input-from-file file
369         (lambda ()
370           (define (search read-int)
371             (let* ((key (if msg2 (string-append msg null-str msg2) msg))
372                    (format (read-int))
373                    (count (read-int))
374                    (src-offset (read-int))
375                    (trans-offset (read-int))
376                    (hash-size (read-int))
377                    (hash-offset (read-int))
378                    (diff (- trans-offset src-offset))
379                    (end (+ src-offset (* (- count 1) 8))))
380               (define (string-at pos)
381                 (set-file-position! (current-input-port) pos)
382                 (let* ((len (read-int))
383                        (off (read-int)))
384                   (set-file-position! (current-input-port) off)
385                   (ces-convert (read-string len) encoding)))
386               (cond ;; check endpoints
387                 ((string=? key (string-at src-offset))
388                  (string-at (+ src-offset diff)))
389                 ((and (> end src-offset) (string=? key (string-at end)))
390                  (string-at (+ end diff)))
391                 (else ;; binary search
392                  (let loop ((lo 0) (hi (- count 1)))
393                    (if (>= lo hi)
394                        #f
395                        (let* ((mid (+ lo (quotient (- hi lo) 2)))
396                               (pos (+ src-offset (* mid 8)))
397                               (str (string-at pos)))
398                          (cond
399                            ((string<? key str)
400                             (if (>= mid hi) #f (loop lo mid)))
401                            ((string>? key str)
402                             (if (<= mid lo) #f (loop mid hi)))
403                            (else ;; match
404                             (string-at (+ pos diff)))))))))))
405           (let* ((b1 (read-byte))
406                  (b2 (read-byte))
407                  (b3 (read-byte))
408                  (b4 (read-byte))
409                  (magic (list b1 b2 b3 b4)))
410             (cond
411               ((equal? magic '(#xde #x12 #x04 #x95))
412                (search read-binary-uint32-le))
413               ((equal? magic '(#x95 #x04 #x12 #xde))
414                (search read-binary-uint32-be))
415               (else
416                (warning "invalid .mo file magic" magic)
417                #f)))))
418     (exn ()
419          (print-error-message exn (current-error-port)
420                               "Warning: lookup-mo-message")
421          ;;(print-call-chain (current-error-port))
422          #f))))
423
424(define (lookup-message gfile msg msg2 . opt)
425  (if (gfile? gfile)
426      ((if (eq? (gfile-type gfile) 'mo) lookup-mo-message lookup-po-message)
427       (gfile-filename gfile)
428       msg
429       msg2
430       (if (pair? opt) (car opt) (gfile-encoding gfile)))
431      ((if (string-suffix? ".mo" gfile) lookup-mo-message lookup-po-message)
432       gfile msg msg2 (if (pair? opt) (car opt) "utf8"))))
433
434;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
435;; the subset C parser for ngettext plural forms
436
437(define (C->Scheme str)
438  (define (read-number c)
439    (let loop ((ls (list c)))
440      (let ((c2 (peek-char)))
441        (cond ((and (not (eof-object? c2)) (char-numeric? c2))
442               (read-char) (loop (cons c2 ls)))
443              (else (string->number (list->string (reverse ls))))))))
444  (define (read-comment)
445    (read-char)
446    (let loop ((c (read-char)))
447      (if (eof-object? c)
448          c ;; maybe signal error
449          (if (eqv? c #\*)
450              (let ((c2 (read-char)))
451                (if (eqv? c2 #\/) #f (loop c2)))
452              (loop (read-char))))))
453  (define (next-token)
454    (let ((c (read-char)))
455      (if (eof-object? c)
456          c
457          (case c
458            ((#\() 'open)
459            ((#\)) 'close)
460            ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
461            ((#\- #\+ #\* #\% #\? #\:)
462             (string->symbol (string c)))
463            ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
464            ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
465            ((#\! #\> #\<)
466             (cond ((eqv? (peek-char) #\=)
467                    (read-char) (string->symbol (string c #\=)))
468                   (else (string->symbol (string c)))))
469            ((#\=)
470             (cond ((eqv? (peek-char) #\=) (read-char) '==)
471                   (else (warning "invalid assignment in C code") #f)))
472            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
473             (read-number c))
474            ((#\n) 'n)
475            ((#\space #\newline) (next-token))
476            (else (warning "invalid character in C code: ~S" c) #f)))))
477  (define (C-parse str)
478    (define (precedence x) ;; lower value is higher precedence
479      (case x
480        ((**) 10)           ((&) 70)
481        ((! ~) 20)          ((^ logand logior) 80)
482        ((* / %) 30)        ((and) 90)
483        ((+ -) 40)          ((or) 100)
484        ((< > <= >=) 50)    ((?) 110)
485        ((== != <=>) 60)    (else 120)))
486    (define (parse1)
487      (let ((x (next-token)))
488        (cond ((not x) (parse1))
489              ((eof-object? x) 'eof)
490              ((eq? x 'open) (parse-until 'close))
491              ((memq x '(! ~)) `(,x ,(parse1)))
492              (else x))))
493    (define (parse-until end)
494      (define (group op left right)
495        (cond
496         ((or (eq? right end) (eq? right 'eof))
497          (warning "expected 2nd argument to" op)
498          `(op ,left))
499         ((eq? op 'and)
500          `(if (zero? ,left) 0 ,right))
501         ((eq? op 'or)
502          `(if (zero? ,left) ,right 1))
503         (else
504          `(,op ,left ,right))))
505      (define (join x stack)
506        (if (null? stack)
507            x
508            (join (group (car stack) (cadr stack) x) (cddr stack))))
509      (let ((init (parse1)))
510        (if (equal? init end)
511            '()
512            (let parse ((left init) (op (parse1)) (stack '()))
513              (cond
514               ((eq? op end) (join left stack))
515               ((eq? op 'eof)
516                (warning "unexpected #<eof>")
517                (join left stack))
518               ((eq? op '?) ;; trinary ? : (right-assoc)
519                (let* ((pass (parse-until ':))
520                       (fail (parse1))
521                       (op2 (parse1)))
522                  (cond
523                   ((or (eq? op2 end) (eq? op2 'eof))
524                    `(if (zero? ,left) ,fail ,pass))
525                   ((< (precedence op) (precedence op2))
526                    (parse `(if (zero? ,left) ,fail ,pass) op2 stack))
527                   (else
528                    (join `(if (zero? ,left) ,(parse fail op2 '()) ,pass)
529                          stack)))))
530               (else ;; assume a (left-assoc) binary operator
531                (let* ((right (parse1))
532                       (op2 (parse1)))
533                  (cond
534                   ((or (eq? op2 end) (eq? op2 'eof))
535                    (join (group op left right) stack))
536                   ((<= (precedence op) (precedence op2))
537                    ;; op2 has less than or equal precedence, group
538                    (let loop2 ((x (group op left right)) (s stack))
539                      (if (and (pair? s)
540                               (< (precedence (car s)) (precedence op2)))
541                          (loop2 (group (car s) (cadr s) x) (cddr s))
542                          (parse x op2 s))))
543                   (else
544                    ;; op2 has higher precedence, push on the stack
545                    (parse right op2 (cons op (cons left stack))))))))))))
546    (with-input-from-string str
547      (lambda () (parse-until 'eof))))
548  (define (map-C-names x)
549    (cond
550     ((symbol? x)
551      (case x
552        ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
553        ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
554        ;; C conflates booleans with integers
555        ((!) '(lambda (a) (if (zero? a) 1 0)))
556        ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
557        ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
558        ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
559        ((>) '(lambda (a b)  (if (> a b) 1 0)))
560        ((<) '(lambda (a b)  (if (< a b) 1 0)))
561        ((>=) '(lambda (a b) (if (>= a b) 1 0)))
562        ((<=) '(lambda (a b) (if (<= a b) 1 0)))
563        (else x)))
564     ((pair? x)
565      (cons (map-C-names (car x)) (map-C-names (cdr x))))
566     (else x)))
567  (let ((body (map-C-names (C-parse str))))
568    ;; could build from chained closures w/o using eval but this is
569    ;; faster at runtime
570    (eval `(lambda (n) ,body) (scheme-report-environment 5))))
571
572;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
573;; internal routines for building/caching files and lookups
574
575(define (split-langs lang)
576  (define (split-at ch)
577    (cond ((string-index lang ch)
578           => (lambda (i) (list (substring lang 0 i))))
579          (else '())))
580  (cons lang (append (split-at #\.) (split-at #\_))))
581
582(define (make-gettext-internal domain locale dirs cdir cached?)
583
584  (define (make-cache) (make-hash-table))
585
586  (define (make-file-list)
587    (define suffixes '(".mo" ".po"))
588    (reverse
589     (fold
590      (lambda (x res)
591        (let ((path
592               (string-append
593                (caddr x) "/" (car x) "/" cdir "/" (cadr x) (cadddr x))))
594          (if (file-read-access? path)
595              (cons (make-gettext-file path (car x)) res)
596              res)))
597      '()
598      (cartesian-product (list (append-map split-langs locale)
599                               domain
600                               dirs
601                               suffixes)))))
602
603  (let ((files (make-file-list))
604        (cache (make-cache)))
605
606    (define (search msg . opt)
607      (if (and cached? (hash-table-exists? cache msg))
608          (hash-table-ref/default cache msg #f)
609          (let-optionals* opt ((msg2 #f) (n #f))
610            (let ((split? (number? n)))
611              (any
612               (lambda (gf)
613                 (and-let* ((x0 (lookup-message gf msg msg2))
614                            (x (if (and split? (eq? (gfile-type gf) 'mo))
615                                   (cons (or msg2 msg)
616                                         (let ((l (string-split x0 null-str)))
617                                           (map cons (iota (length l)) l)))
618                                   x0))
619                            (res (cons x gf)))
620                   (if cached? (hash-table-set! cache msg res))
621                   res))
622               files)))))
623
624    (define (get msg)
625      (let ((res (search msg)))
626        (if res (if (pair? (car res)) (caar res) (car res)) msg)))
627
628    (define (nget msg . opt) ;; [msg2] [n]
629      (let ((msg2 #f) (n #f))
630        ;; option parsing, both optional
631        (when (pair? opt)
632          (let ((x (car opt))) (if (number? x) (set! n x) (set! msg2 x)))
633          (when (pair? (cdr opt))
634            (let ((x (cadr opt))) (if (number? x) (set! n x) (set! msg2 x)))))
635        (let ((res (search msg msg2 n)))
636          (if (pair? res)
637              (let ((plural-index (gfile-plural-index (cdr res))))
638                (or (and (procedure? plural-index)
639                         (cond
640                          ((assv (plural-index (or n 1)) (cdar res)) => cdr)
641                          (else #f)))
642                    (if (eqv? n 1) msg (caar res))))
643              (if (or (eqv? n 1) (not msg2)) msg msg2)))))
644
645    (define (set msg val) (hash-table-set! cache msg val))
646
647    (define (reset!)
648      (set! files (make-file-list))
649      (set! cache (make-cache)))
650
651    ;; return the dispatcher
652    (lambda (dispatch . args)
653      (case dispatch
654        ((searcher) search)
655        ((getter) get)
656        ((ngetter) nget)
657        ((setter) set)
658        ((search) (apply search args))
659        ((get) (apply get args))
660        ((nget) (apply nget args))
661        ((set!) (apply set args))
662        ((locale) locale)
663        ((domain) domain)
664        ((dirs) dirs)
665        ((files) files)
666        ((set-locale!) (set! locale (listify (car args))) (reset!))
667        ((set-domain!) (set! domain (listify (car args))) (reset!))
668        ((set-dirs!) (set! dirs (listify (car args))) (reset!))
669        ((use-cache) (set! cached? (car args)))
670        ((clear) (set! cache (make-cache)))
671        ))))
672
673;; cache the lookups and provide a more friendly interface.  should this
674;; take keyword arguments?
675;; (make-gettext domain locale dirs cdir gettext-cached? lookup-cached?)
676(define make-gettext
677  (let ((gettext-lookup-cache (make-hash-table)))
678    (lambda opt
679      (let-optionals* opt
680          ((domain0 '("default"))
681           (locale0 #f)
682           (dirs0 #f)
683           (cdir0 #f)
684           (gettext-cached? #t)
685           (lookup-cached? #t))
686        (let* ((domain (listify domain0))
687               (locale (listify (or locale0 (get-environment-variable "LANG")
688                                    (get-environment-variable "LC_ALL") "C")))
689               (dirs1 (listify
690                       (or dirs0 (cond ((get-environment-variable "GETTEXT_PATH")
691                                        => (cut string-split <> ":"))
692                                       (else '())))))
693               ;; prepend default dirs based on domain
694               (dirs (append (hash-table-ref/default
695                              domain-message-paths
696                              domain
697                              message-path)
698                             dirs1))
699               (cdir (or cdir0
700                         (get-environment-variable "LC_CATEGORY")
701                         "LC_MESSAGES")))
702          ;; optionally lookup from cache
703          (if lookup-cached?
704            (let* ((key (list domain locale dirs cdir gettext-cached?))
705                   (lookup
706                    (hash-table-ref/default gettext-lookup-cache key #f)))
707              (unless lookup
708                (set! lookup (make-gettext-internal domain locale dirs
709                                                    cdir gettext-cached?))
710                (hash-table-set! gettext-lookup-cache key lookup))
711              lookup)
712            (make-gettext-internal
713             domain locale dirs cdir gettext-cached?)))))))
714
715)
Note: See TracBrowser for help on using the repository browser.