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

Last change on this file since 24882 was 24882, checked in by Alex Shinn, 10 years ago

bugfix splitting on \0, new release

File size: 27.3 KB
Line 
1;; gettext.scm -- gettext superset implemented in Scheme
2;;
3;; Copyright (c) 2003-2011 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* ((encoding (detect-file-encoding filename locale))
223         (property-msg (lookup-message filename "" #f encoding))
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 encoding)))
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
245                 locale
246                 encoding
247                 properties
248                 (if (string-suffix? ".mo" filename) 'mo 'po)
249                 plural-index)))
250
251;; take a list or a single argument which is interpretted as a one
252;; element list
253(define (listify arg)
254  (if (or (pair? arg) (null? arg)) arg (list arg)))
255
256;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257;; the default gettext lookup
258
259(define domain-message-paths (make-hash-table))
260
261(define default-gettext-lookup (make-parameter #f))
262
263(define (gettext msgid)
264  ((default-gettext-lookup) 'get msgid))
265(define (dgettext domain msgid)
266  ((make-gettext domain) 'get msgid))
267(define (dcgettext domain msgid locale)
268  ((make-gettext domain (list locale)) 'get msgid))
269
270;; plural forms
271(define (ngettext . opt)
272  (apply (default-gettext-lookup) 'nget opt))
273(define (dngettext domain . opt)
274  (apply (make-gettext domain) 'nget opt))
275(define (dcngettext domain msgid locale . opt)
276  (apply (make-gettext domain (list locale)) 'nget msgid opt))
277
278;; bind the default domain
279(define (textdomain . opt)
280  (if (pair? opt)
281    (let ((accessor (apply make-gettext opt)))
282      (default-gettext-lookup accessor)
283      accessor)
284    ((default-gettext-lookup) 'domain)))
285
286(define (bindtextdomain domain dirs)
287  (hash-table-set! domain-message-paths domain (listify dirs)))
288
289;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290;; The gettext .po parser.
291;;   We sequentially scan all the .po msgstr entries until the one
292;;   matching the msg string is found.  This is slow but only meant
293;;   for development, so that you can quickly test your message
294;;   files without compiling them to .mo files.
295
296(define (lookup-po-message file msg msg2 encoding)
297  ;; resisting jokes about indigent messages...
298
299  ;; grab the 2nd scheme object in a string
300  (define (tail-str str)
301    (call-with-input-string str (lambda (p) (read p) (read p))))
302
303  ;; read a sequence of lines in "" starting w/ an initial string.
304  ;; doesn't affect trailing lines.
305  (define (read-str default)
306    (let reader ((res (list default)))
307      (cond
308        ((and-let* ((ch (peek-char))
309                    ((eqv? ch #\"))
310                    (line (string-trim-both (read-line)))
311                    (len (string-length line))
312                    ((and (>= len 2)
313                          (eqv? #\" (string-ref line 0))
314                          (eqv? #\" (string-ref line (- len 1))))))
315           (call-with-input-string line read))
316         => (lambda (str) (reader (cons str res))))
317        (else (string-concatenate-reverse res)))))
318
319  (define (read-plural default)
320    (let reader ((res (list default)))
321      (cond
322        ((and-let* (((eqv? (peek-char) #\m))
323                    (line (read-line))
324                    (len (string-length line))
325                    ((>= len 10))
326                    ((string-prefix? "msgstr[" line))
327                    (i (string-index line #\] 7))
328                    (n (string->number (substring line 8 i)))
329                    (str (call-with-input-string
330                             (substring/shared line (+ i 1))
331                           read))
332                    ((string? str)))
333           (cons n str))
334         => (lambda (x) (reader (cons x res))))
335        (else (reverse res)))))
336
337  ;; read from the file if it exists
338  (and
339   (file-read-access? file)
340   (condition-case
341       (with-input-from-encoded-file file encoding
342         (lambda ()
343           (let search ((line (read-line)))
344             (cond ((eof-object? line) #f)
345                   ((string-prefix? "msgid " line)
346                    (let ((msgid (read-str (tail-str line))))
347                      (cond ((string=? msgid msg)
348                             (let lp ((line (read-line)))
349                               (cond ((eof-object? line) #f)
350                                     ((string-prefix? "msgid_plural " line)
351                                      (read-plural (read-str (tail-str line))))
352                                     ((string-prefix? "msgstr " line)
353                                      (read-str (tail-str line)))
354                                     (else (lp (read-line))))))
355                            (else (search (read-line))))))
356                   (else (search (read-line)))))))
357     (exn ()
358          (print-error-message exn (current-error-port)
359                               "Warning: lookup-po-message")
360          ;;(print-call-chain (current-error-port))
361          #f))))
362
363;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
364;; The gettext binary .mo file parser.
365;;   The format is well described in the GNU gettext documentation.
366;;   Essentially it's an index of source strings with offsets to their
367;;   translation string, and we binary search the index.
368
369(define (lookup-mo-message file msg msg2 encoding)
370  (and
371   (file-read-access? file)
372   (condition-case
373       (with-input-from-encoded-file file encoding
374         (lambda ()
375           (define (search read-int)
376             (let* ((key (if msg2 (string-append msg null-str msg2) msg))
377                    (format (read-int))
378                    (count (read-int))
379                    (src-offset (read-int))
380                    (trans-offset (read-int))
381                    (hash-size (read-int))
382                    (hash-offset (read-int))
383                    (diff (- trans-offset src-offset))
384                    (end (+ src-offset (* (- count 1) 8))))
385               (define (string-at pos)
386                 (set-file-position! (current-input-port) pos)
387                 (let* ((len (read-int))
388                        (off (read-int)))
389                   (set-file-position! (current-input-port) off)
390                   (ces-convert (read-string len) encoding)))
391               (cond ;; check endpoints
392                 ((string=? key (string-at src-offset))
393                  (string-at (+ src-offset diff)))
394                 ((and (> end src-offset) (string=? key (string-at end)))
395                  (string-at (+ end diff)))
396                 (else ;; binary search
397                  (let loop ((lo 0) (hi (- count 1)))
398                    (if (>= lo hi)
399                        #f
400                        (let* ((mid (+ lo (quotient (- hi lo) 2)))
401                               (pos (+ src-offset (* mid 8)))
402                               (str (string-at pos)))
403                          (cond
404                            ((string<? key str)
405                             (if (>= mid hi) #f (loop lo mid)))
406                            ((string>? key str)
407                             (if (<= mid lo) #f (loop mid hi)))
408                            (else ;; match
409                             (string-at (+ pos diff)))))))))))
410           (let* ((b1 (read-byte))
411                  (b2 (read-byte))
412                  (b3 (read-byte))
413                  (b4 (read-byte))
414                  (magic (list b1 b2 b3 b4)))
415             (cond
416               ((equal? magic '(#xde #x12 #x04 #x95))
417                (search read-binary-uint32-le))
418               ((equal? magic '(#x95 #x04 #x12 #xde))
419                (search read-binary-uint32-be))
420               (else
421                (warning "invalid .mo file magic" magic)
422                #f)))))
423     (exn ()
424          (print-error-message exn (current-error-port)
425                               "Warning: lookup-mo-message")
426          ;;(print-call-chain (current-error-port))
427          #f))))
428
429(define (lookup-message gfile msg msg2 . opt)
430  (if (gfile? gfile)
431      ((if (eq? (gfile-type gfile) 'mo) lookup-mo-message lookup-po-message)
432       (gfile-filename gfile)
433       msg
434       msg2
435       (if (pair? opt) (car opt) (gfile-encoding gfile)))
436      ((if (string-suffix? ".mo" gfile) lookup-mo-message lookup-po-message)
437       gfile msg msg2 (if (pair? opt) (car opt) 'utf8))))
438
439;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
440;; the subset C parser for ngettext plural forms
441
442(define (C->Scheme str)
443  (define (read-number c)
444    (let loop ((ls (list c)))
445      (let ((c2 (peek-char)))
446        (cond ((and (not (eof-object? c2)) (char-numeric? c2))
447               (read-char) (loop (cons c2 ls)))
448              (else (string->number (list->string (reverse ls))))))))
449  (define (read-comment)
450    (read-char)
451    (let loop ((c (read-char)))
452      (if (eof-object? c)
453        c ;; maybe signal error
454        (if (eqv? c #\*)
455          (let ((c2 (read-char)))
456            (if (eqv? c2 #\/) #f (loop c2)))
457          (loop (read-char))))))
458  (define (next-token)
459    (let ((c (read-char)))
460      (if (eof-object? c)
461        c
462        (case c
463          ((#\() 'open)
464          ((#\)) 'close)
465          ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
466          ((#\- #\+ #\* #\% #\? #\:)
467           (string->symbol (string c)))
468          ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
469          ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
470          ((#\! #\> #\<)
471           (cond ((eqv? (peek-char) #\=)
472                  (read-char) (string->symbol (string c #\=)))
473                 (else (string->symbol (string c)))))
474          ((#\=)
475           (cond ((eqv? (peek-char) #\=) (read-char) '==)
476                 (else (warning "invalid assignment in C code") #f)))
477          ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
478           (read-number c))
479          ((#\n) 'n)
480          ((#\space #\newline) (next-token))
481          (else (warning "invalid character in C code: ~S" c) #f)))))
482  (define (C-parse str)
483    (define (precedence x) ;; lower value is higher precedence
484      (case x
485        ((**) 10)           ((&) 70)
486        ((! ~) 20)          ((^ logand logior) 80)
487        ((* / %) 30)        ((and) 90)
488        ((+ -) 40)          ((or) 100)
489        ((< > <= >=) 50)    ((?) 110)
490        ((== != <=>) 60)    (else 120)))
491    (define (parse1)
492      (let ((x (next-token)))
493        (cond ((not x) (parse1))
494              ((eof-object? x) 'eof)
495              ((eq? x 'open) (parse-until 'close))
496              ((memq x '(! ~)) `(,x ,(parse1)))
497              (else x))))
498    (define (parse-until end)
499      (define (group op left right)
500        (cond
501          ((or (eq? right end) (eq? right 'eof))
502           (warning "expected 2nd argument to" op)
503           `(op ,left))
504          ((eq? op 'and)
505           `(if (zero? ,left) 0 ,right))
506          ((eq? op 'or)
507           `(if (zero? ,left) ,right 1))
508          (else
509           `(,op ,left ,right))))
510      (define (join x stack)
511        (if (null? stack)
512          x
513          (join (group (car stack) (cadr stack) x) (cddr stack))))
514      (let ((init (parse1)))
515        (if (equal? init end)
516          '()
517          (let parse ((left init) (op (parse1)) (stack '()))
518            (cond
519              ((eq? op end) (join left stack))
520              ((eq? op 'eof)
521               (warning "unexpected #<eof>")
522               (join left stack))
523              ((eq? op '?) ;; trinary ? : (right-assoc)
524               (let* ((pass (parse-until ':))
525                      (fail (parse1))
526                      (op2 (parse1)))
527                 (cond
528                   ((or (eq? op2 end) (eq? op2 'eof))
529                    `(if (zero? ,left) ,fail ,pass))
530                   ((< (precedence op) (precedence op2))
531                    (parse `(if (zero? ,left) ,fail ,pass) op2 stack))
532                   (else
533                    (join `(if (zero? ,left) ,(parse fail op2 '()) ,pass)
534                          stack)))))
535              (else ;; assume a (left-assoc) binary operator
536               (let* ((right (parse1))
537                      (op2 (parse1)))
538                 (cond
539                   ((or (eq? op2 end) (eq? op2 'eof))
540                    (join (group op left right) stack))
541                   ((<= (precedence op) (precedence op2))
542                    ;; op2 has less than or equal precedence, group
543                    (let loop2 ((x (group op left right)) (s stack))
544                      (if (and (pair? s)
545                               (< (precedence (car s)) (precedence op2)))
546                        (loop2 (group (car s) (cadr s) x) (cddr s))
547                        (parse x op2 s))))
548                   (else
549                    ;; op2 has higher precedence, push on the stack
550                    (parse right op2 (cons op (cons left stack))))))))))))
551    (with-input-from-string str
552      (lambda () (parse-until 'eof))))
553  (define (map-C-names x)
554    (cond
555      ((symbol? x)
556       (case x
557         ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
558         ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
559         ;; C conflates booleans with integers
560         ((!) '(lambda (a) (if (zero? a) 1 0)))
561         ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
562         ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
563         ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
564         ((>) '(lambda (a b)  (if (> a b) 1 0)))
565         ((<) '(lambda (a b)  (if (< a b) 1 0)))
566         ((>=) '(lambda (a b) (if (>= a b) 1 0)))
567         ((<=) '(lambda (a b) (if (<= a b) 1 0)))
568         (else x)))
569      ((pair? x)
570       (cons (map-C-names (car x)) (map-C-names (cdr x))))
571      (else x)))
572  (let ((body (map-C-names (C-parse str))))
573    ;; could build from chained closures w/o using eval but this is
574    ;; faster at runtime
575    (eval `(lambda (n) ,body) (scheme-report-environment 5))))
576
577;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
578;; internal routines for building/caching files and lookups
579
580(define (split-langs lang)
581  (define (split-at ch)
582    (cond ((string-index lang ch)
583           => (lambda (i) (list (substring lang 0 i))))
584          (else '())))
585  (cons lang (append (split-at #\.) (split-at #\_))))
586
587(define (make-gettext-internal domain locale dirs cdir cached?)
588
589  (define (make-cache) (make-hash-table))
590
591  (define (make-file-list)
592    (define suffixes '(".mo" ".po"))
593    (reverse
594     (fold
595      (lambda (x res)
596        (let ((path
597               (string-append
598                (caddr x) "/" (car x) "/" cdir "/" (cadr x) (cadddr x))))
599          (if (file-read-access? path)
600              (cons (make-gettext-file path (car x)) res)
601              res)))
602      '()
603      (cartesian-product (list (append-map split-langs locale)
604                               domain
605                               dirs
606                               suffixes)))))
607
608  (let ((files (make-file-list))
609        (cache (make-cache)))
610
611    (define (search msg . opt)
612      (if (and cached? (hash-table-exists? cache msg))
613        (hash-table-ref/default cache msg #f)
614        (let-optionals* opt ((msg2 #f) (n #f))
615          (let ((split? (number? n)))
616            (any
617             (lambda (gf)
618               (and-let* ((x0 (lookup-message gf msg msg2))
619                          (x (if (and split? (eq? (gfile-type gf) 'mo))
620                               (cons (or msg2 msg)
621                                     (let ((l (string-split x0 null-str)))
622                                       (map cons (iota (length l)) l)))
623                               x0))
624                          (res (cons x gf)))
625                 (if cached? (hash-table-set! cache msg res))
626                 res))
627             files)))))
628
629    (define (get msg)
630      (let ((res (search msg)))
631        (if res (if (pair? (car res)) (caar res) (car res)) msg)))
632
633    (define (nget msg . opt) ;; [msg2] [n]
634      (let ((msg2 #f) (n #f))
635        ;; option parsing, both optional
636        (when (pair? opt)
637          (let ((x (car opt))) (if (number? x) (set! n x) (set! msg2 x)))
638          (when (pair? (cdr opt))
639            (let ((x (cadr opt))) (if (number? x) (set! n x) (set! msg2 x)))))
640        (let ((res (search msg msg2 n)))
641          (if (pair? res)
642            (let ((plural-index (gfile-plural-index (cdr res))))
643              (or (and (procedure? plural-index)
644                       (cond
645                        ((assv (cdar res) (plural-index (or n 1))) => cdr)
646                        (else #f)))
647                  (if (eqv? n 1) msg (caar res))))
648            (if (or (eqv? n 1) (not msg2)) msg msg2)))))
649
650    (define (set msg val) (hash-table-set! cache msg val))
651
652    (define (reset!)
653      (set! files (make-file-list))
654      (set! cache (make-cache)))
655
656    ;; return the dispatcher
657    (lambda (dispatch . args)
658      (case dispatch
659        ((searcher) search)
660        ((getter) get)
661        ((ngetter) nget)
662        ((setter) set)
663        ((search) (apply search args))
664        ((get) (apply get args))
665        ((nget) (apply nget args))
666        ((set!) (apply set args))
667        ((locale) locale)
668        ((domain) domain)
669        ((dirs) dirs)
670        ((files) files)
671        ((set-locale!) (set! locale (listify (car args))) (reset!))
672        ((set-domain!) (set! domain (listify (car args))) (reset!))
673        ((set-dirs!) (set! dirs (listify (car args))) (reset!))
674        ((use-cache) (set! cached? (car args)))
675        ((clear) (set! cache (make-cache)))
676        ))))
677
678;; cache the lookups and provide a more friendly interface.  should this
679;; take keyword arguments?
680;; (make-gettext domain locale dirs cdir gettext-cached? lookup-cached?)
681(define make-gettext
682  (let ((gettext-lookup-cache (make-hash-table)))
683    (lambda opt
684      (let-optionals* opt
685          ((domain0 '("default"))
686           (locale0 #f)
687           (dirs0 #f)
688           (cdir0 #f)
689           (gettext-cached? #t)
690           (lookup-cached? #t))
691        (let* ((domain (listify domain0))
692               (locale (listify (or locale0 (get-environment-variable "LANG")
693                                    (get-environment-variable "LC_ALL") "C")))
694               (dirs1 (listify
695                       (or dirs0 (cond ((get-environment-variable "GETTEXT_PATH")
696                                        => (cut string-split <> ":"))
697                                       (else '())))))
698               ;; prepend default dirs based on domain
699               (dirs (append (hash-table-ref/default
700                              domain-message-paths
701                              domain
702                              message-path)
703                             dirs1))
704               (cdir (or cdir0
705                         (get-environment-variable "LC_CATEGORY")
706                         "LC_MESSAGES")))
707          ;; optionally lookup from cache
708          (if lookup-cached?
709            (let* ((key (list domain locale dirs cdir gettext-cached?))
710                   (lookup
711                    (hash-table-ref/default gettext-lookup-cache key #f)))
712              (unless lookup
713                (set! lookup (make-gettext-internal domain locale dirs
714                                                    cdir gettext-cached?))
715                (hash-table-set! gettext-lookup-cache key lookup))
716              lookup)
717            (make-gettext-internal
718             domain locale dirs cdir gettext-cached?)))))))
719
720)
Note: See TracBrowser for help on using the repository browser.