From bd9733926076885e3417b74de76e4c9c7bc56254 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:28 -0800 Subject: Import Upstream version 2c7 --- htmlform.scm | 278 +++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 232 insertions(+), 46 deletions(-) (limited to 'htmlform.scm') diff --git a/htmlform.scm b/htmlform.scm index f8656e2..c7ce1dc 100644 --- a/htmlform.scm +++ b/htmlform.scm @@ -1,5 +1,4 @@ -;;; "htmlform.scm" Generate HTML 2.0 forms and -*-scheme-*- -;;; service CGI requests from RDB command table. +;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*- ; Copyright 1997, 1998 Aubrey Jaffer ; ;Permission to copy this software, to redistribute it, and to use it @@ -25,6 +24,8 @@ (require 'parameters) (require 'fluid-let) (require 'dynamic-wind) +(require 'pretty-print) +(require 'object->string) (require 'string-case) (require 'string-port) (require 'string-search) @@ -41,71 +42,267 @@ ;;@body Returns a string with character substitutions appropriate to ;;send @1 as an @dfn{attribute-value}. -(define (html:atval txt) ; attribute-value +(define (make-atval txt) ; attribute-value (if (symbol? txt) (set! txt (symbol->string txt))) - (string-subst txt - "&" "&" - "\"" """ - "<" "<" - ">" ">")) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "\"" """ + "<" "<" + ">" ">"))) ;;@body Returns a string with character substitutions appropriate to ;;send @1 as an @dfn{plain-text}. -(define (html:plain txt) ; plain-text `Data Characters' +(define (make-plain txt) ; plain-text `Data Characters' (if (symbol? txt) (set! txt (symbol->string txt))) - (string-subst txt - "&" "&" - "<" "<" - ">" ">")) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "<" "<" + ">" ">"))) + +;;@args title backlink tags ... +;;@args title backlink +;;@args title +;; +;;Outputs headers for an HTML page named @1. If string arguments @2 +;;... are supplied they are printed verbatim within the @t{} +;;section. +(define (html:start-page title . args) + (define backlink (if (null? args) #f (car args))) + (if (not (null? args)) (set! args (cdr args))) + (html:printf "\\n") + (html:printf "\\n") + (html:comment "HTML by SLIB" + "http://swissnet.ai.mit.edu/~jaffer/SLIB.html") + (html:printf "%s%s\\n" + (apply string-append args) (make-plain title)) + (html:printf "

%s

\\n" + (or backlink (make-plain title)))) + +;;@body Outputs HTML codes to end a page. +(define (html:end-page) + (html:printf "\\n") + (html:printf "\\n")) + +;;@body Writes (using @code{html:printf}) the strings @1, @2 as +;;@dfn{PRE}formmated plain text (rendered in fixed-width font). +;;Newlines are inserted between @1, @2. HTML tags (@samp{}) +;;within @2 will be visible verbatim. +(define (html:pre line1 . lines) + (html:printf "

\\n%s" (make-plain line1))
+  (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
+  (html:printf "

\\n")) ;;@body Writes (using @code{html:printf}) the strings @1 as HTML ;;comments. -(define (html:comment . lines) +(define (html:comment line1 . lines) (html:printf "\\n")) +;;@section HTML Tables + +;;@body +(define (html:start-table caption) + (html:printf "\\n") + (html:printf "\\n" (make-plain caption))) + +;;@body +(define (html:end-table) + (html:printf "

\\n")) + +;;@body Outputs a heading row for the currently-started table. +(define (html:heading columns) + (html:printf "\\n") + (for-each (lambda (datum) (html:printf "%s\\n" (or datum ""))) columns)) + +;;@body Outputs a heading row with column-names @1 linked to URLs @2. +(define (html:href-heading columns urls) + (html:heading + (map (lambda (column url) + (if url + (sprintf #f "%s" url column) + column)) + columns urls))) + +;;@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 prints the table row to @var{*html:output-port*}. +(define (make-row-converter pkl foreigns) + (lambda (data-row) + (define anchored? #f) + (define (present datum) + (cond ((or (string? datum) (symbol? datum)) + (html:printf "%s" (make-plain datum))) + (else + (html:printf + "

\\n%s

\\n" + (make-plain (call-with-output-string + (lambda (port) + (pretty-print datum port)))))))) + (html:printf "") + (for-each (lambda (datum foreign) + (html:printf "") + (cond ((not datum)) + ((null? datum)) + ((not anchored?) + (html:printf "= idx pkl)) + (html:printf + " %s" (make-atval (car contents)))))) + (html:printf "\">") + (set! anchored? (not (zero? pkl))))) + (cond ((not datum)) ((null? datum)) + ((not foreign) (present datum)) + ((zero? pkl) + (html:printf "" foreign) + (present datum) + (html:printf "")) + (else + (html:printf "" + foreign (make-atval datum)) + (present datum) + (html:printf "")))) + data-row foreigns) + (html:printf "\\n"))) + +;;@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{} +;;Writes HTML for @2 table @3 to @var{*html:output-port*}. +;; +;;The optional @4 @dots{} arguments restrict actions to a subset of +;;the table. @xref{Table Operations, match-key}. +(define (table->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))) + (html:start-table caption) + (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)) + (apply (table 'for-each-row) (make-row-converter primlim tags) args) + (html:end-table))) + +;;@body +;;Writes a complete HTML page to @var{*html:output-port*}. The string +;;@3 names the page which refers to this one. +(define (table->page db table-name index-filename) + (dynamic-wind + (lambda () + (if index-filename + (html:start-page + table-name + (sprintf #f "%s" + index-filename + (make-atval table-name) + (make-plain table-name))) + (html:start-page table-name))) + (lambda () (table->html table-name db table-name)) + html:end-page)) + +;;@body +;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}. +(define (catalog->html db caption) + (html:start-table caption) + (html:heading '(table columns)) + ((((db 'open-table) '*catalog-data* #f) 'for-each-row) + (lambda (row) + (cond ((and (eq? '*columns* (caddr row)) + (not (eq? '*columns* (car row))))) + (else ((make-row-converter + 0 (list (table-name->filename (car row)) + (table-name->filename (caddr row)))) + (list (car row) (caddr row)))))))) + +;;@body +;;Writes a complete HTML page for the catalog of @1 to +;;@var{*html:output-port*}. +(define (catalog->page db caption) + (dynamic-wind + (lambda () (html:start-page caption)) + (lambda () + (catalog->html db caption) + (html:end-table)) + html:end-page)) + +;;@section HTML Forms + (define (html:dt-strong-doc name doc) (if (and (string? doc) (not (equal? "" doc))) (html:printf "

%s (%s)\\n" - (html:plain name) (html:plain doc)) - (html:printf "

%s\\n" (html:plain name)))) + (make-plain name) (make-plain doc)) + (html:printf "

%s\\n" (make-plain name)))) (define (html:checkbox name doc pname) (html:printf "

\\n" - (html:atval pname)) + (make-atval pname)) (if (and (string? doc) (not (equal? "" doc))) (html:printf "

%s (%s)\\n" - (html:plain name) (html:plain doc)) - (html:printf "

%s\\n" (html:plain name)))) + (make-plain name) (make-plain doc)) + (html:printf "

%s\\n" (make-plain name)))) (define (html:text name doc pname default) (cond (default (html:dt-strong-doc name doc) (html:printf "

\\n" - (html:atval pname) + (make-atval pname) (max 20 (string-length (if (symbol? default) (symbol->string default) default))) - (html:atval default))) + (make-atval default))) (else (html:dt-strong-doc name doc) - (html:printf "

\\n" (html:atval pname))))) + (html:printf "

\\n" (make-atval pname))))) (define (html:text-area name doc pname default-list) (html:dt-strong-doc name doc) (html:printf "

\\n")) (define (html:s %s\\n" - (html:atval pname) (html:atval value) + (make-atval pname) (make-atval value) (if (member value default-list) " CHECKED" "") - (html:plain value))) + (make-plain value))) value-list)) ((nary nary1) (for-each (lambda (value) (html:printf "

%s\\n" - (html:atval pname) (html:atval value) + (make-atval pname) (make-atval value) (if (member value default-list) " CHECKED" "") - (html:plain value))) + (make-plain value))) value-list))) (html:printf "")) @@ -166,7 +363,7 @@ (cond ((not (memq method '(get head post put delete))) (slib:error 'html:start-form "method unknown:" method))) (html:printf "

\\n")) -;;@body Outputs headers for an HTML page named @1. -(define (html:start-page title) - (html:printf "\\n") - (html:comment) - (html:printf "%s\\n" (html:plain title)) - (html:printf "

%s

\\n" (html:plain title))) - -;;@body Outputs HTML codes to end a page. -(define (html:end-page) - (html:printf "\\n")) - (define (html:generate-form comname method action docu pnames docs aliases arities types default-lists value-lists) (define aliast (map list pnames)) @@ -198,7 +384,7 @@ (dynamic-wind (lambda () (html:printf "

%s:

%s

\\n" - (html:plain comname) (html:plain docu)) + (make-plain comname) (make-plain docu)) (html:start-form 'post action)) (lambda () (for-each -- cgit v1.2.3