aboutsummaryrefslogtreecommitdiffstats
path: root/db2html.scm
diff options
context:
space:
mode:
Diffstat (limited to 'db2html.scm')
-rw-r--r--db2html.scm77
1 files changed, 56 insertions, 21 deletions
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)))