(define-module html-form-fill (use gauche.regexp) (export html-form-fill html-form-fill-by-hash-table)) (select-module html-form-fill) (define html-form-fill-by-hash-table (lambda (body form-param) (letrec ((inner-regexp (string-append "(?:" "[^\\\s]+|" "[^\\\s]+\\\s" "(?:[^\"\'\>]*?(?:\"[^\"]*?\"|\'[^\']*?\'))*?" "(?:[^\"\'>]*?)" ")")) ( html-split (lambda (body) (let (( html-match (rxmatch (string->regexp (string-append "^(.*?)(\<\!\-\-.*?\-\-\>|\<" inner-regexp "\>)(.*?)$")) body))) (if (not html-match) (list body) (cons (rxmatch-substring html-match 1) (cons (rxmatch-substring html-match 2) (html-split (rxmatch-substring html-match 3)))))))) ( form-fill (lambda (html-list form-param current-type current-name) (let ( (ctype current-type) (cname current-name)) (if (null? html-list) "" (string-append (if (and (form? (car html-list)) (hash-table-exists? form-param (if (> (string-length cname) 0) cname (form-name-get (car html-list))))) (begin (let ( (form-type (form-type-get (car html-list)))) (cond ((or (string=? form-type "text") (string=? form-type "password") (string=? form-type "hidden")) (value-set (value-clear (car html-list)) (form-name-get (car html-list)) form-param)) ((string=? form-type "radio") (checked-set (checked-clear (car html-list)) (form-name-get (car html-list)) form-param)) ((string=? form-type "checkbox") (checked-set (checked-clear (car html-list)) (form-name-get (car html-list)) form-param)) ((string=? form-type "option") (selected-set (selected-clear (car html-list)) cname form-param)) ((string=? form-type "select") (set! ctype "select") (set! cname (form-name-get (car html-list))) (car html-list)) ((string=? form-type "/select") (set! ctype "") (set! cname "") (car html-list)) ((string=? form-type "textarea") (set! ctype "textarea") (set! cname (form-name-get (car html-list))) (car html-list)) ((string=? form-type "/textarea") (let ((textarea-body (hash-table-get form-param cname))) (set! ctype "") (set! cname "") (string-append textarea-body (car html-list)))) (#t (car html-list))))) (if (string=? ctype "textarea") "" (string-append (car html-list) ""))) (form-fill (cdr html-list) form-param ctype cname)))))) ( form? (lambda (html-str) (if (or (rxmatch (string->regexp (string-append "(?i:\)")) html-str) (rxmatch (string->regexp "(?i:\)") html-str) (rxmatch (string->regexp "(?i:\<)(?i:select|\/select)(?i:.*?\>)") html-str) (rxmatch (string->regexp "(?i:\<)(?i:textarea|\/textarea)(?i:.*?\>)") html-str)) #t #f))) ( form-name-get (lambda (html-str) (let (( form-match (or (rxmatch (string->regexp (string-append "(?i:\<" inner-regexp "name\=\")([^\"]*?)(?:\".*?\>)")) html-str) (rxmatch (string->regexp (string-append "(?i:\<" inner-regexp "name\=\')([^\']*?)(?:\'.*?\>)")) html-str) (rxmatch (string->regexp (string-append "(?i:\<" inner-regexp "name\=)([^ ]*?)(?:\s*?.*?\>)")) html-str)))) (if form-match (rxmatch-substring form-match 1) "")))) ( checked-clear (lambda (html-str) (regexp-replace-all (string->regexp "(?i:[ ]checked)") html-str ""))) ( selected-clear (lambda (html-str) (regexp-replace-all (string->regexp "(?i:[ ]selected)") html-str ""))) ( value-clear (lambda (html-str) (regexp-replace-all (string->regexp "(?i:value=(\"[^\"]*?\"|\'[^\']*?\'|[^ ]*?))") html-str ""))) ( form-type-get (lambda (html-str) (cond ((rxmatch (string->regexp "(?i:[ ]type=(\"|\'|)text(\"|\'|\s*?).*?)") html-str) "text") ((rxmatch (string->regexp "(?i:[ ]type=(\"|\'|)password(\"|\'|\s*?).*?)") html-str) "password") ((rxmatch (string->regexp "(?i:[ ]type=(\"|\'|)radio(\"|\'|\s*?).*?)") html-str) "radio") ((rxmatch (string->regexp "(?i:[ ]type=(\"|\'|)checkbox(\"|\'|\s*?).*?)") html-str) "checkbox") ((rxmatch (string->regexp "(?i:\regexp "(?i:\regexp "(?i:\<\/select)(?i:[ ]|\>)") html-str) "/select") ((rxmatch (string->regexp "(?i:\regexp "(?i:\<\/textarea)(?i:[ ]|\>)") html-str) "/textarea") (#t "none")))) ( selected-set (lambda (html-str item-name form-param) (let (( param-value (hash-table-get form-param item-name))) (if (list? param-value) (pickup-set-rec html-str param-value " selected") (pickup-set-rec html-str (list param-value) " selected"))))) ( checked-set (lambda (html-str item-name form-param) (let (( param-value (hash-table-get form-param item-name))) (if (list? param-value) (pickup-set-rec html-str param-value " checked") (pickup-set-rec html-str (list param-value) " checked"))))) ( pickup-set-rec (lambda (html-str param-value sub-str) (if (null? param-value) html-str (begin (let (( replaced-html-str (pickup-set html-str (car param-value) sub-str))) (if (not (string=? html-str replaced-html-str)) replaced-html-str (pickup-set-rec html-str (cdr param-value) sub-str))))))) ( pickup-set (lambda (html-str item-value inline-string) (let (( form-match (or (rxmatch (string->regexp (string-append "(\<" inner-regexp "[vV][aA][lL][uU][eE]=\"" (regexp-quote item-value) "\".*?)(\/?\>)")) html-str) (rxmatch (string->regexp (string-append "(\<" inner-regexp "[vV][aA][lL][uU][eE]=\'" (regexp-quote item-value) "\'.*?)(\/?\>)")) html-str) (rxmatch (string->regexp (string-append "(\<" inner-regexp "[vV][aA][lL][uU][eE]=" (regexp-quote item-value) "\s*?.*?)(\/?\>)")) html-str)))) (if form-match (string-append (rxmatch-substring form-match 1) inline-string (rxmatch-substring form-match 2)) html-str)))) ( value-set (lambda (html-str item-name form-param) (let (( form-match (rxmatch (string->regexp "(\<.*?)(\/?\>)") html-str))) (if form-match (string-append (rxmatch-substring form-match 1) " value=\"" (hash-table-get form-param item-name) "\" " (rxmatch-substring form-match 2)) html-str))))) (form-fill (html-split body) form-param "" "")))) (define-syntax html-form-fill (syntax-rules () ((_ e1 ((i1 v1) (i2 v2) ...)) (make-param e1 ((i1 v1) (i2 v2) ...) (list))))) (define-syntax make-param (syntax-rules () ((_ e1 () param-ls) (html-form-fill-by-hash-table e1 (apply hash-table 'string=? param-ls)) ) ((_ e1 ((i1 v1) (i2 v2) ...) param-ls) (make-param e1 ((i2 v2) ...) (cons (cons i1 v1) param-ls))) )) (provide "html-form-fill")