From 67f6358fe41e93a5c4831d58be56b0bccc0dd72a Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Mon, 27 Jun 2005 20:50:18 +0000 Subject: Rewritten using new Gamma git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@336 941c8c0f-9102-463b-b60b-cd22ce0e6858 --- cgi-bin/dict.cgi.in | 256 +++++++++++++++++++++++++++------------------------- 1 file changed, 132 insertions(+), 124 deletions(-) (limited to 'cgi-bin/dict.cgi.in') diff --git a/cgi-bin/dict.cgi.in b/cgi-bin/dict.cgi.in index d323c5a..a414ffe 100644 --- a/cgi-bin/dict.cgi.in +++ b/cgi-bin/dict.cgi.in @@ -35,25 +35,63 @@ ;; Τα μέρη του λογου (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)) + +(defmacro catch-sql-failure (expr) + `(catch 'gsql-error + (lambda () ,expr) + (lambda (key err descr) + (sql-error-handler err descr)))) + +(defmacro ignore-sql-failure (expr) + `(catch 'gsql-error + (lambda () ,expr) + (lambda (key err descr) + #f))) + (define (load-pos) - (let ((conn (sql-connect - sql-iface sql-host sql-port sql-database - sql-username sql-password))) - (cond - (conn - (sql-query conn "SET NAMES utf8") - (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)))) - (sql-connect-close conn))))) - + (ignore-sql-failure + (let ((conn (dict-connect))) + (let ((plist (my-sql-query + conn + "SELECT name,id FROM pos WHERE canonical='Y' order by id"))) + (set! part-of-speech + (cons + (cons "κανένα μέρος του λόγου" #f) + (map + (lambda (x) + (cons (car x) (cadr x))) + plist))))))) + ;; Protect occurences of " in a string. ;; Usual backslash escapes do not work in INPUT widgets, so I ;; change all quotation marks to " @@ -72,34 +110,27 @@ (let ((categories #f)) (letrec ((getcat (lambda () - (let ((conn (sql-connect sql-iface sql-host sql-port sql-database - sql-username sql-password))) - (cond - (conn - (sql-query conn "SET NAMES utf8") - (let ((categories (my-sql-query - conn - "SELECT category, title, description FROM category ORDER BY category"))) - (let ((result (if (null? categories) - '() - (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))))) - categories)))) - (sql-connect-close conn) - result))) - (else - '())))))) + (ignore-sql-failure + (let ((conn (dict-connect))) + (let ((ctg (my-sql-query + conn + "SELECT category, title, description FROM category ORDER BY category"))) + (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 (getcat))) + (set! categories (or (getcat) '()))) categories))) (define (join-widget widget-id tabindex) @@ -451,99 +482,75 @@ v)))))))) (pos (or (cgi:value "POS") "0"))) - (cond - ((and keyval - (not (string-null? keyval)) - (null? theme) - (= (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 "

~A

\n" - (_"ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))) - (else - (sql-query conn "SET NAMES utf8") - (display "
") - (let* ((key (ellinika:translate-input keyval)) - (result (my-sql-query + (catch-sql-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 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,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning FROM dict,articles,pos WHERE dict.word=\"" - key - "\" and dict.ident=articles.ident 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)))) - (sql-connect-close conn)))))) - ((or (not (null? theme)) (> (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 "
") - (sql-query conn "SET NAMES utf8") - (fuzzy-search conn (ellinika:translate-input (or keyval "")) theme pos) - (sql-connect-close conn)))))))) + "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 (let ((conn (sql-connect - sql-iface sql-host sql-port sql-database - sql-username sql-password))) - (cond - (conn - (sql-query conn "SET NAMES utf8") - (let ((x (my-sql-query conn - "SELECT count,updated from stat"))) - (sql-connect-close conn) - x)) - (else - '()))))) + (set! stat-data + (or + (ignore-sql-failure + (my-sql-query (dict-connect) + "SELECT count,updated from stat")) + '()))) (if (null? stat-data) "<>" (case key - ((#:updated) + ((#:updated) (list-ref (car stat-data) 1)) - ((#:count) + ((#:count) (list-ref (car stat-data) 0)) - (else - "<>"))))) + (else + "<>"))))) ;;; @@ -579,6 +586,7 @@ (template-file target-language dict-template-file-name) dict-html) +(dict-connect #t) ;;;; Local variables: ;;;; mode: Scheme -- cgit v1.2.1