\\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 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)
(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"))))
((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 ))
(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)))))))))
(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.
;;
;;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))
(require 'database-commands)
(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 (if (eq? 'boolean type) 'boolean '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-table) 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 ordinal)) ;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)
(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))))))
(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 " |