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

Return to:

Send suggestions and report system problems to the System administrator.