(module util mzscheme
(require (lib "string.ss" "srfi" "13"))
(require (lib "pregexp.ss"))
(require (lib "servlet.ss" "web-server"))
(require "debug.scm")
(provide normalize
good-name?
last
copy-to
read-whole-string
extract-binding/choice
)
(define (good-name? name)
(debug "good-name? :" name)
(let ((N (string-downcase (string-trim-both name))))
(if (pregexp-match "\\s|[/\\\\]" N)
#f
(if (string=? N "")
#f
#t))))
(define (normalize name)
(let ((N (string-downcase (string-trim-both name))))
(if (string=? N "")
""
(pregexp-replace* "\\s|[/\\\\]" N "_"))))
(define (last L)
(if (null? L)
'%no-last%
(car (reverse L))))
(define (copy-to filename dest-file)
(display (format "copy-to: ~a ~a~%" filename dest-file))
(let ((fh1 (open-input-file filename))
(fh2 (open-output-file dest-file 'replace)))
(letrec ((f (lambda ()
(let ((r (read-bytes 10240 fh1)))
(if (eof-object? r)
#t
(begin
(write-bytes r fh2)
(f)))))))
(f)
(close-input-port fh1)
(close-output-port fh2))))
(define (read-whole-string fh)
(letrec ((f (lambda ()
(let ((r (read-string 10240 fh)))
(if (eof-object? r)
""
(string-append r (f)))))))
(f)))
(define (extract-binding/choice possibilities binding . default)
(letrec ((f (lambda (possibilities)
(if (null? possibilities)
(if (null? default)
#f
(car default))
(if (exists-binding? (car possibilities) binding)
(cons (symbol->string (car possibilities)) (extract-binding/single (car possibilities) binding))
(f (cdr possibilities)))))))
(f (map (lambda (x) (string->symbol (format "~a" x))) possibilities))))
)