;; 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.
;;======================================================================
;; dumbobj helpers
;;======================================================================
;; (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:))
;; 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))))
;;======================================================================
;; 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)))))))))
;; (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)))))))
;;======================================================================
;; P A R A M S
;;======================================================================
;; input: 'a ('a "val a" 'b "val b") => "val a"
(define (s:find-param key param-lst)
(let loop ((head (car param-lst))
(tail (cdr param-lst)))
(if (eq? head key)
(car tail)
(if (< (length tail) 2) #f
(loop (cadr tail)(cddr tail))))))
(define (s:param->string param)
(conc (symbol->string (car param)) "=" "\"" (cadr param) "\""))
;; remove 'foo "bar" from ('foo "bar" 'bar "foo")
(define (s:remove-param-matching params key)
(if (= (length params) 0)'() ;; proper params list >= 2 items
(let loop ((head (car params))
(tail (cdr params))
(result '()))
(if (symbol? head) ;; symbols have params
(let ((val (car tail))
(newtail (cdr tail)))
(if (eq? head key) ;; get rid of this one
(if (null? newtail) result
(loop (car newtail)(cdr newtail) result))
(let ((newresult (append result (list head val))))
(if (null? newtail) newresult
(loop (car newtail)(cdr newtail) newresult)))))
(let ((newresult (append result (list head))))
(if (null? tail) newresult
(loop (car tail)(cdr tail) newresult)))))))
(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)))))))))
(define (s:process-params params)
(if (null? params) ""
(let loop ((res "")
(head (car params))
(tail (cdr params)))
(if (null? tail)
(conc res " " (s:param->string head))
(loop
(conc res " " (s:param->string head))
(car tail)
(cdr tail))))))
;; remove key=var from (key=var key1=var1 key2=var2 ...)
(define (k=v-params:remove-matching params key)
(if (= (length params) 0) params
(let ((r1 (regexp (conc "^" key "="))))
(let loop ((head (car params))
(tail (cdr params))
(result '()))
(if (string-match r1 head)
(if (null? tail) result
(loop (car tail)(cdr tail) result))
(let ((newlst (cons head result)))
(if (null? tail) newlst
(loop (car tail)(cdr tail) newlst))))))))
)