diff options
Diffstat (limited to 'cgi-bin/dict.scm4')
-rw-r--r-- | cgi-bin/dict.scm4 | 621 |
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 --- /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=\"" | ||