From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 3a1 --- db2html.scm | 77 ++++++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 56 insertions(+), 21 deletions(-) (limited to 'db2html.scm') diff --git a/db2html.scm b/db2html.scm index 3462966..df34389 100644 --- a/db2html.scm +++ b/db2html.scm @@ -8,7 +8,7 @@ ;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 +;2. I have made no warranty 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. ; @@ -18,11 +18,20 @@ ;each case. (require 'uri) +(require 'printf) (require 'html-form) -(require 'net-clients) +(require 'directory) +(require 'databases) +(require 'string-case) (require 'string-search) +(require 'common-list-functions) +(require-if 'compiling 'pretty-print) +(require-if 'compiling 'database-commands) +(require 'hash) +(define (crc:hash-obj obj) (number->string (hash obj most-positive-fixnum) 16)) ;;@code{(require 'db->html)} +;;@ftindex db->html ;;@body (define (html:table options . rows) @@ -224,11 +233,11 @@ ;;@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}. +;;Returns procedure (of @var{db}) which returns procedure to modify +;;row of @1. @2 is the list of @dfn{null} keys indicating the row is +;;to be deleted when any matches its corresponding primary key. +;;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) @@ -251,7 +260,7 @@ (table:update new-row) ((rdb 'sync-database)) #t) (else '("Row changed by other user")))) - ((equal? null-keys new-pkeys) ;blanked keys + ((command:null-key? 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 )) @@ -268,6 +277,26 @@ (apply table:delete pkeys)) ((rdb 'sync-database)) #t))))))))) +(define (command:null-key? null-keys new-pkeys) + (define sts #f) + (for-each (lambda (nuk nep) (if (equal? nuk nep) (set! sts #t))) + null-keys + new-pkeys) + sts) + +(define (make-defaulter arity type) + `(lambda (pl) + ',(case arity + ((optional nary) '()) + ((boolean) #f) + ((single nary1) + (case type + ((string) '("")) + ((symbol) '(nil)) + ((number) '(0)) + (else '(#f)))) + (else (slib:error 'make-defaulter 'unknown 'arity arity))))) + ;;@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. @@ -286,6 +315,7 @@ ;;@end table (define (command:make-editable-table rdb table-name . args) (define table ((rdb 'open-table) table-name #t)) + (require 'database-commands) (let ((pkl (table 'primary-limit)) (columns (table 'column-names)) (domains (table 'column-domains)) @@ -313,7 +343,8 @@ (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)) '())) + (if tab-name (get-foreign-choices + ((rdb 'open-table) tab-name #f)) '())) domains)) (define-tables rdb `(,(symbol-append table-name '- 'params) @@ -323,7 +354,7 @@ ,@field-specs)) `(,(symbol-append table-name '- 'pname) ((name string)) - ((parameter-index uint)) ;should be address-params + ((parameter-index ordinal)) ;should be address-params (("*keys*" 1) ("*row-hash*" 2) ,@(map (lambda (idx column) (list (symbol->string column) idx)) @@ -335,7 +366,10 @@ ,(symbol-append table-name '- 'pname) (command:modify-table ',table-name ',(map (lambda (fs) - (caadr (caddar (cddddr fs)))) + (define dfl + ((slib:eval (car (cddddr fs))) + '())) + (if (pair? dfl) (car dfl) dfl)) (butnthcdr pkl field-specs)) ,@args) ,(string-append "Modify " (symbol->string table-name)))))) @@ -424,16 +458,17 @@ ;;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) + (set! dir (if dir (sub-vicinity "" dir) "")) + (call-with-output-file (in-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)))))) + (let ((catdat ((db 'open-table) '*catalog-data* #f))) + ((or (catdat 'for-each-row-in-order) (catdat 'for-each-row)) + (lambda (row) + (call-with-output-file + (in-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 @@ -457,7 +492,7 @@ ;;@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 +;;@code{browse-url} with the uri for the top page after the ;;pages are created. (define (db->netscape . args) - (browse-url-netscape (apply db->html-directory args))) + (browse-url (apply db->html-directory args))) -- cgit v1.2.3