From: uid67408 Date: Mon, 29 Dec 2003 07:34:21 +0000 (+0000) Subject: Repackage using standard packaging tools. X-Git-Tag: 20090517-FFI~1743 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a53b883984200512207e4832125575f980b911f;p=mit-scheme.git Repackage using standard packaging tools. --- diff --git a/v7/src/ssp/compile.scm b/v7/src/ssp/compile.scm index 772c6a3a9..fd5234a02 100644 --- a/v7/src/ssp/compile.scm +++ b/v7/src/ssp/compile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compile.scm,v 1.1 2003/12/29 05:24:29 uid67408 Exp $ +$Id: compile.scm,v 1.2 2003/12/29 07:30:39 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -23,14 +23,18 @@ USA. |# -;;;; XDOC/mod-lisp compilation +;;;; SSP/XDOC compilation +(load-option 'CREF) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (compile-file "xhtml-expander") - (compile-file "xhtml") - (compile-file "db") - (compile-file "mod-lisp") - (compile-file "matcher") - (compile-file "xdoc") - (compile-file "xmlrpc"))) \ No newline at end of file + (for-each compile-file + '("db" + "expenv" + "matcher" + "mod-lisp" + "xdoc" + "xhtml" + "xhtml-expander" + "xmlrpc")) + (cref/generate-constructors "ssp"))) \ No newline at end of file diff --git a/v7/src/ssp/db.scm b/v7/src/ssp/db.scm index 63af5a2e3..8c1145992 100644 --- a/v7/src/ssp/db.scm +++ b/v7/src/ssp/db.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: db.scm,v 1.1 2003/12/29 05:24:32 uid67408 Exp $ +$Id: db.scm,v 1.2 2003/12/29 07:31:03 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -27,14 +27,13 @@ USA. (declare (usual-integrations)) -(define db-name "six002x_spring04") (define pgsql-conn #f) (define *database-connection* #f) (define *user-name*) (define *ps-number*) (define *page-key*) -(define (with-database-connection ps-number pathname thunk) +(define (with-database-connection db-name ps-number pathname thunk) (if (not (and pgsql-conn (pgsql-conn-open? pgsql-conn))) (set! pgsql-conn (open-pgsql-conn (string-append "dbname=" db-name)))) (let ((page-key (enough-namestring pathname (server-root-dir)))) @@ -78,54 +77,50 @@ USA. (set! pgsql-conn #f) unspecific))) -(define-expander 'db-run-query - (lambda strings - (exec-pgsql-query (database-connection) - (string-append (apply string-append strings) ";")))) - -(define-expander 'db-run-cmd - (lambda strings - (let ((result (apply db-run-query strings))) - (let ((status (pgsql-cmd-status result))) - (pgsql-clear result) - status)))) - -(define-expander 'db-quote - (lambda (object) - (if object - (if (exact-integer? object) - (number->string object) - (string-append "'" - (escape-pgsql-string - (if (symbol? object) - (symbol-name object) - object)) - "'")) - "NULL"))) +(define (db-run-query . strings) + (exec-pgsql-query (database-connection) + (string-append (apply string-append strings) ";"))) + +(define (db-run-cmd . strings) + (let ((result (apply db-run-query strings))) + (let ((status (pgsql-cmd-status result))) + (pgsql-clear result) + status))) + +(define (db-quote object) + (if object + (if (exact-integer? object) + (number->string object) + (string-append "'" + (escape-pgsql-string + (if (symbol? object) + (symbol-name object) + object)) + "'")) + "NULL")) ;;;; Problem-set registration -(define-expander 'db-register-problem-set - (lambda (ps-number directory) - (db-run-cmd "DELETE FROM saved_inputs" - " WHERE ps_number = " (db-quote ps-number)) - (db-run-cmd "DELETE FROM saved_outputs" - " WHERE ps_number = " (db-quote ps-number)) - (db-run-cmd "DELETE FROM registered_outputs" - " WHERE ps_number = " (db-quote ps-number)) - (let ((n-parts 0) - (n-outputs 0)) - (for-each (lambda (pathname) - (if (not (string=? (pathname-name pathname) "index")) - (begin - (set! n-parts (+ n-parts 1)) - (set! n-outputs - (+ n-outputs - (register-part-outputs ps-number - pathname))))) - unspecific) - (directory-read (merge-pathnames "*.xdoc" directory))) - (values n-parts n-outputs)))) +(define (db-register-problem-set ps-number directory) + (db-run-cmd "DELETE FROM saved_inputs" + " WHERE ps_number = " (db-quote ps-number)) + (db-run-cmd "DELETE FROM saved_outputs" + " WHERE ps_number = " (db-quote ps-number)) + (db-run-cmd "DELETE FROM registered_outputs" + " WHERE ps_number = " (db-quote ps-number)) + (let ((n-parts 0) + (n-outputs 0)) + (for-each (lambda (pathname) + (if (not (string=? (pathname-name pathname) "index")) + (begin + (set! n-parts (+ n-parts 1)) + (set! n-outputs + (+ n-outputs + (register-part-outputs ps-number + pathname))))) + unspecific) + (directory-read (merge-pathnames "*.xdoc" directory))) + (values n-parts n-outputs))) (define (register-part-outputs ps-number pathname) (with-xdoc-expansion-context ps-number pathname @@ -160,66 +155,62 @@ USA. ", " (db-quote part) ")")) -(define-expander 'db-registered-problem-sets - (lambda () - (let ((result - (db-run-query "SELECT DISTINCT ps_number" - " FROM registered_outputs" - " ORDER BY ps_number"))) - (let ((n (pgsql-n-tuples result))) - (do ((i 0 (+ i 1)) - (numbers '() - (cons (string->number (pgsql-get-value result i 0)) - numbers))) - ((= i n) - (pgsql-clear result) - (reverse! numbers))))))) - -(define-expander 'db-ps-problem-names - (lambda (ps-number) - (let ((result - (db-run-query "SELECT name" - " FROM registered_outputs" - " WHERE ps_number = " (db-quote ps-number)))) - (let ((n (pgsql-n-tuples result))) - (do ((i 0 (+ i 1)) - (names '() (cons (pgsql-get-value result i 0) names))) - ((= i n) - (pgsql-clear result) - names)))))) - -(define-expander 'db-problem-submitted? - (lambda (ps-number name user-name) - (let ((result - (db-run-query "SELECT submitter" - " FROM saved_outputs" - " WHERE ps_number = " (db-quote ps-number) - " AND name = " (db-quote name) - " AND user_name = " (db-quote user-name)))) - (let ((submitted? - (and (> (pgsql-n-tuples result) 0) - (let ((v (pgsql-get-value result 0 0))) - (and v - (not (string-null? v))))))) - (pgsql-clear result) - submitted?)))) +(define (db-registered-problem-sets) + (let ((result + (db-run-query "SELECT DISTINCT ps_number" + " FROM registered_outputs" + " ORDER BY ps_number"))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (numbers '() + (cons (string->number (pgsql-get-value result i 0)) + numbers))) + ((= i n) + (pgsql-clear result) + (reverse! numbers)))))) + +(define (db-ps-problem-names ps-number) + (let ((result + (db-run-query "SELECT name" + " FROM registered_outputs" + " WHERE ps_number = " (db-quote ps-number)))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (names '() (cons (pgsql-get-value result i 0) names))) + ((= i n) + (pgsql-clear result) + names))))) + +(define (db-problem-submitted? ps-number name user-name) + (let ((result + (db-run-query "SELECT submitter" + " FROM saved_outputs" + " WHERE ps_number = " (db-quote ps-number) + " AND name = " (db-quote name) + " AND user_name = " (db-quote user-name)))) + (let ((submitted? + (and (> (pgsql-n-tuples result) 0) + (let ((v (pgsql-get-value result 0 0))) + (and v + (not (string-null? v))))))) + (pgsql-clear result) + submitted?))) -(define-expander 'db-get-ps-structure - (lambda () - (let ((result - (db-run-query "SELECT ps_number, ps_part, name" - " FROM registered_outputs" - " ORDER BY ps_number, ps_part, name"))) - (let ((n (pgsql-n-tuples result))) - (do ((i 0 (+ i 1)) - (items '() - (cons (vector (string->number (pgsql-get-value result i 0)) - (pgsql-get-value result i 1) - (pgsql-get-value result i 2)) - items))) - ((= i n) - (pgsql-clear result) - (ps-structure->tree (reverse! items)))))))) +(define (db-get-ps-structure) + (let ((result + (db-run-query "SELECT ps_number, ps_part, name" + " FROM registered_outputs" + " ORDER BY ps_number, ps_part, name"))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (items '() + (cons (vector (string->number (pgsql-get-value result i 0)) + (pgsql-get-value result i 1) + (pgsql-get-value result i 2)) + items))) + ((= i n) + (pgsql-clear result) + (ps-structure->tree (reverse! items))))))) (define (ps-structure->tree items) (map (lambda (pset) @@ -356,86 +347,81 @@ USA. " AND ps_number = " (db-quote *ps-number*) " AND name = " (db-quote id))) -(define-expander 'db-get-saved-output - (lambda (user-name ps-number name) - (let ((result - (db-run-query "SELECT correctness, submitter, late_p" - " FROM saved_outputs" - " WHERE user_name = " (db-quote user-name) - " AND ps_number = " (db-quote ps-number) - " AND name = " (db-quote name)))) - (if (> (pgsql-n-tuples result) 0) - (let ((correctness (pgsql-get-value result 0 0)) - (submitter (pgsql-get-value result 0 1)) - (late? (string=? (pgsql-get-value result 0 2) "t"))) - (pgsql-clear result) - (values correctness - (and submitter (string->symbol submitter)) - late?)) - (begin - (pgsql-clear result) - (values #f #f #f)))))) +(define (db-get-saved-output user-name ps-number name) + (let ((result + (db-run-query "SELECT correctness, submitter, late_p" + " FROM saved_outputs" + " WHERE user_name = " (db-quote user-name) + " AND ps_number = " (db-quote ps-number) + " AND name = " (db-quote name)))) + (if (> (pgsql-n-tuples result) 0) + (let ((correctness (pgsql-get-value result 0 0)) + (submitter (pgsql-get-value result 0 1)) + (late? (string=? (pgsql-get-value result 0 2) "t"))) + (pgsql-clear result) + (values correctness + (and submitter (string->symbol submitter)) + late?)) + (begin + (pgsql-clear result) + (values #f #f #f))))) ;;;; Persistent values -(define-expander 'db-get-persistent-value - (lambda (name default) - (let ((result - (db-run-query (persistent-value-query name '(var_value) #f)))) - (let ((string - (and (> (pgsql-n-tuples result) 0) - (pgsql-get-value result 0 0)))) - (pgsql-clear result) - (if string - (read (open-input-string string)) - default))))) - -(define-expander 'db-set-persistent-value! - (lambda (name object) - (let ((value (write-to-string object)) - (result - (db-run-query (persistent-value-query name '(var_value) #t)))) - (if (> (pgsql-n-tuples result) 0) - (let ((same-value? (string=? (pgsql-get-value result 0 0) value))) - (pgsql-clear result) - (if (not same-value?) - (db-run-cmd "UPDATE persistent_values SET" - " var_value = " - (db-quote value) - " WHERE " - (persistent-value-condition name)))) - (begin - (pgsql-clear result) +(define (db-get-persistent-value name default) + (let ((result + (db-run-query (persistent-value-query name '(var_value) #f)))) + (let ((string + (and (> (pgsql-n-tuples result) 0) + (pgsql-get-value result 0 0)))) + (pgsql-clear result) + (if string + (read (open-input-string string)) + default)))) + +(define (db-set-persistent-value! name object) + (let ((value (write-to-string object)) + (result + (db-run-query (persistent-value-query name '(var_value) #t)))) + (if (> (pgsql-n-tuples result) 0) + (let ((same-value? (string=? (pgsql-get-value result 0 0) value))) + (pgsql-clear result) + (if (not same-value?) + (db-run-cmd "UPDATE persistent_values SET" + " var_value = " + (db-quote value) + " WHERE " + (persistent-value-condition name)))) + (begin + (pgsql-clear result) + (db-run-cmd "INSERT INTO persistent_values VALUES" + " (" (db-quote *user-name*) + ", " (db-quote *page-key*) + ", " (db-quote name) + ", " (db-quote value) + ")"))))) + +(define (db-intern-persistent-value! name get-object) + (let ((result + (db-run-query (persistent-value-query name '(var_value) #t)))) + (if (> (pgsql-n-tuples result) 0) + (let ((value (pgsql-get-value result 0 0))) + (pgsql-clear result) + (read (open-input-string value))) + (begin + (pgsql-clear result) + (let ((object (get-object))) (db-run-cmd "INSERT INTO persistent_values VALUES" " (" (db-quote *user-name*) ", " (db-quote *page-key*) ", " (db-quote name) - ", " (db-quote value) - ")")))))) - -(define-expander 'db-intern-persistent-value! - (lambda (name get-object) - (let ((result - (db-run-query (persistent-value-query name '(var_value) #t)))) - (if (> (pgsql-n-tuples result) 0) - (let ((value (pgsql-get-value result 0 0))) - (pgsql-clear result) - (read (open-input-string value))) - (begin - (pgsql-clear result) - (let ((object (get-object))) - (db-run-cmd "INSERT INTO persistent_values VALUES" - " (" (db-quote *user-name*) - ", " (db-quote *page-key*) - ", " (db-quote name) - ", " (db-quote (write-to-string object)) - ")") - object)))))) - -(define-expander 'db-delete-persistent-value! - (lambda (name) - (db-run-cmd "DELETE FROM persistent_values WHERE " - (persistent-value-condition name)))) + ", " (db-quote (write-to-string object)) + ")") + object))))) + +(define (db-delete-persistent-value! name) + (db-run-cmd "DELETE FROM persistent_values WHERE " + (persistent-value-condition name))) (define (persistent-value-query name fields for-update?) (string-append "SELECT " (field-list->db-string fields) @@ -450,13 +436,11 @@ USA. ;;;; Clear submitted/late -(define-expander 'db-saved-submitters - (lambda (user-name) - (db-marked-submitters user-name "submitter IS NOT NULL"))) +(define (db-saved-submitters user-name) + (db-marked-submitters user-name "submitter IS NOT NULL")) -(define-expander 'db-late-submitters - (lambda (user-name) - (db-marked-submitters user-name "late_p"))) +(define (db-late-submitters user-name) + (db-marked-submitters user-name "late_p")) (define (db-marked-submitters user-name condition) (let ((result @@ -478,21 +462,19 @@ USA. (pgsql-clear result) (reverse! names))))))) -(define-expander 'db-clear-submitter - (lambda (user-name number) - (receive (ps-number submitter) (parse-problem-number number) - (db-run-cmd "UPDATE saved_inputs" - " SET submitter IS NULL" - " WHERE user_name = " (db-quote user-name) - " AND ps_number = " (db-quote ps-number) - " AND submitter = " (db-quote submitter)) - (db-set-output-field user-name ps-number submitter - "submitter IS NULL")))) - -(define-expander 'db-clear-late-flag - (lambda (user-name number) - (receive (ps-number submitter) (parse-problem-number number) - (db-set-output-field user-name ps-number submitter "late_p = FALSE")))) +(define (db-clear-submitter user-name number) + (receive (ps-number submitter) (parse-problem-number number) + (db-run-cmd "UPDATE saved_inputs" + " SET submitter IS NULL" + " WHERE user_name = " (db-quote user-name) + " AND ps_number = " (db-quote ps-number) + " AND submitter = " (db-quote submitter)) + (db-set-output-field user-name ps-number submitter + "submitter IS NULL"))) + +(define (db-clear-late-flag user-name number) + (receive (ps-number submitter) (parse-problem-number number) + (db-set-output-field user-name ps-number submitter "late_p = FALSE"))) (define (db-set-output-field user-name ps-number submitter assignment) (let ((result @@ -507,9 +489,8 @@ USA. ;;;; Users -(define-expander 'db-known-user? - (lambda (user-name) - (known-user? user-name #f))) +(define (db-known-user? user-name) + (known-user? user-name #f)) (define (known-user? user-name for-update?) (let ((result @@ -532,85 +513,76 @@ USA. (if (not (known-user? user-name #t)) (error "Unknown user:" user-name))) -(define-expander 'db-known-users - (lambda (condition) - (let ((result - (db-run-query "SELECT user_name" - " FROM users" - (case condition - ((enabled) " WHERE enabled_p") - ((disabled) " WHERE NOT enabled_p") - (else "")) - " ORDER BY user_name"))) - (let ((n (pgsql-n-tuples result))) - (let loop ((i 0) (users '())) - (if (< i n) - (loop (+ i 1) (cons (pgsql-get-value result i 0) users)) - (begin - (pgsql-clear result) - (reverse! users)))))))) - -(define-expander 'db-new-user-account - (lambda (user-name first-names last-name password enabled?) - (if (known-user? user-name #t) - #f - (begin - (db-run-cmd "INSERT INTO users VALUES" - " (" (db-quote user-name) - ", " (db-quote first-names) - ", " (db-quote last-name) - ", " (db-quote (encrypt-password password)) - ", " "FALSE" - ", " (if enabled? "TRUE" "FALSE") - ")") - #t)))) - -(define-expander 'db-change-user-password - (lambda (user-name password) - (guarantee-known-user user-name) - (db-run-cmd "UPDATE users" - " SET password = " (db-quote (encrypt-password password)) - " WHERE user_name = " (db-quote user-name)))) +(define (db-known-users condition) + (let ((result + (db-run-query "SELECT user_name" + " FROM users" + (case condition + ((enabled) " WHERE enabled_p") + ((disabled) " WHERE NOT enabled_p") + (else "")) + " ORDER BY user_name"))) + (let ((n (pgsql-n-tuples result))) + (let loop ((i 0) (users '())) + (if (< i n) + (loop (+ i 1) (cons (pgsql-get-value result i 0) users)) + (begin + (pgsql-clear result) + (reverse! users))))))) + +(define (db-new-user-account user-name first-names last-name password enabled?) + (if (known-user? user-name #t) + #f + (begin + (db-run-cmd "INSERT INTO users VALUES" + " (" (db-quote user-name) + ", " (db-quote first-names) + ", " (db-quote last-name) + ", " (db-quote (encrypt-password password)) + ", " "FALSE" + ", " (if enabled? "TRUE" "FALSE") + ")") + #t))) + +(define (db-change-user-password user-name password) + (guarantee-known-user user-name) + (db-run-cmd "UPDATE users" + " SET password = " (db-quote (encrypt-password password)) + " WHERE user_name = " (db-quote user-name))) -(define-expander 'db-user-real-name - (lambda (user-name) - (let ((result - (db-run-query "SELECT first_names, last_name" - " FROM users" - " WHERE user_name = " (db-quote user-name)))) - (if (> (pgsql-n-tuples result) 0) - (let ((first (pgsql-get-value result 0 0)) - (last (pgsql-get-value result 0 1))) - (pgsql-clear result) - (values first last)) - (begin - (pgsql-clear result) - (error "Unknown user:" user-name) - (values #f #f)))))) - -(define-expander 'db-set-user-real-name - (lambda (user-name first-names last-name) - (guarantee-known-user user-name) - (db-run-cmd "UPDATE users" - " SET first_names = " (db-quote first-names) - ", last_name = " (db-quote last-name) - " WHERE user_name = " (db-quote user-name)))) - -(define-expander 'db-user-enabled? - (lambda (user-name) - (get-user-flag user-name "enabled_p"))) - -(define-expander 'db-user-administrator? - (lambda (user-name) - (get-user-flag user-name "administrator_p"))) - -(define-expander 'db-set-user-enabled - (lambda (user-name value) - (set-user-flag user-name "enabled_p" value))) - -(define-expander 'db-set-user-administrator - (lambda (user-name value) - (set-user-flag user-name "administrator_p" value))) +(define (db-user-real-name user-name) + (let ((result + (db-run-query "SELECT first_names, last_name" + " FROM users" + " WHERE user_name = " (db-quote user-name)))) + (if (> (pgsql-n-tuples result) 0) + (let ((first (pgsql-get-value result 0 0)) + (last (pgsql-get-value result 0 1))) + (pgsql-clear result) + (values first last)) + (begin + (pgsql-clear result) + (error "Unknown user:" user-name) + (values #f #f))))) + +(define (db-set-user-real-name user-name first-names last-name) + (guarantee-known-user user-name) + (db-run-cmd "UPDATE users" + " SET first_names = " (db-quote first-names) + ", last_name = " (db-quote last-name) + " WHERE user_name = " (db-quote user-name))) + +(define (db-user-enabled? user-name) + (get-user-flag user-name "enabled_p")) + +(define (db-user-administrator? user-name) + (get-user-flag user-name "administrator_p")) + +(define (db-set-user-enabled user-name value) + (set-user-flag user-name "enabled_p" value)) + +(define (db-set-user-administrator user-name value) + (set-user-flag user-name "administrator_p" value)) (define (get-user-flag user-name flag-name) (let ((result @@ -648,13 +620,12 @@ USA. (error "Unknown result from htpasswd:" pw-line)) (substring pw-line 4 (fix:- (string-length pw-line) 1)))) -(define-expander 'db-valid-password? - (lambda (string) - (and (fix:>= (string-length string) 8) - (not (string-find-next-char-in-set string char-set:not-password)) - (string-find-next-char-in-set string char-set:lower-case) - (string-find-next-char-in-set string char-set:upper-case) - (string-find-next-char-in-set string char-set:numeric)))) +(define (db-valid-password? string) + (and (fix:>= (string-length string) 8) + (not (string-find-next-char-in-set string char-set:not-password)) + (string-find-next-char-in-set string char-set:lower-case) + (string-find-next-char-in-set string char-set:upper-case) + (string-find-next-char-in-set string char-set:numeric))) (define char-set:password (char-set-union char-set:alphanumeric @@ -663,11 +634,10 @@ USA. (define char-set:not-password (char-set-invert char-set:password)) -(define-expander 'db-generate-password - (lambda () - (string-append (string (integer->char (+ (char->integer #\A) (random 26)))) - (string (integer->char (+ (char->integer #\a) (random 26)))) - (random-digit-string 6)))) +(define (db-generate-password) + (string-append (string (integer->char (+ (char->integer #\A) (random 26)))) + (string (integer->char (+ (char->integer #\a) (random 26)))) + (random-digit-string 6))) (define (random-digit-string n-chars) (string-pad-left (number->string (random (expt 10 n-chars))) n-chars #\0)) diff --git a/v7/src/ssp/expenv.scm b/v7/src/ssp/expenv.scm new file mode 100644 index 000000000..910d59e4a --- /dev/null +++ b/v7/src/ssp/expenv.scm @@ -0,0 +1,29 @@ +#| -*-Scheme-*- + +$Id: expenv.scm,v 1.1 2003/12/29 07:31:06 uid67408 Exp $ + +Copyright 2003 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XHTML expander environment + +(define expander-environment + (the-environment)) \ No newline at end of file diff --git a/v7/src/ssp/load.scm b/v7/src/ssp/load.scm index a770ea873..f89b93d24 100644 --- a/v7/src/ssp/load.scm +++ b/v7/src/ssp/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 1.1 2003/12/29 05:24:36 uid67408 Exp $ +$Id: load.scm,v 1.2 2003/12/29 07:31:10 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -23,17 +23,12 @@ USA. |# -;;;; XDOC/mod-lisp loader +;;;; SSP/XDOC loader -(load-option 'xml) -(load-option 'postgresql) -(load-option 'mime-codec) +(load-option 'XML) +(load-option 'POSTGRESQL) +(load-option 'MIME-CODEC) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (load "xhtml-expander") - (load "xhtml") - (load "mod-lisp") - (load "db") - (load "matcher") - (load "xdoc") - (load "xmlrpc"))) \ No newline at end of file + (package/system-loader "ssp" '() 'QUERY))) +(add-subsystem-identification! "SSP/XDOC" '(0 2)) \ No newline at end of file diff --git a/v7/src/ssp/mod-lisp.scm b/v7/src/ssp/mod-lisp.scm index 425b0beb1..fdc932d32 100644 --- a/v7/src/ssp/mod-lisp.scm +++ b/v7/src/ssp/mod-lisp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: mod-lisp.scm,v 1.1 2003/12/29 05:24:43 uid67408 Exp $ +$Id: mod-lisp.scm,v 1.2 2003/12/29 07:31:14 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -27,7 +27,7 @@ USA. (declare (usual-integrations)) -(define (start-server) +(define (start-mod-lisp-server) (start-server-internal 3000 (host-address-loopback) (cond ((file-directory? "/web/www/") "/web/www/") @@ -64,15 +64,6 @@ USA. port)) (lambda () (close-port port)))))) (lambda () (channel-close socket))))) - -(let ((target (the-environment)) - (source (->environment '(RUNTIME DEBUGGER)))) - (for-each (lambda (name) - (link-variables target name source name)) - '(MAKE-INITIAL-DSTATE - DSTATE/SUBPROBLEM - COMMAND/EARLIER-SUBPROBLEM - COMMAND/PRINT-SUBPROBLEM))) (define (condition->html condition) (call-with-output-string @@ -548,76 +539,85 @@ USA. ;;;; Request/response accessors -(let ((defaccess - (lambda (name accessor) - (define-expander name - (lambda () - (accessor *current-request*)))))) - (defaccess 'HTTP-REQUEST-ENTITY http-message-entity) - (defaccess 'HTTP-REQUEST-METHOD http-message-method) - (defaccess 'HTTP-REQUEST-URL http-message-url)) - -(let ((defget - (lambda (name accessor) - (define-expander name - (lambda (keyword #!optional error?) - (let ((p (assq keyword (accessor *current-request*)))) - (if p - (cdr p) - (begin - (if (and (not (default-object? error?)) error?) - (error:bad-range-argument keyword name)) - #f))))) - (define-expander (symbol-append name '-bindings) - (lambda () - (accessor *current-request*)))))) - (defget 'HTTP-REQUEST-HEADER http-message-headers) - (defget 'HTTP-REQUEST-URL-PARAMETER http-message-url-parameters) - (defget 'HTTP-REQUEST-POST-PARAMETER http-message-post-parameters) - (defget 'HTTP-REQUEST-COOKIE-PARAMETER http-message-cookie-parameters)) - -(define-expander 'HTTP-REQUEST-POST-PARAMETER-MULTIPLE - (lambda (keyword) - (let loop - ((bindings (http-message-post-parameters *current-request*)) - (strings '())) - (if (pair? bindings) - (loop (cdr bindings) - (if (eq? (caar bindings) keyword) - (cons (cdar bindings) strings) - strings)) - (reverse! strings))))) - -(define-expander 'HTTP-REQUEST-PATHNAME - (lambda () - *current-pathname*)) +(define (http-request-entity) + (http-message-entity *current-request*)) + +(define (http-request-method) + (http-message-method *current-request*)) + +(define (http-request-url) + (http-message-url *current-request*)) + +(define (http-request-header-bindings) + (http-message-headers *current-request*)) + +(define (http-request-url-parameter-bindings) + (http-message-url-parameters *current-request*)) + +(define (http-request-post-parameter-bindings) + (http-message-post-parameters *current-request*)) + +(define (http-request-cookie-parameter-bindings) + (http-message-cookie-parameters *current-request*)) + +(define (keyword-proc accessor name) + (lambda (keyword #!optional error?) + (let ((p (assq keyword (accessor *current-request*)))) + (if p + (cdr p) + (begin + (if (if (default-object? error?) #f error?) + (error:bad-range-argument keyword name)) + #f))))) + +(define http-request-header + (keyword-proc http-message-headers 'HTTP-REQUEST-HEADER)) + +(define http-request-url-parameter + (keyword-proc http-message-url-parameters 'HTTP-REQUEST-URL-PARAMETER)) + +(define http-request-post-parameter + (keyword-proc http-message-post-parameters 'HTTP-REQUEST-POST-PARAMETER)) + +(define http-request-cookie-parameter + (keyword-proc http-message-cookie-parameters 'HTTP-REQUEST-COOKIE-PARAMETER)) + +(define (http-request-post-parameter-multiple keyword) + (let loop + ((bindings (http-message-post-parameters *current-request*)) + (strings '())) + (if (pair? bindings) + (loop (cdr bindings) + (if (eq? (caar bindings) keyword) + (cons (cdar bindings) strings) + strings)) + (reverse! strings)))) -(define-expander 'HTTP-RESPONSE-HEADER - (lambda (keyword datum) - (guarantee-symbol keyword 'HTTP-RESPONSE-HEADER) - (guarantee-string datum 'HTTP-RESPONSE-HEADER) - (if (memq keyword '(STATUS CONTENT-LENGTH)) - (error "Illegal header keyword:" keyword)) - (add-header *current-response* keyword datum))) - -(define-expander 'HTTP-STATUS-RESPONSE - (lambda (code extra) - (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE) - (guarantee-string extra 'HTTP-STATUS-RESPONSE) - (status-response! *current-response* code extra))) - -(define-expander 'SERVER-ROOT-DIR - (lambda () - *root-dir*)) - -(define-expander 'HTTP-REQUEST-USER-NAME - (lambda () - (let ((auth (http-request-header 'authorization))) - (and auth - (cond ((string-prefix? "Basic " auth) - (decode-basic-auth-header auth 6 (string-length auth))) - (else - (error "Unknown authorization header format:" auth))))))) +(define (http-request-pathname) + *current-pathname*) + +(define (server-root-dir) + *root-dir*) + +(define (http-response-header keyword datum) + (guarantee-symbol keyword 'HTTP-RESPONSE-HEADER) + (guarantee-string datum 'HTTP-RESPONSE-HEADER) + (if (memq keyword '(STATUS CONTENT-LENGTH)) + (error "Illegal header keyword:" keyword)) + (add-header *current-response* keyword datum)) + +(define (http-status-response code extra) + (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE) + (guarantee-string extra 'HTTP-STATUS-RESPONSE) + (status-response! *current-response* code extra)) + +(define (http-request-user-name) + (let ((auth (http-request-header 'authorization))) + (and auth + (cond ((string-prefix? "Basic " auth) + (decode-basic-auth-header auth 6 (string-length auth))) + (else + (error "Unknown authorization header format:" auth)))))) (define (decode-basic-auth-header string start end) (let ((auth @@ -657,6 +657,4 @@ USA. (if (not (eof-object? line)) (begin (procedure line) - (loop)))))) - -(initialize-mime-extensions) \ No newline at end of file + (loop)))))) \ No newline at end of file diff --git a/v7/src/ssp/ssp.pkg b/v7/src/ssp/ssp.pkg new file mode 100644 index 000000000..79f15b10a --- /dev/null +++ b/v7/src/ssp/ssp.pkg @@ -0,0 +1,495 @@ +#| -*-Scheme-*- + +$Id: ssp.pkg,v 1.1 2003/12/29 07:34:21 uid67408 Exp $ + +Copyright 2003 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; SSP: packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../xml/xml") + +(define-package (runtime ssp) + (parent (runtime))) + +(define-package (runtime ssp xhtml) + (files "xhtml") + (parent (runtime ssp)) + (export (runtime ssp) + a + abbr + acronym + address + attributes + b + big + blockquote + body + br + button + caption + cite + code + col + colgroup + comment + convert-xhtml-string-value + dd + define-empty-element + define-standard-element + defn + del + dir + div + dl + dt + em + empty-element-constructor + flatten-xml-element-contents + form + h1 + h2 + h3 + h4 + h5 + head + hr + href + html + http-equiv + i + id-def + id-ref + img + input + ins + kbd + li + link + listing + menu + meta + ol + optgroup + option + p + pre + q + rel-link + s + samp + script + select + small + span + standard-element-constructor + strike + strong + style + style-link + sub + sup + table + tbody + td + textarea + tfoot + th + thead + title + tr + tt + u + ul + var + xhtml-dtd + xhtml-iri) + (export (runtime ssp-expander-environment) + a + abbr + acronym + address + attributes + b + big + blockquote + body + br + button + caption + cite + code + col + colgroup + comment + dd + defn + del + dir + div + dl + dt + em + form + h1 + h2 + h3 + h4 + h5 + head + hr + href + html + http-equiv + i + id-def + id-ref + img + input + ins + kbd + li + link + listing + menu + meta + ol + optgroup + option + p + pre + q + rel-link + s + samp + script + select + small + span + strike + strong + style + style-link + sub + sup + table + tbody + td + textarea + tfoot + th + thead + title + tr + tt + u + ul + var + xhtml-dtd + xhtml-iri)) + +(define-package (runtime ssp xhtml-expander) + (files "xhtml-expander") + (parent (runtime ssp)) + (export () + expand-xhtml-directory + expand-xhtml-file + read/expand-xml-file) + (export (runtime ssp) + expander-eval + make-expansion-environment) + (export (runtime ssp-expander-environment) + emit + define-sabbr + get-sabbr)) + +(define-package (runtime ssp-expander-environment) + (files "expenv") + (parent ()) + (export (runtime ssp xhtml-expander) + expander-environment)) + +(define-package (runtime ssp mod-lisp) + (files "mod-lisp") + (parent (runtime ssp)) + (import (runtime debugger) + command/earlier-subproblem + command/print-subproblem + dstate/subproblem + make-initial-dstate) + (export () + start-mod-lisp-server) + (export (runtime ssp) + define-mime-handler + define-subtree-handler + http-request-cookie-parameter + http-request-cookie-parameter-bindings + http-request-entity + http-request-header + http-request-header-bindings + http-request-method + http-request-pathname + http-request-post-parameter + http-request-post-parameter-bindings + http-request-post-parameter-multiple + http-request-url + http-request-url-parameter + http-request-url-parameter-bindings + http-request-user-name + http-response-header + http-status-response + mod-lisp-expander + server-root-dir) + (export (runtime ssp-expander-environment) + http-request-cookie-parameter + http-request-cookie-parameter-bindings + http-request-entity + http-request-header + http-request-header-bindings + http-request-method + http-request-pathname + http-request-post-parameter + http-request-post-parameter-bindings + http-request-post-parameter-multiple + http-request-url + http-request-url-parameter + http-request-url-parameter-bindings + http-request-user-name + http-response-header + http-status-response + server-root-dir) + (initialization (initialize-mime-extensions))) + +(define-package (runtime ssp xdoc) + (files "xdoc") + (parent (runtime ssp)) + (export (runtime ssp) + int0-attribute + with-xdoc-expansion-context + xd:answer + xd:answer? + xd:boolean + xd:boolean? + xd:case + xd:case? + xd:check-action + xd:check-action? + xd:check-input + xd:check-input? + xd:check-inputs + xd:check-inputs? + xd:checkbox + xd:checkbox? + xd:choice + xd:choice? + xd:default + xd:default? + xd:due-date + xd:due-date? + xd:expected-value + xd:expected-value? + xd:explain + xd:explain? + xd:head + xd:head? + xd:hint + xd:hint? + xd:label + xd:label? + xd:menu + xd:menu? + xd:menuindex + xd:menuindex? + xd:menuitem + xd:menuitem? + xd:number + xd:number? + xd:problem + xd:problem? + xd:radio-buttons + xd:radio-buttons? + xd:radio-entry + xd:radio-entry? + xd:refer + xd:refer? + xd:submit-action + xd:submit-action? + xd:text + xd:text? + xd:true-false + xd:true-false? + xd:when + xd:when? + xd:xdoc + xd:xdoc? + xdoc-db-id + xdoc-output?) + (export (runtime ssp-expander-environment) + xd:answer + xd:answer? + xd:boolean + xd:boolean? + xd:case + xd:case? + xd:check-action + xd:check-action? + xd:check-input + xd:check-input? + xd:check-inputs + xd:check-inputs? + xd:checkbox + xd:checkbox? + xd:choice + xd:choice? + xd:default + xd:default? + xd:due-date + xd:due-date? + xd:expected-value + xd:expected-value? + xd:explain + xd:explain? + xd:head + xd:head? + xd:hint + xd:hint? + xd:label + xd:label? + xd:menu + xd:menu? + xd:menuindex + xd:menuindex? + xd:menuitem + xd:menuitem? + xd:number + xd:number? + xd:problem + xd:problem? + xd:radio-buttons + xd:radio-buttons? + xd:radio-entry + xd:radio-entry? + xd:refer + xd:refer? + xd:submit-action + xd:submit-action? + xd:text + xd:text? + xd:true-false + xd:true-false? + xd:when + xd:when? + xd:xdoc + xd:xdoc? + xdoc-due-date-attributes + xdoc-due-date-string + xdoc-part-number)) + +(define-package (runtime ssp database-interface) + (files "db") + (parent (runtime ssp)) + (export (runtime ssp) + close-database + with-database-connection) + (export (runtime ssp xdoc) + db-delete-persistent-value! + db-get-persistent-value + db-intern-persistent-value! + db-previously-saved-input + db-previously-saved-output + db-save-input! + db-save-output! + db-set-persistent-value!) + (export (runtime ssp-expander-environment) + db-change-user-password + db-clear-late-flag + db-clear-submitter + db-delete-persistent-value! + db-generate-password + db-get-persistent-value + db-get-ps-structure + db-get-saved-output + db-intern-persistent-value! + db-known-user? + db-known-users + db-late-submitters + db-new-user-account + db-problem-submitted? + db-ps-problem-names + db-quote + db-register-problem-set + db-registered-problem-sets + db-run-cmd + db-run-query + db-saved-submitters + db-set-persistent-value! + db-set-user-administrator + db-set-user-enabled + db-set-user-real-name + db-user-administrator? + db-user-enabled? + db-user-real-name + db-valid-password?)) + +(define-package (runtime ssp xml-rpc) + (files "xmlrpc") + (parent (runtime ssp)) + (export (runtime ssp) + rpc-elt:array + rpc-elt:base64 + rpc-elt:boolean + rpc-elt:data + rpc-elt:date-time + rpc-elt:double + rpc-elt:fault + rpc-elt:i4 + rpc-elt:int + rpc-elt:member + rpc-elt:method-call + rpc-elt:method-name + rpc-elt:method-response + rpc-elt:name + rpc-elt:param + rpc-elt:params + rpc-elt:string + rpc-elt:struct + rpc-elt:value) + (export (runtime ssp-expander-environment) + rpc-elt:array + rpc-elt:base64 + rpc-elt:boolean + rpc-elt:data + rpc-elt:date-time + rpc-elt:double + rpc-elt:fault + rpc-elt:i4 + rpc-elt:int + rpc-elt:member + rpc-elt:method-call + rpc-elt:method-name + rpc-elt:method-response + rpc-elt:name + rpc-elt:param + rpc-elt:params + rpc-elt:string + rpc-elt:struct + rpc-elt:value)) \ No newline at end of file diff --git a/v7/src/ssp/xdoc.scm b/v7/src/ssp/xdoc.scm index 51a1d2242..98c352168 100644 --- a/v7/src/ssp/xdoc.scm +++ b/v7/src/ssp/xdoc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xdoc.scm,v 1.1 2003/12/29 05:24:51 uid67408 Exp $ +$Id: xdoc.scm,v 1.2 2003/12/29 07:31:19 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -35,6 +35,7 @@ USA. (define *xdoc-inputs*) (define *xdoc-outputs*) (define *trace-expansion-port* #f) +(define db-name "six002x_spring04") (define-mime-handler '(application/xdoc+xml "xdoc") (lambda (pathname port) @@ -69,7 +70,7 @@ USA. 0)))) (define (with-xdoc-expansion-context ps-number pathname procedure) - (with-database-connection ps-number pathname + (with-database-connection db-name ps-number pathname (lambda () (let ((environment (make-expansion-environment pathname))) (fluid-let ((*xdoc-environment* environment) @@ -173,11 +174,10 @@ USA. (for-each walk-html (xml-element-contents item)))) (loop (cdr items) count)))))))))) -(define-expander 'xdoc-part-number - (lambda (name) - (if (string-prefix? "xdoc_" name) - (string-tail name 5) - name))) +(define (xdoc-part-number name) + (if (string-prefix? "xdoc_" name) + (string-tail name 5) + name)) (define (ps-info elt) (let ((no (find-attribute 'first-problem elt #f))) @@ -288,7 +288,7 @@ USA. submitter *xdoc-late?*))) (values correctness* submitter)))))) - + (define (current-input-status elt) (let ((p (%current-input-status elt))) (values (car p) (cdr p)))) @@ -506,34 +506,32 @@ USA. elt #t))) -(define-expander 'xdoc-due-date-attributes - (lambda (dt) - (attributes 'class - (string-append "xdoc-due-date " - (if (decoded-time-in-past? dt) - "xdoc-due-date-overdue" - "xdoc-due-date-on-time"))))) - -(define-expander 'xdoc-due-date-string - (lambda (dt) - (let ((hour (decoded-time/hour dt)) - (minute (decoded-time/minute dt))) - (string-append "Due: " - (day-of-week/long-string (decoded-time/day-of-week dt)) - " " - (month/short-string (decoded-time/month dt)) - ". " - (number->string (decoded-time/day dt)) - " at " - (number->string - (cond ((> hour 12) (- hour 12)) - ((> hour 0) hour) - (else 12))) - (if (> minute 0) - (string-append ":" (string-pad-left minute 2 #\0)) - "") - " " - (if (> hour 12) "PM" "AM"))))) +(define (xdoc-due-date-attributes dt) + (attributes 'class + (string-append "xdoc-due-date " + (if (decoded-time-in-past? dt) + "xdoc-due-date-overdue" + "xdoc-due-date-on-time")))) + +(define (xdoc-due-date-string dt) + (let ((hour (decoded-time/hour dt)) + (minute (decoded-time/minute dt))) + (string-append "Due: " + (day-of-week/long-string (decoded-time/day-of-week dt)) + " " + (month/short-string (decoded-time/month dt)) + ". " + (number->string (decoded-time/day dt)) + " at " + (number->string + (cond ((> hour 12) (- hour 12)) + ((> hour 0) hour) + (else 12))) + (if (> minute 0) + (string-append ":" (string-pad-left minute 2 #\0)) + "") + " " + (if (> hour 12) "PM" "AM")))) (define (due-date-in-past?) (let ((elt (find-named-child 'due-date *xdoc-root* #f))) @@ -1403,65 +1401,71 @@ USA. (define (xdoc-action? elt) (eq? (xdoc-element-type elt) 'action)) -(let ((define-element - (lambda (local content-type elt-type) - (let ((qname (symbol-append 'xd: local))) - (define-expander qname - ((if (eq? content-type 'empty) - empty-element-constructor - standard-element-constructor) - qname xdoc-iri)) - (define-expander (symbol-append qname '?) - (let ((name (make-xml-name qname xdoc-iri))) - (lambda (object) - (and (xml-element? object) - (xml-name=? (xml-element-name object) name)))))) - (hash-table/put! xdoc-content-types local content-type) - (hash-table/put! xdoc-element-types local elt-type)))) - (define-element 'xdoc 'mixed 'top-level-container) - (define-element 'head 'mixed 'internal) - (define-element 'due-date 'empty 'internal) - (define-element 'problem 'mixed 'internal-container) - (define-element 'answer 'element 'internal-container) - (define-element 'label 'mixed 'internal) - - (define-element 'text 'empty 'input) - (define-element 'menu 'element 'input) - (define-element 'menuitem 'text 'internal) - (define-element 'checkbox 'empty 'input) - (define-element 'radio-buttons 'element 'input) - (define-element 'radio-entry 'mixed 'internal) - - (define-element 'check-input 'empty 'output) - (define-element 'check-inputs 'empty 'output) - (define-element 'number 'empty 'output) - (define-element 'boolean 'empty 'output) - (define-element 'menuindex 'empty 'output) - - (define-element 'explain 'mixed 'content-selector) - (define-element 'hint 'mixed 'content-selector) - (define-element 'expected-value 'empty 'content-selector) - (define-element 'when 'mixed 'content-selector) - (define-element 'case 'element 'content-selector) - (define-element 'refer 'empty 'internal) - (define-element 'choice 'mixed 'internal) - (define-element 'default 'mixed 'internal) - - (define-element 'check-action 'empty 'action) - (define-element 'submit-action 'empty 'action)) - -(define-expander 'xd:true-false - (lambda keyword-list - (xd:radio-buttons (apply attributes keyword-list) - (xd:radio-entry (attributes 'value 'true) "True") - (xd:radio-entry (attributes 'value 'false) "False")))) - -(define-expander 'xd:true-false? - (lambda (object) - (and (xd:radio-buttons? object) - (let ((entries (xml-element-contents object))) - (and (fix:= (length entries) 2) - (let ((v1 (find-attribute 'value (car entries) #t)) - (v2 (find-attribute 'value (cadr entries) #t))) - (or (and (string=? v1 "true") (string=? v2 "false")) - (and (string=? v1 "false") (string=? v2 "true"))))))))) \ No newline at end of file +(define-syntax define-element + (sc-macro-transformer + (lambda (form env) + env + (let ((local (cadr form)) + (content-type (caddr form)) + (elt-type (cadddr form))) + (let ((qname (symbol-append 'xd: local))) + `(BEGIN + (DEFINE ,qname + (,(if (eq? content-type 'empty) + 'EMPTY-ELEMENT-CONSTRUCTOR + 'STANDARD-ELEMENT-CONSTRUCTOR) + ',qname + XDOC-IRI)) + (DEFINE ,(symbol-append qname '?) + (LET ((NAME (MAKE-XML-NAME ',qname XDOC-IRI))) + (LAMBDA (OBJECT) + (AND (XML-ELEMENT? OBJECT) + (XML-NAME=? (XML-ELEMENT-NAME OBJECT) NAME))))) + (HASH-TABLE/PUT! XDOC-CONTENT-TYPES ',local ',content-type) + (HASH-TABLE/PUT! XDOC-ELEMENT-TYPES ',local ',elt-type))))))) + +(define-element xdoc mixed top-level-container) +(define-element head mixed internal) +(define-element due-date empty internal) +(define-element problem mixed internal-container) +(define-element answer element internal-container) +(define-element label mixed internal) + +(define-element text empty input) +(define-element menu element input) +(define-element menuitem text internal) +(define-element checkbox empty input) +(define-element radio-buttons element input) +(define-element radio-entry mixed internal) + +(define-element check-input empty output) +(define-element check-inputs empty output) +(define-element number empty output) +(define-element boolean empty output) +(define-element menuindex empty output) + +(define-element explain mixed content-selector) +(define-element hint mixed content-selector) +(define-element expected-value empty content-selector) +(define-element when mixed content-selector) +(define-element case element content-selector) +(define-element refer empty internal) +(define-element choice mixed internal) +(define-element default mixed internal) + +(define-element check-action empty action) +(define-element submit-action empty action) + +(define (xd:true-false . keyword-list) + (xd:radio-buttons (apply attributes keyword-list) + (xd:radio-entry (attributes 'value 'true) "True") + (xd:radio-entry (attributes 'value 'false) "False"))) + +(define (xd:true-false? object) + (and (xd:radio-buttons? object) + (let ((entries (xml-element-contents object))) + (and (fix:= (length entries) 2) + (let ((v1 (find-attribute 'value (car entries) #t)) + (v2 (find-attribute 'value (cadr entries) #t))) + (or (and (string=? v1 "true") (string=? v2 "false")) + (and (string=? v1 "false") (string=? v2 "true")))))))) \ No newline at end of file diff --git a/v7/src/ssp/xhtml-expander.scm b/v7/src/ssp/xhtml-expander.scm index 4fd8a0013..b19f1d64b 100644 --- a/v7/src/ssp/xhtml-expander.scm +++ b/v7/src/ssp/xhtml-expander.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xhtml-expander.scm,v 1.1 2003/12/29 05:24:59 uid67408 Exp $ +$Id: xhtml-expander.scm,v 1.2 2003/12/29 07:31:22 uid67408 Exp $ Copyright 2002,2003 Massachusetts Institute of Technology @@ -26,17 +26,9 @@ USA. ;;;; XHTML+Scheme expander (declare (usual-integrations)) -(load-option 'xml) -(define default-expander-directory - (merge-pathnames "*.xml" - (directory-pathname (current-load-pathname)))) - -(define (expand-xhtml-directory #!optional directory) - (for-each expand-xhtml-file - (directory-read (if (default-object? directory) - default-expander-directory - directory)))) +(define (expand-xhtml-directory directory) + (for-each expand-xhtml-file (directory-read directory))) (define (expand-xhtml-file input #!optional output) (let ((document @@ -74,14 +66,11 @@ USA. (let ((pathname (merge-pathnames pathname)) (environment (extend-top-level-environment expander-environment))) (environment-define environment 'document-pathname pathname) - (environment-define environment 'emit emit) (environment-define environment 'load (let ((directory (directory-pathname pathname))) (lambda (pathname) (load (merge-pathnames pathname directory) environment)))) - (environment-define environment 'define-sabbr define-sabbr) - (environment-define environment 'get-sabbr get-sabbr) environment)) (define ((pi-expander environment) text) @@ -97,26 +86,6 @@ USA. (car *outputs*))) (define expander-eval eval) -(define expander-environment) -(define server-environment (the-environment)) -(define expander-directory (directory-pathname (current-load-pathname))) - -(define (initialize-expander-environment) - (set! expander-environment - (let ((e (make-top-level-environment))) - (load (merge-pathnames "xhtml" expander-directory) e) - e)) - (for-each (lambda (name) - (link-variables server-environment name - expander-environment name)) - (environment-bound-names expander-environment))) - -(define (define-expander name value) - (environment-define expander-environment name value) - (link-variables server-environment name - expander-environment name)) - -(initialize-expander-environment) (define (svar-expander text) (list (make-xml-element 'code '() (list (string-trim text))))) diff --git a/v7/src/ssp/xmlrpc.scm b/v7/src/ssp/xmlrpc.scm index ad42f496f..73573491a 100644 --- a/v7/src/ssp/xmlrpc.scm +++ b/v7/src/ssp/xmlrpc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xmlrpc.scm,v 1.1 2003/12/29 05:25:02 uid67408 Exp $ +$Id: xmlrpc.scm,v 1.2 2003/12/29 07:31:26 uid67408 Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -241,7 +241,7 @@ USA. ;; Probably not right -- formatting issues (rpc-elt:double (number->string object))) ((boolean? object) - (rpc-elt:boolean? (if object "1" "0"))) + (rpc-elt:boolean (if object "1" "0"))) ((string? object) (if (utf8-string-valid? object) (rpc-elt:string object)