From 4eb48d2f187bc9bb3266cee025da2ea61270e4c4 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Sun, 22 Jun 2008 07:33:31 +0000 Subject: 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 --- src/Makefile.am | 17 ++ src/cgi-bin/Makefile.am | 56 +++++ src/cgi-bin/dict.scm4 | 611 +++++++++++++++++++++++++++++++++++++++++++++++ src/cgi-bin/nea.scm4 | 536 +++++++++++++++++++++++++++++++++++++++++ src/ellinika/Makefile.am | 43 ++++ src/ellinika/cgi.scm4 | 169 +++++++++++++ src/ellinika/config.scm4 | 42 ++++ src/ellinika/dico.scm | 306 ++++++++++++++++++++++++ src/ellinika/i18n.scm | 308 ++++++++++++++++++++++++ src/ellinika/xlat.scm | 309 ++++++++++++++++++++++++ 10 files changed, 2397 insertions(+) create mode 100644 src/Makefile.am create mode 100644 src/cgi-bin/Makefile.am create mode 100644 src/cgi-bin/dict.scm4 create mode 100644 src/cgi-bin/nea.scm4 create mode 100644 src/ellinika/Makefile.am create mode 100644 src/ellinika/cgi.scm4 create mode 100644 src/ellinika/config.scm4 create mode 100644 src/ellinika/dico.scm create mode 100644 src/ellinika/i18n.scm create mode 100644 src/ellinika/xlat.scm (limited to 'src') 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 . + +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 . + +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 . +;;;; + +;;; 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 "

~A

\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 " +;; 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 ""))) + +(define (main-form) + (load-pos) + (display "
+ + + + +") + + (display "") + + (display " + + ") + + (let ((tabindex 4)) + (for-each + (lambda (category) + (display "") + (set! tabindex (1+ tabindex)))) + (get-topic-list)) + + (display " + + + +
") + (display (_"Εισάγετε τη λέξη")) + (display " + + +
") + (display (_"Συμπληρωματικοί όροι")) + (display "
") + (display (_"Επιλέξτε το μέρος του λόγου")) + (display "") + + (let ((selected-choice (or (let ((s (cgi:value "POS"))) + (if s + (string->number s) + #f)) + 0)) + (index 0)) + + (display "")) + + (display "") + (join-widget "pos" "3") + (display "
") + (display (list-ref category 1)) + (display "") + (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0)))) + (if s + (string->number s) + #f)) + 0))) + + (display (string-append + "") + (display "") + (join-widget (list-ref category 0) (number->string tabindex)) + (display "
+ +
+
+"))) + +;; +(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 "") + (display "") + (cond + ((list-ref x 3) + (display ""))) + (display "")) + (for-each + (lambda (x) + (display "")) + rlist) + (display "
") + (display (car x)) + (display "") + (let ((href (assoc (list-ref x 2) word-forms-reference))) + (cond + (href + (display "") + (display (list-ref x 3)) + (display "")) + (else + (display (list-ref x 3))))) + (display "") + (display (list-ref x 2)) + (display "
") + (display (1+ (string->number (list-ref x 4)))) + (display "") + (display (replace-tilde (car x) (list-ref x 5))) + (display ";
") + (newline)) + +(define (display-cross-reference word) + (display "") + (display word) + (display "")) + +(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 "

") + (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key) + (display "

")) + +(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 "") + (let* ((result-length (length result)) + (lim (1+ (quotient result-length match-list-columns)))) + (do ((i 0 (1+ i))) + ((= i lim) #f) + (display "") + (do ((j i (+ j lim))) + ((>= j result-length) #f) + (display "")) + (display ""))) + (display "
") + (display-cross-reference (car (list-ref result j))) + (display "
")))))) + + +(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 "
") + (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 "

") + (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 "

") + (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 "&") + (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 . +;;;; + +;;; 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 "[permanent link]") + (display (string-append ""))) + +(define (sql-error-handler err descr) + (format #t "

~A

\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 "

~A

\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 "
") + (display (_ "Κανένα νέα")) + (display "
")) + (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 "

") + (format #t (_ "Εγγραφείς ~A - ~A") begin end) + (display "

"))) + + (display "\n") + (let ((ctr 0) + (langlist (make-my-lang-list))) + (for-each + (lambda (entry) + (display "\n") + (set! ctr (1+ ctr)) + (display "") + (display "") + (display "\n\n")) + result)) + (display "
") + (display (list-ref entry 1)) + (display "") + (display (list-ref entry 0))) + (else + (display "\">string begin))) + (display "\">") + (display (list-ref entry 0)) + (display ""))) + (display "
") + + (display "
") + (cond + ((> begin 0) + (display "string begin) + "dir" "0" + (if id + (list "id" id) + '()))) + (display "\">") + (display (_ "Προηγούμενες")) + (display ""))) + + (cond + ((< end count) + (display "string end) + "dir" "1" + (if id + (list "id" id) + '()))) + (display "\">") + (display (_ "Ερχόμενες")) + (display ""))) + (display "
")))))))) + +(define (display-article-header item) + (display "
") + (format #t "~A\n" (car item)) + (display "\n") + (display (list-ref item 2)) + (display "") + (if (not (cgi:value "timestamp")) + (permalink "span" (list-ref item 1))) + (display "
")) + +(define (display-article-text item . rest) + (let ((class (and (not (null? rest)) (car rest)))) + (cond + (class + (display "\n
\n") + (display (list-ref item 3)) + (display "
\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 + "

" + (_ "Κάμια καταχώρηση") + "

") + (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 "&") + (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 "\n") + (display " + + Τα νέα + Τα νέα + http://ellinika.gnu.org.ua") + (format #t "~A" (language-code target-language)) + (display " + EllinikaNea + 2006 Sergey Poznyakoff + gray@gnu.org.ua + http://blogs.law.harvard.edu/tech/rss +")) + +(define (nea-rss-footer) + (display " +")) + +(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 "\n") + (display "") + (display (list-ref tuple 0)) + (display "\n") + (display "") + (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 "\n") + (display "") + (display (string-append + (string-downcase cgi-server-protocol-name) + "://" + cgi-server-hostname + "/" + (make-cgi-name cgi-script-name + "timestamp" (list-ref tuple 1)))) + (display "\n") + (display "\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 . + +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 . +;;;; +(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) "=" "&") + 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 . +;;;; + +(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 . +;;;; + +(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 . + +(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 . +;;;; +(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 "Θ")