aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 +0000
commit109cf4d84378cbfce6b157ac854383be2a9ea866 (patch)
tree9c1b4a25f39d3f7bf7a8ecf879b1b40014f4af5a
parentc4a4896b38006d9966ffd6112e27539ba0efeaca (diff)
downloadellinika-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.scm4621
-rw-r--r--cgi-bin/nea.scm4536
-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
--- /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))