#! =GUILE_BINDIR=/guile -s !# ;;;; Greek Dictionary Web Engine ;;;; Copyright (C) 2004 Sergey Poznyakoff ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; ;;; Tailor this statement to your needs if necessary. ;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path)) (use-modules (www cgi) (gamma sql) (gamma gettext) (xmltools dict) (ellinika xlat)) (cgi:init) ;;; User-definable variables (define base-dir "=PREFIX=") (define html-dir "=HTMLDIR=") (define sysconf-dir "=SYSCONFDIR=") (define locale-dir "=LOCALEDIR=") (define ref-loc #f) (define dict-cgi-path "cgi-bin/dict.cgi") ;; Path to the cgi (relative ;; to the Base HREF) (define config-file-name "ellinika.conf") (define template-file-name "dict.html") (define target-language "el_GR") (define word-forms-reference '()) (define sql-iface "mysql") ;; SQL interface ("mysql" or "postgres") (define sql-host "localhost") ;; SQL server hostname or a path to the UNIX ;; socket (define sql-port 3306) ;; SQL port number (0 for sockaddr_un ;; connection) (define sql-database "ellinika") ;; Name of the database (define sql-username "gray") ;; Database user name (define sql-password "") ;; Password for that user name (define match-list-columns 4) ;; Number of colums in fuzzy search output ;;; End of user-definable variables ;;; Load the site defaults (let ((rc-file (string-append sysconf-dir "/" config-file-name))) (if (file-exists? rc-file) (load rc-file))) (define (language-code lang) (cond ((string-index lang #\_) => (lambda (len) (substring lang 0 len))) (else lang))) (define (template-file lang) (string-append html-dir "/" (language-code lang) "/" template-file-name)) ;;; Load the language-specific defaults (cond ((cgi:value "LANG") => (lambda (x) (if (and (file-exists? (template-file x)) (false-if-exception (setlocale LC_ALL x))) (set! target-language x))))) ;;; Initialize i18n (setlocale LC_ALL target-language) (bindtextdomain "=PACKAGE=" locale-dir) (bind_textdomain_codeset "=PACKAGE=" "UTF-8") (textdomain "=PACKAGE=") (define (make-cgi-name . rest) (apply string-append (cons dict-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 part-of-speech '()) (define (hbase num) (do ((i 0 (1+ i)) (n num (ash n -1))) ((= n 0) (ash 1 (- i 1))))) (define (load-pos) (let ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond (conn (let ((plist (sql-query conn "SELECT name,id FROM pos WHERE canonical='Y' order by id"))) (set! part-of-speech (cons (cons "κανένα μέρος του λόγου" #f) (map (lambda (x) (let* ((value (string->number (car (cdr x)))) (mask (hbase value))) (cons (car x) (number->string (if (= value mask) value (logand value (lognot mask))))))) plist))) (sql-connect-close conn)))))) ;; 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 ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond (conn (let ((result (sql-query conn "SELECT ident,title FROM topic ORDER BY title"))) (sql-connect-close conn) result)) (else #f)))) (define (main-form) (load-pos) (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 (car x)) (display " | ") (cond ((list-ref x 3) (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 "") (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 "; |
") (display-cross-reference (car (list-ref result j))) (display " | ")) (display "
") (let ((x (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)))) (sql-connect-close conn)))))) ((or (> (string->number theme) 0) (> (string->number pos) 0)) (let ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond ((not conn) (format #t "
\n" (_"ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))) (else (display "