aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2008-06-22 07:33:31 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2008-06-22 07:33:31 +0000
commit4eb48d2f187bc9bb3266cee025da2ea61270e4c4 (patch)
treea99c057485f72d9074d22ea518804a4c8d2eb5bb /src
parent64af4748a2cae68c7ff4aa48d3dc7c93a2d469f6 (diff)
downloadellinika-4eb48d2f187bc9bb3266cee025da2ea61270e4c4.tar.gz
ellinika-4eb48d2f187bc9bb3266cee025da2ea61270e4c4.tar.bz2
Move cgi-bin and ellinika to src.
* src: New dir * src/Makefile.am: New file. * cgi-bin, ellinika: Move to src. * configure.ac: Reflect the above changes. git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@525 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'src')
-rw-r--r--src/Makefile.am17
-rw-r--r--src/cgi-bin/Makefile.am56
-rw-r--r--src/cgi-bin/dict.scm4611
-rw-r--r--src/cgi-bin/nea.scm4536
-rw-r--r--src/ellinika/Makefile.am43
-rw-r--r--src/ellinika/cgi.scm4169
-rw-r--r--src/ellinika/config.scm442
-rw-r--r--src/ellinika/dico.scm306
-rw-r--r--src/ellinika/i18n.scm308
-rw-r--r--src/ellinika/xlat.scm309
10 files changed, 2397 insertions, 0 deletions
diff --git a/src/Makefile.am b/src/Makefile.am
new file mode 100644
index 0000000..31223e7
--- /dev/null
+++ b/src/Makefile.am
@@ -0,0 +1,17 @@
+# This file is part of Ellinika project.
+# Copyright (C) 2008 Sergey Poznyakoff
+#
+# Ellinika 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 3 of the License, or
+# (at your option) any later version.
+#
+# Ellinika 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, see <http://www.gnu.org/licenses/>.
+
+SUBDIRS=cgi-bin ellinika \ No newline at end of file
diff --git a/src/cgi-bin/Makefile.am b/src/cgi-bin/Makefile.am
new file mode 100644
index 0000000..bb90eed
--- /dev/null
+++ b/src/cgi-bin/Makefile.am
@@ -0,0 +1,56 @@
+# This file is part of Ellinika project.
+# Copyright (C) 2004, 2005, 2007, 2008 Sergey Poznyakoff
+#
+# Ellinika 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 3 of the License, or
+# (at your option) any later version.
+#
+# Ellinika 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, see <http://www.gnu.org/licenses/>.
+
+cgidir=@CGIDIR@
+cgi_SCRIPTS=$(EXTRA_DIST:.scm4=.@SCRIPT_SUFFIX@)
+EXTRA_DIST=dict.scm4 nea.scm4
+CLEANFILES=dict.m4 dict.scm nea.scm dict.cgi nea.cgi
+
+dict.m4: Makefile
+ echo 'divert(-1)' > $@
+ echo 'changequote([,])' >> $@
+ echo 'changecom([;],[' >> $@
+ echo '])' >> $@
+ echo 'undefine([format])' >> $@
+ echo 'define([IFACE],$(APACHE_IFACE))' >> $@
+ echo 'define([GUILE_BINDIR],$(GUILE_BINDIR))' >> $@
+ echo 'define([GUILE_SITE],@GUILE_SITE@)' >> $@
+ echo 'define([PACKAGE],$(PACKAGE))'>> $@
+ echo 'define([PREFIX],$(prefix))' >> $@
+ echo 'define([SYSCONFDIR],$(sysconfdir))' >> $@
+ echo 'define([LOCALEDIR],$(datadir)/locale)' >> $@
+ echo 'define([HTMLDIR],$(HTMLDIR))' >> $@
+ echo 'divert(0)dnl' >> $@
+ echo 'ifelse(IFACE,[CGI],#! $(GUILE_BINDIR)/guile -s' >> $@
+ echo ')dnl' >> $@
+ echo '@AUTOGENERATED@' >> $@
+ echo 'ifelse(IFACE,[CGI],!#' >> $@
+ echo ')dnl' >> $@
+
+SUFFIXES = .scm4 .scm .cgi
+
+.scm4.scm:
+ m4 dict.m4 $< > $@
+
+.scm.cgi:
+ cp $< $@
+
+dict.scm: dict.scm4 dict.m4
+nea.scm: nea.scm4 dict.m4
+
+dict.cgi: dict.scm
+nea.cgi: nea.scm
+
diff --git a/src/cgi-bin/dict.scm4 b/src/cgi-bin/dict.scm4
new file mode 100644
index 0000000..c9f895b
--- /dev/null
+++ b/src/cgi-bin/dict.scm4
@@ -0,0 +1,611 @@
+;;;; Greek Dictionary Web Engine
+;;;; Copyright (C) 2004, 2005, 2006, 2007 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 3 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, see <http://www.gnu.org/licenses/>.
+;;;;
+
+;;; Tailor this statement to your needs if necessary.
+(set! %load-path (cons "GUILE_SITE" %load-path))
+
+(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
+ (ice-9 rdelim)
+ (gamma sql)
+ (xmltools dict)
+ (ellinika i18n)
+ (ellinika xlat)
+ (ellinika cgi))
+
+ifelse(IFACE,[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))
+
+(define (load-pos)
+ (sql-ignore-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 ()
+ (sql-ignore-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=\"selected\""))
+ (display ">") (display (_"και")) (display "</option>")
+ (display "<option value=\"1\"")
+ (if (= selected-choice 1)
+ (display " selected=\"selected\""))
+ (display ">") (display (_"ή")) (display "</option>")
+ (display "</select>")))
+
+(define (main-form)
+ (load-pos)
+ (display "<form action=\"")
+ (display (make-cgi-name cgi-script-name))
+ (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)
+ (display "\"")
+ (if (= index selected-choice)
+ (display " selected=\"selected\""))
+ (display ">")
+ (display name)
+ (display "</option>")
+ (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\">---</option>")
+ (for-each
+ (lambda (x)
+ (let ((id (car x))
+ (name (car (cdr x))))
+ (display "<option value=\"")
+ (display id)
+ (display "\"")
+ (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>
+")))
+
+;;
+(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 cgi-script-name "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+ (quotient 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")))
+
+ (sql-catch-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
+ (sql-ignore-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
+ifelse(IFACE,[CGI],(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/src/cgi-bin/nea.scm4 b/src/cgi-bin/nea.scm4
new file mode 100644
index 0000000..e490a59
--- /dev/null
+++ b/src/cgi-bin/nea.scm4
@@ -0,0 +1,536 @@
+;;;; News page for Ellinika
+;;;; Copyright (C) 2004, 2005, 2006, 2007 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 3 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, see <http://www.gnu.org/licenses/>.
+;;;;
+
+;;; Tailor this statement to your needs if necessary.
+(set! %load-path (cons "GUILE_SITE" %load-path))
+
+(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
+ (ice-9 rdelim)
+ (gamma sql)
+ (gamma gettext)
+ (xmltools dict)
+ (ellinika xlat)
+ (ellinika cgi))
+
+ifelse(IFACE,[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 cgi-script-name "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 cgi-script-name
+ "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\">")
+ (cond
+ ((> begin 0)
+ (display "<span class=\"menu-cell\"><a href=\"")
+ (display (apply make-cgi-name
+ cgi-script-name
+ "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
+ cgi-script-name
+ "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 cgi-script-name
+ "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")
+ ifelse(IFACE,[CGI],
+ (display ["Content-type: text/xml; charset=utf-8\r\n\r\n"]),
+ (request-rec:set-content-type! Request ["text/xml; charset=UTF-8"]))
+ (nea-rss))
+ (else
+ (catch 'gsql-error
+ (lambda ()
+ ifelse(IFACE,[CGI],dnl
+ (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))
+ (cons "@@full-header@@" (lambda () #f)))))
+ (do ((line (read-line) (read-line)))
+ ((eof-object? line) #f)
+ (expand-template explist line)
+ (newline)))))))))
+
+;;;; Local variables:
+;;;; mode: Scheme
+;;;; buffer-file-coding-system: utf-8
+;;;; End:
diff --git a/src/ellinika/Makefile.am b/src/ellinika/Makefile.am
new file mode 100644
index 0000000..136b44f
--- /dev/null
+++ b/src/ellinika/Makefile.am
@@ -0,0 +1,43 @@
+# This file is part of Ellinika project.
+# Copyright (C) 2004,2006,2007,2008 Sergey Poznyakoff
+#
+# Ellinika 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 3 of the License, or
+# (at your option) any later version.
+#
+# Ellinika 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, see <http://www.gnu.org/licenses/>.
+
+guiledir=$(GUILE_SITE)/$(PACKAGE)
+guile_DATA=xlat.scm cgi.scm i18n.scm config.scm dico.scm
+
+cgi.m4: Makefile
+ echo 'divert(-1)' > $@
+ echo 'changequote([,])' >> $@
+ echo 'changecom([;],[' >> $@
+ echo '])' >> $@
+ echo 'undefine([format])' >> $@
+ echo 'define([IFACE],$(APACHE_IFACE))' >> $@
+ echo 'define([GUILE_BINDIR],$(GUILE_BINDIR))' >> $@
+ echo 'define([GUILE_SITE],@GUILE_SITE@)' >> $@
+ echo 'define([PACKAGE],$(PACKAGE))'>> $@
+ echo 'define([PREFIX],$(prefix))' >> $@
+ echo 'define([SYSCONFDIR],$(sysconfdir))' >> $@
+ echo 'define([LOCALEDIR],$(datadir)/locale)' >> $@
+ echo 'define([HTMLDIR],$(HTMLDIR))' >> $@
+ echo 'divert(0)dnl' >> $@
+ echo '@AUTOGENERATED@' >> $@
+
+SUFFIXES = .scm4 .scm
+
+.scm4.scm:
+ m4 cgi.m4 $< > $@
+
+cgi.scm: cgi.scm4 cgi.m4
+config.scm: config.scm4 cgi.m4
diff --git a/src/ellinika/cgi.scm4 b/src/ellinika/cgi.scm4
new file mode 100644
index 0000000..38fd3de
--- /dev/null
+++ b/src/ellinika/cgi.scm4
@@ -0,0 +1,169 @@
+;;;; -*- scheme -*-
+;;;; Greek Dictionary Web Engine
+;;;; Copyright (C) 2005, 2007 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 3 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, see <http://www.gnu.org/licenses/>.
+;;;;
+(define-module (ellinika cgi)
+ #:use-module (ellinika config)
+ #:use-module (ellinika i18n)
+ #:use-module ifelse(IFACE,[CGI],(www cgi),(guile-user))
+ #:re-export (base-dir html-dir sysconf-dir locale-path
+ sql-iface sql-host sql-port sql-database
+ sql-username sql-password
+ config-file-name ))
+
+
+ifelse(IFACE,[CGI],,dnl
+(define form-data
+ (append
+ (parse-form-data
+ (table:get (request-rec:subprocess-env Request) "QUERY_STRING"))
+ (if (= (request-rec:method-number Request) 2)
+ (parse-form-data (read-post-data Request))
+ '())))
+
+(define-public (cgi:value name)
+ (assoc-ref form-data name))
+
+(define-public (cgi:names)
+ (map car form-data))
+
+(define-public cgi-script-name
+ (table:get (request-rec:subprocess-env Request)
+ "SCRIPT_NAME"))
+
+(define-public cgi-server-hostname
+ (table:get (request-rec:subprocess-env Request)
+ "SERVER_NAME"))
+
+(define-public cgi-server-protocol-name #f)
+(define-public cgi-server-protocol-version #f)
+
+(let* ((server-protocol (table:get (request-rec:subprocess-env Request)
+ "SERVER_PROTOCOL")))
+ (if server-protocol
+ (let ((slash (string-index server-protocol #\/)))
+ (set! cgi-server-protocol-name (substring server-protocol
+ 0 slash))
+ (set! cgi-server-protocol-version (substring server-protocol
+ (1+ slash))))))
+
+)
+
+
+;;; User-definable variables
+(define-public dict-template-file-name "dict.html")
+(define-public nea-template-file-name "nea.html")
+(define-public monima-nea-template-file-name "monima.html")
+(define-public target-language "el_GR")
+
+(define-public word-forms-reference '())
+
+(define-public ref-loc #f)
+
+;; Number of colums in fuzzy search output
+(define-public match-list-columns 4)
+;;; End of user-definable variables
+
+(define-public (language-code lang)
+ (cond
+ ((string-index lang #\_) =>
+ (lambda (len)
+ (substring lang 0 len)))
+ (else
+ lang)))
+
+(define-public (template-file lang template-file-name)
+ (string-append html-dir "/" (language-code lang) "/" template-file-name))
+
+(define-public (make-cgi-name cgi-path . rest)
+ (apply
+ string-append
+ (cons
+ cgi-path
+ (let ((arglist (let ((lang (cgi:value "LANG")))
+ (do ((ilist (if lang
+ (cons "LANG" (cons lang rest))
+ rest) (cdr ilist))
+ (i 1 (1+ i))
+ (olist '()))
+ ((null? ilist) (if (null? olist)
+ olist
+ (reverse (cdr olist))))
+ (set! olist (cons (car ilist) olist))
+ (set! olist (cons
+ (if (odd? i) "=" "&amp;")
+ olist))))))
+ (if (null? arglist)
+ arglist
+ (cons "?" arglist))))))
+
+(define-public (expand-template explist template)
+ "(expand-template EXPLIST TEMPLATE)
+
+Expands string TEMPLATE in accordance with EXPLIST. EXPLIST is a list
+of elements:
+
+ (cons WORD THUNK)
+
+Each occurrence of WORD in TEMPLATE is replaced with the return value of
+THUNK.
+"
+ (let loop ((template template))
+ (cond
+ ((string-index template #\@) =>
+ (lambda (w)
+ (display (substring template 0 w))
+ (if (and (< (+ w 2) (string-length template))
+ (char=? (string-ref template (1+ w)) #\@))
+ (let ((end-pos (string-index template #\@ (+ w 2))))
+ (if (and end-pos
+ (< (1+ end-pos) (string-length template))
+ (char=? (string-ref template (1+ end-pos)) #\@))
+ (let* ((name (substring template w (+ end-pos 2)))
+ (entry (assoc name explist)))
+ (cond
+ (entry
+ ((cdr entry))
+ (loop (substring template (+ end-pos 2))))
+ (else
+ (display "@@")
+ (loop (substring template (+ w 2))))))
+ (begin
+ (display "@")
+ (loop (substring template (+ w 1))))))
+ (begin
+ (display "@")
+ (loop (substring template (1+ w)))))))
+ (else
+ (display template)))))
+
+
+(define-public (ellinika-cgi-init template-file-name)
+ ;;; Load the site defaults
+ (ellinika-config-setup)
+
+ ;;; Load the language-specific defaults
+ (cond
+ ((cgi:value "LANG") =>
+ (lambda (x)
+ (if (file-exists? (template-file x template-file-name))
+ (set! target-language x)))))
+ ;;; Initialize i18n
+ (let ((x (locale-setup target-language "PACKAGE" locale-path)))
+ (if x
+ (set! target-language x))))
+
+;;; End of cgi.scmi
diff --git a/src/ellinika/config.scm4 b/src/ellinika/config.scm4
new file mode 100644
index 0000000..8032409
--- /dev/null
+++ b/src/ellinika/config.scm4
@@ -0,0 +1,42 @@
+;;;; -*- scheme -*-
+;;;; Greek Dictionary Web Engine
+;;;; Copyright (C) 2005, 2007, 2008 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 3 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, see <http://www.gnu.org/licenses/>.
+;;;;
+
+(define-module (ellinika config))
+
+(define-public base-dir "PREFIX")
+(define-public html-dir "HTMLDIR")
+(define-public sysconf-dir "SYSCONFDIR")
+(define-public locale-path "LOCALEDIR:/usr/share/locale:/usr/local/share/locale")
+(define-public sql-iface "mysql") ;; SQL interface ("mysql" or "postgres")
+;; SQL server hostname or a path to the UNIX socket
+(define-public sql-host "localhost")
+(define-public sql-port 3306) ;; SQL port number (0 for sockaddr_un
+ ;; connection)
+(define-public sql-database "ellinika") ;; Name of the database
+(define-public sql-username "gray") ;; Database user name
+(define-public sql-password "") ;; Password for that user name
+
+(define-public config-file-name "ellinika.conf")
+
+(define-public (ellinika-config-setup)
+ ;;; Load the site defaults
+ (let ((rc-file (string-append sysconf-dir "/" config-file-name)))
+ (if (file-exists? rc-file)
+ (load rc-file))))
+
+
diff --git a/src/ellinika/dico.scm b/src/ellinika/dico.scm
new file mode 100644
index 0000000..9383d1f
--- /dev/null
+++ b/src/ellinika/dico.scm
@@ -0,0 +1,306 @@
+;;;; A Dico module for Greek Dictionary Web Engine -*- scheme -*-
+;;;; Copyright (C) 2008 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 3 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, see <http://www.gnu.org/licenses/>.
+;;;;
+
+(define-module (ellinika dico))
+
+(use-modules (guile-user)
+ (ice-9 rdelim)
+ (gamma sql)
+ (xmltools dict)
+ (ellinika xlat)
+ (ellinika config))
+
+(define (sql-error-handler err descr)
+ (format #t "cannot connect to the database")
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (display err)
+ (display ": ")
+ (display descr))))
+
+(define (my-sql-query conn query)
+ (catch #t
+ (lambda ()
+ (sql-query conn query))
+ (lambda args
+ '())))
+
+;; END of FIXME
+
+(define (dico-error err . rest)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (display err)
+ (for-each
+ display
+ rest)
+ (newline))))
+
+;; Dico interface
+
+(define (open-module name . rest)
+ (let ((target-language "el")
+ (type 'dict))
+ (for-each (lambda (arg)
+ (let ((av (string-split arg #\=)))
+ (case (length av)
+ ((1) (cond
+ ((string=? (car av) "synonym")
+ (set! type 'synonim))
+ ((string=? (car av) "antonym")
+ (set! type 'antonym))
+ (else
+ (dico-error "Unknown option " (car av)))))
+ ((2) (cond
+ ((string=? (car av) "lang")
+ (set! target-language (cadr av)))
+ (else
+ (dico-error "Unknown option " (car av)))))
+ (else
+ (dico-error "Unknown option " (car av))))))
+ (cdr rest))
+ (let ((db-connection (sql-connect
+ sql-iface sql-host sql-port sql-database
+ sql-username sql-password)))
+ (sql-query db-connection "SET NAMES utf8")
+ (list db-connection target-language type))))
+
+(defmacro dbh:conn (dbh) `(list-ref ,dbh 0))
+(defmacro dbh:lang (dbh) `(list-ref ,dbh 1))
+(defmacro dbh:type (dbh) `(list-ref ,dbh 2))
+
+(define (close-module dbh)
+ (sql-connect-close (dbh:conn dbh)))
+
+(define descr-list
+ '(("pl" . "Słownik grecko-polski")
+ ("uk" . "Грецько-украЇнський словник")
+ ("ru" . "Греческо-русский словарь")))
+
+(define (descr dbh)
+ (case (dbh:type dbh)
+ ((dict)
+ (let ((res (assoc (dbh:lang dbh) descr-list)))
+ (if res
+ (cdr res)
+ "Ellinika (no description available)")))
+ ((antonym)
+ "Λέξικο αντωνύμων της Ελληνικής γλώσσας")
+ ((synonym)
+ "a")))
+
+(define (info dbh)
+ (string-append "Ellinika - A greek dictionary.\n\
+See http://ellinika.gnu.org.ua/cgi-bin/dict.cgi?LANG="
+ (dbh:lang dbh) "\n\
+Copyright © 2004, 2005, 2006, 2007, 2008 Sergey Poznyakoff\n\
+\n\
+Permission is granted to copy, distribute and/or modify this document\n\
+under the terms of the GNU Free Documentation License, Version 1.2 or\n\
+any later version published by the Free Software Foundation; with no\n\
+Invariant Sections, no Front-Cover and Back-Cover Texts"))
+
+(define (define-word-dict dbh key)
+ (let ((result '())
+ (last-id -1)
+ (word '())
+ (articles '()))
+ (for-each
+ (lambda (tuple)
+ (cond
+ ((not (= last-id (string->number (car tuple))))
+ (if (not (null? articles))
+ (set! result (cons
+ (cons word (reverse articles))
+ result)))
+ (set! last-id (string->number (car tuple)))
+ (set! word (cons (list-ref tuple 1)
+ (list-ref tuple 2))); FIXME: forms?
+ (set! articles '())))
+ (set! articles (cons
+ (cons (list-ref tuple 4)
+ (list-ref tuple 5))
+ articles)))
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT dict.ident,dict.word,pos.abbr,dict.forms,articles.subindex,articles.meaning "
+ "FROM dict,articles,pos WHERE dict.word=\""
+ key
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' "
+ "AND dict.pos=pos.id AND pos.canonical='Y' ORDER BY dict.ident, articles.subindex")))
+ (if (not (null? articles))
+ (set! result (cons
+ (cons word (reverse articles))
+ result)))
+ (cons 'define-word-dict (reverse result))))
+
+(define (define-word-x dbh word link-type)
+ (let ((res (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict,links,articles "
+ "WHERE links.type='" link-type "' AND links.ident IN "
+ "(SELECT ident FROM dict WHERE word=\"" word "\") "
+ "AND dict.ident=links.xref "
+ "AND dict.ident=articles.ident and articles.lang=\""
+ (dbh:lang dbh)
+ "\" ORDER BY word"))))
+ (if (and res (not (null? res)))
+ (cons 'define-word-x (list (cons word (map car res))))
+ #f)))
+
+(define (define-word-antonym dbh word)
+ (define-word-x dbh word "XREF"))
+
+(define (define-word-synonym dbh word)
+ (define-word-x dbh word "ANT"))
+
+(define define-list
+ (list (cons 'dict define-word-dict)
+ (cons 'synonym define-word-synonym)
+ (cons 'antonym define-word-antonym)))
+
+(define (define-word dbh word)
+ (let ((key (ellinika:translate-input word))
+ (x (assoc (dbh:type dbh) define-list)))
+ (if x
+ ((cdr x) dbh key)
+ #f)))
+
+(define (match-exact dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word=\""
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-prefix dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word LIKE \""
+ (ellinika:translate-input word)
+ "%\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-suffix dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word LIKE \"%"
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-extnd-regex dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word regexp \""
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-basic-regex dbh strat word)
+ #f) ;FIXME
+
+(define (match-default dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict,articles WHERE dict.sound LIKE \""
+ (ellinika:sounds-like word)
+ "%\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+
+(define strategy-list
+ (list (cons "exact" match-exact)
+ (cons "prefix" match-prefix)
+ (cons "suffix" match-suffix)
+ (cons "re" match-extnd-regex)
+ (cons "regexp" match-basic-regex)))
+
+(define (match-word dbh strat word)
+ (let ((sp (assoc (dico-strat-name strat) strategy-list)))
+ (let ((res (if sp
+ ((cdr sp) dbh strat word)
+ (match-default dbh strat word))))
+ (if res
+ (cons #f (map car res))
+ #f))))
+
+(define (output res n)
+ (let ((type (car res))
+ (contents (list-ref (cdr res) n)))
+ (case type
+ ((define-word-dict)
+ (let ((word-pair (car contents))
+ (defn (cdr contents)))
+ (display (car word-pair))
+ (display ", <")
+ (display (cdr word-pair))
+ (display ">")
+ (for-each
+ (lambda (article)
+ (newline)
+ (display (1+ (string->number (car article))))
+ (display ". ")
+ (display (cdr article))
+ (display ";"))
+ defn)))
+ ((define-word-x)
+ (let ((word (car contents))
+ (defn (cdr contents)))
+ (display word)
+ (display " -- ")
+ (display (car defn))
+ (if (cdr defn)
+ (for-each
+ (lambda (elt)
+ (display ", ")
+ (display elt))
+ (cdr defn)))))
+ (else
+ (display contents)))))
+
+(define (result-count res)
+ (length (cdr res)))
+
+(define-public (dico-ellinika-init arg)
+ (list (cons "open" open-module)
+ (cons "close" close-module)
+ (cons "descr" descr)
+ (cons "info" info)
+ (cons "define" define-word)
+ (cons "match" match-word)
+ (cons "output" output)
+ (cons "result-count" result-count)))
+
+;;
+;; Setup
+(ellinika-config-setup)
+(dico-register-strat "suffix" "Match word suffixes")
+
+
+
diff --git a/src/ellinika/i18n.scm b/src/ellinika/i18n.scm
new file mode 100644
index 0000000..474c8c9
--- /dev/null
+++ b/src/ellinika/i18n.scm
@@ -0,0 +1,308 @@
+;;;; This file is part of Greek Dictionary Web Engine
+;;;; Copyright (C) 2006, 2007 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 3, 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, see <http://www.gnu.org/licenses/>.
+
+(define-module (ellinika i18n)
+ #:use-syntax (ice-9 syncase)
+ #:export-syntax (_)
+ #:export (locale-setup))
+
+(define-syntax _
+ (syntax-rules ()
+ ((_ msg) (gettext msg))))
+
+
+;;; ISO 639 language code => ISO 3166 country code
+;;; The corresponding country codes where selected using the following
+;;; principles:
+;;; 1. If the language is spoken in only one country, this country code is
+;;; used.
+;;; 2. If the language is spoken in more than one country, select the code of
+;;; that country where it has official status.
+;;; 3. If the language does not have official status, select the country with
+;;; greater number of speakers
+;;;
+;;; The table does not list artificial languages (Esperanto, Ido, Interlingua,
+;;; etc), as the notion of a territory does not apply to them.
+;;;
+;;; If you find any inconsistency in this table, please let me know.
+;;;
+
+(define defterr
+ '((aa . "ET") ; Afar
+ (ab . "GE") ; Abkhazian
+ (ae . "IR") ; Avestan
+ (af . "ZA") ; Afrikaans
+ (ak . "GH") ; Akan # or ak_CI
+ (am . "ET") ; Amharic
+ (an . "ES") ; Aragonese
+ (ar . "SA") ; Arabic
+ (as . "IN") ; Assamese
+ (av . "RU") ; Avaric # Spoken mainly in Dagestan
+ (ay . "BO") ; Aymara
+ (az . "AZ") ; Azerbaijani
+
+ (ba . "RU") ; Bashkir
+ (be . "BY") ; Byelorussian; Belarusian
+ (bg . "BG") ; Bulgarian
+ (bh . "IN") ; Bihari
+ (bi . "VU") ; Bislama
+ (bm . "ML") ; Bambara
+ (bn . "BD") ; Bengali; Bangla
+ (bo . "CN") ; Tibetan
+ (br . "FR") ; Breton
+ (bs . "BA") ; Bosnian
+
+ (ca . "ES") ; Catalan
+ (ce . "RU") ; Chechen
+ (ch . "GU") ; Chamorro
+ (co . "FR") ; Corsican
+ (cr . "CA") ; Cree
+ (cs . "CZ") ; Czech
+ (cu . "BG") ; Church Slavic
+ (cv . "RU") ; Chuvash
+ (cy . "GB") ; Welsh
+
+ (da . "DK") ; Danish
+ (de . "DE") ; German
+ (dv . "MV") ; Divehi
+ (dz . "BT") ; Dzongkha; Bhutani
+
+ (ee . "GH") ; @'Ew@'e
+ (el . "GR") ; Greek
+ (en . "US") ; English
+ (es . "ES") ; Spanish
+ (et . "EE") ; Estonian
+ (eu . "ES") ; Basque
+
+ (fa . "IR") ; Persian
+ (ff . "CM") ; Fulah # Also NG, MR, and many others
+ (fi . "FI") ; Finnish
+ (fj . "FJ") ; Fijian; Fiji
+ (fo . "FO") ; Faroese
+ (fr . "FR") ; French
+ (fy . "NL") ; Frisian
+
+ (ga . "IE") ; Irish
+ (gd . "GB") ; Scots; Gaelic
+ (gl . "ES") ; Gallegan; Galician
+ (gn . "PE") ; Guarani
+ (gu . "IN") ; Gujarati
+ (gv . "GB") ; Manx
+
+ (ha . "NG") ; Hausa (?)
+ (he . "IL") ; Hebrew (formerly iw)
+ (hi . "IN") ; Hindi
+ (ho . "PG") ; Hiri Motu
+ (hr . "HR") ; Croatian
+ (ht . "HT") ; Haitian; Haitian Creole
+ (hu . "HU") ; Hungarian
+ (hy . "AM") ; Armenian
+ (hz . "NA") ; Herero
+
+ (id . "ID") ; Indonesian (formerly in)
+ (ig . "NG") ; Igbo
+ (ii . "CN") ; Sichuan Yi
+ (ik . "CA") ; Inupiak
+ (is . "IS") ; Icelandic
+ (it . "IT") ; Italian
+ (iu . "CA") ; Inuktitut
+
+ (ja . "JP") ; Japanese
+ (jv . "ID") ; Javanese
+
+ (ka . "GE") ; Georgian
+ (kg . "CG") ; Kongo # also CD and AO
+ (ki . "KE") ; Kikuyu
+ (kj . "AO") ; Kuanyama
+ (kk . "KZ") ; Kazakh
+ (kl . "DK") ; Kalaallisut; Greenlandic
+ (km . "KH") ; Khmer; Cambodian
+ (kn . "IN") ; Kannada
+ (ko . "KR") ; Korean
+ (kr . "NG") ; Kanuri
+ (ks . "IN") ; Kashmiri
+ (ku . "IQ") ; Kurdish
+ (kv . "RU") ; Komi
+ (kw . "GB") ; Cornish
+ (ky . "KG") ; Kirghiz
+
+ (la . "VA") ; Latin
+ (lb . "LU") ; Letzeburgesch
+ (lg . "UG") ; Ganda
+ (li . "NL") ; Limburgish; Limburger; Limburgan
+ (ln . "CD") ; Lingala
+ (lo . "LA") ; Lao; Laotian
+ (lt . "LT") ; Lithuanian
+ (lu . "CD") ; Luba-Katanga
+ (lv . "LV") ; Latvian; Lettish
+
+ (mg . "MG") ; Malagasy
+ (mh . "MH") ; Marshall
+ (mi . "NZ") ; Maori
+ (mk . "MK") ; Macedonian
+ (ml . "IN") ; Malayalam
+ (mn . "MN") ; Mongolian
+ (mo . "MD") ; Moldavian
+ (mr . "IN") ; Marathi
+ (ms . "MY") ; Malay
+ (mt . "MT") ; Maltese
+ (my . "MM") ; Burmese
+
+ (na . "NR") ; Nauru
+ (nb . "NO") ; Norwegian Bokm@aa{}l
+ (nd . "ZA") ; Ndebele, North
+ (ne . "NP") ; Nepali
+ (ng . "NA") ; Ndonga
+ (nl . "NL") ; Dutch
+ (nn . "NO") ; Norwegian Nynorsk
+ (no . "NO") ; Norwegian
+ (nr . "ZA") ; Ndebele, South
+ (nv . "US") ; Navajo
+ (ny . "MW") ; Chichewa; Nyanja
+
+ (oc . "FR") ; Occitan; Proven@,{c}al
+ (oj . "CA") ; Ojibwa
+ (om . "ET") ; (Afan) Oromo
+ (or . "IN") ; Oriya
+ (os . "RU") ; Ossetian; Ossetic
+
+ (pa . "IN") ; Panjabi; Punjabi
+ (pi . "IN") ; Pali
+ (pl . "PL") ; Polish
+ (ps . "AF") ; Pashto, Pushto
+ (pt . "PT") ; Portuguese
+
+ (qu . "PE") ; Quechua
+
+ (rm . "FR") ; Rhaeto-Romance
+ (rn . "BI") ; Rundi; Kirundi
+ (ro . "RO") ; Romanian
+ (ru . "RU") ; Russian
+ (rw . "RW") ; Kinyarwanda
+
+ (sa . "IN") ; Sanskrit
+ (sc . "IT") ; Sardinian
+ (sd . "PK") ; Sindhi
+ (se . "NO") ; Northern Sami
+ (sg . "CF") ; Sango; Sangro
+ (si . "LK") ; Sinhalese
+ (sk . "SK") ; Slovak
+ (sl . "SI") ; Slovenian
+ (sm . "WS") ; Samoan
+ (sn . "ZW") ; Shona
+ (so . "SO") ; Somali
+ (sq . "AL") ; Albanian
+ (sr . "CS") ; Serbian
+ (ss . "SZ") ; Swati; Siswati
+ (st . "LS") ; Sesotho; Sotho, Southern
+ (su . "ID") ; Sundanese
+ (sv . "SE") ; Swedish
+ (sw . "TZ") ; Swahili # Also KE
+
+ (ta . "IN") ; Tamil
+ (te . "IN") ; Telugu
+ (tg . "TJ") ; Tajik
+ (th . "TH") ; Thai
+ (ti . "ER") ; Tigrinya
+ (tk . "TM") ; Turkmen
+ (tl . "PH") ; Tagalog
+ (tn . "BW") ; Tswana; Setswana
+ (to . "ZM") ; Tonga (?) # Also ZW ; MW
+ (tr . "TR") ; Turkish
+ (ts . "MZ") ; Tsonga # ZA SZ XW
+ (tt . "RU") ; Tatar
+ (tw . "GH") ; Twi
+ (ty . "PF") ; Tahitian
+
+ (ug . "RU") ; Uighur
+ (uk . "UA") ; Ukrainian
+ (ur . "IN") ; Urdu
+ (uz . "UZ") ; Uzbek
+
+ (ve . "ZA") ; Venda
+ (vi . "VN") ; Vietnamese
+
+ (wa . "FR") ; Walloon
+ (wo . "SN") ; Wolof
+
+ (xh . "ZA") ; Xhosa
+
+ (yi . "IL") ; Yiddish (formerly ji)
+ (yo . "NG") ; Yoruba
+
+ (za . "CN") ; Zhuang
+ (zh . "CN") ; Chinese
+ (zu . "ZA"))); Zulu
+
+(define (supported-locale-dir lang textdomain locale-path)
+ (call-with-current-continuation
+ (lambda (return)
+ (for-each
+ (lambda (dir)
+ (let ((name (string-append dir "/" lang "/LC_MESSAGES/" textdomain)))
+ (if (or (access? (string-append name ".mo") R_OK)
+ (access? (string-append name ".gmo") R_OK))
+ (return dir))))
+ (string-split locale-path #\:))
+ #f)))
+
+(define (locale-setup lang domain-name locale-path)
+ (catch 'system-error
+ (lambda ()
+ (cond
+ ((not lang)
+ (setenv "LC_ALL" "C")
+ (setlocale LC_ALL "C")
+ #f)
+ (else
+ (let ((curlocale (if (> (string-length lang) 2)
+ (string-downcase (substring lang 0 2))
+ lang))
+ (terr #f)
+ (sublocale #f)
+ (domaindir #f))
+
+ (cond
+ ((and (> (string-length lang) 2) (char=? (string-ref lang 2) #\-))
+ (set! terr (string-upcase (substring lang 3 2)))
+ (set! sublocale (string-append curlocale "_" terr)))
+ ((assoc-ref defterr (string->symbol curlocale)) =>
+ (lambda (elt)
+ (set! sublocale curlocale)
+ (set! terr elt)))
+ (else
+ (set! sublocale curlocale)
+ (set! terr "XX"))) ; Hack for languages without defined territory.
+
+ (let ((domaindir
+ (supported-locale-dir sublocale domain-name locale-path)))
+ (cond
+ (domaindir
+ (let ((locale (string-append curlocale "_" terr ".UTF-8")))
+ (setenv "LC_ALL" locale)
+ (setlocale LC_ALL locale)
+ (textdomain domain-name)
+ (bindtextdomain domain-name domaindir)
+ locale))
+ ((setenv "LC_ALL" "C")
+ (setlocale LC_ALL "C")
+ #f)))))))
+ (lambda args
+ #f)))
+
+
+
+
diff --git a/src/ellinika/xlat.scm b/src/ellinika/xlat.scm
new file mode 100644
index 0000000..c51edaa
--- /dev/null
+++ b/src/ellinika/xlat.scm
@@ -0,0 +1,309 @@
+;;;; This file is part of Ellinika
+;;;; Copyright (C) 2004, 2007 Sergey Poznyakoff
+;;;;
+;;;; Ellinika 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 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; Ellinika 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, see <http://www.gnu.org/licenses/>.
+;;;;
+(define-module (ellinika xlat))
+
+(define greek-postfix-map
+ (list
+ (cons #\: (list (cons "ι" "ϊ") (cons "υ" "ϋ")
+ (cons "ί" "ΐ") (cons "ύ" "ΰ")
+ (cons "θ" "ϊ") (cons "θ" "ϋ")))
+ (cons #\' (list (cons "α" "ά") (cons "Α" "Ά")
+ (cons "ε" "έ") (cons "Ε" "Έ")
+ (cons "η" "ή") (cons "Η" "Ή")
+ (cons "ι" "ί") (cons "Ι" "Ί")
+ (cons "ϊ" "ΐ") (cons "Ϊ" "Ϊ")
+ (cons "ο" "ό") (cons "Ο" "Ό")
+ (cons "υ" "ύ") (cons "Υ" "Ύ")
+ (cons "θ" "ύ") (cons "Θ" "Ύ")
+ (cons "ϋ" "ΰ") (cons "Ϋ" "Ϋ")
+ (cons "ω" "ώ") (cons "Ω" "Ώ")))
+ (cons #\s (list (cons "κ" "ξ") (cons "π" "ψ")))))
+
+(define greek-kbd-map
+ (list (cons #\a "α")
+ (cons #\A "Α")
+ (cons #\b "β")
+ (cons #\B "Β")
+ (cons #\g "γ")
+ (cons #\G "Γ")
+ (cons #\d "δ")
+ (cons #\D "Δ")
+ (cons #\e "ε")
+ (cons #\E "Ε")
+ (cons #\z "ζ")
+ (cons #\Z "Ζ")
+ (cons #\h "η")
+ (cons #\H "Η")
+ (cons #\u "θ")
+ (cons #\U "Θ")
+ (cons #\i "ι")
+ (cons #\I "Ι")
+ (cons #\k "κ")
+ (cons #\K "Κ")
+ (cons #\l "λ")
+ (cons #\L "Λ")
+ (cons #\m "μ")
+ (cons #\M "Μ")
+ (cons #\n "ν")
+ (cons #\M "Ν")
+ (cons #\j "ξ")
+ (cons #\J "Ξ")
+ (cons #\o "ο")
+ (cons #\O "Ο")
+ (cons #\p "π")
+ (cons #\P "Π")
+ (cons #\r "ρ")
+ (cons #\R "Ρ")
+ (cons #\s "σ")
+ (cons #\S "Σ")
+ (cons #\w "ς")
+ (cons #\W "Σ")
+ (cons #\t "τ")
+ (cons #\T "Τ")
+ (cons #\y "υ")
+ (cons #\Y "Υ")
+ (cons #\f "φ")
+ (cons #\F "Φ")
+ (cons #\x "χ")
+ (cons #\X "Χ")
+ (cons #\c "ψ")
+ (cons #\C "Ψ")
+ (cons #\v "ω")
+ (cons #\V "Ω")))
+
+
+(define (after-thita? c)
+ (member c (list #\a #\e #\i #\o #\y #\v)))
+
+;;; Given input string in Greek transliteration, convert it to
+;;; an equivalent Greek word in UTF-8 encoding. The input string is
+;;; supposed to follow the traditional Greek keyboard layout:
+;;;
+;;; +----------------------------------------------------------------+
+;;; | 1! | 2@ | 3# | 4$ | 5% | 6^ | 7& | 8* | 9( | 0) | -_ | =+ | `~ |
+;;; +----------------------------------------------------------------+
+;;; | ·― | ςΣ | εΕ | ρΡ | τΤ | υΥ | θΘ | ιΙ | οΟ | πΠ | [{ | ]} |
+;;; +------------------------------------------------------------+
+;;; | αΑ | σΣ | δΔ | φΦ | γΓ | ηΗ | ξΞ | κΚ | λΛ | ΄¨ | '" | \| |
+;;; +-----------------------------------------------------------+
+;;; | ζΖ | χΧ | ψΨ | ωΩ | βΒ | νΝ | μΜ | ,; | .: | /? |
+;;; +-------------------------------------------------+
+;;; +-----------------------------+
+;;; | space bar |
+;;; +-----------------------------+
+;;;
+;;;
+;;; The followin escape sequences are recognized:
+;;;
+;;; '\ks' -> 'ξ'
+;;; '\ps' -> 'ψ'
+;;; '\th' -> 'θ'
+;;;
+;;; Additionally some spell fixing heuristics is applied:
+;;;
+;;; 's' at the end of the word -> 'ς'
+;;; 'w' anywhere but at the end of the word -> 'ω'
+;;; 'ks' -> 'ξ'
+;;; 'ps' -> 'ψ'
+;;; "th" -> 'θ' unless followed by a consonant
+;;; "u'" -> 'ύ'
+;;;
+;;; FIXME: The case of less obvious spelling errors, like e.g. 'ou' -> 'ου'
+;;; will be handled by later spelling corrections if fuzzy search is
+;;; enabled
+(define-public (ellinika:translate-kbd str)
+ (apply
+ string-append
+ (do ((sl (string->list str) (cdr sl))
+ (l '()))
+ ((null? sl) (reverse l))
+ (letrec ((decode-kbd-map
+ (lambda ()
+ (let ((g (assoc
+ (let ((c (car sl)))
+ (cond
+ ((and (char=? c #\w) (not (null? (cdr sl))))
+ #\v)
+ ((and (char=? c #\s) (null? (cdr sl)))
+ #\w)
+ (else
+ c)))
+ greek-kbd-map)))
+ (if g
+ (set! l (cons (cdr g) l))
+ (if (char=? (car sl) #\\)
+ (cond
+ ((> (length sl) 2)
+ (cond
+ ((char=? (car (cdr (cdr sl))) #\s)
+ (let ((c (car (cdr sl))))
+ (cond
+ ((char=? c #\k)
+ (set! sl (cdr (cdr sl)))
+ (set! l (cons "ξ" l)))
+ ((char=? c #\p)
+ (set! sl (cdr (cdr sl)))
+ (set! l (cons "ψ" l)))
+ (else
+ (set! sl (cdr sl))))))
+ ((and (char=? (car (cdr sl)))
+ (char=? (car (cdr (cdr sl))) #\h))
+ (set! sl (cdr (cdr sl)))
+ (set! l (cons "θ" l)))))
+
+ (else
+ (set! l (cons (string (car sl)) l))))))))))
+ (if (null? l)
+ (decode-kbd-map)
+ (cond
+ ((char=? (car sl) #\h)
+ (if (and (not (null? (cdr sl)))
+ (after-thita? (car (cdr sl))))
+ (set-car! l "θ")
+ (decode-kbd-map)))
+ ((assoc (car sl) greek-postfix-map) =>
+ (lambda (cmap)
+ (let ((x (assoc (car l) (cdr cmap))))
+ (if x
+ (set-car! l (cdr x))
+ (decode-kbd-map)))))
+ (else
+ (decode-kbd-map))))))))
+
+
+;; Translate the input string to UTF-8 if necessary.
+(define-public (ellinika:translate-input input)
+ (if (and input
+ (not (string-null? input))
+ (< (char->integer (string-ref input 0)) 127))
+ (ellinika:translate-kbd input)
+ input))
+
+
+
+(define transcription-list
+ (list
+ (cons "μπ" "b" )
+ (cons "γγ" "g" )
+ (cons "γκ" "g" )
+ (cons "γχ" "g" )
+ (cons "ντ" "d" )
+ (cons "αι" "e" )
+ (cons "αί" "e" )
+ (cons "αυ" "au")
+ (cons "αύ" "au")
+ (cons "ου" "ou")
+ (cons "ού" "ou")
+ (cons "ευ" "eu")
+ (cons "εύ" "eu")
+ (cons "οι" "i" )
+ (cons "ει" "i" )
+ (cons "εί" "i" )
+ (cons "υι" "i" )
+
+ (cons "α" "a" )
+ (cons "Α" "a" )
+ (cons "Ά" "a" )
+ (cons "ά" "a" )
+ (cons "β" "b" )
+ (cons "Β" "b" )
+ (cons "γ" "g" )
+ (cons "Γ" "g" )
+ (cons "δ" "d" )
+ (cons "Δ" "d" )
+ (cons "ε" "e" )
+ (cons "Ε" "e" )
+ (cons "Έ" "e" )
+ (cons "έ" "e" )
+ (cons "ζ" "z" )
+ (cons "Ζ" "z" )
+ (cons "η" "i" )
+ (cons "Η" "i" )
+ (cons "Ή" "i" )
+ (cons "ή" "i" )
+ (cons "θ" "t" )
+ (cons "Θ" "t" )
+ (cons "ι" "i" )
+ (cons "Ι" "i" )
+ (cons "Ί" "i" )
+ (cons "ί" "i" )
+ (cons "κ" "k" )
+ (cons "Κ" "k" )
+ (cons "λ" "l" )
+ (cons "Λ" "l" )
+ (cons "μ" "m" )
+ (cons "Μ" "m" )
+ (cons "ν" "n" )
+ (cons "Ν" "n" )
+ (cons "ξ" "x" )
+ (cons "Ξ" "x" )
+ (cons "ο" "o" )
+ (cons "Ο" "o" )
+ (cons "Ό" "o" )
+ (cons "ό" "o" )
+ (cons "π" "p" )
+ (cons "Π" "p" )
+ (cons "ρ" "r" )
+ (cons "Ρ" "r" )
+ (cons "σ" "s" )
+ (cons "Σ" "s" )
+ (cons "ς" "s" )
+ (cons "τ" "t" )
+ (cons "Τ" "t" )
+ (cons "υ" "i" )
+ (cons "Υ" "i" )
+ (cons "Ύ" "i" )
+ (cons "ύ" "i" )
+ (cons "φ" "f" )
+ (cons "Φ" "f" )
+ (cons "χ" "h" )
+ (cons "Χ" "h" )
+ (cons "ψ" "P" )
+ (cons "Ψ" "P" )
+ (cons "ω" "o" )
+ (cons "Ω" "o" )
+ (cons "Ώ" "o" )
+ (cons "ώ" "o" )
+ (cons "Ϊ" "i" )
+ (cons "ΐ" "i" )
+ (cons "Ϋ" "i" )
+ (cons "ΰ" "i" )))
+
+(define-public (ellinika:sounds-like str)
+ (let ((len (string-length str)))
+ (do ((i 0)
+ (sl '()))
+ ((= i len) (apply string-append (reverse sl)))
+ (set! sl (cons
+ (cond
+ ((and (<= (+ i 4) len)
+ (assoc (substring str i (+ i 4)) transcription-list)) =>
+ (lambda (x)
+ (set! i (+ i 4))
+ (cdr x)))
+ ((and (<= (+ i 2) len)
+ (assoc (substring str i (+ i 2)) transcription-list)) =>
+ (lambda (x)
+ (set! i (+ i 2))
+ (cdr x)))
+ (else
+ (set! i (1+ i))
+ (substring str (- i 1) i)))
+ sl)))))
+
+;;;; End of ellinika.scm
+

Return to:

Send suggestions and report system problems to the System administrator.