From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:28 -0800 Subject: Import Upstream version 2d2 --- db2html.scm | 463 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 463 insertions(+) create mode 100644 db2html.scm (limited to 'db2html.scm') diff --git a/db2html.scm b/db2html.scm new file mode 100644 index 0000000..3462966 --- /dev/null +++ b/db2html.scm @@ -0,0 +1,463 @@ +;"db2html.scm" Convert relational database to hyperlinked pages. +; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'uri) +(require 'html-form) +(require 'net-clients) +(require 'string-search) + +;;@code{(require 'db->html)} + +;;@body +(define (html:table options . rows) + (apply string-append + (sprintf #f "\\n" (or options "")) + (append rows (list (sprintf #f "
\\n"))))) + +;;@args caption align +;;@args caption +;;@2 can be @samp{top} or @samp{bottom}. +(define (html:caption caption . align) + (if (null? align) + (sprintf #f " %s\\n" + (html:plain caption)) + (sprintf #f " %s\\n" + (car align) + (html:plain caption)))) + +;;@body Outputs a heading row for the currently-started table. +(define (html:heading columns) + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (datum) + (sprintf #f " %s\\n" (or datum ""))) + columns)))) + +;;@body Outputs a heading row with column-names @1 linked to URIs @2. +(define (html:href-heading columns uris) + (html:heading + (map (lambda (column uri) + (if uri + (html:link uri column) + column)) + columns uris))) + +(define (row->anchor pkl row) + (sprintf #f "" (uri:make-path (butnthcdr pkl row)))) + +;;@args k foreigns +;; +;;The positive integer @1 is the primary-key-limit (number of +;;primary-keys) of the table. @2 is a list of the filenames of +;;foreign-key field pages and #f for non foreign-key fields. +;; +;;@0 returns a procedure taking a row for its single argument. This +;;returned procedure returns the html string for that table row. +(define (html:linked-row-converter pkl foreigns) + (define idxs (do ((idx (length foreigns) (+ -1 idx)) + (nats '() (cons idx nats))) + ((not (positive? idx)) nats))) + (require 'pretty-print) + (lambda (row) + (define (present datum) + (if (or (string? datum) (symbol? datum)) + (html:plain datum) + (let* ((str (pretty-print->string datum)) + (len (+ -1 (string-length str)))) + (cond ((eqv? (string-index str #\newline) len) + (string-append "" (substring str 0 len) "")) + (else (html:pre str)))))) + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " %s%s\\n" + (if (eqv? 1 idx) (row->anchor pkl row) "") + (cond ((or (not datum) (null? datum)) "") + ((not foreign) (present datum)) + ((equal? "catalog-data.html" foreign) + (html:link (make-uri + (table-name->filename datum) + #f #f) + (present datum))) + (else (html:link (make-uri foreign #f datum) + (present datum)))))) + idxs row foreigns))))) + +;;@body +;;Returns the symbol @1 converted to a filename. +(define (table-name->filename table-name) + (and table-name (string-append + (string-subst (symbol->string table-name) "*" "" ":" "_") + ".html"))) + +(define (table-name->column-table-name db table-name) + ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name) + table-name)) + +;;@args caption db table-name match-key1 @dots{} +;;Returns HTML string for @2 table @3. Every foreign-key value is +;;linked to the page (of the table) defining that key. +;; +;;The optional @4 @dots{} arguments restrict actions to a subset of +;;the table. @xref{Table Operations, match-key}. +(define (table->linked-html caption db table-name . args) + (let* ((table ((db 'open-table) table-name #f)) + (foreigns (table 'column-foreigns)) + (tags (map table-name->filename foreigns)) + (names (table 'column-names)) + (primlim (table 'primary-limit))) + (apply html:table "CELLSPACING=0 BORDER=1" + (html:caption caption 'BOTTOM) + (html:href-heading + names + (append (make-list primlim + (table-name->filename + (table-name->column-table-name db table-name))) + (make-list (- (length names) primlim) #f))) + (html:heading (table 'column-domains)) + (html:href-heading foreigns tags) + (html:heading (table 'column-types)) + (map (html:linked-row-converter primlim tags) + (apply (table 'row:retrieve*) args))))) + +;;@body +;;Returns a complete HTML page. The string @3 names the page which +;;refers to this one. +;; +;;The optional @4 @dots{} arguments restrict actions to a subset of +;;the table. @xref{Table Operations, match-key}. +(define (table->linked-page db table-name index-filename . args) + (string-append + (if index-filename + (html:head table-name + (html:link (make-uri index-filename #f table-name) + (html:plain table-name))) + (html:head table-name)) + (html:body (apply table->linked-html table-name db table-name args)))) + +(define (html:catalog-row-converter row foreigns) + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (datum foreign) + (sprintf #f " %s%s\\n" + (html:anchor (sprintf #f "%s" datum)) + (html:link (make-uri foreign #f #f) datum))) + row foreigns)))) + +;;@body +;;Returns HTML string for the catalog table of @1. +(define (catalog->html db caption . args) + (apply html:table "BORDER=1" + (html:caption caption 'BOTTOM) + (html:heading '(table columns)) + (map (lambda (row) + (cond ((and (eq? '*columns* (caddr row)) + (not (eq? '*columns* (car row)))) + "") + (else (html:catalog-row-converter + (list (car row) (caddr row)) + (list (table-name->filename (car row)) + (table-name->filename (caddr row))))))) + (apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*) + args)))) + +;;Returns complete HTML page (string) for the catalog table of @1. +(define (catalog->page db caption . args) + (string-append (html:head caption) + (html:body (apply catalog->html db caption args)))) + +;;@subsection HTML editing tables + +;;@noindent A client can modify one row of an editable table at a time. +;;For any change submitted, these routines check if that row has been +;;modified during the time the user has been editing the form. If so, +;;an error page results. +;; +;;@noindent The behavior of edited rows is: +;; +;;@itemize @bullet +;;@item +;;If no fields are changed, then no change is made to the table. +;;@item +;;If the primary keys equal null-keys (parameter defaults), and no other +;;user has modified that row, then that row is deleted. +;;@item +;;If only primary keys are changed, there are non-key fields, and no +;;row with the new keys is in the table, then the old row is +;;deleted and one with the new keys is inserted. +;;@item +;;If only non-key fields are changed, and that row has not been +;;modified by another user, then the row is changed to reflect the +;;fields. +;;@item +;;If both keys and non-key fields are changed, and no row with the +;;new keys is in the table, then a row is created with the new +;;keys and fields. +;;@item +;;If fields are changed, all fields are primary keys, and no row with +;;the new keys is in the table, then a row is created with the new +;;keys. +;;@end itemize +;; +;;@noindent After any change to the table, a @code{sync-database} of the +;;database is performed. + +;;@args table-name null-keys update delete retrieve +;;@args table-name null-keys update delete +;;@args table-name null-keys update +;;@args table-name null-keys +;; +;;Returns procedure (of @var{db}) which returns procedure to modify row +;;of @1. @2 is the list of @dfn{null} keys which indicate that the row +;;is to be deleted. Optional arguments @3, @4, and @5 default to the +;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in +;;@var{db}. +(define (command:modify-table table-name null-keys . args) + (define argc (length args)) + (lambda (rdb) + (define table ((rdb 'open-table) table-name #t)) + (let ((table:update (or (and (> argc 0) (car args)) (table 'row:update))) + (table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete))) + (table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve))) + (pkl (length null-keys))) + (define ptypes (butnthcdr pkl (table 'column-types))) + (if (> argc 4) (slib:error 'command:modify-table 'too-many-args + table-name null-keys args)) + (lambda (*keys* *row-hash* . new-row) + (let* ((new-pkeys (butnthcdr pkl new-row)) + (pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes)) + (row (apply table:retrieve pkeys)) + (same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row)))) + (cond ((equal? pkeys new-pkeys) ;did not change keys + (cond ((not row) '("Row deleted by other user")) + ((equal? (crc:hash-obj row) *row-hash*) + (table:update new-row) + ((rdb 'sync-database)) #t) + (else '("Row changed by other user")))) + ((equal? null-keys new-pkeys) ;blanked keys + (cond ((not row) #t) + ((equal? (crc:hash-obj row) *row-hash*) + ;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys )) + (apply table:delete pkeys) + ((rdb 'sync-database)) #t) + (else '("Row changed by other user")))) + (else ;changed keys + (set! row (apply table:retrieve new-pkeys)) + (cond (row (list "Row already exists" + (sprintf #f "%#a" row))) + (else (table:update new-row) + (if (and same-nonkeys? + (not (null? (nthcdr pkl new-row)))) + (apply table:delete pkeys)) + ((rdb 'sync-database)) #t))))))))) + +;;@body Given @2 in @1, creates parameter and @code{*command*} tables +;;for editing one row of @2 at a time. @0 returns a procedure taking a +;;row argument which returns the HTML string for editing that row. +;; +;;Optional @3 are expressions (lists) added to the call to +;;@code{command:modify-table}. +;; +;;The domain name of a column determines the expected arity of the data +;;stored in that column. Domain names ending in: +;; +;;@table @samp +;;@item * +;;have arity @samp{nary}; +;;@item + +;;have arity @samp{nary1}. +;;@end table +(define (command:make-editable-table rdb table-name . args) + (define table ((rdb 'open-table) table-name #t)) + (let ((pkl (table 'primary-limit)) + (columns (table 'column-names)) + (domains (table 'column-domains)) + (types (table 'column-types)) + (idxs (do ((idx (length (table 'column-names)) (+ -1 idx)) + (nats '() (cons (+ 2 idx) nats))) + ((not (positive? idx)) nats))) + (ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table))) + (define field-specs + (map (lambda (idx column domain type) + (let* ((dstr (symbol->string domain)) + (len (+ -1 (string-length dstr)))) + (define arity + (case (string-ref dstr len) + ((#\*) 'nary) + ((#\+) 'nary1) + (else 'single))) + (case (string-ref dstr len) + ((#\* #\+) + (set! type (string->symbol (substring dstr 0 len))) + (set! domain type))) + `(,idx ,column ,arity ,domain + ,(make-defaulter arity type) #f ""))) + idxs columns domains types)) + (define foreign-choice-lists + (map (lambda (domain-name) + (define tab-name (ftn domain-name)) + (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '())) + domains)) + (define-tables rdb + `(,(symbol-append table-name '- 'params) + *parameter-columns* *parameter-columns* + ((1 *keys* single string #f #f "") + (2 *row-hash* single string #f #f "") + ,@field-specs)) + `(,(symbol-append table-name '- 'pname) + ((name string)) + ((parameter-index uint)) ;should be address-params + (("*keys*" 1) + ("*row-hash*" 2) + ,@(map (lambda (idx column) (list (symbol->string column) idx)) + idxs columns))) + `(*commands* + desc:*commands* desc:*commands* + ((,(symbol-append 'edit '- table-name) + ,(symbol-append table-name '- 'params) + ,(symbol-append table-name '- 'pname) + (command:modify-table ',table-name + ',(map (lambda (fs) + (caadr (caddar (cddddr fs)))) + (butnthcdr pkl field-specs)) + ,@args) + ,(string-append "Modify " (symbol->string table-name)))))) + (let ((arities (map caddr field-specs))) + (lambda (row) + (define elements + (map form:element + columns + arities + (map (lambda (fld arity) (case arity + ((nary nary1) fld) + (else (list fld)))) + row arities) + foreign-choice-lists)) + (sprintf #f " \\n %s%s\\n \\n" + (string-append + (html:hidden '*row-hash* (crc:hash-obj row)) + (html:hidden '*keys* (uri:make-path (butnthcdr pkl row))) + ;; (html:hidden '*suggest* '<>) + (car elements) + (form:submit '<> (symbol-append 'edit '- table-name)) + ;; (form:image "Modify Row" "/icons/bang.png") + ) + (apply string-append + (map (lambda (elt) (sprintf #f " %s\\n" elt)) + (cdr elements)))))))) + +;;@args k names edit-point edit-converter +;; +;;The positive integer @1 is the primary-key-limit (number of +;;primary-keys) of the table. @2 is a list of the field-names. @3 is +;;the list of primary-keys denoting the row to edit (or #f). @4 is the +;;procedure called with @1, @2, and the row to edit. +;; +;;@0 returns a procedure taking a row for its single argument. This +;;returned procedure returns the html string for that table row. +;; +;;Each HTML table constructed using @0 has first @1 fields (typically +;;the primary key fields) of each row linked to a text encoding of these +;;fields (the result of calling @code{row->anchor}). The page so +;;referenced typically allows the user to edit fields of that row. +(define (html:editable-row-converter pkl names edit-point edit-converter) + (require 'pretty-print) + (let ((idxs (do ((idx (length names) (+ -1 idx)) + (nats '() (cons idx nats))) + ((not (positive? idx)) nats))) + (datum->html + (lambda (datum) + (if (or (string? datum) (symbol? datum)) + (html:plain datum) + (let* ((str (pretty-print->string datum)) + (len (+ -1 (string-length str)))) + (cond ((eqv? (string-index str #\newline) len) + (string-append "" (substring str 0 len) "")) + (else (html:pre str)))))))) + (lambda (row) + (string-append + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " %s%s\\n" + (if (eqv? 1 idx) (row->anchor pkl row) "") + (cond ((or (not datum) (null? datum)) "") + ((<= idx pkl) + (let ((keystr (uri:make-path + (butnthcdr pkl row)))) + (sprintf #f "%s" + keystr keystr + (datum->html datum)))) + (else (datum->html datum))))) + idxs row names))) + (if (and edit-point edit-converter + (equal? (butnthcdr pkl edit-point) (butnthcdr pkl row))) + (edit-converter row) + ""))))) + +;;@subsection HTML databases + +;;@body @1 must be a relational database. @2 must be #f or a +;;non-empty string naming an existing sub-directory of the current +;;directory. +;; +;;@0 creates an html page for each table in the database @1 in the +;;sub-directory named @2, or the current directory if @2 is #f. The +;;top level page with the catalog of tables (captioned @4) is written +;;to a file named @3. +(define (db->html-files db dir index-filename caption) + (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "") + index-filename) + (lambda (port) + (display (catalog->page db caption) port))) + ((((db 'open-table) '*catalog-data* #f) 'for-each-row) + (lambda (row) + (call-with-output-file + (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row))) + (lambda (port) + (display (table->linked-page db (car row) index-filename) port)))))) + +;;@args db dir index-filename +;;@args db dir +;;@1 must be a relational database. @2 must be a non-empty +;;string naming an existing sub-directory of the current directory or +;;one to be created. The optional string @3 names the filename of the +;;top page, which defaults to @file{index.html}. +;; +;;@0 creates sub-directory @2 if neccessary, and calls +;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is +;;returned. +(define (db->html-directory db dir . index-filename) + (set! index-filename (if (null? index-filename) + "index.html" + (car index-filename))) + (if (symbol? dir) (set! dir (symbol->string dir))) + (if (not (file-exists? dir)) (make-directory dir)) + (db->html-files db dir index-filename dir) + (path->uri (in-vicinity (sub-vicinity "" dir) index-filename))) + +;;@args db dir index-filename +;;@args db dir +;;@0 is just like @code{db->html-directory}, but calls +;;@code{browse-url-netscape} with the uri for the top page after the +;;pages are created. +(define (db->netscape . args) + (browse-url-netscape (apply db->html-directory args))) -- cgit v1.2.3