ADDED .fossil-settings/ignore-glob Index: .fossil-settings/ignore-glob ================================================================== --- /dev/null +++ .fossil-settings/ignore-glob @@ -0,0 +1,2 @@ +install.cfg +requirements.scm Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -11,11 +11,11 @@ # # CSC_OPTIONS='-C "-fPIC"' make # include install.cfg -SRCFILES = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm +SRCFILES = stml2.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm MODULEFILES = $(wildcard modules/*/*-mod.scm) SOFILES = $(MODULEFILES:%.scm=%.so) CFILES = $(MODULEFILES:%.scm=%.c) OFILES = $(SRCFILES:%.scm=%.o) TARGFILES = $(notdir $(SOFILES)) @@ -29,11 +29,11 @@ # stmlrun : stmlrun.scm formdat.scm misc-stml.scm session.scm stml.scm \ # setup.scm html-filter.scm requirements.scm keystore.scm \ # cookie.scm sqltbl.scm # csc stmlrun.scm -$(TARGDIR)/stmlrun : stmlrun stml.so +$(TARGDIR)/stmlrun : stmlrun stml2.so echo "NOTE: CSC_OPTIONS='-C \"-fPIC\"' make" install stmlrun $(TARGDIR) chmod a+rx $(TARGDIR)/stmlrun $(TARGDIR)/modules : @@ -72,11 +72,11 @@ # Complile it in by include (see dependencies above). cookie.so : cookie.scm csc i$(CSCOPTS) -s cookie.scm clean : - rm -f *.o *.so + rm -f doc/*~ modules/*/*.so *.import.scm *.import.so *.o *.so *~ # $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm # chicken $< -output-file $@ # # Index: cookie.scm ================================================================== --- cookie.scm +++ cookie.scm @@ -40,11 +40,17 @@ ;; RFC 2964 Use of HTTP state management ;; ;; The parser also supports the old Netscape spec ;; -(declare (unit cookie)) +;; (declare (unit cookie)) + +(module cookie + * + +(import chicken scheme data-structures extras srfi-13 ports posix) + (require-extension srfi-1 srfi-13 srfi-14 regex) ;; (use srfi-1 srfi-13 srfi-14 regex) ;; (declare (export parse-cookie-string construct-cookie-string)) ;; #> @@ -253,5 +259,6 @@ (define (string-search-after r s #!optional (start 0)) (and-let* ((match-indices (string-search-positions r s start)) (right-match (second (first match-indices)))) (substring s right-match))) +) Index: formdat.scm ================================================================== --- formdat.scm +++ formdat.scm @@ -5,11 +5,18 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(declare (unit formdat)) +;; (declare (unit formdat)) + +(module formdat + * + +(import chicken scheme data-structures extras srfi-13 ports ) +(use html-filter) + (use regex) (require-extension srfi-69) (define formdat:*debug* #f) @@ -345,5 +352,7 @@ #| (define inp (open-input-file "/tmp/stmlrun/delme-33.log.keep-for-ref")) (define dat (read-string #f inp)) (close-input-port inp) |# + +) Index: html-filter.scm ================================================================== --- html-filter.scm +++ html-filter.scm @@ -5,11 +5,18 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(declare (unit html-filter)) +;; (declare (unit html-filter)) + +(module html-filter + * + +(import chicken scheme data-structures extras srfi-13 ports ) +(use misc-stml) + (require-extension regex) ;; (define (s:split-string strng delim) (if (eq? (string-length strng) 0) (list strng) @@ -195,5 +202,6 @@ (s:divy-up-cgi-str instr))) ;; for testing -- deletme ;; (define blah "post_title=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&post_body=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&new_post=Submit") ;; (define blah2 "post_title=5%25&post_body=and+10%25&new_post=Submit") +) Index: keystore.scm ================================================================== --- keystore.scm +++ keystore.scm @@ -10,11 +10,17 @@ ;;====================================================================== ;; The meta data key store, just a general dumping ground for values ;; only used occasionally ;;====================================================================== -(declare (unit keystore)) +;; (declare (unit keystore)) + +(module keystore + * + +(import chicken scheme data-structures extras srfi-13 ports ) + (define (keystore:get db key) (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key)) (define (keystore:set! db key value) @@ -23,5 +29,7 @@ (dbi:exec db "UPDATE metadata SET value=? WHERE key=?;" value key) (dbi:exec db "INSERT INTO metadata (key,value) VALUES (?,?);" key value)))) (define (keystore:del! db key) (dbi:exec db "DELETE FROM metadata WHERE key=?;" key)) + +) Index: misc-stml.scm ================================================================== --- misc-stml.scm +++ misc-stml.scm @@ -9,53 +9,84 @@ ;;====================================================================== ;; dumbobj helpers ;;====================================================================== -(declare (unit misc-stml)) +;; (declare (unit misc-stml)) + +(module misc-stml + * + +(import chicken scheme data-structures extras srfi-13 ports posix) + (use regex (prefix dbi dbi:)) (use (prefix crypt c:)) (use (prefix dbi dbi:)) -;; given a list of symbols give the count of the matching symbol -;; l => '(a b c) (dumobj:indx a 'b) => 1 -(define (s:get-fieldnum lst field-name) - (let loop ((head (car lst)) - (tail (cdr lst)) - (fnum 0)) - (if (eq? head field-name) fnum - (if (null? tail) #f - (loop (car tail)(cdr tail)(+ fnum 1)))))) - -(define (s:fields->string lst) - (string-join (map symbol->string lst) ",")) - -(define (s:vector-get-field vec field field-list) - (vector-ref vec (s:get-fieldnum field-list field))) - -;;====================================================================== +;; moved to stmlcommon +;; (bunch of stuff) + +;; moved from stmlcommon +;; +;; anything except a list is converted to a string!!! +(define (s:any->string val) + (cond + ((string? val) val) + ((number? val) (number->string val)) + ((symbol? val) (symbol->string val)) + ((eq? val #f) "") + ((eq? val #t) "TRUE") + ((list? val) val) + (else + (let ((ostr (open-output-string))) + (with-output-to-port ostr + (lambda () + (display val))) + (get-output-string ostr))))) + +(define (s:any->number val) + (cond + ((number? val) val) + ((string? val) (string->number val)) + ((symbol? val) (string->number (symbol->string val))) + (else #f))) + +;; Moved from stmlcommon ;; -;;====================================================================== +(define (s:cgi-out inlst) + (s:output (current-output-port) inlst)) + +(define (s:output port inlst) + (map (lambda (x) + (cond + ((string? x) (print x)) ;; (print x)) + ((symbol? x) (print x)) ;; (print x)) + ((list? x) (s:output port x)) + (else "" + ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk. + ))) + inlst)) +; (if (> (length inlst) 2) +; (print))) +(define (s:output-new port inlst) + (with-output-to-port port + (lambda () + (map (lambda (x) + (cond + ((string? x) (print x)) + ((symbol? x) (print x)) + ((list? x) (s:output port x)) + (else + ;; (print "ERROR: Bad input 03") + ))) + inlst)))) + (define (err:log . msg) (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt) (lambda () (apply print msg)))) -(define (s:tidy-url url) - (if url - (let ((r1 (regexp "^http:\\/\\/")) - (r2 (regexp "^[ \\t]*$"))) ;; blank - (if (string-match r1 url) url - (if (string-match r2 url) #f ;; convert a blank to #f - (conc "http://" url)))) - url)) - -(define (s:lazy->num num) - (if (number? num) num - (if (string->number num) (string->number num) - (if num 1 0)))) ;; wierd eh! yep, #f=>0 #t=>1 - ;;====================================================================== ;; D B ;;====================================================================== ;; convert values to appropriate strings @@ -103,19 +134,10 @@ (cdr tail) newresult (car argtail) (cdr argtail))))))))) -;;====================================================================== -;; M I S C S T R I N G S T U F F -;;====================================================================== - -(define (s:string-downcase str) - (if (string? str) - (string-translate str "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz") - str)) - ;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") (define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. (define session:num-valid-chars (string-length session:valid-chars)) (define (session:get-nth-char nth) @@ -140,105 +162,10 @@ (let ((char-num (random num-chars))) (if (> n len) res (loop (string-append res (substring seed-string char-num (+ char-num 1))) (+ n 1))))))) -;; Rely on crypt egg's default settings being secure enough, accept -;; backwards-compatible OpenSSL crypt passwords too. -;; -(define (s:crypt-passwd pw s) - (c:crypt pw (or s (c:crypt-gensalt)))) - -(define (s:password-match? password crypted) - (let* ((salt (substring crypted 0 2)) - (pcrypted (s:crypt-passwd password salt))) - ;; (s:log "INFO: pcrypted=" pcrypted " crypted=" crypted) - (and (string? password) - (string? pcrypted) - (string=? pcrypted crypted)))) - -;; (read-line (open-input-pipe "echo foo | mkpasswd -S ab -s")) - -(define (s:error-page . err) - (s:cgi-out (cons "Content-type: text/html; charset=iso-8859-1\n\n" - (s:html (s:head - (s:title err) - (s:body - (s:h1 "ERROR") - (s:p err))))))) - -;; BUG: The regex implements a rule, but what rule? AH! usaztempe, get rid of this? No, this also looks for &key=value ... -(define (s:validate-uri) - (let ((uri (get-environment-variable "REQUEST_URI")) - (qrs (get-environment-variable "QUERY_STRING"))) - (if (not uri) - (set! uri qrs)) - (if uri - (string-match - (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri) - (begin - (s:log "REQUEST URI NOT AVAILABLE!") - (let ((p (open-input-pipe "env"))) - (let loop ((l (read-line p)) - (res '())) - (if (eof-object? l) - (s:log res) - (loop (read-line p)(cons (list l "
") res))))) - #t)))) - -(define (s:validate-inputs) - (if (not (s:validate-uri)) - (begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER"))) - (if ref - (list "referred from" ref) - ""))) - (exit)))) - -;; anything except a list is converted to a string!!! -(define (s:any->string val) - (cond - ((string? val) val) - ((number? val) (number->string val)) - ((symbol? val) (symbol->string val)) - ((eq? val #f) "") - ((eq? val #t) "TRUE") - ((list? val) val) - (else - (let ((ostr (open-output-string))) - (with-output-to-port ostr - (lambda () - (display val))) - (get-output-string ostr))))) - -(define (s:any->number val) - (cond - ((number? val) val) - ((string? val) (string->number val)) - ((symbol? val) (string->number (symbol->string val))) - (else #f))) - -;; NB// this is *illegal* pgint -(define (s:illegal-pgint val) - (cond - ((> val 2147483647) 1) - ((< val -2147483648) -1) - (else #f))) - -(define (s:any->pgint val) - (let ((n (s:any->number val))) - (if n - (if (s:illegal-pgint n) - #f - n) - n))) - -;; string is a string and non-zero length -(define (misc:non-zero-string str) - (if (and (string? str) - (> (string-length str) 0)) - str - #f)) ;;====================================================================== ;; P A R A M S ;;====================================================================== @@ -308,5 +235,6 @@ (loop (car tail)(cdr tail) result)) (let ((newlst (cons head result))) (if (null? tail) newlst (loop (car tail)(cdr tail) newlst)))))))) +) Index: session.scm ================================================================== --- session.scm +++ session.scm @@ -5,14 +5,20 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(declare (unit session)) -(use (prefix dbi dbi:)) +;; (declare (unit session)) +(module session + * + +(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) +(use formdat html-filter misc-stml) + +(use (prefix dbi dbi:) srfi-69) (require-extension regex) -(declare (uses cookie)) +(use cookie) ;; (declare (uses cookie)) ;; sessions table ;; id session_id session_key ;; create table sessions (id serial not null,session-key text); @@ -763,10 +769,21 @@ res)) ;; should return #f if not a string and can't escape it? (else (if (string? res) (s:html-filter->string res '()) res))))) +#;(define (session:get-param-from params key) + (let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$")))) + (if (null? params) #f + (let loop ((head (car params)) + (tail (cdr params))) + (let ((match (string-match r1 head))) + (if match + (list-ref match 1) + (if (null? tail) #f + (loop (car tail)(cdr tail))))))))) + ;; params are stored as list of key=val ;; (define (session:get-param self key type-params) ;; (session:log s:session "params=" (slot-ref s:session 'params)) (let* ((params (sdat-get-params self)) @@ -868,5 +885,12 @@ 0)) (print "Keep-Alive: timeout=15, max=100") (print "Connection: Keep-Alive") (print "") (write-string (blob->string dat) #f (current-output-port)))) + +;; was in setup +;; +(define (s:log . msg) + (apply session:log s:session msg)) + +) Index: setup.scm ================================================================== --- setup.scm +++ setup.scm @@ -5,12 +5,17 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(declare (unit setup)) -(declare (uses session)) +(module setup + * +(import chicken scheme data-structures extras srfi-13 ports posix) + +(uses session misc-stml) +;; (declare (unit setup)) +;; (declare (uses session)) (require-extension srfi-69) (require-extension regex) ;; macros in sugar don't work, have to load in all files or use compiled mode? ;; @@ -27,13 +32,10 @@ (define (s:lget var . default) (hash-table-ref/default *page-data* var (if (null? default) #f (car default)))) -(define (s:log . msg) - (apply session:log s:session msg)) - (define (s:set-err . args) (sdat-set-curr-err! s:session args)) ;; Usage: (s:get-err s:big) (define (s:get-err wrapperfunc) @@ -212,5 +214,6 @@ ;; find out if we are in debugmode (define (s:debug-mode?) (sdat-get-debugmode s:session)) +) Index: sqltbl.scm ================================================================== --- sqltbl.scm +++ sqltbl.scm @@ -15,11 +15,16 @@ ;; num-rows ;; whatever ;; curr-row-ptr ;; number of the current row ;; curr-row ;; the current row vector (?? do we really want this ??) ;; )) -(declare (unit sqltbl)) +(module sqltbl + * + +(import chicken scheme data-structures extras srfi-13 ports ) + +;; (declare (unit sqltbl)) (define (make-sqltbl:tbl)(make-vector 9)) (define (sqltbl:tbl-get-rows vec) (vector-ref vec 0)) (define (sqltbl:tbl-get-fields vec) (vector-ref vec 1)) (define (sqltbl:tbl-get-fields-hash vec) (vector-ref vec 2)) @@ -109,5 +114,6 @@ ;; runs proc on each row and returns the resulting list (define (sqltbl:map self proc) (map (lambda (row) (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self))) +) DELETED stml.meta Index: stml.meta ================================================================== --- stml.meta +++ /dev/null @@ -1,20 +0,0 @@ -( -; Your egg's license: -(license "LGPL") - -; Pick one from the list of categories (see below) for your egg and enter it -; here. -(category misc) - -; A list of eggs mpeg3 depends on. If none, you can omit this declaration -; altogether. If you are making an egg for chicken 3 and you need to use -; procedures from the `files' unit, be sure to include the `files' egg in the -; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). -; `depends' is an alias to `needs'. -(needs srfi-69) - -; A list of eggs required for TESTING ONLY. See the `Tests' section. -(test-depends test) - -(author "Matt Welland") -(synopsis "Primitive argument processor.")) DELETED stml.scm Index: stml.scm ================================================================== --- stml.scm +++ /dev/null @@ -1,280 +0,0 @@ -;; Copyright 2007-2011, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -;; stml is a list of html strings - -(declare (unit stml)) -(declare (uses misc-stml)) -(require-extension regex) - -;; extract various tokens from the parameter list -;; 'key val => put in the params list -;; strings => maintain order and add to the datalist <<== IMPORTANT -(define (s:extract inlst) - (if (null? inlst) inlst - (let loop ((data '()) - (params '()) - (head (car inlst)) - (tail (cdr inlst))) - ;; (print "head=" head " tail=" tail) - (cond - ((null? tail) - (if (symbol? head) ;; the last item is a param - borked - (s:log "ERROR: param with no value")) - (list (append data (list (s:any->string head))) params)) - ((or (string? head)(list? head)(number? head)) - (loop (append data (list (s:any->string head))) params (car tail) (cdr tail))) - ((symbol? head) - (let ((new-params (cons (list head (car tail)) params)) - (new-tail (cdr tail))) - (if (null? new-tail) ;; we are done, no more params etc. - (list data new-params) - (loop data new-params (car new-tail)(cdr new-tail))))) - (else - (s:log "WARNING: Malformed input, you have broken stml, remember that all stml calls should return a result (null list or empty string is ok):\n head=" head - "\n tail=" tail - "\n inlst=" inlst - "\n params=" params) - (if (null? tail) - (list data params) - (loop data params (car tail)(cdr tail)))))))) - -;; most tags can be handled by this routine -(define (s:common-tag tagname args) - (let* ((inputs (s:extract args)) - (data (car inputs)) - (params (s:process-params (cadr inputs)))) - (list (conc "<" tagname params ">") - data - (conc "")))) - -;; Suggestion: order these alphabetically -(define (s:a . args) (s:common-tag "A" args)) -(define (s:b . args) (s:common-tag "B" args)) -(define (s:u . args) (s:common-tag "U" args)) -(define (s:big . args) (s:common-tag "BIG" args)) -(define (s:body . args) (s:common-tag "BODY" args)) -(define (s:button . args) (s:common-tag "BUTTON" args)) -(define (s:center . args) (s:common-tag "CENTER" args)) -(define (s:code . args) (s:common-tag "CODE" args)) -(define (s:div . args) (s:common-tag "DIV" args)) -(define (s:h1 . args) (s:common-tag "H1" args)) -(define (s:h2 . args) (s:common-tag "H2" args)) -(define (s:h3 . args) (s:common-tag "H3" args)) -(define (s:h4 . args) (s:common-tag "H4" args)) -(define (s:h5 . args) (s:common-tag "H5" args)) -(define (s:head . args) (s:common-tag "HEAD" args)) -(define (s:html . args) (s:common-tag "HTML" args)) -(define (s:i . args) (s:common-tag "I" args)) -(define (s:img . args) (s:common-tag "IMG" args)) -(define (s:input . args) (s:common-tag "INPUT" args)) -(define (s:link . args) (s:common-tag "LINK" args)) -(define (s:p . args) (s:common-tag "P" args)) -(define (s:strong . args) (s:common-tag "STRONG" args)) -(define (s:table . args) (s:common-tag "TABLE" args)) -(define (s:tbody . args) (s:common-tag "TBODY" args)) -(define (s:thead . args) (s:common-tag "THEAD" args)) -(define (s:th . args) (s:common-tag "TH" args)) -(define (s:td . args) (s:common-tag "TD" args)) -(define (s:title . args) (s:common-tag "TITLE" args)) -(define (s:tr . args) (s:common-tag "TR" args)) -(define (s:small . args) (s:common-tag "SMALL" args)) -(define (s:quote . args) (s:common-tag "QUOTE" args)) -(define (s:hr . args) (s:common-tag "HR" args)) -(define (s:li . args) (s:common-tag "LI" args)) -(define (s:ul . args) (s:common-tag "UL" args)) -(define (s:ol . args) (s:common-tag "OL" args)) -(define (s:dl . args) (s:common-tag "DL" args)) -(define (s:dt . args) (s:common-tag "DT" args)) -(define (s:dd . args) (s:common-tag "DD" args)) -(define (s:pre . args) (s:common-tag "PRE" args)) -(define (s:span . args) (s:common-tag "SPAN" args)) -(define (s:label . args) (s:common-tag "LABEL" args)) - -(define (s:dblquote . args) - (let* ((inputs (s:extract args)) - (data (caar inputs)) - (params (s:process-params (cadr inputs)))) - (conc """ data """))) - -(define (s:br . args) "
") ;; THIS MAY NOT WORK!!!! BR CAN (MISTAKENLY) GET PARAM TEXT -;; (define (s:br . args) (s:common-tag "BR" args)) -(define (s:font . args) (s:common-tag "FONT" args)) -(define (s:err-font . args) - (s:b (s:font 'color "red" args))) - -(define (s:comment . args) - (let* ((inputs (s:extract args)) - (data (car inputs)) - (params (s:process-params (cadr inputs)))) - (list ""))) - -(define (s:null . args) ;; nop - (let* ((inputs (s:extract args)) - (data (car inputs)) - (params (s:process-params (cadr inputs)))) - (list data))) - -;; puts a nice box around a chunk of stuff -(define (s:fieldset legend . args) - (list "
" legend "" args "
")) - -;; given a string return the string if it is non-white space or   otherwise -(define (s:nbsp str) - (if (string-match "^\\s*$" str) - " " - str)) - -;; USE 'page_override to override a linkto page from a button -(define (s:form . args) - ;; create a link for calling back into the current page and calling a specified - ;; function - (let* ((action (let ((v (s:find-param 'action args))) - (if v v "default"))) - (id (let ((i (s:find-param 'id args))) - (if i i #f))) - (page (let ((p (sdat-get-page s:session))) - (if p p "home"))) - ;; (link (session:link-to s:session page (if id - ;; (list 'action action 'id id) - ;; (list 'action action))))) - (link (if (string=? (substring action 0 5) "http:") ;; if first part of string is http: - action - (session:link-to s:session - page - (if id - (list 'action action 'id id) - (list 'action action)))))) - ;; (script (slot-ref s:session 'script)) - ;; (action-str (string-append script "/" page "?action=" action))) - (s:common-tag "FORM" (append (s:remove-param-matching (s:remove-param-matching args 'action) 'id) - (list 'action link))))) - -;; look up the variable name (via the 'name tag) then inject the value from the session var -;; replacing the 'value value if it is already there, adding it if it is not. -(define (s:preserve tag args) - (let* ((var-name (s:find-param 'name args)) ;; name='varname' - (value (let ((v (s:get var-name))) - (if v v #f))) - (newargs (append (s:remove-param-matching args 'value) (if value (list 'value value) '())))) - (s:common-tag tag newargs))) - -(define (s:input-preserve . args) - (s:preserve "INPUT" args)) - -;; text areas are done a little differently. The value is stored between the tags -(define (s:textarea-preserve . args) - (let* ((var-name (s:find-param 'name args)) - (value (let ((v (s:get var-name))) - (if v v #f)))) - (s:common-tag "TEXTAREA" (if value (cons value args) args)))) - -(define (s:option dat) - (let ((len (length dat))) - (cond - ((eq? len 1) - (let ((item (car dat))) - (s:option (list item item item)))) - ((eq? len 2) - (s:option (append dat (list (car dat))))) - (else - (let ((label (car dat)) - (value (cadr dat)) - (dispval (caddr dat)) - (selected (if (> len 3)(cadddr dat) #f))) - (list (conc ""))))))) - -;; call only with (label (label value dispval [#t]) ...) -;; NB// sadly this block is redundantly almost identical to the s:select -;; fix that later ... -(define (s:optgroup dat) - (let ((label (car dat)) - (rem (cdr dat))) - (if (null? rem) - (s:common-tag "OPTGROUP" 'label label) - (let loop ((hed (car rem)) - (tal (cdr rem)) - (res (list (conc "")) - (loop (car tal)(cdr tal) new))))))) - -;; items is a hierarchial alist -;; ( (label1 value1 dispval1 #t) ;; <== this one is selected -;; (label2 (label3 value2 dispval2) -;; (label4 value3 dispval3))) -;; -;; required arg is 'name -(define (s:select items . args) - (if (null? items) - (s:common-tag "SELECT" args) - (let loop ((hed (car items)) - (tal (cdr items)) - (res '())) - ;; (print "hed: " hed " tal: " tal " res: " res) - (let ((new (append res (list (if (and (> (length hed) 1) - (list? (cadr hed))) - (s:optgroup hed) - (s:option hed)))))) - (if (null? tal) - (s:common-tag "SELECT" (cons new args)) - (loop (car tal)(cdr tal) new)))))) - -(define (s:color . args) - "#00ff00") - -(define (s:print indent inlst) - (map (lambda (x) - (cond - ((or (string? x)(symbol? x)) - (print (conc (make-string (* indent 2) #\ ) (any->string x)))) - ((list? x) - (s:print (+ indent 1) x)) - (else - ;; (print "ERROR: Bad input 01") ;; why do anything with junk? - ))) - inlst)) - -(define (s:cgi-out inlst) - (s:output (current-output-port) inlst)) - -(define (s:output port inlst) - (map (lambda (x) - (cond - ((string? x) (print x)) ;; (print x)) - ((symbol? x) (print x)) ;; (print x)) - ((list? x) (s:output port x)) - (else "" - ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk. - ))) - inlst)) -; (if (> (length inlst) 2) -; (print))) - -(define (s:output-new port inlst) - (with-output-to-port port - (lambda () - (map (lambda (x) - (cond - ((string? x) (print x)) - ((symbol? x) (print x)) - ((list? x) (s:output port x)) - (else - ;; (print "ERROR: Bad input 03") - ))) - inlst)))) - DELETED stml.setup Index: stml.setup ================================================================== --- stml.setup +++ /dev/null @@ -1,18 +0,0 @@ -;; Copyright 2007-2010, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -;;;; margs.setup - -;; compile the code into a dynamically loadable shared object -;; (will generate margs.so) -;; (compile -s margs.scm) - -;; Install as extension library -(install-extension 'stml "stml.so") - ADDED stml2.meta Index: stml2.meta ================================================================== --- /dev/null +++ stml2.meta @@ -0,0 +1,20 @@ +( +; Your egg's license: +(license "LGPL") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category misc) + +; A list of eggs mpeg3 depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +(needs srfi-69) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "Primitive argument processor.")) ADDED stml2.scm Index: stml2.scm ================================================================== --- /dev/null +++ stml2.scm @@ -0,0 +1,292 @@ +;; Copyright 2007-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; stml is a list of html strings + +;; (declare (unit stml)) + +(module stml2 + * + +(import chicken scheme data-structures extras srfi-13 ports ) + +(use stmlcommon cookie misc-stml formdat session sqltbl keystore) + +;; (declare (uses misc-stml)) +(use regex) + +;; extract various tokens from the parameter list +;; 'key val => put in the params list +;; strings => maintain order and add to the datalist <<== IMPORTANT +(define (s:extract inlst) + (if (null? inlst) inlst + (let loop ((data '()) + (params '()) + (head (car inlst)) + (tail (cdr inlst))) + ;; (print "head=" head " tail=" tail) + (cond + ((null? tail) + (if (symbol? head) ;; the last item is a param - borked + (s:log "ERROR: param with no value")) + (list (append data (list (s:any->string head))) params)) + ((or (string? head)(list? head)(number? head)) + (loop (append data (list (s:any->string head))) params (car tail) (cdr tail))) + ((symbol? head) + (let ((new-params (cons (list head (car tail)) params)) + (new-tail (cdr tail))) + (if (null? new-tail) ;; we are done, no more params etc. + (list data new-params) + (loop data new-params (car new-tail)(cdr new-tail))))) + (else + (s:log "WARNING: Malformed input, you have broken stml, remember that all stml calls should return a result (null list or empty string is ok):\n head=" head + "\n tail=" tail + "\n inlst=" inlst + "\n params=" params) + (if (null? tail) + (list data params) + (loop data params (car tail)(cdr tail)))))))) + +;; most tags can be handled by this routine +(define (s:common-tag tagname args) + (let* ((inputs (s:extract args)) + (data (car inputs)) + (params (s:process-params (cadr inputs)))) + (list (conc "<" tagname params ">") + data + (conc "")))) + +;; Suggestion: order these alphabetically +(define (s:a . args) (s:common-tag "A" args)) +(define (s:b . args) (s:common-tag "B" args)) +(define (s:u . args) (s:common-tag "U" args)) +(define (s:big . args) (s:common-tag "BIG" args)) +(define (s:body . args) (s:common-tag "BODY" args)) +(define (s:button . args) (s:common-tag "BUTTON" args)) +(define (s:center . args) (s:common-tag "CENTER" args)) +(define (s:code . args) (s:common-tag "CODE" args)) +(define (s:div . args) (s:common-tag "DIV" args)) +(define (s:h1 . args) (s:common-tag "H1" args)) +(define (s:h2 . args) (s:common-tag "H2" args)) +(define (s:h3 . args) (s:common-tag "H3" args)) +(define (s:h4 . args) (s:common-tag "H4" args)) +(define (s:h5 . args) (s:common-tag "H5" args)) +(define (s:head . args) (s:common-tag "HEAD" args)) +(define (s:html . args) (s:common-tag "HTML" args)) +(define (s:i . args) (s:common-tag "I" args)) +(define (s:img . args) (s:common-tag "IMG" args)) +(define (s:input . args) (s:common-tag "INPUT" args)) +(define (s:link . args) (s:common-tag "LINK" args)) +(define (s:p . args) (s:common-tag "P" args)) +(define (s:strong . args) (s:common-tag "STRONG" args)) +(define (s:table . args) (s:common-tag "TABLE" args)) +(define (s:tbody . args) (s:common-tag "TBODY" args)) +(define (s:thead . args) (s:common-tag "THEAD" args)) +(define (s:th . args) (s:common-tag "TH" args)) +(define (s:td . args) (s:common-tag "TD" args)) +(define (s:title . args) (s:common-tag "TITLE" args)) +(define (s:tr . args) (s:common-tag "TR" args)) +(define (s:small . args) (s:common-tag "SMALL" args)) +(define (s:quote . args) (s:common-tag "QUOTE" args)) +(define (s:hr . args) (s:common-tag "HR" args)) +(define (s:li . args) (s:common-tag "LI" args)) +(define (s:ul . args) (s:common-tag "UL" args)) +(define (s:ol . args) (s:common-tag "OL" args)) +(define (s:dl . args) (s:common-tag "DL" args)) +(define (s:dt . args) (s:common-tag "DT" args)) +(define (s:dd . args) (s:common-tag "DD" args)) +(define (s:pre . args) (s:common-tag "PRE" args)) +(define (s:span . args) (s:common-tag "SPAN" args)) +(define (s:label . args) (s:common-tag "LABEL" args)) + +(define (s:dblquote . args) + (let* ((inputs (s:extract args)) + (data (caar inputs)) + (params (s:process-params (cadr inputs)))) + (conc """ data """))) + +(define (s:br . args) "
") ;; THIS MAY NOT WORK!!!! BR CAN (MISTAKENLY) GET PARAM TEXT +;; (define (s:br . args) (s:common-tag "BR" args)) +(define (s:font . args) (s:common-tag "FONT" args)) +(define (s:err-font . args) + (s:b (s:font 'color "red" args))) + +(define (s:comment . args) + (let* ((inputs (s:extract args)) + (data (car inputs)) + (params (s:process-params (cadr inputs)))) + (list ""))) + +(define (s:null . args) ;; nop + (let* ((inputs (s:extract args)) + (data (car inputs)) + (params (s:process-params (cadr inputs)))) + (list data))) + +;; puts a nice box around a chunk of stuff +(define (s:fieldset legend . args) + (list "
" legend "" args "
")) + +;; given a string return the string if it is non-white space or   otherwise +(define (s:nbsp str) + (if (string-match "^\\s*$" str) + " " + str)) + +;; USE 'page_override to override a linkto page from a button +(define (s:form . args) + ;; create a link for calling back into the current page and calling a specified + ;; function + (let* ((action (let ((v (s:find-param 'action args))) + (if v v "default"))) + (id (let ((i (s:find-param 'id args))) + (if i i #f))) + (page (let ((p (sdat-get-page s:session))) + (if p p "home"))) + ;; (link (session:link-to s:session page (if id + ;; (list 'action action 'id id) + ;; (list 'action action))))) + (link (if (string=? (substring action 0 5) "http:") ;; if first part of string is http: + action + (session:link-to s:session + page + (if id + (list 'action action 'id id) + (list 'action action)))))) + ;; (script (slot-ref s:session 'script)) + ;; (action-str (string-append script "/" page "?action=" action))) + (s:common-tag "FORM" (append (s:remove-param-matching (s:remove-param-matching args 'action) 'id) + (list 'action link))))) + +;; look up the variable name (via the 'name tag) then inject the value from the session var +;; replacing the 'value value if it is already there, adding it if it is not. +(define (s:preserve tag args) + (let* ((var-name (s:find-param 'name args)) ;; name='varname' + (value (let ((v (s:get var-name))) + (if v v #f))) + (newargs (append (s:remove-param-matching args 'value) (if value (list 'value value) '())))) + (s:common-tag tag newargs))) + +(define (s:input-preserve . args) + (s:preserve "INPUT" args)) + +;; text areas are done a little differently. The value is stored between the tags +(define (s:textarea-preserve . args) + (let* ((var-name (s:find-param 'name args)) + (value (let ((v (s:get var-name))) + (if v v #f)))) + (s:common-tag "TEXTAREA" (if value (cons value args) args)))) + +(define (s:option dat) + (let ((len (length dat))) + (cond + ((eq? len 1) + (let ((item (car dat))) + (s:option (list item item item)))) + ((eq? len 2) + (s:option (append dat (list (car dat))))) + (else + (let ((label (car dat)) + (value (cadr dat)) + (dispval (caddr dat)) + (selected (if (> len 3)(cadddr dat) #f))) + (list (conc ""))))))) + +;; call only with (label (label value dispval [#t]) ...) +;; NB// sadly this block is redundantly almost identical to the s:select +;; fix that later ... +(define (s:optgroup dat) + (let ((label (car dat)) + (rem (cdr dat))) + (if (null? rem) + (s:common-tag "OPTGROUP" 'label label) + (let loop ((hed (car rem)) + (tal (cdr rem)) + (res (list (conc "")) + (loop (car tal)(cdr tal) new))))))) + +;; items is a hierarchial alist +;; ( (label1 value1 dispval1 #t) ;; <== this one is selected +;; (label2 (label3 value2 dispval2) +;; (label4 value3 dispval3))) +;; +;; required arg is 'name +(define (s:select items . args) + (if (null? items) + (s:common-tag "SELECT" args) + (let loop ((hed (car items)) + (tal (cdr items)) + (res '())) + ;; (print "hed: " hed " tal: " tal " res: " res) + (let ((new (append res (list (if (and (> (length hed) 1) + (list? (cadr hed))) + (s:optgroup hed) + (s:option hed)))))) + (if (null? tal) + (s:common-tag "SELECT" (cons new args)) + (loop (car tal)(cdr tal) new)))))) + +(define (s:color . args) + "#00ff00") + +(define (s:print indent inlst) + (map (lambda (x) + (cond + ((or (string? x)(symbol? x)) + (print (conc (make-string (* indent 2) #\ ) (any->string x)))) + ((list? x) + (s:print (+ indent 1) x)) + (else + ;; (print "ERROR: Bad input 01") ;; why do anything with junk? + ))) + inlst)) + +;; Moved to misc-stml +;; +#;(define (s:cgi-out inlst) + (s:output (current-output-port) inlst)) + +#;(define (s:output port inlst) + (map (lambda (x) + (cond + ((string? x) (print x)) ;; (print x)) + ((symbol? x) (print x)) ;; (print x)) + ((list? x) (s:output port x)) + (else "" + ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk. + ))) + inlst)) +; (if (> (length inlst) 2) +; (print))) + +#;(define (s:output-new port inlst) + (with-output-to-port port + (lambda () + (map (lambda (x) + (cond + ((string? x) (print x)) + ((symbol? x) (print x)) + ((list? x) (s:output port x)) + (else + ;; (print "ERROR: Bad input 03") + ))) + inlst)))) + + +) ADDED stml2.setup Index: stml2.setup ================================================================== --- /dev/null +++ stml2.setup @@ -0,0 +1,29 @@ +;; Copyright 2007-2010, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;;; margs.setup + +;; compile the code into a dynamically loadable shared object +;; (will generate margs.so) +;; (compile -s margs.scm) + +;; Install as extension library +(standard-extension 'cookie "0.5") +(standard-extension 'misc-stml "0.5") ;; moved to stmlcommon.scm +(standard-extension 'html-filter "0.5") +(standard-extension 'formdat "0.5") +(standard-extension 'session "0.5") +(standard-extension 'setup "0.5") +(standard-extension 'sqltbl "0.5") +(standard-extension 'keystore "0.5") +(standard-extension 'stmlcommon "0.5") +(standard-extension 'stml2 "0.5") + +;; (install-extension 'stml "stml.so") + Index: stmlcommon.scm ================================================================== --- stmlcommon.scm +++ stmlcommon.scm @@ -8,20 +8,28 @@ ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) +(module stmlcommon + * + +(import chicken scheme data-structures extras srfi-13 ports ) + +(use cookie misc-stml formdat session sqltbl keystore) + (include "requirements.scm") -(declare (uses cookie)) -(declare (uses html-filter)) -(declare (uses misc-stml)) -(declare (uses formdat)) -(declare (uses stml)) -(declare (uses session)) -(declare (uses setup)) ;; s:session gets created here -(declare (uses sqltbl)) -(declare (uses keystore)) + +;;(declare (uses cookie)) +;;(declare (uses html-filter)) +;;(declare (uses misc-stml)) +;;(declare (uses formdat)) +;;(declare (uses stml)) +;;(declare (uses session)) +;;(declare (uses setup)) ;; s:session gets created here +;;(declare (uses sqltbl)) +;;(declare (uses keystore)) (define (stml:cgi-session session) (session:initialize session) (session:setup session) (session:get-vars session) @@ -91,5 +99,235 @@ (print ""))) (if proc (proc s:session) (stml:cgi-session s:session)) ;; (raise-error) ;; (exit) )) + +;; given a list of symbols give the count of the matching symbol +;; l => '(a b c) (dumobj:indx a 'b) => 1 +(define (s:get-fieldnum lst field-name) + (let loop ((head (car lst)) + (tail (cdr lst)) + (fnum 0)) + (if (eq? head field-name) fnum + (if (null? tail) #f + (loop (car tail)(cdr tail)(+ fnum 1)))))) + +(define (s:fields->string lst) + (string-join (map symbol->string lst) ",")) + +(define (s:vector-get-field vec field field-list) + (vector-ref vec (s:get-fieldnum field-list field))) + +;;====================================================================== +;; +;;====================================================================== + +;; moved to misc-stml +;; +#;(define (err:log . msg) + (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt) + (lambda () + (apply print msg)))) + +(define (s:tidy-url url) + (if url + (let ((r1 (regexp "^http:\\/\\/")) + (r2 (regexp "^[ \\t]*$"))) ;; blank + (if (string-match r1 url) url + (if (string-match r2 url) #f ;; convert a blank to #f + (conc "http://" url)))) + url)) + +(define (s:lazy->num num) + (if (number? num) num + (if (string->number num) (string->number num) + (if num 1 0)))) ;; wierd eh! yep, #f=>0 #t=>1 + +;;====================================================================== +;; D B +;;====================================================================== + +;; convert values to appropriate strings +;; +#;(define (s:sqlparam-val->string val) + (cond + ((list? val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c + ((string? val)(conc "'" (dbi:escape-string val) "'")) + ((number? val)(number->string val)) + ((symbol? val)(dbi:escape-string (symbol->string val))) + ((boolean? val) + (if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1? + ;; should this be "FALSE" or 0 or NULL? + (else + (err:log "sqlparam: unknown type for value: " val) + ""))) + +;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20) +;; NB// 1. values only!! +;; 2. terminating semicolon required (used as part of logic) +;; +;; a=? 1 (number) => a=1 +;; a=? 1 (string) => a='1' +;; a=? #f => a=FALSE +;; a=? a (symbol) => a=a +;; +#;(define (s:sqlparam query . args) + (let* ((query-parts (string-split query "?")) + (num-parts (length query-parts)) + (num-args (length args))) + (if (not (= (+ num-args 1) num-parts)) + (err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query) + (if (= num-args 0) query + (let loop ((section (car query-parts)) + (tail (cdr query-parts)) + (result "") + (arg (car args)) + (argtail (cdr args))) + (let* ((valstr (s:sqlparam-val->string arg)) + (newresult (conc result section valstr))) + (if (null? argtail) ;; we are done + (conc newresult (car tail)) + (loop + (car tail) + (cdr tail) + newresult + (car argtail) + (cdr argtail))))))))) + +;;====================================================================== +;; M I S C S T R I N G S T U F F +;;====================================================================== + +(define (s:string-downcase str) + (if (string? str) + (string-translate str "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz") + str)) + +;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") +#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. +#;(define session:num-valid-chars (string-length session:valid-chars)) + +#;(define (session:get-nth-char nth) + (substring session:valid-chars nth (+ nth 1))) + +#;(define (session:get-rand-char) + (session:get-nth-char (random session:num-valid-chars))) + +#;(define (session:make-rand-string len) + (let loop ((res "") + (n 1)) + (if (> n len) res + (loop (string-append res (session:get-rand-char)) + (+ n 1))))) + +;; maybe replace above make-rand-string with this someday? +;; +#;(define (session:generic-make-rand-string len seed-string) + (let ((num-chars (string-length seed-string))) + (let loop ((res "") + (n 1)) + (let ((char-num (random num-chars))) + (if (> n len) res + (loop (string-append res (substring seed-string char-num (+ char-num 1))) + (+ n 1))))))) + +;; Rely on crypt egg's default settings being secure enough, accept +;; backwards-compatible OpenSSL crypt passwords too. +;; +(define (s:crypt-passwd pw s) + (c:crypt pw (or s (c:crypt-gensalt)))) + +(define (s:password-match? password crypted) + (let* ((salt (substring crypted 0 2)) + (pcrypted (s:crypt-passwd password salt))) + ;; (s:log "INFO: pcrypted=" pcrypted " crypted=" crypted) + (and (string? password) + (string? pcrypted) + (string=? pcrypted crypted)))) + +;; (read-line (open-input-pipe "echo foo | mkpasswd -S ab -s")) + +(define (s:error-page . err) + (s:cgi-out (cons "Content-type: text/html; charset=iso-8859-1\n\n" + (s:html (s:head + (s:title err) + (s:body + (s:h1 "ERROR") + (s:p err))))))) + +;; BUG: The regex implements a rule, but what rule? AH! usaztempe, get rid of this? No, this also looks for &key=value ... +(define (s:validate-uri) + (let ((uri (get-environment-variable "REQUEST_URI")) + (qrs (get-environment-variable "QUERY_STRING"))) + (if (not uri) + (set! uri qrs)) + (if uri + (string-match + (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri) + (begin + (s:log "REQUEST URI NOT AVAILABLE!") + (let ((p (open-input-pipe "env"))) + (let loop ((l (read-line p)) + (res '())) + (if (eof-object? l) + (s:log res) + (loop (read-line p)(cons (list l "
") res))))) + #t)))) + +(define (s:validate-inputs) + (if (not (s:validate-uri)) + (begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER"))) + (if ref + (list "referred from" ref) + ""))) + (exit)))) + +;; moved to misc-stml +;; +;; anything except a list is converted to a string!!! +#;(define (s:any->string val) + (cond + ((string? val) val) + ((number? val) (number->string val)) + ((symbol? val) (symbol->string val)) + ((eq? val #f) "") + ((eq? val #t) "TRUE") + ((list? val) val) + (else + (let ((ostr (open-output-string))) + (with-output-to-port ostr + (lambda () + (display val))) + (get-output-string ostr))))) + +#;(define (s:any->number val) + (cond + ((number? val) val) + ((string? val) (string->number val)) + ((symbol? val) (string->number (symbol->string val))) + (else #f))) + +;; NB// this is *illegal* pgint +(define (s:illegal-pgint val) + (cond + ((> val 2147483647) 1) + ((< val -2147483648) -1) + (else #f))) + +(define (s:any->pgint val) + (let ((n (s:any->number val))) + (if n + (if (s:illegal-pgint n) + #f + n) + n))) + +;; string is a string and non-zero length +(define (misc:non-zero-string str) + (if (and (string? str) + (> (string-length str) 0)) + str + #f)) + + +)