summaryrefslogtreecommitdiffabout
path: root/cgi-bin/dict.scm4
Unidiff
Diffstat (limited to 'cgi-bin/dict.scm4') (more/less context) (ignore whitespace changes)
-rw-r--r--cgi-bin/dict.scm4621
1 files changed, 621 insertions, 0 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
30ifelse(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 &#34;
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 "&amp;")
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
609ifelse(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

Return to:

Send suggestions and report system problems to the System administrator.