source: project/release/3/svnwiki-translations/tags/1.2/svnwiki-translations.scm @ 18200

Last change on this file since 18200 was 18200, checked in by azul, 11 years ago

release

  • Property svn:keywords set to id
File size: 17.4 KB
Line 
1; $id$
2;
3; License: GPL-3
4
5(declare (export))
6(use content-type format-modular html-stream iconv orders posix srfi-1 srfi-40 stream-base64 stream-ext svn-client svnwiki-extensions-support url embedded-test)
7
8(define *languages*
9  '((es "Español")
10    (en "English")
11    (fr "Français")
12    (pt "Português")))
13
14(define (translations-links env)
15  (let-from-environment env (path-out-real path-in params)
16    (let* ((special (svnwiki-is-special? #f path-out-real))
17           (base-filename
18             (string-append
19               (stream->string
20                 (svnwiki-file-without-language (svnwiki-basename path-out-real)))
21               "."))
22           (dir
23             (svnwiki-make-pathname 
24               path-in
25               ((if special svnwiki-dirname identity)
26                (svnwiki-dirname path-out-real))))
27           (translations
28             (stream-filter
29               (lambda (file)
30                 (and (> (string-length file) (string-length base-filename))
31                      (substring=? base-filename file)
32                      (or (not (string=? file path-out-real))
33                          special)))
34               (if (directory? dir)
35                 (list->stream (directory dir))
36                 stream-null)))
37           (charset (svnwiki-encoding-for-file env))
38           (charset-convert
39             (if (string=? charset "utf-8")
40               identity
41               (let ((descriptor (iconv-open charset "utf-8")))
42                 (cut iconv descriptor <>)))))
43      (if (stream-null? translations)
44        (html-stream
45          (p (cdr (or (assoc 'none params) (cons #f (html-stream "No translations are available for this file."))))))
46        (html-stream
47          (ul
48            (stream-concatenate
49              (stream-map
50                (lambda (file)
51                  (html-stream
52                    ((li class "translationLink")
53                     ((a href
54                         (svnwiki-make-pathname
55                           (and special "..")
56                           file
57                           (mime->ending (render-file-mime-type env))))
58                      (let* ((language (svnwiki-file-language file))
59                             (name (and language (assoc (stream->symbol language) *languages*))))
60                        (if name
61                          (charset-convert (cadr name))
62                          language))))))
63                translations))))))))
64
65(svnwiki-extension-define 'code-break 'translations translations-links)
66
67;;; Database handling
68
69(define *translations-db* #f)
70
71(define (translations-db-run env query . params)
72  (let-from-environment env (data)
73    (unless *translations-db*
74      (let* ((db-path (svnwiki-make-pathname data "translations" "db"))
75             (existed (file-exists? db-path)))
76        (format (current-error-port) "Opening DB: ~A~%" db-path)
77        (set! *translations-db* (sqlite3:open db-path))
78        (unless existed
79          (format (current-error-port) "Creating initial tables in DB: ~A~%" db-path)
80          (translations-db-create env))))
81    (let ((result
82            (iterator->stream
83              (lambda (capture stop)
84                (receive (stmt rest)
85                         (sqlite3:prepare *translations-db* query)
86                  (apply (stream-wrap-proc-string sqlite3:for-each-row) (compose capture vector) stmt params)
87                  (sqlite3:finalize! stmt))))))
88      (stream-length result) ; force execution
89      result)))
90
91(define (translations-db-create env)
92  (translations-db-run env "CREATE TABLE dependencies ( path varchar, string varchar );")
93  (translations-db-run env "CREATE TABLE translations ( path varchar, source varchar, destination varchar );"))
94
95;;; Translating strings
96
97(define (string-canonical str)
98  (stream-drop-while
99    char-whitespace?
100    (stream-fold-right-delay
101      (lambda (c rest)
102        (cond
103          ((not (char-whitespace? c))
104           (stream-cons c rest))
105          ((or (stream-null? rest)
106               (char-whitespace? (stream-car rest)))
107           rest)
108          (else (stream-cons #\space rest))))
109      stream-null
110      (if (string? str) (string->stream str) str))))
111
112(test-group string-canonical
113  (test (stream->string (string-canonical (string->stream "  hey\nthere    you  \n  boy   ")))
114        "hey there you boy"))
115
116(define (get-trans env src)
117  (let-from-environment env (translations-path)
118    (let ((dst (translations-db-run env "SELECT destination FROM translations WHERE path = ? AND source = ?;" translations-path (string-canonical src))))
119      (and (not (stream-null? dst))
120           (string->stream (vector-ref (stream-car dst) 0))))))
121
122(define (translate-str env text)
123  (let-from-environment env (path-in path)
124    (when (stream-null? (translations-db-run env "SELECT path FROM dependencies WHERE path = ? AND string = ?;" path (string-canonical text)))
125      (translations-db-run env "INSERT INTO dependencies VALUES ( ?, ? );" path (string-canonical text)))
126    (let ((trans (get-trans env text)))
127      (html-stream
128        (format "<translation original='~A' translated=~A>" (url-encode (stream->string text)) (if trans "true" "false"))
129        (or trans text)
130        "</translation>"))))
131
132(define (translation env)
133  (let-from-environment env (text parse-paragraph path path-in translations-path params)
134    (let ((container (format #f "untranslated-~A" (random 1000000)))
135          (original (cdr (or (assoc 'original params) (cons #f text))))
136          (translated (stream= char=? (cdr (or (assoc 'translated params) (cons #f stream-null))) (string->stream "true"))))
137      (html-stream
138        ((span class (if translated "translationdone" "translation") id container)
139         (parse-paragraph text)
140         ((span class "translatelink")
141          " ["
142          ((a href (format #f "~A~A?action=edit&section=~A&create=true"
143                           (get-props-parents-first "svnwiki:application-url:http" path-in path #f)
144                           translations-path
145                           (stream->string (string-canonical original)))
146              onclick (format #f "if (typeof(svnwikiInlineEdit) == 'object') { return !svnwikiInlineEdit.loadForm('~A', '~A', '~A', true); } return true;"
147                              (url-encode container)
148                              (stream->string (string-canonical original))
149                              (url-encode translations-path (list #\. #\/))))
150           (if translated
151             "Edit translation"
152             "Add translation"))
153          "]"))))))
154
155(svnwiki-extension-define 'code-span 'translation translation)
156
157;;; Generating translated files
158
159(define (find-translations-path env . rest)
160  (let-from-environment env (path-in path)
161    (let-optionals rest ((my-directory? directory?))
162      (let loop ((path path))
163        (if (my-directory? (svnwiki-make-pathname (list path-in path) "xsvnwiki-translations"))
164          path
165          (and (not (string=? path ""))
166               (loop (svnwiki-dirname path))))))))
167
168(test-group find-translations-path
169  (test (find-translations-path (environment ((path-in "/path-in") (path "foo/bar/hey")))
170                                (lambda (str)
171                                  (string=? str "/path-in/xsvnwiki-translations")))
172        "")
173
174  (test (find-translations-path (environment ((path-in "/path-in") (path "foo/bar/hey")))
175                                (lambda (str)
176                                  (or (string=? str "/path-in/foo/bar/xsvnwiki-translations")
177                                      (string=? str "/path-in/xsvnwiki-translations"))))
178        "foo/bar"))
179
180
181(define (translatable? env)
182  (let-from-environment env (path)
183    (not (or (directory? (svnwiki-repository-path env))
184             (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
185             (svnwiki-file-language path)
186             (get-props-parents-first-boolean env "svnwiki:translations:ignore" #f)
187             (not (svnwiki-render-file-contents (environment env ((path-out-real path)))))))))
188
189(define (translations-update env)
190  (let-from-environment env (path-in path path-out)
191    (when (translatable? env)
192      (let* ((translations-path (find-translations-path env))
193             (languages (list->stream (directory (svnwiki-make-pathname (list path-in translations-path) "xsvnwiki-translations")))))
194        (when translations-path
195          (stream-for-each
196            (lambda (lang)
197              (svnwiki-report-progress env (svnwiki-translate env "Generating translation to ~A for: ~A~%") lang path)
198              (translations-db-run env "DELETE FROM dependencies WHERE path = ?;" path)
199              (let ((content-type (render-file-mime-type env))
200                    (path-out-real (format #f "~A.~A" path lang)))
201                (write-file-with-tmp path-out-real content-type path-out
202                  (render-file
203                    (environment env ((path-out-real path-out-real)
204                                      (translations-path (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang))
205                                      (translate
206                                        (cut translate-str
207                                             (environment env
208                                               ((translations-path (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang))))
209                                             <...>))))
210                    'view))))
211            languages)
212          (render-translations-status env translations-path languages))))))
213
214(svnwiki-extension-define 'update-notify-recursive 'translations translations-update)
215
216;;; Status of translations
217
218(define (render-translations-status env translations-path languages)
219  (let-from-environment env (path-in path path-out)
220    (svnwiki-report-progress env (svnwiki-translate env "Generating report of translations status for: ~A~%") path)
221    (let ((path-out-real (svnwiki-make-pathname (list (svnwiki-dirname path) "xsvnwiki-translations-status") (svnwiki-basename path))))
222      (write-file-with-tmp path-out-real "text/html" path-out
223        (render-template
224          (environment env ((path-out-real path-out-real)))
225          "Translations: "
226          (html-stream
227            (p "The following is the translation status for this file:")
228            (table
229              (tr
230                (td "Original")
231                (stream-concatenate
232                  (stream-map
233                    (lambda (lang)
234                      (html-stream
235                        (td
236                          ((a href (make-link-url path-out-real (svnwiki-make-pathname #f path lang) #f)) lang)
237                          " ["
238                          ((a href (make-link-url path-out-real (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang) #f)) "catalog")
239                          "]")))
240                    languages)))
241              (stream-concatenate
242                (stream-map
243                  (lambda (str)
244                    (html-stream
245                      (tr
246                        (td (vector-ref str 0))
247                        (stream-concatenate
248                          (stream-map
249                            (lambda (lang)
250                              (html-stream
251                                (td
252                                  (let ((text (translations-db-run env "SELECT destination FROM translations WHERE path = ? AND source = ?;"
253                                                                   (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang)
254                                                                   (string-canonical (vector-ref str 0)))))
255                                    (if (stream-null? text)
256                                      "Missing"
257                                      (svnwiki-stream-cut-with-ellipsis (vector-ref (stream-car text) 0) 40)))
258                                  " ["
259                                  ((a href (format #f "~A~A?action=edit&section=~A&create=true"
260                                                   (get-props-parents-first "svnwiki:application-url:http" path-in path #f)
261                                                   (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang)
262                                                   (stream->string (string-canonical (vector-ref str 0)))))
263                                   "Edit")
264                                  "]")))
265                            languages)))))
266                  (translations-db-run env "SELECT string FROM dependencies WHERE path = ?;" path)))))
267          'view)))))
268
269(define (translations-actions-links env)
270  (when (translatable? env)
271    (let-from-environment env (path path-out-real)
272      (unless (string=? (svnwiki-basename (svnwiki-dirname path-out-real))
273                        "xsvnwiki-translations-status")
274        (svnwiki-file-action-link
275          env
276          (svnwiki-make-pathname "xsvnwiki-translations-status" (svnwiki-basename path))
277          "Translations")))))
278
279(svnwiki-extension-define 'files-actions-links 'translations translations-actions-links)
280
281;;; Updating lists of translations
282
283; Return a stream of elements of the form (src dst), where both src and dst are
284; streams of characters.  Each corresponds to one translation of the string
285; 'src' to the string 'dst' found in the file specified (by path-in and path).
286
287(define (get-translations-from-file env)
288  (let-from-environment env (path-in path)
289    (wiki-translations (wiki-open path-in path))))
290
291(define (translations-update-catalog env)
292  (let-from-environment env (path-in path path-out regenerate-page)
293    (when (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
294      (svnwiki-report-progress env (svnwiki-translate env "Updating cache of translations: ~A~%") path)
295      (let ((new-translations (get-translations-from-file env)))
296        ; Regenerate pages that depend on translations that changed:
297        (stream-for-each
298          (lambda (data)
299            (let ((old (get-trans (environment env ((translations-path path))) (car data))))
300              (unless (and old (stream= char=? old (cadr data)))
301                (stream-for-each
302                  (compose regenerate-page (cut vector-ref <> 0))
303                  (translations-db-run env "SELECT path FROM dependencies WHERE string = ?;" (string-canonical (car data)))))))
304          new-translations)
305        ; Remove old translations
306        (translations-db-run env "DELETE FROM translations WHERE path = ?;" path)
307        ; Store new translations
308        (stream-for-each
309          (lambda (data)
310            (translations-db-run env "INSERT INTO translations VALUES ( ?, ?, ? );" path (string-canonical (car data)) (cadr data)))
311          new-translations)))))
312
313(svnwiki-extension-define 'update-notify-recursive-meta 'translations translations-update-catalog)
314
315;;; List of dependencies on translations
316
317(define (translations-footer env)
318  (let-from-environment env (path-in path return name path-out-real)
319    (when (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
320      (let ((deps (translations-db-run env "SELECT path FROM dependencies WHERE string = ?;" (string-canonical name))))
321        (return
322          (if (stream-null? deps)
323            (html-stream (p "No pages depend on this translation."))
324            (html-stream
325              (p "The following pages depend on this translation:")
326              (stream->html-ul
327                (stream-map
328                  (lambda (data)
329                    (svnwiki-get-title-html (environment env ((path (vector-ref data 0))))))
330                  deps)))))))))
331
332(svnwiki-extension-define 'section-footer 'translations translations-footer)
333
334(define (translations-catalog? env)
335  (let-from-environment env (path)
336    (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")))
337
338(test-group translations-catalog?
339  (test (translations-catalog? (environment ((path "foo/xsvnwiki-translations/en")))))
340  (test (translations-catalog? (environment ((path "xsvnwiki-translations/en")))))
341  (test (not (translations-catalog? (environment ((path "foo/xsvnwiki-translations"))))))
342  (test (not (translations-catalog? (environment ((path "foo/bar")))))))
343
344(define (edit-form-instructions env)
345  (when (translations-catalog? env)
346    (let-from-environment env (path return user-input)
347      (return
348        (let ((section (user-input 'section stream-null)))
349          (if (stream-null? section)
350            (html-stream
351              (p "You are editing a catalog of translations to " (tt (svnwiki-basename path)) 
352                 " ("
353                 (cadr (or (assoc (string->symbol (svnwiki-basename path)) *languages*) (list #f "Unknown")))
354                 "):"))
355            (html-stream
356              (p "You are editing the " (tt (svnwiki-basename path)) 
357                 " ("
358                 (cadr (or (assoc (string->symbol (svnwiki-basename path)) *languages*) (list #f "Unknown")))
359                 ")"
360                 " translation for the string:")
361              (blockquote (i section)))))))))
362
363(svnwiki-extension-define 'edit-form-instructions 'translations edit-form-instructions)
364
365(define (translations-hide-title env)
366  (when (translations-catalog? env)
367    (let-from-environment env (return)
368      (return #t))))
369
370(svnwiki-extension-define 'edit-form-section-title-hide 'translations translations-hide-title)
371
372(define (body-default env)
373  (when (translations-catalog? env)
374    (let-from-environment env (return section)
375      (return (html-stream "== " section "\n\n" section)))))
376
377(svnwiki-extension-define 'edit-form-section-body-default 'translations body-default)
Note: See TracBrowser for help on using the repository browser.