diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2005-02-09 11:06:34 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2005-02-09 11:06:34 +0000 |
commit | 2d8e6979d8f9ef46a94091cb6f7735af9f6fc58a (patch) | |
tree | 3aa28f6699f4f94e6e621b4a546bf32ad7d09a51 /scm/dictrans.scm | |
parent | 22068cecd6b41b0b5e5c376f02f951acf1cb9c06 (diff) | |
download | ellinika-2d8e6979d8f9ef46a94091cb6f7735af9f6fc58a.tar.gz ellinika-2d8e6979d8f9ef46a94091cb6f7735af9f6fc58a.tar.bz2 |
(insert-categories): New function. Fills
category table.
(CLASS,D,TD): New tags
(check-node): Bail out if the topic is not declared.
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@293 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'scm/dictrans.scm')
-rw-r--r-- | scm/dictrans.scm | 120 |
1 files changed, 95 insertions, 25 deletions
diff --git a/scm/dictrans.scm b/scm/dictrans.scm index 1a5320a..5250368 100644 --- a/scm/dictrans.scm +++ b/scm/dictrans.scm @@ -1,10 +1,11 @@ #! =GUILE_BINDIR=/guile -s +=AUTOGENERATED= !# ;;;; This file is part of Ellinika -;;;; Copyright (C) 2004 Sergey Poznyakoff +;;;; Copyright (C) 2004, 2005 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 2 of the License, or ;;;; (at your option) any later version. ;;;; @@ -170,12 +171,15 @@ (xmltrans:make-tag tag attr text) tag-list)) #f) (xmltrans:set-default-end-handler lingua:default-end) +;;; Themes class list +(define class-list '()) + ;;; Current node (define current-node #f) (define-syntax node-get (syntax-rules () ((node-get #:key node) @@ -336,13 +340,13 @@ (define expected-k #f) (define (k-expect) (set! expected-k #f)) -;;; +;;;; NODE (xmltrans:start-tag "NODE" (tag attr) (set! current-node (vector #f #f '() '() (xmltrans:get-input-location))) (set! p-article #f) (set! expected-k #t) @@ -523,12 +527,47 @@ (xmltrans:parse-error #f "P element not defined") (mark-invalid)) (else (current-article-set #:article text))) #f) + +;;; CLASS +(xmltrans:end-tag + "CLASS" + (tag attr text) + (expect-context tag "DICT") + (let ((id (xmltrans:attr attr "ID")) + (descr (xmltrans:attr attr "DESCR")) + (tds (xmltrans:attr attr "__TDS__"))) + (set! class-list (cons + (list id descr tds) + class-list))) + #f) + +;;; D +(xmltrans:end-tag + "D" + (tag attr text) + (expect-context tag "CLASS") + ;; FIXME: Check for duplicates + (xmltrans:set-attr #t "DESCR" text) + #f) + +;;; TD +(xmltrans:end-tag + "TD" + (tag attr text) + (expect-context tag "CLASS") + (xmltrans:set-attr #t "__TDS__" + (cons + text + (or (xmltrans:attr #t "__TDS__") '()))) + #f) + + ;;; Formatting elements (xmltrans:end-tag "C" (tag attr text) (expect-context tag "M" "F") (list @@ -602,12 +641,13 @@ (run-query conn "DELETE FROM locus") (run-query conn "DELETE FROM links") (run-query conn "DELETE FROM articles") (run-query conn "DELETE FROM dict") (run-query conn "DELETE FROM topic") (run-query conn "DELETE FROM topic_tab") + (run-query conn "DELETE FROM category") (run-query conn "DELETE FROM pending_links")) (define (pending-fixup conn) (run-query conn "INSERT IGNORE INTO links \ SELECT p.type,p.originator,d.ident \ @@ -646,13 +686,48 @@ (run-query conn (string-append "INSERT INTO stat (count,updated) VALUES(" (number->string count) ",now())")))) - +;;; Insert (or update) topics and topic categories +(define (insert-categories conn) + (for-each + (lambda (cat) + (let ((cn (let ((res (run-query conn + (string-append + "SELECT category FROM category WHERE title=\"" + (escape-string (list-ref cat 0)) + "\"")))) + (cond + ((not (null? res)) + (run-query conn (string-append "UPDATE category SET descr=\"" + (escape-string (list-ref cat 1)) + "' WHERE category=" + (caar res))) + (caar res)) + (else + (run-query conn (string-append + "INSERT INTO category (title,description) VALUES (\"" + (escape-string (list-ref cat 0)) + "\",\"" + (escape-string (or (list-ref cat 1) "")) + "\")")) + (number->string (query-number conn "SELECT LAST_INSERT_ID()"))))))) + (for-each + (lambda (topic) + (run-query conn + (string-append "INSERT INTO topic (title,category) VALUES(\"" + (escape-string topic) + "\"," + cn + ")"))) + (list-ref cat 2)))) + class-list)) + +;;; (define dict-index 0) (define (check-node conn node) (call-with-current-continuation (lambda (return) (for-each @@ -746,34 +821,27 @@ (insert-link "ANT" x)) (p-article-get #:aref p-article)) ;;; Insert topics (for-each (lambda (t) - (let ((index (or - (query-number - conn - (format - #f - "SELECT ident FROM topic WHERE title=\"~A\"" - (escape-string t))) - (begin - (run-query - conn - (format - #f - "INSERT INTO topic (title) VALUES (\"~A\")" - (escape-string t))) - (query-number conn "SELECT LAST_INSERT_ID()"))))) - (run-query - conn - (format - #f - "INSERT INTO topic_tab VALUES(~A,~A)" - index - dict-index)))) + (let ((index (query-number + conn + (format + #f + "SELECT ident FROM topic WHERE title=\"~A\"" + (escape-string t))))) + (if (not index) + (xmltrans:parse-error (node-get #:locus node) "Undefined topic") + (run-query + conn + (format + #f + "INSERT INTO topic_tab VALUES(~A,~A)" + index + dict-index))))) (p-article-get #:topic p-article)) ;;; Insert articles (let ((article-index 0)) (for-each (lambda (text) @@ -911,12 +979,14 @@ Informational options: (if cleanup-option (cleanup-db conn)) (get-dict-index conn) + + (insert-categories conn) (for-each (lambda (node) (and (check-node conn node) (insert-node conn node))) (reverse node-list)) |