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 --- ChangeLog | 5 + Makefile.am | 4 +- cgi-bin/Makefile.am | 56 ----- cgi-bin/dict.scm4 | 611 ----------------------------------------------- cgi-bin/nea.scm4 | 536 ----------------------------------------- configure.ac | 11 +- ellinika/Makefile.am | 43 ---- ellinika/cgi.scm4 | 169 ------------- ellinika/config.scm4 | 42 ---- ellinika/dico.scm | 306 ------------------------ ellinika/i18n.scm | 308 ------------------------ ellinika/xlat.scm | 309 ------------------------ 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 ++++++++++++++++++++++++ 22 files changed, 2410 insertions(+), 2387 deletions(-) delete mode 100644 cgi-bin/Makefile.am delete mode 100644 cgi-bin/dict.scm4 delete mode 100644 cgi-bin/nea.scm4 delete mode 100644 ellinika/Makefile.am delete mode 100644 ellinika/cgi.scm4 delete mode 100644 ellinika/config.scm4 delete mode 100644 ellinika/dico.scm delete mode 100644 ellinika/i18n.scm delete mode 100644 ellinika/xlat.scm 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 diff --git a/ChangeLog b/ChangeLog index 75c993e..ee82c7e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2008-06-22 Sergey Poznyakoff + * src: New dir + * src/Makefile.am: New file. + * cgi-bin, ellinika: Move to src. + * configure.ac: Reflect the above changes. + * ellinika/i18n.scm (_): New syntax. * cgi-bin/dict.scm4 (gamma gettext): Remove. Use (ellinika i18n). diff --git a/Makefile.am b/Makefile.am index 9f08e82..6e3a25a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ # This file is part of Ellinika project. -# Copyright (C) 2004, 2007 Sergey Poznyakoff +# Copyright (C) 2004, 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 @@ -17,7 +17,7 @@ AUTOMAKE_OPTIONS = gnits 1.8 ACLOCAL_AMFLAGS = -I m4 -SUBDIRS=cgi-bin elisp data ellinika scm xml po +SUBDIRS=src elisp data scm xml po htmldir = $(HTMLDIR) diff --git a/cgi-bin/Makefile.am b/cgi-bin/Makefile.am deleted file mode 100644 index bb90eed..0000000 --- a/cgi-bin/Makefile.am +++ /dev/null @@ -1,56 +0,0 @@ -# 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/cgi-bin/dict.scm4 b/cgi-bin/dict.scm4 deleted file mode 100644 index c9f895b..0000000 --- a/cgi-bin/dict.scm4 +++ /dev/null @@ -1,611 +0,0 @@ -;;;; 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/cgi-bin/nea.scm4 b/cgi-bin/nea.scm4 deleted file mode 100644 index e490a59..0000000 --- a/cgi-bin/nea.scm4 +++ /dev/null @@ -1,536 +0,0 @@ -;;;; 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/configure.ac b/configure.ac index c4d2ee3..0f11ede 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ # This file is part of Ellinika -*- autoconf -*- -# Copyright (C) 2004, 2005, 2007 Sergey Poznyakoff +# 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 @@ -19,7 +19,7 @@ AC_PREREQ(2.59) AC_REVISION($Revision$) AC_INIT(ellinika, 1.2, [gray@gnu.org.ua]) -AC_CONFIG_SRCDIR(cgi-bin/dict.scm4) +AC_CONFIG_SRCDIR(src/cgi-bin/dict.scm4) AC_CONFIG_AUX_DIR([build-aux]) AC_CANONICAL_SYSTEM AM_INIT_AUTOMAKE(no-exeext) @@ -110,13 +110,14 @@ AC_SUBST(AUTOGENERATED, AC_CONFIG_FILES(Makefile .htaccess - cgi-bin/Makefile + src/Makefile + src/cgi-bin/Makefile + src/ellinika/Makefile elisp/Makefile + scm/Makefile data/Makefile data/pl/Makefile data/ru/Makefile - scm/Makefile - ellinika/Makefile xml/Makefile xml/pl/Makefile xml/ru/Makefile diff --git a/ellinika/Makefile.am b/ellinika/Makefile.am deleted file mode 100644 index 136b44f..0000000 --- a/ellinika/Makefile.am +++ /dev/null @@ -1,43 +0,0 @@ -# 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/ellinika/cgi.scm4 b/ellinika/cgi.scm4 deleted file mode 100644 index 38fd3de..0000000 --- a/ellinika/cgi.scm4 +++ /dev/null @@ -1,169 +0,0 @@ -;;;; -*- 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/ellinika/config.scm4 b/ellinika/config.scm4 deleted file mode 100644 index 8032409..0000000 --- a/ellinika/config.scm4 +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- 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/ellinika/dico.scm b/ellinika/dico.scm deleted file mode 100644 index 9383d1f..0000000 --- a/ellinika/dico.scm +++ /dev/null @@ -1,306 +0,0 @@ -;;;; 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/ellinika/i18n.scm b/ellinika/i18n.scm deleted file mode 100644 index 474c8c9..0000000 --- a/ellinika/i18n.scm +++ /dev/null @@ -1,308 +0,0 @@ -;;;; 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