aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:39:00 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:39:00 +0000
commitc4a4896b38006d9966ffd6112e27539ba0efeaca (patch)
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
-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
+++ /dev/null
@@ -1,622 +0,0 @@
-#! =GUILE_BINDIR=/guile -s
-=AUTOGENERATED=
-!#
-;;;; Greek Dictionary Web Engine
-;;;; Copyright (C) 2004, 2005 Sergey Poznyakoff
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-;;;;
-
-;;; Tailor this statement to your needs if necessary.
-;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path))
-
-(use-modules (www cgi)
- (gamma sql)
- (gamma gettext)
- (xmltools dict)
- (ellinika xlat)
- (ellinika cgi))
-(cgi:init)
-
-(ellinika-cgi-init dict-template-file-name)
-
-;; Τα μέρη του λογου
-(define part-of-speech '())
-
-(define (sql-error-handler err descr)
- (format #t "<h1 class=\"error\">~A</h1>\n"
- (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))
- (with-output-to-port
- (current-error-port)
- (lambda ()
- (display err)
- (display ": ")
- (display descr))))
-
-(define (mk-dict-connect)
- (let ((db-connection #f))
- (lambda (. rest)
- (cond
- ((null? rest)
- (if (not db-connection)
- (begin
- (set! db-connection
- (sql-connect
- sql-iface sql-host sql-port sql-database
- sql-username sql-password))
- (sql-query db-connection "SET NAMES utf8")
- )))
- (else
- (if db-connection
- (sql-connect-close db-connection))
- (set! db-connection #f)))
- db-connection)))
-
-(define dict-connect (mk-dict-connect))
-
-(defmacro catch-sql-failure (expr)
- `(catch 'gsql-error
- (lambda () ,expr)
- (lambda (key err descr)
- (sql-error-handler err descr))))
-
-(defmacro ignore-sql-failure (expr)
- `(catch 'gsql-error
- (lambda () ,expr)
- (lambda (key err descr)
- #f)))
-
-(define (load-pos)
- (ignore-sql-failure
- (let ((conn (dict-connect)))
- (let ((plist (my-sql-query
- conn
- "SELECT name,id FROM pos WHERE canonical='Y' order by id")))
- (set! part-of-speech
- (cons
- (cons "κανένα μέρος του λόγου" #f)
- (map
- (lambda (x)
- (cons (car x) (cadr x)))
- plist)))))))
-
-;; Protect occurences of " in a string.
-;; Usual backslash escapes do not work in INPUT widgets, so I
-;; change all quotation marks to &#34;
-;; Possibly not the better solution, though...
-(define (protect string)
- (list->string
- (apply append
- (map
- (lambda (x)
- (if (eq? x #\")
- (list #\& #\# #\3 #\4 #\;)
- (list x)))
- (string->list string)))))
-
-(define (get-topic-list)
- (let ((categories #f))
- (letrec ((getcat
- (lambda ()
- (ignore-sql-failure
- (let ((conn (dict-connect)))
- (let ((ctg (my-sql-query
- conn
- (string-append
- "SELECT t.category, c.title, c.description "
- "FROM category c,topic t "
- "WHERE c.lang='" (language-code target-language) "' "
- "AND c.category=t.category GROUP BY 1 ORDER BY 1"))))
- (if (null? ctg)
- '()
- (map
- (lambda (category)
- (let ((topics (my-sql-query
- conn
- (string-append
- "SELECT ident,title FROM topic WHERE category="
- (car category)
- " ORDER BY title"))))
- (append category (if (null? topics)
- '()
- (list topics)))))
- ctg))))))))
- (if (not categories)
- (set! categories (or (getcat) '())))
- categories)))
-
-(define (join-widget widget-id tabindex)
- (let* ((name (string-append "join" widget-id))
- (selected-choice (or (let ((s (cgi:value name)))
- (if s
- (string->number s)
- #f))
- 0)))
- (display (string-append "<SELECT NAME=\""
- name
- "\" TABINDEX=\""
- tabindex
- "\">"))
- (display "<OPTION VALUE=\"0\"")
- (if (= selected-choice 0)
- (display " selected"))
- (display ">") (display (_"και")) (display "</OPTION>")
- (display "<OPTION VALUE=\"1\"")
- (if (= selected-choice 1)
- (display " selected"))
- (display ">") (display (_"ή")) (display "</OPTION>")
- (display "</SELECT>")))
-
-(define (main-form)
- (load-pos)
- (display "<FORM ACTION=\"")
- (display (make-cgi-name dict-cgi-path))
- (display "\" METHOD=POST>
-<table class=\"noframe\">
-<tr>
- <td>")
- (display (_"Εισάγετε τη λέξη"))
- (display "
- </td>
- <td>
- <input size=\"36\" name=\"key\" tabindex=\"1\"")
- (let ((value (cgi:value "key")))
- (if value
- (begin
- (display "value=\"")
- (display (protect value))
- (display "\""))))
- (display ">
- </td>
-</tr>")
-
- (display "<tr><td colspan=\"3\" align=\"center\">")
- (display (_"Συμπληρωματικοί όροι"))
- (display "</td></tr>")
-
- (display "
-<tr>
- <td>")
- (display (_"Επιλέξτε το μέρος του λόγου"))
- (display "</td><td>")
-
- (let ((selected-choice (or (let ((s (cgi:value "POS")))
- (if s
- (string->number s)
- #f))
- 0))
- (index 0))
-
- (display "<select name=\"POS\" tabindex=\"2\">")
-
- (for-each
- (lambda (x)
- (let ((name (car x)))
- (display "<option value=")
- (display index)
- (if (= index selected-choice)
- (display " selected"))
- (display ">")
- (display name)
- (set! index (1+ index))))
- part-of-speech)
- (display "</select>"))
-
- (display "</td><td>")
- (join-widget "pos" "3")
- (display "</td></tr>")
-
- (let ((tabindex 4))
- (for-each
- (lambda (category)
- (display "<tr><td>")
- (display (list-ref category 1))
- (display "</td><td>")
- (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0))))
- (if s
- (string->number s)
- #f))
- 0)))
-
- (display (string-append
- "<select name=\""
- (list-ref category 0)
- "\" tabindex=\""
- (number->string tabindex)
- "\">"))
- (set! tabindex (1+ tabindex))
- (display "<option value=0>---")
- (for-each
- (lambda (x)
- (let ((id (car x))
- (name (car (cdr x))))
- (display "<option value=")
- (display id)
- (if (eq? (string->number id) selected-choice)
- (display " selected"))
- (display ">")
- (display name)
- (display "</option>")))
- (list-ref category 3))
- (display "</select>")
- (display "</td><td>")
- (join-widget (list-ref category 0) (number->string tabindex))
- (display "</td></tr>")
- (set! tabindex (1+ tabindex))))
- (get-topic-list))
-
- (display "
-<tr>
- <td colspan=\"3\" align=\"center\">
- <input type=\"submit\" name=\"search\" value=\"")
- (display (_"Αναζήτηση"))
- (display "\" tabindex=\"")
- (display tabindex)
- (display "\">
- </td>
-</tr>
-</table>
-</form>
-<p>")))
-
-;;
-(define (replace-tilde word sentence)
- (apply
- string-append
- (let loop ((lst '())
- (str sentence))
- (cond
- ((string-index str #\~) =>
- (lambda (x)
- (loop
- (append lst (list (substring str 0 x) word))
- (substring str (1+ x)))))
- ((string-null? str)
- lst)
- (else
- (append lst (list str)))))))
-
-;;
-(define (display-results rlist)
- (let ((x (car rlist)))
- (display "<table class=\"noframe\">")
- (display "<tr><td>")
- (display (car x))
- (display "</td>")
- (cond
- ((list-ref x 3)
- (display "<td>")
- (let ((href (assoc (list-ref x 2) word-forms-reference)))
- (cond
- (href
- (display "<a href=\"")
- (cond
- (ref-loc
- (display ref-loc)
- (display "/")))
- (display (language-code target-language))
- (display "/")
- (display (cdr href))
- (display (dict:encode-string (car x)))
- (display "\">")
- (display (list-ref x 3))
- (display "</a>"))
- (else
- (display (list-ref x 3)))))
- (display "</td>")))
- (display "<td>")
- (display (list-ref x 2))
- (display "</td></tr>"))
- (for-each
- (lambda (x)
- (display "<tr><td>")
- (display (1+ (string->number (list-ref x 4))))
- (display "</td><td>")
- (display (replace-tilde (car x) (list-ref x 5)))
- (display ";</td></tr>"))
- rlist)
- (display "</table>")
- (newline))
-
-(define (display-cross-reference word)
- (display "<a href=\"")
- (display (make-cgi-name dict-cgi-path "IDENT" (dict:encode-string word)))
- (display "\">")
- (display word)
- (display "</a>"))
-
-(define (display-xref rlist text)
- (display text)
- (let ((n 0))
- (for-each
- (lambda (x)
- (if (> n 0)
- (display ", "))
- (set! n (1+ n))
- (display-cross-reference (car x)))
- rlist))
- (display ";"))
-
-(define (sort-result input-list)
- (let ((output-list '())
- (current-element '()))
- (for-each
- (lambda (x)
- (cond
- ((or (null? current-element)
- (= (string->number (cadr x))
- (string->number (cadr (car current-element)))))
- (set! current-element (cons x current-element)))
- (else
- (set! output-list (cons (reverse current-element) output-list))
- (set! current-element (list x)))))
- input-list)
- (cons (reverse current-element) output-list)))
-
-
-(define (search-failure key)
- (display "<h2>")
- (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key)
- (display "</h2>"))
-
-(define (my-sql-query conn query)
- (catch #t
- (lambda ()
- (sql-query conn query))
- (lambda args
- '())))
-
-(define (fuzzy-search conn key theme pos)
- (let ((where-cond (list (string-append
- "WHERE dict.ident=articles.ident and articles.lang='"
- (language-code target-language)
- "' AND")))
- (select-stmt "SELECT DISTINCT dict.word FROM ")
- (from-list (list ",articles" "dict")))
-
- (cond
- ((not (null? theme))
- (set! where-cond (cons " topic_tab.word_ident=dict.ident"
- where-cond))
- (set! from-list (cons ",topic_tab" from-list))))
-
- (cond
- ((not (string-null? key))
- (if (not (null? theme))
- (set! where-cond (cons " AND" where-cond)))
- (set! where-cond (cons (string-append
- " dict.sound LIKE \""
- (ellinika:sounds-like key)
- "%\"")
- where-cond))))
-
- (cond
- ((> (string->number pos) 0)
- (let ((pos-entry
- (list-ref part-of-speech (string->number pos))))
- (if (or (not (string-null? key)) (not (null? theme)))
- (set! where-cond (cons
- (if (string=? (cgi:value "joinpos") "0")
- " AND"
- " OR")
- where-cond)))
-
- (set! where-cond (cons
- (string-append " (dict.pos & "
- (cdr pos-entry)
- ") = "
- (cdr pos-entry))
- where-cond)))))
-
- (let ((result
- (my-sql-query conn
- (string-append
- select-stmt
-
- " "
-
- (apply
- string-append
- (reverse from-list))
-
- " "
-
- (apply
- string-append
- (append
- (reverse where-cond)
- (map
- (lambda (x)
- (cond
- ((boolean? x)
- (if x " AND" " OR"))
- (else
- (if (not (member ",topic_tab" from-list))
- (set! from-list
- (cons ",topic_tab"
- from-list)))
- (string-append
- " topic_tab.topic_ident=" x))))
- theme)))
-
- " ORDER BY dict.word"))))
-
- (cond
- ((null? result)
- (search-failure key))
- (else
- (display "<table width=\"100%\" class=\"noframe\">")
- (let* ((result-length (length result))
- (lim (1+ (inexact->exact (/ result-length match-list-columns)))))
- (do ((i 0 (1+ i)))
- ((= i lim) #f)
- (display "<tr>")
- (do ((j i (+ j lim)))
- ((>= j result-length) #f)
- (display "<td>")
- (display-cross-reference (car (list-ref result j)))
- (display "</td>"))
- (display "</tr>")))
- (display "</table>"))))))
-
-
-(define (dict-search)
- (let ((keyval (if (cgi:value "IDENT")
- (dict:decode-string (cgi:value "IDENT"))
- (cgi:value "key")))
- (theme (do ((catlist (get-topic-list) (cdr catlist))
- (ret '()))
- ((null? catlist) ret)
- (let ((name (caar catlist)))
- (let ((v (cgi:value name)))
- (if (and v (> (string->number v) 0))
- (set! ret (append
- ret
- (list (= (string->number
- (cgi:value (string-append "join" name))) 0)
- v))))))))
- (pos (or (cgi:value "POS") "0")))
-
- (catch-sql-failure
- (let ((conn (dict-connect)))
- (cond
- ((and keyval
- (not (string-null? keyval))
- (null? theme)
- (= (string->number pos) 0))
- (display "<hr>")
- (let* ((key (ellinika:translate-input keyval))
- (result (my-sql-query
- conn
- (string-append
- "SELECT dict.word,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning "
- "FROM dict,articles,pos WHERE dict.word=\""
- key
- "\" AND dict.ident=articles.ident "
- "AND articles.lang='" (language-code target-language) "' "
- "AND dict.pos=pos.id AND pos.canonical='Y' order by dict.ident, articles.subindex"))))
-
- (cond
- ((null? result)
- (fuzzy-search conn key theme pos))
- (else
- (for-each
- (lambda (entry)
- (display-results entry)
- (let ((ant (my-sql-query
- conn
- (string-append
- "SELECT dict.word FROM dict,links WHERE links.type='ANT' AND links.ident="
- (cadr (car entry))
- " AND dict.ident=links.xref ORDER BY word"))))
- (if (and ant (not (null? ant)))
- (display-xref ant
- (if (= (length ant) 1)
- (_"Αντώνυμο: ") (_"Αντώνυμα: ")))))
- (display "<p>")
- (let ((x (my-sql-query
- conn
- (string-append
- "SELECT dict.word FROM dict,links WHERE links.type='XREF' AND links.ident="
- (cadr (car entry))
- " AND dict.ident=links.xref ORDER BY word"))))
- (if (and x (not (null? x)))
- (display-xref x (_"Βλέπετε επίσης ")))))
- (sort-result result))))))
- ((or (not (null? theme)) (> (string->number pos) 0))
- (display "<hr>")
- (fuzzy-search conn
- (ellinika:translate-input (or keyval "")) theme pos)))))))
-
-;;;
-
-(define (stat key)
- (let ((stat-data #f))
- (if (not stat-data)
- (set! stat-data
- (or
- (ignore-sql-failure
- (my-sql-query (dict-connect)
- (string-append
- "SELECT count,updated from stat WHERE lang='"
- (language-code target-language)
- "'")))
- '())))
-
- (if (null? stat-data)
- "<>"
- (case key
- ((#:updated)
- (list-ref (car stat-data) 1))
- ((#:count)
- (list-ref (car stat-data) 0))
- (else
- "<>")))))
-
-
-;;;
-
-(define (dict-html)
- (let ((explist (list
- (cons "@@args@@"
- (lambda ()
- (for-each
- (lambda (name)
- (cond
- ((string=? name "LANG"))
- (else
- (let ((v (cgi:value name)))
- (cond ((and v (not (string-null? v)))
- (display "&amp;")
- (display name)
- (display "=")
- (display v)))))))
- (cgi:names))))
- (cons "@@dict@@"
- (lambda ()
- (main-form)
- (dict-search)))
- (cons "@@stat_updated@@"
- (lambda ()
- (display (stat #:updated))))
- (cons "@@stat_count@@"
- (lambda ()
- (display
- (let ((s (stat #:count)))
- (if (string=? s "<>")
- s
- (let ((n (string->number s)))
- (string-append s " "
- (ngettext "λέξη" "λέξεις"
- n)))))))))))
- (do ((line (read-line) (read-line)))
- ((eof-object? line) #f)
- (expand-template explist line)
- (newline))))
-
-;;; Main
-(display "Content-type: text/html; charset=utf-8\r\n\r\n")
-
-(with-input-from-file
- (template-file target-language dict-template-file-name)
- dict-html)
-
-(dict-connect #t)
-
-;;;; Local variables:
-;;;; mode: Scheme
-;;;; buffer-file-coding-system: utf-8
-;;;; End:
-
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
+++ /dev/null
@@ -1,534 +0,0 @@
-#! =GUILE_BINDIR=/guile -s
-=AUTOGENERATED=
-!#
-;;;; News page for Ellinika
-;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-;;;;
-
-;;; Tailor this statement to your needs if necessary.
-;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path))
-
-(use-modules (www cgi)
- (gamma sql)
- (gamma gettext)
- (xmltools dict)
- (ellinika xlat)
- (ellinika cgi))
-(cgi:init)
-
-(define tmpl (if (and monima-nea-template-file-name
- (cgi:value "timestamp"))
- monima-nea-template-file-name
- nea-template-file-name))
-
-(ellinika-cgi-init tmpl)
-
-(define conn #f)
-(define article #f)
-(define accepted-lang (map
- (lambda (s)
- (cond
- ((string-split s #\;) =>
- (lambda (l)
- (car l)))
- (else
- s)))
- (string-split (or
- (getenv "HTTP_ACCEPT_LANGUAGE")
- "")
- #\,)))
-
-(define nea-max-rows 20) ;; FIXME: Move to the config
-
-(define (permalink tag timestamp)
- (display (string-append "<" tag " class=\"permalink\">"))
- (display "<a href=\"")
- (display (make-cgi-name nea-cgi-path "timestamp" timestamp))
- (display "\">[permanent link]</a>")
- (display (string-append "</" tag ">")))
-
-(define (sql-error-handler err descr)
- (format #t "<h1 class=\"error\">~A</h1>\n"
- (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε."))
- (with-output-to-port
- (current-error-port)
- (lambda ()
- (display err)
- (display ": ")
- (display descr))))
-
-(defmacro catch-sql (expr)
- `(catch 'gsql-error
- (lambda () ,expr)
- (lambda (key err descr)
- (sql-error-handler err descr))))
-
-(defmacro assert-article (. expr)
- `(if article
- (cond
- ((null? article)
- (format #t "<h1 class=\"error\">~A</h1>\n"
- (_ "Κάμια καταχώρηση")))
- (else
- ,@expr))))
-
-(define (make-sql-list input-list)
- (let loop ((str "")
- (input-list input-list))
- (if (null? input-list)
- (string-append "(" str ")")
- (loop (string-append str
- (if (string-null? str) "'" ",'")
- (car input-list) "'")
- (cdr input-list)))))
-
-(define (get-sql-lang conn ident langlist)
- (let ((res (map car (sql-query conn
- (string-append
- "SELECT lang "
- "FROM newsart "
- "WHERE ident=" ident " "
- "AND lang in " (make-sql-list langlist))))))
- (cond
- ((null? res)
- #f)
- (else
- (call-with-current-continuation
- (lambda (return)
- (for-each
- (lambda (elt)
- (if (member elt res)
- (return elt)))
- langlist)))))))
-
-(define (make-my-lang-list)
- (map language-code (cons target-language
- accepted-lang)))
-
-
-(define (collect-entries from fwd)
- (let loop ((start from)
- (result '()))
- (cond
- ((not fwd)
- (set! start (- start nea-max-rows))
- (if (< start 0)
- (set! start 0))))
- (call-with-current-continuation
- (lambda (return)
- (let ((tuples (sql-query
- conn
- (format #f
- "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A"
- start nea-max-rows))))
- (cond
- ((null? tuples)
- (cons start (if fwd (reverse result) result)))
- (else
- (let ((langlist (make-my-lang-list))
- (rest (- nea-max-rows (length result)))
- (ctr 0))
- (for-each
- (lambda (entry)
- (let ((lang (get-sql-lang conn (list-ref entry 1) langlist)))
- (set! ctr (1+ ctr))
- (if lang
- (let ((hdr (sql-query conn
- (string-append
- "SELECT header,lang "
- "FROM newsart "
- "WHERE ident=" (list-ref entry 1) " "
- "AND lang='" lang "' "
- "LIMIT 1"))))
- (cond
- (hdr
- (set! result (cons
- (cons (caar hdr) entry)
- result))
- (set! rest (1- rest))
- (cond
- ((= 0 rest)
- (if fwd
- (return (cons (+ ctr start) (reverse result)))
- (return (cons (+ start (- nea-max-rows ctr))
- result)))))))))))
-
- (if fwd
- tuples
- (reverse tuples)))
-
- (cond
- ((and (not fwd) (= 0 start))
- (cons start (if fwd (reverse result) result)))
- (else
- (if fwd
- (set! start (+ ctr start)))
- (loop start result)))))))))))
-
-(define (summary)
- (catch-sql
- (let* ((count (catch #t
- (lambda ()
- (string->number
- (caar (sql-query conn "SELECT count(*) FROM news"))))
- (lambda args
- 0)))
- (from (catch #t
- (lambda ()
- (let ((x (string->number (cgi:value "from"))))
- (if (< x count)
- x
- 0)))
- (lambda args
- 0)))
- (fwd (let ((dir (cgi:value "dir")))
- (or (not dir)
- (string=? dir "1"))))
- (entries (collect-entries from fwd)))
-
- (let ((start (car entries))
- (result (cdr entries)))
- (cond
- ((null? result)
- (display "<div align=\"center\">")
- (display (_ "Κανένα νέα"))
- (display "</div>"))
- (else
- (let ((num-entries (length result))
- (begin (if fwd from start))
- (end (if fwd start from))
- (id (cgi:value "id")))
-
- (cond
- ((not (and (= from 0) (< num-entries nea-max-rows)))
- (display "<p>")
- (format #t (_ "Εγγραφείς ~A - ~A") begin end)
- (display "</p>")))
-
- (display "<table class=\"news-summary frame\">\n")
- (let ((ctr 0)
- (langlist (make-my-lang-list)))
- (for-each
- (lambda (entry)
- (display "<tr class=\"")
- (display (if (= (modulo ctr 2) 0) "even" "odd"))
- (display "\">\n")
- (set! ctr (1+ ctr))
- (display "<td class=\"date\">")
- (display (list-ref entry 1))
- (display "</td>")
- (display "<td class=\"subject")
- (cond
- ((and id (string=? (list-ref entry 2) id))
- (display " current\">")
- (display (list-ref entry 0)))
- (else
- (display "\"><a href=\"")
- (display (make-cgi-name nea-cgi-path
- "id" (list-ref entry 2)
- "from" (number->string begin)))
- (display "\">")
- (display (list-ref entry 0))
- (display "</a>")))
- (display "</td>")
- (display "\n</tr>\n"))
- result))
- (display "</table>")
-
- (display "<div class=\"menu-bar\" align=\"center\">")
- (cond
- ((> begin 0)
- (display "<span class=\"menu-cell\"><a href=\"")
- (display (apply make-cgi-name
- nea-cgi-path
- "from" (number->string begin)
- "dir" "0"
- (if id
- (list "id" id)
- '())))
- (display "\">")
- (display (_ "Προηγούμενες"))
- (display "</a></span>")))
-
- (cond
- ((< end count)
- (display "<span class=\"menu-cell\"><a href=\"")
- (display (apply make-cgi-name
- nea-cgi-path
- "from" (number->string end)
- "dir" "1"
- (if id
- (list "id" id)
- '())))
- (display "\">")
- (display (_ "Ερχόμενες"))
- (display "</a></span>")))
- (display "</div>"))))))))
-
-(define (display-article-header item)
- (display "<div id=\"news-header\">")
- (format #t "<span class=\"itemdate\">~A</span>\n" (car item))
- (display "<span class=\"itemsubject\">\n")
- (display (list-ref item 2))
- (display "</span>")
- (if (not (cgi:value "timestamp"))
- (permalink "span" (list-ref item 1)))
- (display "</div><!-- news-header -->"))
-
-(define (display-article-text item . rest)
- (let ((class (and (not (null? rest)) (car rest))))
- (cond
- (class
- (display "\n<div class=\"")
- (display class)
- (display "\">\n")
- (display (list-ref item 3))
- (display "</div>\n"))
- (else
- (display (list-ref item 3))))))
-
-(define (main)
- (catch-sql
- (assert-article
- (display-article-header article)
- (display-article-text article "itemtext"))))
-
-(define (title)
- (if article
- (display (if (null? article)
- (string-append
- "<h1 class=\"error\">"
- (_ "Κάμια καταχώρηση")
- "</h1>")
- (list-ref article 2)))))
-
-
-(define (nea-html)
- (let ((explist (list (cons "@@main@@" main)
- (cons "@@summary@@" summary)
- (cons "@@title@@" title)
- (cons "@@article-text@@"
- (lambda ()
- (catch-sql
- (assert-article
- (display-article-text article)))))
- (cons "@@article-date@@"
- (lambda ()
- (catch-sql
- (assert-article
- (display (car article))))))
- (cons "@@article-header@@"
- (lambda ()
- (catch-sql
- (assert-article
- (display (list-ref article 2))))))
- (cons "@@full-header@@"
- (lambda ()
- (catch-sql
- (assert-article
- (display-article-header
- article)))))
- (cons "@@args@@"
- (lambda ()
- (for-each
- (lambda (name)
- (cond
- ((string=? name "LANG"))
- (else
- (let ((v (cgi:value name)))
- (cond ((and v (not (string-null? v)))
- (display "&amp;")
- (display name)
- (display "=")
- (display v)))))))
- (cgi:names)))))))
-
- (do ((line (read-line) (read-line)))
- ((eof-object? line) #f)
- (expand-template explist line)
- (newline))))
-
-(define (nea-rss-header)
- (display "<?xml version=\"1.0\"?>\n")
- (display "<rss version=\"2.0\">
- <channel>
- <title>Τα νέα</title>
- <description>Τα νέα</description>
- <link>http://ellinika.gnu.org.ua</link>")
- (format #t "<language>~A</language>" (language-code target-language))
- (display "
- <generator>EllinikaNea</generator>
- <copyright>2006 Sergey Poznyakoff</copyright>
- <managingEditor>gray@gnu.org.ua</managingEditor>
- <docs>http://blogs.law.harvard.edu/tech/rss</docs>
-"))
-
-(define (nea-rss-footer)
- (display " </channel>
-</rss>"))
-
-(define (nea-sql-connect)
- (let ((conn (sql-connect
- sql-iface sql-host sql-port sql-database
- sql-username sql-password)))
- (sql-query conn "SET NAMES utf8")
- conn))
-
-(define (nea-rss)
- (nea-rss-header)
- (catch 'gsql-error
- (lambda ()
- (let ((conn (nea-sql-connect)))
- (for-each
- (lambda (tuple)
- (display "<item>\n")
- (display "<pubDate>")
- (display (list-ref tuple 0))
- (display "</pubDate>\n")
- (display "<title>")
- (let ((title (sql-query conn
- (string-append
- "SELECT header "
- "FROM newsart "
- "WHERE ident=" (list-ref tuple 2) " "
- "AND lang='"
- (get-sql-lang conn
- (list-ref tuple 2)
- (make-my-lang-list))
- "' "
- "LIMIT 1"))))
- (display (if (not (null? title))
- (caar title)
- (list-ref tuple 0))))
- (display "</title>\n")
- (display "<link>")
- (display (string-append
- (string-downcase cgi-server-protocol-name)
- "://"
- cgi-server-hostname
- "/"
- (make-cgi-name nea-cgi-path "timestamp" (list-ref tuple 1))))
- (display "</link>\n")
- (display "</item>\n"))
- (sql-query
- conn
- (string-append
- "SELECT date,unix_timestamp(date),ident "
- "FROM news "
- "ORDER BY 1 DESC LIMIT 10")))))
- (lambda (key err descr)
- (sql-error-handler err descr)))
- (nea-rss-footer))
-
-
-(define (get-article-by-timestamp ts)
- (let ((tuples (sql-query
- conn
- "SELECT date,unix_timestamp(date),ident FROM news WHERE unix_timestamp(date)=" ts)))
- (cond
- (tuples
- (let* ((res (car tuples))
- (lang (get-sql-lang conn (list-ref res 2) (make-my-lang-list)))
- (art (sql-query conn
- (string-append
- "SELECT header,text,lang "
- "FROM newsart "
- "WHERE ident=" (list-ref res 2) " "
- "AND lang='" lang "' "
- "LIMIT 1"))))
- (append
- (list (list-ref res 0)
- (list-ref res 1))
- (car art)))))))
-
-
-;;; Main
-
-(cond
- ((cgi:value "rss")
- (display "Content-type: text/xml; charset=utf-8\r\n\r\n")
- (nea-rss))
- (else
- (catch 'gsql-error
- (lambda ()
- (display "Content-type: text/html; charset=utf-8\r\n\r\n")
- (set! conn (nea-sql-connect))
- (cond
- ((or (cgi:value "timestamp") (cgi:value "id"))
- (let ((tuples (sql-query
- conn
- (string-append
- "SELECT date,unix_timestamp(date),ident "
- "FROM news "
- "WHERE "
- (cond
- ((cgi:value "timestamp") =>
- (lambda (ts)
- (string-append "unix_timestamp(date)=" ts)))
- ((cgi:value "id") =>
- (lambda (id)
- (string-append "ident=" id))))))))
-
- (if (not (null? tuples))
- (let* ((res (car tuples))
- (lang (get-sql-lang conn
- (list-ref res 2)
- (make-my-lang-list)))
- (art (sql-query
- conn
- (string-append
- "SELECT header,text,lang "
- "FROM newsart "
- "WHERE ident=" (list-ref res 2) " "
- "AND lang='" lang "' "
- "LIMIT 1"))))
- (set! article (append
- (list (list-ref res 0)
- (list-ref res 1))
- (car art))))))))
-
- (with-input-from-file
- (template-file target-language tmpl)
- nea-html)
-
- (sql-connect-close conn))
-
- (lambda (key err descr)
- (with-input-from-file
- (template-file target-language tmpl)
- (lambda ()
- (let ((explist
- (list (cons "@@main@@"
- (lambda ()
- (sql-error-handler err descr)))
- (cons "@@article-text@@"
- (lambda ()
- (sql-error-handler err descr)))
- (cons "@@summary@@" (lambda () #f))
- (cons "@@title@@" (lambda () #f))
- (cons "@@article-date@@" (lambda () #f))
- (cons "@@article-header@@" (lambda () #f))