From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Thien-Thi Nguyen Newsgroups: gmane.lisp.guile.user,gmane.lisp.guile.sources Subject: markup.scm v2 Date: Mon, 06 Jan 2003 12:39:06 -0800 Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Message-ID: Reply-To: ttn@glug.org NNTP-Posting-Host: main.gmane.org X-Trace: main.gmane.org 1041975118 2775 80.91.224.249 (7 Jan 2003 21:31:58 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Tue, 7 Jan 2003 21:31:58 +0000 (UTC) Cc: guile-user@gnu.org Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 18W1KF-0000iR-00 for ; Tue, 07 Jan 2003 22:31:55 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.10.13) id 18VyD0-0004iO-07 for guile-user@m.gmane.org; Tue, 07 Jan 2003 13:12:14 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.10.13) id 18VeBD-0003df-00 for guile-user@gnu.org; Mon, 06 Jan 2003 15:49:03 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.10.13) id 18VeB4-0003Ic-00 for guile-user@gnu.org; Mon, 06 Jan 2003 15:48:59 -0500 Original-Received: from ca-crlsca-cuda3-c6a-b-211.crlsca.adelphia.net ([68.71.15.211] helo=giblet.glug.org) by monty-python.gnu.org with esmtp (Exim 4.10.13) id 18VeAw-0003AG-00; Mon, 06 Jan 2003 15:48:46 -0500 Original-Received: from ttn by giblet.glug.org with local (Exim 3.35 #1 (Debian)) id 18Ve1a-0001D3-00; Mon, 06 Jan 2003 12:39:06 -0800 Original-To: guile-sources@gnu.org X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1b5 Precedence: list List-Id: General Guile related discussions List-Help: List-Post: List-Subscribe: , List-Archive: List-Unsubscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.user:1502 gmane.lisp.guile.sources:31 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.user:1502 this version does not use the postgresql-specific "oid" support; the generated SQL is more portable. the markup table now includes a back- pointer to the client table and thus is usable by multiple clients (as long as clients maintain back-pointer namespace exclusivity). thi _____________________________________________ ;;; Copyright (C) 2003 Thien-Thi Nguyen ;;; This program is provided under the terms of the GNU GPL, version 2. ;;; See http://www.fsf.org/copyleft/gpl.html for details. ;;; version: 2 (define-module (markup) :use-module (database postgres) :use-module (database postgres-types) :use-module (database postgres-table) :use-module (ttn display-table)) ;; database (define *db* (getenv "USER")) ;; table defs (define *markup-defs* '((raw text) (mtype text) (mdata text) (back text) ; client info (back pointer) (seq int4))) ; client sequence number (define *client-defs* '((project text) (description int4))) ; item count ;; display-tree (define (display-tree tree) (if (list? tree) (for-each display-tree tree) (display tree))) ;; play! (let ((m (pgtable-manager *db* "markup_play" *markup-defs*)) (c (pgtable-manager *db* "client_play" *client-defs*))) ;; Add POSSIBLY-MARKED-TEXT for BACK/SEQ to markup table. ;; POSSIBLY-MARKED-TEXT can either be a simple string, in which ;; case no markup is implied, or a list taking one of the forms: ;; ;; (url URL) ;; (url URL TEXT) ;; (email TEXT ADDR) ;; ;; in which case, the markup is extracted as '("url" URL) and '("email" ;; ADDR), respectively, and the TEXT is passed through directly. In the ;; url case, if TEXT is missing, use URL instead. ;; ;; BACK is string indicating the client using this row. SEQ is the sequence ;; number (integer) of this row in the client. ;; (define (add-possibly-marked-text possibly-marked-text back seq) (let ((insert (lambda (raw mtype mdata) ((m 'insert-values) raw mtype mdata back seq)))) (if (string? possibly-marked-text) (insert possibly-marked-text #f #f) (let* ((form possibly-marked-text) (type (car form))) (insert (case type ((url) ((if (= 3 (length form)) caddr cadr) form)) ((email) (cadr form)) (else (error (format #f "bad form: ~A" form)))) (symbol->string (car form)) ((case type ((url) cadr) ((email) caddr)) form)))))) (define (add-project pair) ((c 'insert-values) (car pair) (let loop ((count 0) (ls (cdr pair))) (if (null? ls) count (begin (add-possibly-marked-text (car ls) (format #f "description:~A" (car pair)) count) (loop (1+ count) (cdr ls))))))) (define (>>table heading manager) (write-line heading) (display-table (tuples-result->table ((manager 'select) "*")))) (define (get-rows manager order as . args) ((manager 'tuples-result->object-alist) ((manager 'select) "*" (where-clausifier (apply format #f as args)) (if order (format #f "ORDER BY ~A" order) "")))) (define (get-one-row manager as . args) (map (lambda (col) (cons (car col) (cadr col))) (apply get-rows manager #f as args))) (define (tree<-possibly-marked-text back max-seq) (let ((alist (get-rows m "seq" "back = '~A' AND seq < ~A" back max-seq))) (map (lambda (raw mtype mdata) (if (string=? "" mtype) raw (case (string->symbol mtype) ((url) (list "" raw "")) ((email) (list "" raw "")) (else (error (format #f "bad markup type: ~A" mtype)))))) (assq-ref alist 'raw) (assq-ref alist 'mtype) (assq-ref alist 'mdata)))) (define (>>project project) (let* ((alist (get-one-row c "project = '~A'" project)) (description (assq-ref alist 'description))) (format #t "project: ~A\ndescription: ~A\n" project description) (display-tree (tree<-possibly-marked-text (format #f "description:~A" project) description))) (newline)) (define (delete-project project) (let* ((alist (get-one-row c "project = '~A'" project)) (description (assq-ref alist 'description))) ((m 'delete-rows) (format #f "back = '~A' AND seq < ~A" (format #f "description:~A" project) description)) ((c 'delete-rows) (format #f "project = '~A'" project)))) (define *samples* (list (cons "guile projects list maintenance" '("This is the guile scheme code that maintains the " (url "http://www.glug.org/projects/list.html" "guile projects list") ". There are configurations for glug.org as well for " (url "http://www.gnu.org/software/guile/gnu-guile-projects.html" "the gnu.org subset of the list") ".")) (cons "guile-pg" '("An interface to PostgreSQL from guile.")) (cons "snd" '((url "http://www-ccrma.stanford.edu/software/snd/") " is where you can find Snd.")) (cons "hobbit" '("The hobbit author is " (email "Tanel Tammet" "tammet@cs.chalmers.se") ".")))) ;;((m 'drop)) ((c 'drop)) (write-line ((m 'create))) (write-line ((c 'create))) (for-each write-line (map add-project *samples*)) (>>table "markup" m) (>>table "client" c) (for-each >>project (map car *samples*)) (write-line (delete-project (list-ref (map car *samples*) 0))) (write-line (delete-project (list-ref (map car *samples*) 1))) ;;(for-each >>project (map car (cddr *samples*))) (>>table "markup" m) (>>table "client" c) (write-line ((c 'drop))) (write-line ((m 'drop)))) ;;; markup.scm ends here _______________________________________________ Guile-user mailing list Guile-user@gnu.org http://mail.gnu.org/mailman/listinfo/guile-user