author | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-10-08 21:40:09 (GMT) |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-10-08 21:40:09 (GMT) |
commit | 109cf4d84378cbfce6b157ac854383be2a9ea866 (patch) (unidiff) | |
tree | 9c1b4a25f39d3f7bf7a8ecf879b1b40014f4af5a | |
parent | c4a4896b38006d9966ffd6112e27539ba0efeaca (diff) | |
download | ellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.gz ellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.bz2 |
*** empty log message ***
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@460 941c8c0f-9102-463b-b60b-cd22ce0e6858
-rw-r--r-- | cgi-bin/dict.scm4 | 621 | ||||
-rw-r--r-- | cgi-bin/nea.scm4 | 536 | ||||
-rw-r--r-- | ellinika/cgi.scm4 (renamed from ellinika/cgi.scmi) | 41 |
3 files changed, 1185 insertions, 13 deletions
diff --git a/cgi-bin/dict.scm4 b/cgi-bin/dict.scm4 new file mode 100644 index 0000000..ab445d4 --- a/dev/null +++ b/cgi-bin/dict.scm4 | |||
@@ -0,0 +1,621 @@ | |||
1 | ;;;; Greek Dictionary Web Engine | ||
2 | ;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff | ||
3 | ;;;; | ||
4 | ;;;; This program is free software; you can redistribute it and/or modify | ||
5 | ;;;; it under the terms of the GNU General Public License as published by | ||
6 | ;;;; the Free Software Foundation; either version 2 of the License, or | ||
7 | ;;;; (at your option) any later version. | ||
8 | ;;;; | ||
9 | ;;;; This program is distributed in the hope that it will be useful, | ||
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
12 | ;;;; GNU General Public License for more details. | ||
13 | ;;;; | ||
14 | ;;;; You should have received a copy of the GNU General Public License | ||
15 | ;;;; along with this program; if not, write to the Free Software | ||
16 | ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ||
17 | ;;;; | ||
18 | |||
19 | ;;; Tailor this statement to your needs if necessary. | ||
20 | (set! %load-path (cons "GUILE_SITE" %load-path)) | ||
21 | |||
22 | (use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) | ||
23 | (ice-9 rdelim) | ||
24 | (gamma sql) | ||
25 | (gamma gettext) | ||
26 | (xmltools dict) | ||
27 | (ellinika xlat) | ||
28 | (ellinika cgi)) | ||
29 | |||
30 | ifelse(IFACE,[CGI],(cgi:init)) | ||
31 | |||
32 | (ellinika-cgi-init dict-template-file-name) | ||
33 | |||
34 | ;; Τα μέρη του λογου | ||
35 | (define part-of-speech '()) | ||
36 | |||
37 | (define (sql-error-handler err descr) | ||
38 | (format #t "<h1 class=\"error\">~A</h1>\n" | ||
39 | (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) | ||
40 | (with-output-to-port | ||
41 | (current-error-port) | ||
42 | (lambda () | ||
43 | (display err) | ||
44 | (display ": ") | ||
45 | (display descr)))) | ||
46 | |||
47 | (define (mk-dict-connect) | ||
48 | (let ((db-connection #f)) | ||
49 | (lambda (. rest) | ||
50 | (cond | ||
51 | ((null? rest) | ||
52 | (if (not db-connection) | ||
53 | (begin | ||
54 | (set! db-connection | ||
55 | (sql-connect | ||
56 | sql-iface sql-host sql-port sql-database | ||
57 | sql-username sql-password)) | ||
58 | (sql-query db-connection "SET NAMES utf8") | ||
59 | ))) | ||
60 | (else | ||
61 | (if db-connection | ||
62 | (sql-connect-close db-connection)) | ||
63 | (set! db-connection #f))) | ||
64 | db-connection))) | ||
65 | |||
66 | (define dict-connect (mk-dict-connect)) | ||
67 | |||
68 | (defmacro catch-sql-failure (expr) | ||
69 | `(catch 'gsql-error | ||
70 | (lambda () ,expr) | ||
71 | (lambda (key err descr) | ||
72 | (sql-error-handler err descr)))) | ||
73 | |||
74 | (defmacro ignore-sql-failure (expr) | ||
75 | `(catch 'gsql-error | ||
76 | (lambda () ,expr) | ||
77 | (lambda (key err descr) | ||
78 | #f))) | ||
79 | |||
80 | (define (load-pos) | ||
81 | (ignore-sql-failure | ||
82 | (let ((conn (dict-connect))) | ||
83 | (let ((plist (my-sql-query | ||
84 | conn | ||
85 | "SELECT name,id FROM pos WHERE canonical='Y' order by id"))) | ||
86 | (set! part-of-speech | ||
87 | (cons | ||
88 | (cons "κανένα μέρος του λόγου" #f) | ||
89 | (map | ||
90 | (lambda (x) | ||
91 | (cons (car x) (cadr x))) | ||
92 | plist))))))) | ||
93 | |||
94 | ;; Protect occurences of " in a string. | ||
95 | ;; Usual backslash escapes do not work in INPUT widgets, so I | ||
96 | ;; change all quotation marks to " | ||
97 | ;; Possibly not the better solution, though... | ||
98 | (define (protect string) | ||
99 | (list->string | ||
100 | (apply append | ||
101 | (map | ||
102 | (lambda (x) | ||
103 | (if (eq? x #\") | ||
104 | (list #\& #\# #\3 #\4 #\;) | ||
105 | (list x))) | ||
106 | (string->list string))))) | ||
107 | |||
108 | (define (get-topic-list) | ||
109 | (let ((categories #f)) | ||
110 | (letrec ((getcat | ||
111 | (lambda () | ||
112 | (ignore-sql-failure | ||
113 | (let ((conn (dict-connect))) | ||
114 | (let ((ctg (my-sql-query | ||
115 | conn | ||
116 | (string-append | ||
117 | "SELECT t.category, c.title, c.description " | ||
118 | "FROM category c,topic t " | ||
119 | "WHERE c.lang='" (language-code target-language) "' " | ||
120 | "AND c.category=t.category GROUP BY 1 ORDER BY 1")))) | ||
121 | (if (null? ctg) | ||
122 | '() | ||
123 | (map | ||
124 | (lambda (category) | ||
125 | (let ((topics (my-sql-query | ||
126 | conn | ||
127 | (string-append | ||
128 | "SELECT ident,title FROM topic WHERE category=" | ||
129 | (car category) | ||
130 | " ORDER BY title")))) | ||
131 | (append category (if (null? topics) | ||
132 | '() | ||
133 | (list topics))))) | ||
134 | ctg)))))))) | ||
135 | (if (not categories) | ||
136 | (set! categories (or (getcat) '()))) | ||
137 | categories))) | ||
138 | |||
139 | (define (join-widget widget-id tabindex) | ||
140 | (let* ((name (string-append "join" widget-id)) | ||
141 | (selected-choice (or (let ((s (cgi:value name))) | ||
142 | (if s | ||
143 | (string->number s) | ||
144 | #f)) | ||
145 | 0))) | ||
146 | (display (string-append "<SELECT NAME=\"" | ||
147 | name | ||
148 | "\" TABINDEX=\"" | ||
149 | tabindex | ||
150 | "\">")) | ||
151 | (display "<OPTION VALUE=\"0\"") | ||
152 | (if (= selected-choice 0) | ||
153 | (display " selected")) | ||
154 | (display ">") (display (_"και")) (display "</OPTION>") | ||
155 | (display "<OPTION VALUE=\"1\"") | ||
156 | (if (= selected-choice 1) | ||
157 | (display " selected")) | ||
158 | (display ">") (display (_"ή")) (display "</OPTION>") | ||
159 | (display "</SELECT>"))) | ||
160 | |||
161 | (define (main-form) | ||
162 | (load-pos) | ||
163 | (display "<FORM ACTION=\"") | ||
164 | (display (make-cgi-name cgi-script-name)) | ||
165 | (display "\" METHOD=POST> | ||
166 | <table class=\"noframe\"> | ||
167 | <tr> | ||
168 | <td>") | ||
169 | (display (_"Εισάγετε τη λέξη")) | ||
170 | (display " | ||
171 | </td> | ||
172 | <td> | ||
173 | <input size=\"36\" name=\"key\" tabindex=\"1\"") | ||
174 | (let ((value (cgi:value "key"))) | ||
175 | (if value | ||
176 | (begin | ||
177 | (display "value=\"") | ||
178 | (display (protect value)) | ||
179 | (display "\"")))) | ||
180 | (display "> | ||
181 | </td> | ||
182 | </tr>") | ||
183 | |||
184 | (display "<tr><td colspan=\"3\" align=\"center\">") | ||
185 | (display (_"Συμπληρωματικοί όροι")) | ||
186 | (display "</td></tr>") | ||
187 | |||
188 | (display " | ||
189 | <tr> | ||
190 | <td>") | ||
191 | (display (_"Επιλέξτε το μέρος του λόγου")) | ||
192 | (display "</td><td>") | ||
193 | |||
194 | (let ((selected-choice (or (let ((s (cgi:value "POS"))) | ||
195 | (if s | ||
196 | (string->number s) | ||
197 | #f)) | ||
198 | 0)) | ||
199 | (index 0)) | ||
200 | |||
201 | (display "<select name=\"POS\" tabindex=\"2\">") | ||
202 | |||
203 | (for-each | ||
204 | (lambda (x) | ||
205 | (let ((name (car x))) | ||
206 | (display "<option value=") | ||
207 | (display index) | ||
208 | (if (= index selected-choice) | ||
209 | (display " selected")) | ||
210 | (display ">") | ||
211 | (display name) | ||
212 | (set! index (1+ index)))) | ||
213 | part-of-speech) | ||
214 | (display "</select>")) | ||
215 | |||
216 | (display "</td><td>") | ||
217 | (join-widget "pos" "3") | ||
218 | (display "</td></tr>") | ||
219 | |||
220 | (let ((tabindex 4)) | ||
221 | (for-each | ||
222 | (lambda (category) | ||
223 | (display "<tr><td>") | ||
224 | (display (list-ref category 1)) | ||
225 | (display "</td><td>") | ||
226 | (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0)))) | ||
227 | (if s | ||
228 | (string->number s) | ||
229 | #f)) | ||
230 | 0))) | ||
231 | |||
232 | (display (string-append | ||
233 | "<select name=\"" | ||
234 | (list-ref category 0) | ||
235 | "\" tabindex=\"" | ||
236 | (number->string tabindex) | ||
237 | "\">")) | ||
238 | (set! tabindex (1+ tabindex)) | ||
239 | (display "<option value=0>---") | ||
240 | (for-each | ||
241 | (lambda (x) | ||
242 | (let ((id (car x)) | ||
243 | (name (car (cdr x)))) | ||
244 | (display "<option value=") | ||
245 | (display id) | ||
246 | (if (eq? (string->number id) selected-choice) | ||
247 | (display " selected")) | ||
248 | (display ">") | ||
249 | (display name) | ||
250 | (display "</option>"))) | ||
251 | (list-ref category 3)) | ||
252 | (display "</select>") | ||
253 | (display "</td><td>") | ||
254 | (join-widget (list-ref category 0) (number->string tabindex)) | ||
255 | (display "</td></tr>") | ||
256 | (set! tabindex (1+ tabindex)))) | ||
257 | (get-topic-list)) | ||
258 | |||
259 | (display " | ||
260 | <tr> | ||
261 | <td colspan=\"3\" align=\"center\"> | ||
262 | <input type=\"submit\" name=\"search\" value=\"") | ||
263 | (display (_"Αναζήτηση")) | ||
264 | (display "\" tabindex=\"") | ||
265 | (display tabindex) | ||
266 | (display "\"> | ||
267 | </td> | ||
268 | </tr> | ||
269 | </table> | ||
270 | </form> | ||
271 | <p>"))) | ||
272 | |||
273 | ;; | ||
274 | (define (replace-tilde word sentence) | ||
275 | (apply | ||
276 | string-append | ||
277 | (let loop ((lst '()) | ||
278 | (str sentence)) | ||
279 | (cond | ||
280 | ((string-index str #\~) => | ||
281 | (lambda (x) | ||
282 | (loop | ||
283 | (append lst (list (substring str 0 x) word)) | ||
284 | (substring str (1+ x))))) | ||
285 | ((string-null? str) | ||
286 | lst) | ||
287 | (else | ||
288 | (append lst (list str))))))) | ||
289 | |||
290 | ;; | ||
291 | (define (display-results rlist) | ||
292 | (let ((x (car rlist))) | ||
293 | (display "<table class=\"noframe\">") | ||
294 | (display "<tr><td>") | ||
295 | (display (car x)) | ||
296 | (display "</td>") | ||
297 | (cond | ||
298 | ((list-ref x 3) | ||
299 | (display "<td>") | ||
300 | (let ((href (assoc (list-ref x 2) word-forms-reference))) | ||
301 | (cond | ||
302 | (href | ||
303 | (display "<a href=\"") | ||
304 | (cond | ||
305 | (ref-loc | ||
306 | (display ref-loc) | ||
307 | (display "/"))) | ||
308 | (display (language-code target-language)) | ||
309 | (display "/") | ||
310 | (display (cdr href)) | ||
311 | (display (dict:encode-string (car x))) | ||
312 | (display "\">") | ||
313 | (display (list-ref x 3)) | ||
314 | (display "</a>")) | ||
315 | (else | ||
316 | (display (list-ref x 3))))) | ||
317 | (display "</td>"))) | ||
318 | (display "<td>") | ||
319 | (display (list-ref x 2)) | ||
320 | (display "</td></tr>")) | ||
321 | (for-each | ||
322 | (lambda (x) | ||
323 | (display "<tr><td>") | ||
324 | (display (1+ (string->number (list-ref x 4)))) | ||
325 | (display "</td><td>") | ||
326 | (display (replace-tilde (car x) (list-ref x 5))) | ||
327 | (display ";</td></tr>")) | ||
328 | rlist) | ||
329 | (display "</table>") | ||
330 | (newline)) | ||
331 | |||
332 | (define (display-cross-reference word) | ||
333 | (display "<a href=\"") | ||
334 | (display (make-cgi-name cgi-script-name "IDENT" (dict:encode-string word))) | ||
335 | (display "\">") | ||
336 | (display word) | ||
337 | (display "</a>")) | ||
338 | |||
339 | (define (display-xref rlist text) | ||
340 | (display text) | ||
341 | (let ((n 0)) | ||
342 | (for-each | ||
343 | (lambda (x) | ||
344 | (if (> n 0) | ||
345 | (display ", ")) | ||
346 | (set! n (1+ n)) | ||
347 | (display-cross-reference (car x))) | ||
348 | rlist)) | ||
349 | (display ";")) | ||
350 | |||
351 | (define (sort-result input-list) | ||
352 | (let ((output-list '()) | ||
353 | (current-element '())) | ||
354 | (for-each | ||
355 | (lambda (x) | ||
356 | (cond | ||
357 | ((or (null? current-element) | ||
358 | (= (string->number (cadr x)) | ||
359 | (string->number (cadr (car current-element))))) | ||
360 | (set! current-element (cons x current-element))) | ||
361 | (else | ||
362 | (set! output-list (cons (reverse current-element) output-list)) | ||
363 | (set! current-element (list x))))) | ||
364 | input-list) | ||
365 | (cons (reverse current-element) output-list))) | ||
366 | |||
367 | |||
368 | (define (search-failure key) | ||
369 | (display "<h2>") | ||
370 | (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key) | ||
371 | (display "</h2>")) | ||
372 | |||
373 | (define (my-sql-query conn query) | ||
374 | (catch #t | ||
375 | (lambda () | ||
376 | (sql-query conn query)) | ||
377 | (lambda args | ||
378 | '()))) | ||
379 | |||
380 | (define (fuzzy-search conn key theme pos) | ||
381 | (let ((where-cond (list (string-append | ||
382 | "WHERE dict.ident=articles.ident and articles.lang='" | ||
383 | (language-code target-language) | ||
384 | "' AND"))) | ||
385 | (select-stmt "SELECT DISTINCT dict.word FROM ") | ||
386 | (from-list (list ",articles" "dict"))) | ||
387 | |||
388 | (cond | ||
389 | ((not (null? theme)) | ||
390 | (set! where-cond (cons " topic_tab.word_ident=dict.ident" | ||
391 | where-cond)) | ||
392 | (set! from-list (cons ",topic_tab" from-list)))) | ||
393 | |||
394 | (cond | ||
395 | ((not (string-null? key)) | ||
396 | (if (not (null? theme)) | ||
397 | (set! where-cond (cons " AND" where-cond))) | ||
398 | (set! where-cond (cons (string-append | ||
399 | " dict.sound LIKE \"" | ||
400 | (ellinika:sounds-like key) | ||
401 | "%\"") | ||
402 | where-cond)))) | ||
403 | |||
404 | (cond | ||
405 | ((> (string->number pos) 0) | ||
406 | (let ((pos-entry | ||
407 | (list-ref part-of-speech (string->number pos)))) | ||
408 | (if (or (not (string-null? key)) (not (null? theme))) | ||
409 | (set! where-cond (cons | ||
410 | (if (string=? (cgi:value "joinpos") "0") | ||
411 | " AND" | ||
412 | " OR") | ||
413 | where-cond))) | ||
414 | |||
415 | (set! where-cond (cons | ||
416 | (string-append " (dict.pos & " | ||
417 | (cdr pos-entry) | ||
418 | ") = " | ||
419 | (cdr pos-entry)) | ||
420 | where-cond))))) | ||
421 | |||
422 | (let ((result | ||
423 | (my-sql-query conn | ||
424 | (string-append | ||
425 | select-stmt | ||
426 | |||
427 | " " | ||
428 | |||
429 | (apply | ||
430 | string-append | ||
431 | (reverse from-list)) | ||
432 | |||
433 | " " | ||
434 | |||
435 | (apply | ||
436 | string-append | ||
437 | (append | ||
438 | (reverse where-cond) | ||
439 | (map | ||
440 | (lambda (x) | ||
441 | (cond | ||
442 | ((boolean? x) | ||
443 | (if x " AND" " OR")) | ||
444 | (else | ||
445 | (if (not (member ",topic_tab" from-list)) | ||
446 | (set! from-list | ||
447 | (cons ",topic_tab" | ||
448 | from-list))) | ||
449 | (string-append | ||
450 | " topic_tab.topic_ident=" x)))) | ||
451 | theme))) | ||
452 | |||
453 | " ORDER BY dict.word")))) | ||
454 | |||
455 | (cond | ||
456 | ((null? result) | ||
457 | (search-failure key)) | ||
458 | (else | ||
459 | (display "<table width=\"100%\" class=\"noframe\">") | ||
460 | (let* ((result-length (length result)) | ||
461 | (lim (1+ (inexact->exact (/ result-length match-list-columns))))) | ||
462 | (do ((i 0 (1+ i))) | ||
463 | ((= i lim) #f) | ||
464 | (display "<tr>") | ||
465 | (do ((j i (+ j lim))) | ||
466 | ((>= j result-length) #f) | ||
467 | (display "<td>") | ||
468 | (display-cross-reference (car (list-ref result j))) | ||
469 | (display "</td>")) | ||
470 | (display "</tr>"))) | ||
471 | (display "</table>")))))) | ||
472 | |||
473 | |||
474 | (define (dict-search) | ||
475 | (let ((keyval (if (cgi:value "IDENT") | ||
476 | (dict:decode-string (cgi:value "IDENT")) | ||
477 | (cgi:value "key"))) | ||
478 | (theme (do ((catlist (get-topic-list) (cdr catlist)) | ||
479 | (ret '())) | ||
480 | ((null? catlist) ret) | ||
481 | (let ((name (caar catlist))) | ||
482 | (let ((v (cgi:value name))) | ||
483 | (if (and v (> (string->number v) 0)) | ||
484 | (set! ret (append | ||
485 | ret | ||
486 | (list (= (string->number | ||
487 | (cgi:value (string-append "join" name))) 0) | ||
488 | v)))))))) | ||
489 | (pos (or (cgi:value "POS") "0"))) | ||
490 | |||
491 | (catch-sql-failure | ||
492 | (let ((conn (dict-connect))) | ||
493 | (cond | ||
494 | ((and keyval | ||
495 | (not (string-null? keyval)) | ||
496 | (null? theme) | ||
497 | (= (string->number pos) 0)) | ||
498 | (display "<hr>") | ||
499 | (let* ((key (ellinika:translate-input keyval)) | ||
500 | (result (my-sql-query | ||
501 | conn | ||
502 | (string-append | ||
503 | "SELECT dict.word,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning " | ||
504 | "FROM dict,articles,pos WHERE dict.word=\"" | ||
505 | key | ||
506 | "\" AND dict.ident=articles.ident " | ||
507 | "AND articles.lang='" (language-code target-language) "' " | ||
508 | "AND dict.pos=pos.id AND pos.canonical='Y' order by dict.ident, articles.subindex")))) | ||
509 | |||
510 | (cond | ||
511 | ((null? result) | ||
512 | (fuzzy-search conn key theme pos)) | ||
513 | (else | ||
514 | (for-each | ||
515 | (lambda (entry) | ||
516 | (display-results entry) | ||
517 | (let ((ant (my-sql-query | ||
518 | conn | ||
519 | (string-append | ||
520 | "SELECT dict.word FROM dict,links WHERE links.type='ANT' AND links.ident=" | ||
521 | (cadr (car entry)) | ||
522 | " AND dict.ident=links.xref ORDER BY word")))) | ||
523 | (if (and ant (not (null? ant))) | ||
524 | (display-xref ant | ||
525 | (if (= (length ant) 1) | ||
526 | (_"Αντώνυμο: ") (_"Αντώνυμα: "))))) | ||
527 | (display "<p>") | ||
528 | (let ((x (my-sql-query | ||
529 | conn | ||
530 | (string-append | ||
531 | "SELECT dict.word FROM dict,links WHERE links.type='XREF' AND links.ident=" | ||
532 | (cadr (car entry)) | ||
533 | " AND dict.ident=links.xref ORDER BY word")))) | ||
534 | (if (and x (not (null? x))) | ||
535 | (display-xref x (_"Βλέπετε επίσης "))))) | ||
536 | (sort-result result)))))) | ||
537 | ((or (not (null? theme)) (> (string->number pos) 0)) | ||
538 | (display "<hr>") | ||
539 | (fuzzy-search conn | ||
540 | (ellinika:translate-input (or keyval "")) theme pos))))))) | ||
541 | |||
542 | ;;; | ||
543 | |||
544 | (define (stat key) | ||
545 | (let ((stat-data #f)) | ||
546 | (if (not stat-data) | ||
547 | (set! stat-data | ||
548 | (or | ||
549 | (ignore-sql-failure | ||
550 | (my-sql-query (dict-connect) | ||
551 | (string-append | ||
552 | "SELECT count,updated from stat WHERE lang='" | ||
553 | (language-code target-language) | ||
554 | "'"))) | ||
555 | '()))) | ||
556 | |||
557 | (if (null? stat-data) | ||
558 | "<>" | ||
559 | (case key | ||
560 | ((#:updated) | ||
561 | (list-ref (car stat-data) 1)) | ||
562 | ((#:count) | ||
563 | (list-ref (car stat-data) 0)) | ||
564 | (else | ||
565 | "<>"))))) | ||
566 | |||
567 | |||
568 | ;;; | ||
569 | |||
570 | (define (dict-html) | ||
571 | (let ((explist (list | ||
572 | (cons "@@args@@" | ||
573 | (lambda () | ||
574 | (for-each | ||
575 | (lambda (name) | ||
576 | (cond | ||
577 | ((string=? name "LANG")) | ||
578 | (else | ||
579 | (let ((v (cgi:value name))) | ||
580 | (cond ((and v (not (string-null? v))) | ||
581 | (display "&") | ||
582 | (display name) | ||
583 | (display "=") | ||
584 | (display v))))))) | ||
585 | (cgi:names)))) | ||
586 | (cons "@@dict@@" | ||
587 | (lambda () | ||
588 | (main-form) | ||
589 | (dict-search))) | ||
590 | (cons "@@stat_updated@@" | ||
591 | (lambda () | ||
592 | (display (stat #:updated)))) | ||
593 | (cons "@@stat_count@@" | ||
594 | (lambda () | ||
595 | (display | ||
596 | (let ((s (stat #:count))) | ||
597 | (if (string=? s "<>") | ||
598 | s | ||
599 | (let ((n (string->number s))) | ||
600 | (string-append s " " | ||
601 | (ngettext "λέξη" "λέξεις" | ||
602 | n))))))))))) | ||
603 | (do ((line (read-line) (read-line))) | ||
604 | ((eof-object? line) #f) | ||
605 | (expand-template explist line) | ||
606 | (newline)))) | ||
607 | |||
608 | ;;; Main | ||
609 | ifelse(IFACE,[CGI],(display ["Content-type: text/html; charset=utf-8\r\n\r\n"])) | ||
610 | |||
611 | (with-input-from-file | ||
612 | (template-file target-language dict-template-file-name) | ||
613 | dict-html) | ||
614 | |||
615 | (dict-connect #t) | ||
616 | |||
617 | ;;;; Local variables: | ||
618 | ;;;; mode: Scheme | ||
619 | ;;;; buffer-file-coding-system: utf-8 | ||
620 | ;;;; End: | ||
621 | |||
diff --git a/cgi-bin/nea.scm4 b/cgi-bin/nea.scm4 new file mode 100644 index 0000000..20e1803 --- a/dev/null +++ b/cgi-bin/nea.scm4 | |||
@@ -0,0 +1,536 @@ | |||
1 | ;;;; News page for Ellinika | ||
2 | ;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff | ||
3 | ;;;; | ||
4 | ;;;; This program is free software; you can redistribute it and/or modify | ||
5 | ;;;; it under the terms of the GNU General Public License as published by | ||
6 | ;;;; the Free Software Foundation; either version 2 of the License, or | ||
7 | ;;;; (at your option) any later version. | ||
8 | ;;;; | ||
9 | ;;;; This program is distributed in the hope that it will be useful, | ||
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
12 | ;;;; GNU General Public License for more details. | ||
13 | ;;;; | ||
14 | ;;;; You should have received a copy of the GNU General Public License | ||
15 | ;;;; along with this program; if not, write to the Free Software | ||
16 | ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ||
17 | ;;;; | ||
18 | |||
19 | ;;; Tailor this statement to your needs if necessary. | ||
20 | (set! %load-path (cons "GUILE_SITE" %load-path)) | ||
21 | |||
22 | (use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) | ||
23 | (gamma sql) | ||
24 | (gamma gettext) | ||
25 | (xmltools dict) | ||
26 | (ellinika xlat) | ||
27 | (ellinika cgi)) | ||
28 | |||
29 | ifelse(IFACE,[CGI],(cgi:init)) | ||
30 | |||
31 | (define tmpl (if (and monima-nea-template-file-name | ||
32 | (cgi:value "timestamp")) | ||
33 | monima-nea-template-file-name | ||
34 | nea-template-file-name)) | ||
35 | |||
36 | (ellinika-cgi-init tmpl) | ||
37 | |||
38 | (define conn #f) | ||
39 | (define article #f) | ||
40 | (define accepted-lang (map | ||
41 | (lambda (s) | ||
42 | (cond | ||
43 | ((string-split s #\;) => | ||
44 | (lambda (l) | ||
45 | (car l))) | ||
46 | (else | ||
47 | s))) | ||
48 | (string-split (or | ||
49 | (getenv "HTTP_ACCEPT_LANGUAGE") | ||
50 | "") | ||
51 | #\,))) | ||
52 | |||
53 | (define nea-max-rows 20) ;; FIXME: Move to the config | ||
54 | |||
55 | (define (permalink tag timestamp) | ||
56 | (display (string-append "<" tag " class=\"permalink\">")) | ||
57 | (display "<a href=\"") | ||
58 | (display (make-cgi-name cgi-script-name "timestamp" timestamp)) | ||
59 | (display "\">[permanent link]</a>") | ||
60 | (display (string-append "</" tag ">"))) | ||
61 | |||
62 | (define (sql-error-handler err descr) | ||
63 | (format #t "<h1 class=\"error\">~A</h1>\n" | ||
64 | (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε.")) | ||
65 | (with-output-to-port | ||
66 | (current-error-port) | ||
67 | (lambda () | ||
68 | (display err) | ||
69 | (display ": ") | ||
70 | (display descr)))) | ||
71 | |||
72 | (defmacro catch-sql (expr) | ||
73 | `(catch 'gsql-error | ||
74 | (lambda () ,expr) | ||
75 | (lambda (key err descr) | ||
76 | (sql-error-handler err descr)))) | ||
77 | |||
78 | (defmacro assert-article (. expr) | ||
79 | `(if article | ||
80 | (cond | ||
81 | ((null? article) | ||
82 | (format #t "<h1 class=\"error\">~A</h1>\n" | ||
83 | (_ "Κάμια καταχώρηση"))) | ||
84 | (else | ||
85 | ,@expr)))) | ||
86 | |||
87 | (define (make-sql-list input-list) | ||
88 | (let loop ((str "") | ||
89 | (input-list input-list)) | ||
90 | (if (null? input-list) | ||
91 | (string-append "(" str ")") | ||
92 | (loop (string-append str | ||
93 | (if (string-null? str) "'" ",'") | ||
94 | (car input-list) "'") | ||
95 | (cdr input-list))))) | ||
96 | |||
97 | (define (get-sql-lang conn ident langlist) | ||
98 | (let ((res (map car (sql-query conn | ||
99 | (string-append | ||
100 | "SELECT lang " | ||
101 | "FROM newsart " | ||
102 | "WHERE ident=" ident " " | ||
103 | "AND lang in " (make-sql-list langlist)))))) | ||
104 | (cond | ||
105 | ((null? res) | ||
106 | #f) | ||
107 | (else | ||
108 | (call-with-current-continuation | ||
109 | (lambda (return) | ||
110 | (for-each | ||
111 | (lambda (elt) | ||
112 | (if (member elt res) | ||
113 | (return elt))) | ||
114 | langlist))))))) | ||
115 | |||
116 | (define (make-my-lang-list) | ||
117 | (map language-code (cons target-language | ||
118 | accepted-lang))) | ||
119 | |||
120 | |||
121 | (define (collect-entries from fwd) | ||
122 | (let loop ((start from) | ||
123 | (result '())) | ||
124 | (cond | ||
125 | ((not fwd) | ||
126 | (set! start (- start nea-max-rows)) | ||
127 | (if (< start 0) | ||
128 | (set! start 0)))) | ||
129 | (call-with-current-continuation | ||
130 | (lambda (return) | ||
131 | (let ((tuples (sql-query | ||
132 | conn | ||
133 | (format #f | ||
134 | "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A" | ||
135 | start nea-max-rows)))) | ||
136 | (cond | ||
137 | ((null? tuples) | ||
138 | (cons start (if fwd (reverse result) result))) | ||
139 | (else | ||
140 | (let ((langlist (make-my-lang-list)) | ||
141 | (rest (- nea-max-rows (length result))) | ||
142 | (ctr 0)) | ||
143 | (for-each | ||
144 | (lambda (entry) | ||
145 | (let ((lang (get-sql-lang conn (list-ref entry 1) langlist))) | ||
146 | (set! ctr (1+ ctr)) | ||
147 | (if lang | ||
148 | (let ((hdr (sql-query conn | ||
149 | (string-append | ||
150 | "SELECT header,lang " | ||
151 | "FROM newsart " | ||
152 | "WHERE ident=" (list-ref entry 1) " " | ||
153 | "AND lang='" lang "' " | ||
154 | "LIMIT 1")))) | ||
155 | (cond | ||
156 | (hdr | ||
157 | (set! result (cons | ||
158 | (cons (caar hdr) entry) | ||
159 | result)) | ||
160 | (set! rest (1- rest)) | ||
161 | (cond | ||
162 | ((= 0 rest) | ||
163 | (if fwd | ||
164 | (return (cons (+ ctr start) (reverse result))) | ||
165 | (return (cons (+ start (- nea-max-rows ctr)) | ||
166 | result))))))))))) | ||
167 | |||
168 | (if fwd | ||
169 | tuples | ||
170 | (reverse tuples))) | ||
171 | |||
172 | (cond | ||
173 | ((and (not fwd) (= 0 start)) | ||
174 | (cons start (if fwd (reverse result) result))) | ||
175 | (else | ||
176 | (if fwd | ||
177 | (set! start (+ ctr start))) | ||
178 | (loop start result))))))))))) | ||
179 | |||
180 | (define (summary) | ||
181 | (catch-sql | ||
182 | (let* ((count (catch #t | ||
183 | (lambda () | ||
184 | (string->number | ||
185 | (caar (sql-query conn "SELECT count(*) FROM news")))) | ||
186 | (lambda args | ||
187 | 0))) | ||
188 | (from (catch #t | ||
189 | (lambda () | ||
190 | (let ((x (string->number (cgi:value "from")))) | ||
191 | (if (< x count) | ||
192 | x | ||
193 | 0))) | ||
194 | (lambda args | ||
195 | 0))) | ||
196 | (fwd (let ((dir (cgi:value "dir"))) | ||
197 | (or (not dir) | ||
198 | (string=? dir "1")))) | ||
199 | (entries (collect-entries from fwd))) | ||
200 | |||
201 | (let ((start (car entries)) | ||
202 | (result (cdr entries))) | ||
203 | (cond | ||
204 | ((null? result) | ||
205 | (display "<div align=\"center\">") | ||
206 | (display (_ "Κανένα νέα")) | ||
207 | (display "</div>")) | ||
208 | (else | ||
209 | (let ((num-entries (length result)) | ||
210 | (begin (if fwd from start)) | ||
211 | (end (if fwd start from)) | ||
212 | (id (cgi:value "id"))) | ||
213 | |||
214 | (cond | ||
215 | ((not (and (= from 0) (< num-entries nea-max-rows))) | ||
216 | (display "<p>") | ||
217 | (format #t (_ "Εγγραφείς ~A - ~A") begin end) | ||
218 | (display "</p>"))) | ||
219 | |||
220 | (display "<table class=\"news-summary frame\">\n") | ||
221 | (let ((ctr 0) | ||
222 | (langlist (make-my-lang-list))) | ||
223 | (for-each | ||
224 | (lambda (entry) | ||
225 | (display "<tr class=\"") | ||
226 | (display (if (= (modulo ctr 2) 0) "even" "odd")) | ||
227 | (display "\">\n") | ||
228 | (set! ctr (1+ ctr)) | ||
229 | (display "<td class=\"date\">") | ||
230 | (display (list-ref entry 1)) | ||
231 | (display "</td>") | ||
232 | (display "<td class=\"subject") | ||
233 | (cond | ||
234 | ((and id (string=? (list-ref entry 2) id)) | ||
235 | (display " current\">") | ||
236 | (display (list-ref entry 0))) | ||
237 | (else | ||
238 | (display "\"><a href=\"") | ||
239 | (display (make-cgi-name cgi-script-name | ||
240 | "id" (list-ref entry 2) | ||
241 | "from" (number->string begin))) | ||
242 | (display "\">") | ||
243 | (display (list-ref entry 0)) | ||
244 | (display "</a>"))) | ||
245 | (display "</td>") | ||
246 | (display "\n</tr>\n")) | ||
247 | result)) | ||
248 | (display "</table>") | ||
249 | |||
250 | (display "<div class=\"menu-bar\" align=\"center\">") | ||
251 | (cond | ||
252 | ((> begin 0) | ||
253 | (display "<span class=\"menu-cell\"><a href=\"") | ||
254 | (display (apply make-cgi-name | ||
255 | cgi-script-name | ||
256 | "from" (number->string begin) | ||
257 | "dir" "0" | ||
258 | (if id | ||
259 | (list "id" id) | ||
260 | '()))) | ||
261 | (display "\">") | ||
262 | (display (_ "Προηγούμενες")) | ||
263 | (display "</a></span>"))) | ||
264 | |||
265 | (cond | ||
266 | ((< end count) | ||
267 | (display "<span class=\"menu-cell\"><a href=\"") | ||
268 | (display (apply make-cgi-name | ||
269 | cgi-script-name | ||
270 | "from" (number->string end) | ||
271 | "dir" "1" | ||
272 | (if id | ||
273 | (list "id" id) | ||
274 | '()))) | ||
275 | (display "\">") | ||
276 | (display (_ "Ερχόμενες")) | ||
277 | (display "</a></span>"))) | ||
278 | (display "</div>")))))))) | ||
279 | |||
280 | (define (display-article-header item) | ||
281 | (display "<div id=\"news-header\">") | ||
282 | (format #t "<span class=\"itemdate\">~A</span>\n" (car item)) | ||
283 | (display "<span class=\"itemsubject\">\n") | ||
284 | (display (list-ref item 2)) | ||
285 | (display "</span>") | ||
286 | (if (not (cgi:value "timestamp")) | ||
287 | (permalink "span" (list-ref item 1))) | ||
288 | (display "</div><!-- news-header -->")) | ||
289 | |||
290 | (define (display-article-text item . rest) | ||
291 | (let ((class (and (not (null? rest)) (car rest)))) | ||
292 | (cond | ||
293 | (class | ||
294 | (display "\n<div class=\"") | ||
295 | (display class) | ||
296 | (display "\">\n") | ||
297 | (display (list-ref item 3)) | ||
298 | (display "</div>\n")) | ||
299 | (else | ||
300 | (display (list-ref item 3)))))) | ||
301 | |||
302 | (define (main) | ||
303 | (catch-sql | ||
304 | (assert-article | ||
305 | (display-article-header article) | ||
306 | (display-article-text article "itemtext")))) | ||
307 | |||
308 | (define (title) | ||
309 | (if article | ||
310 | (display (if (null? article) | ||
311 | (string-append | ||
312 | "<h1 class=\"error\">" | ||
313 | (_ "Κάμια καταχώρηση") | ||
314 | "</h1>") | ||
315 | (list-ref article 2))))) | ||
316 | |||
317 | |||
318 | (define (nea-html) | ||
319 | (let ((explist (list (cons "@@main@@" main) | ||
320 | (cons "@@summary@@" summary) | ||
321 | (cons "@@title@@" title) | ||
322 | (cons "@@article-text@@" | ||
323 | (lambda () | ||
324 | (catch-sql | ||
325 | (assert-article | ||
326 | (display-article-text article))))) | ||
327 | (cons "@@article-date@@" | ||
328 | (lambda () | ||
329 | (catch-sql | ||
330 | (assert-article | ||
331 | (display (car article)))))) | ||
332 | (cons "@@article-header@@" | ||
333 | (lambda () | ||
334 | (catch-sql | ||
335 | (assert-article | ||
336 | (display (list-ref article 2)))))) | ||
337 | (cons "@@full-header@@" | ||
338 | (lambda () | ||
339 | (catch-sql | ||
340 | (assert-article | ||
341 | (display-article-header | ||
342 | article))))) | ||
343 | (cons "@@args@@" | ||
344 | (lambda () | ||
345 | (for-each | ||
346 | (lambda (name) | ||
347 | (cond | ||
348 | ((string=? name "LANG")) | ||
349 | (else | ||
350 | (let ((v (cgi:value name))) | ||
351 | (cond ((and v (not (string-null? v))) | ||
352 | (display "&") | ||
353 | (display name) | ||
354 | (display "=") | ||
355 | (display v))))))) | ||
356 | (cgi:names))))))) | ||
357 | |||
358 | (do ((line (read-line) (read-line))) | ||
359 | ((eof-object? line) #f) | ||
360 | (expand-template explist line) | ||
361 | (newline)))) | ||
362 | |||
363 | (define (nea-rss-header) | ||
364 | (display "<?xml version=\"1.0\"?>\n") | ||
365 | (display "<rss version=\"2.0\"> | ||
366 | <channel> | ||
367 | <title>Τα νέα</title> | ||
368 | <description>Τα νέα</description> | ||
369 | <link>http://ellinika.gnu.org.ua</link>") | ||
370 | (format #t "<language>~A</language>" (language-code target-language)) | ||
371 | (display " | ||
372 | <generator>EllinikaNea</generator> | ||
373 | <copyright>2006 Sergey Poznyakoff</copyright> | ||
374 | <managingEditor>gray@gnu.org.ua</managingEditor> | ||
375 | <docs>http://blogs.law.harvard.edu/tech/rss</docs> | ||
376 | ")) | ||
377 | |||
378 | (define (nea-rss-footer) | ||
379 | (display " </channel> | ||
380 | </rss>")) | ||
381 | |||
382 | (define (nea-sql-connect) | ||
383 | (let ((conn (sql-connect | ||
384 | sql-iface sql-host sql-port sql-database | ||
385 | sql-username sql-password))) | ||
386 | (sql-query conn "SET NAMES utf8") | ||
387 | conn)) | ||
388 | |||
389 | (define (nea-rss) | ||
390 | (nea-rss-header) | ||
391 | (catch 'gsql-error | ||
392 | (lambda () | ||
393 | (let ((conn (nea-sql-connect))) | ||
394 | (for-each | ||
395 | (lambda (tuple) | ||
396 | (display "<item>\n") | ||
397 | (display "<pubDate>") | ||
398 | (display (list-ref tuple 0)) | ||
399 | (display "</pubDate>\n") | ||
400 | (display "<title>") | ||
401 | (let ((title (sql-query conn | ||
402 | (string-append | ||
403 | "SELECT header " | ||
404 | "FROM newsart " | ||
405 | "WHERE ident=" (list-ref tuple 2) " " | ||
406 | "AND lang='" | ||
407 | (get-sql-lang conn | ||
408 | (list-ref tuple 2) | ||
409 | (make-my-lang-list)) | ||
410 | "' " | ||
411 | "LIMIT 1")))) | ||
412 | (display (if (not (null? title)) | ||
413 | (caar title) | ||
414 | (list-ref tuple 0)))) | ||
415 | (display "</title>\n") | ||
416 | (display "<link>") | ||
417 | (display (string-append | ||
418 | (string-downcase cgi-server-protocol-name) | ||
419 | "://" | ||
420 | cgi-server-hostname | ||
421 | "/" | ||
422 | (make-cgi-name cgi-script-name | ||
423 | "timestamp" (list-ref tuple 1)))) | ||
424 | (display "</link>\n") | ||
425 | (display "</item>\n")) | ||
426 | (sql-query | ||
427 | conn | ||
428 | (string-append | ||
429 | "SELECT date,unix_timestamp(date),ident " | ||
430 | "FROM news " | ||
431 | "ORDER BY 1 DESC LIMIT 10"))))) | ||
432 | (lambda (key err descr) | ||
433 | (sql-error-handler err descr))) | ||
434 | (nea-rss-footer)) | ||
435 | |||
436 | |||
437 | (define (get-article-by-timestamp ts) | ||
438 | (let ((tuples (sql-query | ||
439 | conn | ||
440 | "SELECT date,unix_timestamp(date),ident FROM news WHERE unix_timestamp(date)=" ts))) | ||
441 | (cond | ||
442 | (tuples | ||
443 | (let* ((res (car tuples)) | ||
444 | (lang (get-sql-lang conn (list-ref res 2) (make-my-lang-list))) | ||
445 | (art (sql-query conn | ||
446 | (string-append | ||
447 | "SELECT header,text,lang " | ||
448 | "FROM newsart " | ||
449 | "WHERE ident=" (list-ref res 2) " " | ||
450 | "AND lang='" lang "' " | ||
451 | "LIMIT 1")))) | ||
452 | (append | ||
453 | (list (list-ref res 0) | ||
454 | (list-ref res 1)) | ||
455 | (car art))))))) | ||
456 | |||
457 | |||
458 | ;;; Main | ||
459 | |||
460 | (cond | ||
461 | ((cgi:value "rss") | ||
462 | ifelse(IFACE,[CGI], | ||
463 | (display ["Content-type: text/xml; charset=utf-8\r\n\r\n"]), | ||
464 | (request-rec:set-content-type! Request ["text/xml; charset=UTF-8"])) | ||
465 | (nea-rss)) | ||
466 | (else | ||
467 | (catch 'gsql-error | ||
468 | (lambda () | ||
469 | ifelse(IFACE,[CGI],dnl | ||
470 | (display ["Content-type: text/html; charset=utf-8\r\n\r\n"])) | ||
471 | (set! conn (nea-sql-connect)) | ||
472 | (cond | ||
473 | ((or (cgi:value "timestamp") (cgi:value "id")) | ||
474 | (let ((tuples (sql-query | ||
475 | conn | ||
476 | (string-append | ||
477 | "SELECT date,unix_timestamp(date),ident " | ||
478 | "FROM news " | ||
479 | "WHERE " | ||
480 | (cond | ||
481 | ((cgi:value "timestamp") => | ||
482 | (lambda (ts) | ||
483 | (string-append "unix_timestamp(date)=" ts))) | ||
484 | ((cgi:value "id") => | ||
485 | (lambda (id) | ||
486 | (string-append "ident=" id)))))))) | ||
487 | |||
488 | (if (not (null? tuples)) | ||
489 | (let* ((res (car tuples)) | ||
490 | (lang (get-sql-lang conn | ||
491 | (list-ref res 2) | ||
492 | (make-my-lang-list))) | ||
493 | (art (sql-query | ||
494 | conn | ||
495 | (string-append | ||
496 | "SELECT header,text,lang " | ||
497 | "FROM newsart " | ||
498 | "WHERE ident=" (list-ref res 2) " " | ||
499 | "AND lang='" lang "' " | ||
500 | "LIMIT 1")))) | ||
501 | (set! article (append | ||
502 | (list (list-ref res 0) | ||
503 | (list-ref res 1)) | ||
504 | (car art)))))))) | ||
505 | |||
506 | (with-input-from-file | ||
507 | (template-file target-language tmpl) | ||
508 | nea-html) | ||
509 | |||
510 | (sql-connect-close conn)) | ||
511 | |||
512 | (lambda (key err descr) | ||
513 | (with-input-from-file | ||
514 | (template-file target-language tmpl) | ||
515 | (lambda () | ||
516 | (let ((explist | ||
517 | (list (cons "@@main@@" | ||
518 | (lambda () | ||
519 | (sql-error-handler err descr))) | ||
520 | (cons "@@article-text@@" | ||
521 | (lambda () | ||
522 | (sql-error-handler err descr))) | ||
523 | (cons "@@summary@@" (lambda () #f)) | ||
524 | (cons "@@title@@" (lambda () #f)) | ||
525 | (cons "@@article-date@@" (lambda () #f)) | ||
526 | (cons "@@article-header@@" (lambda () #f)) | ||
527 | (cons "@@full-header@@" (lambda () #f))))) | ||
528 | (do ((line (read-line) (read-line))) | ||
529 | ((eof-object? line) #f) | ||
530 | (expand-template explist line) | ||
531 | (newline))))))))) | ||
532 | |||
533 | ;;;; Local variables: | ||
534 | ;;;; mode: Scheme | ||
535 | ;;;; buffer-file-coding-system: utf-8 | ||
536 | ;;;; End: | ||
diff --git a/ellinika/cgi.scmi b/ellinika/cgi.scm4 index b4da8f9..dc7c05d 100644 --- a/ellinika/cgi.scmi +++ b/ellinika/cgi.scm4 | |||
@@ -1,5 +1,4 @@ | |||
1 | ;;;; -*- scheme -*- | 1 | ;;;; -*- scheme -*- |
2 | =AUTOGENERATED= | ||
3 | ;;;; Greek Dictionary Web Engine | 2 | ;;;; Greek Dictionary Web Engine |
4 | ;;;; Copyright (C) 2005 Sergey Poznyakoff | 3 | ;;;; Copyright (C) 2005 Sergey Poznyakoff |
5 | ;;;; | 4 | ;;;; |
@@ -17,24 +16,40 @@ | |||
17 | ;;;; along with this program; if not, write to the Free Software | 16 | ;;;; along with this program; if not, write to the Free Software |
18 | ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | 17 | ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
19 | ;;;; | 18 | ;;;; |
20 | |||
21 | (define-module (ellinika cgi)) | 19 | (define-module (ellinika cgi)) |
22 | 20 | ||
23 | (use-modules (www cgi) | 21 | (use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) |
24 | (gamma gettext) | 22 | (gamma gettext) |
25 | (ellinika i18n)) | 23 | (ellinika i18n)) |
26 | 24 | ||
25 | ifelse(IFACE,[CGI],,dnl | ||
26 | (define form-data | ||
27 | (append | ||
28 | (parse-form-data | ||
29 | (table:get (request-rec:subprocess-env Request) "QUERY_STRING")) | ||
30 | (if (= (request-rec:method-number Request) 2) | ||
31 | (parse-form-data (read-post-data Request)) | ||
32 | '()))) | ||
33 | |||
34 | (define-public (cgi:value name) | ||
35 | (assoc-ref form-data name)) | ||
36 | |||
37 | (define-public (cgi:names) | ||
38 | (map car form-data)) | ||
39 | |||
40 | (define-public cgi-script-name | ||
41 | (table:get (request-rec:subprocess-env Request) | ||
42 | "SCRIPT_NAME")) | ||
43 | ) | ||
44 | |||
45 | |||
27 | ;;; User-definable variables | 46 | ;;; User-definable variables |
28 | (define-public base-dir "=PREFIX=") | 47 | (define-public base-dir "PREFIX") |
29 | (define-public html-dir "=HTMLDIR=") | 48 | (define-public html-dir "HTMLDIR") |
30 | (define-public sysconf-dir "=SYSCONFDIR=") | 49 | (define-public sysconf-dir "SYSCONFDIR") |
31 | (define-public locale-path "=LOCALEDIR=:/usr/share/locale:/usr/local/share/locale") | 50 | (define-public locale-path "LOCALEDIR:/usr/share/locale:/usr/local/share/locale") |
32 | (define-public ref-loc #f) | 51 | (define-public ref-loc #f) |
33 | 52 | ||
34 | (define-public dict-cgi-path "cgi-bin/dict.cgi") | ||
35 | (define-public nea-cgi-path "cgi-bin/nea.cgi") ;; Path to the cgi (relative | ||
36 | ;; to the Base HREF) | ||
37 | |||
38 | (define-public config-file-name "ellinika.conf") | 53 | (define-public config-file-name "ellinika.conf") |
39 | (define-public dict-template-file-name "dict.html") | 54 | (define-public dict-template-file-name "dict.html") |
40 | (define-public nea-template-file-name "nea.html") | 55 | (define-public nea-template-file-name "nea.html") |
@@ -142,7 +157,7 @@ THUNK. | |||
142 | (if (file-exists? (template-file x template-file-name)) | 157 | (if (file-exists? (template-file x template-file-name)) |
143 | (set! target-language x))))) | 158 | (set! target-language x))))) |
144 | ;;; Initialize i18n | 159 | ;;; Initialize i18n |
145 | (let ((x (locale-setup target-language "=PACKAGE=" locale-path))) | 160 | (let ((x (locale-setup target-language "PACKAGE" locale-path))) |
146 | (if x | 161 | (if x |
147 | (set! target-language x)))) | 162 | (set! target-language x)))) |
148 | 163 | ||