Index: archivemod.scm ================================================================== --- archivemod.scm +++ archivemod.scm @@ -22,12 +22,12 @@ (declare (uses commonmod)) (module archivemod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme (chicken base)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") ADDED autoload/autoload.meta Index: autoload/autoload.meta ================================================================== --- /dev/null +++ autoload/autoload.meta @@ -0,0 +1,9 @@ +;;; autoload.meta -*- Hen -*- + +((egg "autoload.egg") + (synopsis "Load modules lazily") + (category lang-exts) + (license "BSD") + (author "Alex Shinn") + (doc-from-wiki) + (files "autoload.meta" "autoload.scm" "autoload.release-info" "autoload.setup")) ADDED autoload/autoload.scm Index: autoload/autoload.scm ================================================================== --- /dev/null +++ autoload/autoload.scm @@ -0,0 +1,93 @@ +;;;; autoload.scm -- load modules lazily +;; +;; Copyright (c) 2005-2009 Alex Shinn +;; All rights reserved. +;; +;; BSD-style license: http://www.debian.org/misc/bsd.license + +;; Provides an Emacs-style autoload facility which takes the basic form +;; +;; (autoload unit procedure-name ...) +;; +;; such that the first time procedure-name is called, it will perform a +;; runtime require of 'unit and then apply the procedure from the newly +;; loaded unit to the args it was passed. Subsequent calls to +;; procedure-name will thereafter refer to the new procedure and will +;; thus not incur any overhead. +;; +;; You may also specify an alias for the procedure, and a default +;; procedure if the library can't be loaded: +;; +;; (autoload unit (name alias default) ...) +;; +;; In this case, although the procedure name from the unit is "name," +;; the form defines the autoload procedure as "alias." +;; +;; If the library can't be loaded then an error is signalled, unless +;; default is given, in which case the values are passed to that. +;; +;; Examples: +;; +;; ;; load iconv procedures lazily +;; (autoload iconv iconv iconv-open) +;; +;; ;; load some sqlite procedures lazily with "-" names +;; (autoload sqlite (sqlite:open sqlite-open) +;; (sqlite:execute sqlite-execute)) +;; +;; ;; load md5 library, falling back on slower scheme version +;; (autoload scheme-md5 (md5:digest scheme-md5:digest)) +;; (autoload md5 (md5:digest #f scheme-md5:digest)) + +(module autoload (autoload) + +(import scheme chicken) + +(define-syntax autoload + (er-macro-transformer + (lambda (expr rename compare) + (let ((module (cadr expr)) + (procs (cddr expr)) + (_import (rename 'import)) + (_define (rename 'define)) + (_let (rename 'let)) + (_set! (rename 'set!)) + (_begin (rename 'begin)) + (_apply (rename 'apply)) + (_args (rename 'args)) + (_tmp (rename 'tmp)) + (_eval (rename 'eval)) + (_condition-case (rename 'condition-case))) + `(,_begin + ,@(map + (lambda (x) + (let* ((x (if (pair? x) x (list x))) + (name (car x)) + (full-name + (string->symbol + (string-append (symbol->string module) "#" + (symbol->string name)))) + (alias (or (and (pair? (cdr x)) (cadr x)) name)) + (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x)))) + (if default + `(,_define (,alias . ,_args) + (,_let ((,_tmp (,_condition-case + (,_begin + (,_eval + (begin (require-library ,module) + #f)) + (,_eval ',full-name)) + (exn () ,default)))) + (,_set! ,alias ,_tmp) + (,_apply ,_tmp ,_args))) + `(,_define (,alias . ,_args) + (,_let ((,_tmp (,_begin + (,_eval + (begin (require-library ,module) + #f)) + (,_eval ',full-name)))) + (,_set! ,alias ,_tmp) + (,_apply ,_tmp ,_args)))))) + procs)))))) + +) ADDED autoload/autoload.setup Index: autoload/autoload.setup ================================================================== --- /dev/null +++ autoload/autoload.setup @@ -0,0 +1,7 @@ + +(compile -s -O2 -j autoload autoload.scm) +(compile -s -O2 autoload.import.scm) + +(install-extension + 'autoload '("autoload.so" "autoload.import.so") + '((version 3.0) (syntax))) Index: clientmod.scm ================================================================== --- clientmod.scm +++ clientmod.scm @@ -22,12 +22,12 @@ (declare (uses commonmod)) (module clientmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme (chicken base)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -17,8 +17,8 @@ ;; along with Megatest. If not, see . ;; ;;====================================================================== ;; (use trace) -(use typed-records) +(import typed-records) ;; moved to commonmod ADDED dbi/dbi.egg Index: dbi/dbi.egg ================================================================== --- /dev/null +++ dbi/dbi.egg @@ -0,0 +1,5 @@ +((license "BSD") + (category db) + (dependencies autoload sql-null) + (test-dependencies test) + (components (extension dbi))) ADDED dbi/dbi.meta Index: dbi/dbi.meta ================================================================== --- /dev/null +++ dbi/dbi.meta @@ -0,0 +1,21 @@ +;; -*- scheme -*- +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category db) + +; A list of eggs dbi 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 (autoload "3.0") sql-null) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "An abstract database interface.")) ADDED dbi/dbi.release-info Index: dbi/dbi.release-info ================================================================== --- /dev/null +++ dbi/dbi.release-info @@ -0,0 +1,7 @@ +(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") +(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") +(release "0.5") +(release "0.4") +(release "0.3") +(release "0.2") +(release "0.1") ADDED dbi/dbi.scm Index: dbi/dbi.scm ================================================================== --- /dev/null +++ dbi/dbi.scm @@ -0,0 +1,483 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2018 Matt Welland +;; Copyright (C) 2016 Peter Bex +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED! + +;; d = db handle +;; t = statement handle +;; s = statement +;; l = proc +;; p = params +;; +;; sqlite3 postgres dbi +;; prepare: (prepare d s) n/a prepare (sqlite3, pg) +;; for-each (for-each-row l d s . p) (query-for-each l s d) for-each-row +;; for-each (for-each-row l t . p) n/a NOT YET +;; exec (exec d s . p) (query-tuples s d) +;; exec (exec t . p) n/a + +;; set to 'pg or 'sqlite3 +;; (define dbi:type 'sqlite3) ;; or 'pg +;; (dbi:open 'sqlite3 (list (cons 'dbname fullname))) + +;;====================================================================== +;; D B I +;;====================================================================== +(module dbi + (open db-dbtype db-conn for-each-row get-one get-one-row get-rows + exec close escape-string mk-db now database? with-transaction fold-row + prepare map-row convert prepare-exec get-res + + ;; TODO: These don't really belong here. Also, the naming is not + ;; consistent with the usual Scheme conventions. + pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day + pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second + pgdatetime-get-microsecond + pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day! + pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second! + pgdatetime-set-microsecond! + + lazy-bool) + +(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13) +(import (chicken condition) autoload sql-null) + +(define-record-type db + (make-db dbtype dbconn) + db? + (dbtype db-dbtype db-dbtype-set!) + (dbconn db-conn db-conn-set!)) + +(define (missing-egg type eggname) + (lambda _ + (error (printf + "Cannot access ~A databases. Please install the ~S egg and try again." type eggname)))) + +;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded + +;; TODO: Make a convenience macro for this? +(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3")) +(autoload sqlite3 + (open-database sqlite3:open-database sqlite3-missing) + (for-each-row sqlite3:for-each-row sqlite3-missing) + (execute sqlite3:execute sqlite3-missing) + (with-transaction sqlite3:with-transaction sqlite3-missing) + (finalize! sqlite3:finalize! sqlite3-missing) + (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing) + (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing) + (database? sqlite3:database? sqlite3-missing) + (prepare sqlite3:prepare sqlite3-missing) + (fold-row sqlite3:fold-row sqlite3-missing) + (map-row sqlite3:map-row sqlite3-missing) + (statement? sqlite3:statement? sqlite3-missing)) + +(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite")) +(autoload sql-de-lite + (open-database sql:open-database sql-de-lite-missing) + (close-database sql:close-database sql-de-lite-missing) + (for-each-row sql:for-each-row sql-de-lite-missing) + (fold-rows sql:fold-rows sql-de-lite-missing) + (exec sql:exec sql-de-lite-missing) + (fetch-value sql:fetch-value sql-de-lite-missing) + (with-transaction sql:with-transaction sql-de-lite-missing) + (finalize! sql:finalize! sql-de-lite-missing) + (make-busy-timeout sql:make-busy-timeout sql-de-lite-missing) + (set-busy-handler! sql:set-busy-handler! sql-de-lite-missing) + (query sql:query sql-de-lite-missing) + (sql sql:sql sql-de-lite-missing)) + +(define pg-missing (missing-egg 'pg "postgresql")) +(autoload postgresql + (connect pg:connect pg-missing) + (row-for-each pg:row-for-each pg-missing) + (with-transaction pg:with-transaction pg-missing) + (query pg:query pg-missing) + ;;(escape-string pg:escape-string pg-missing) + (disconnect pg:disconnect pg-missing) + (connection? pg:connection? pg-missing) + (row-fold pg:row-fold pg-missing) + (row-map pg:row-map pg-missing) + (affected-rows pg:affected-rows pg-missing) + (result? pg:result? pg-missing)) + +(define mysql-missing (missing-egg 'mysql "mysql-client")) +(autoload mysql-client + (make-mysql-connection mysql:make-connection mysql-missing) + (mysql-null? mysql:mysql-null? mysql-missing)) + +(define (open dbtype dbinit) + (make-db + dbtype + (case dbtype + ((sqlite3) (sqlite3:open-database (alist-ref 'dbname dbinit))) + ((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit))) + ((pg) (pg:connect dbinit)) + ((mysql) (mysql:make-connection (alist-ref 'host dbinit) + (alist-ref 'user dbinit) + (alist-ref 'password dbinit) + (alist-ref 'dbname dbinit) + port: (alist-ref 'port dbinit))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (convert dbh) + (cond + ((database? dbh) dbh) + ((sqlite3:database? dbh) (make-db 'sqlite3 dbh)) + ((pg:connection? dbh) (make-db 'pg dbh)) + ((not mysql:mysql-null?) (make-db 'mysql dbh)) + (else (error "Unsupported database handle " dbh)))) + +(define (for-each-row proc dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (sqlite3:for-each-row + (lambda (first . remaining) + (let ((tuple (list->vector (cons first remaining)))) + (proc tuple))) + conn + (apply sqlparam stmt params))) + ((sql-de-lite)(apply sql:query (sql:for-each-row + (lambda (row) + (proc (list->vector row)))) + (sql:sql conn stmt) + params)) + ((pg) (pg:row-for-each + (lambda (tuple) + (proc (list->vector tuple))) + (pg:query conn (apply sqlparam stmt params)))) + ((mysql) (let* ((replaced-sql (apply sqlparam stmt params)) + (fetcher (conn replaced-sql))) + (fetcher (lambda (tuple) + (proc (list->vector tuple)))))) + (else (error "Unsupported dbtype " dbtype))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) + (apply sql:query sql:fetch-value (sql:sql conn stmt) params)) + (else + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res (vector-ref row 0)))) + dbh + stmt + params) + res))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one-row dbh stmt . params) + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res row))) + dbh + stmt + params) + res)) + +;; common idiom is to seek a list of rows, '() if no match +(define (get-rows dbh stmt . params) + (let ((res '())) + (apply for-each-row + (lambda (row) + (set! res (cons row res))) + dbh + stmt + params) + (reverse res))) + +(define (exec dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (junk #f)) + (case dbtype + ((sqlite3) (apply sqlite3:execute conn stmt params)) + ((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params)) + ((pg) (pg:query conn (apply sqlparam stmt params))) + ((mysql) (conn (apply sqlparam stmt params))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (with-transaction dbh proc) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite)(sql:with-transaction conn proc)) + ((sqlite3) (sqlite3:with-transaction + conn + (lambda () (proc)))) + ((pg) (pg:with-transaction + conn (lambda () (proc)))) + ((mysql) + (conn "START TRANSACTION") + (conn proc) + (conn "COMMIT")) + (else (error "Unsupported dbtype " dbtype))))) + +(define (prepare dbh stmt) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) dbh) ;; nop? + ((sqlite3) (sqlite3:prepare conn stmt)) + ((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '())) + ((mysql) (print "WIP")) + (else (error "Unsupported dbtype" dbtype))))) + +(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (apply sql:query (sql:fold-rows proc init) + (sql:sql conn stmt) params)) + ((sqlite3) (let ((newproc (lambda (prev . rem) + (proc rem prev)))) + (apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) + ((pg) (pg:row-fold proc init (exec dbh stmt params))) + ((mysql) (fold proc '() (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (map-row proc init dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (apply sqlite3:map-row proc conn stmt params)) + ((pg) (pg:row-map proc (exec dbh stmt params))) + ((mysql) (map proc (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (prepare-exec stmth . params) + (if (sqlite3:statement? stmth) + (apply sqlite3:execute stmth params)) + (if (pair? stmth) + (let* ((dbh (car (car stmth))) + (dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (stmth-name (string->symbol (cdr (car stmth))))) + (apply pg:query conn stmth-name params)))) + +(define (get-res handle option) + (if (pg:result? handle) + (case option + ((affected-rows) (pg:affected-rows handle))))) + +(define (close dbh) + (cond + ((database? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (sql:close-database conn)) + ((sqlite3) (sqlite3:finalize! conn)) + ((pg) (pg:disconnect conn)) + ((mysql) (void)) ; The mysql-client egg doesn't support closing... + (else (error "Unsupported dbtype " dbtype))))) + ((pair? dbh) + (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";"))) + (exec (car (car dbh)) stmt))) + ((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called + (sqlite3:finalize! dbh)) + + )) + +;;====================================================================== +;; D B M I S C +;;====================================================================== + +(define (escape-string str) + (let ((parts (split-string str "'"))) + (string-intersperse parts "''"))) +;; (pg:escape-string val))) + +;; convert values to appropriate strings +;; +(define (sqlparam-val->string val) + (cond + ((list? val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c + ((string? val)(string-append "'" (escape-string val) "'")) + ((sql-null? val) "NULL") + ((number? val)(number->string val)) + ((symbol? val)(sqlparam-val->string (symbol->string val))) + ((boolean? val) + (if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1? + ;; should this be "FALSE" or 0 or NULL? + ((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY! + (sqlparam-val->string (time->string (seconds->local-time (current-seconds))))) + (else + (error "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 (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)) + (error "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 (sqlparam-val->string arg)) + (newresult (string-append result section valstr))) + (if (null? argtail) ;; we are done + (string-append newresult (car tail)) + (loop + (car tail) + (cdr tail) + newresult + (car argtail) + (cdr argtail))))))))) + +;; a poorly written but non-broken split-string +;; +(define (split-string strng delim) + (if (eq? (string-length strng) 0) (list strng) + (let loop ((head (make-string 1 (car (string->list strng)))) + (tail (cdr (string->list strng))) + (dest '()) + (temp "")) + (cond ((equal? head delim) + (set! dest (append dest (list temp))) + (set! temp "")) + ((null? head) + (set! dest (append dest (list temp)))) + (else (set! temp (string-append temp head)))) ;; end if + (cond ((null? tail) + (set! dest (append dest (list temp))) dest) + (else (loop (make-string 1 (car tail)) (cdr tail) dest temp)))))) + +(define (database? dbh) + (if (db? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (if (sqlite3:database? conn) #t #f)) + ((sql-de-lite) #t) ;; don't know how to test for database + ((pg) (if (pg:connection? conn) #t #f)) + ((mysql) #t) + (else (error "Unsupported dbtype " dbtype)))) #f)) + +;;====================================================================== +;; Convienence routines +;;====================================================================== + +;; make a db from a list of statements or open it if it already exists +(define (mk-db path file stmts) + (let* ((fname (conc path "/" file)) + (dbexists (file-exists? fname)) + (dbh (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + (system (conc "mkdir -p " path)) ;; create the path + (set! dbh (open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + (exec dbh sqry)) + stmts))) + (sqlite3:set-busy-handler! + (db-conn dbh) (sqlite3:make-busy-timeout 1000000)) + dbh)) + +(define (now dbh) + (let ((dbtype (db-dbtype dbh))) + (case dbtype + ((sqlite3) "datetime('now')") + ;; Standard SQL + (else "now()")))) + +(define (make-pgdatetime)(make-vector 7)) +(define (pgdatetime-get-year vec) (vector-ref vec 0)) +(define (pgdatetime-get-month vec) (vector-ref vec 1)) +(define (pgdatetime-get-day vec) (vector-ref vec 2)) +(define (pgdatetime-get-hour vec) (vector-ref vec 3)) +(define (pgdatetime-get-minute vec) (vector-ref vec 4)) +(define (pgdatetime-get-second vec) (vector-ref vec 5)) +(define (pgdatetime-get-microsecond vec) (vector-ref vec 6)) +(define (pgdatetime-set-year! vec val)(vector-set! vec 0 val)) +(define (pgdatetime-set-month! vec val)(vector-set! vec 1 val)) +(define (pgdatetime-set-day! vec val)(vector-set! vec 2 val)) +(define (pgdatetime-set-hour! vec val)(vector-set! vec 3 val)) +(define (pgdatetime-set-minute! vec val)(vector-set! vec 4 val)) +(define (pgdatetime-set-second! vec val)(vector-set! vec 5 val)) +(define (pgdatetime-set-microsecond! vec val)(vector-set! vec 6 val)) + +;; takes postgres date or timestamp +(define (pg-date->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate))) + +;; takes postgres date or timestamp +(define (pg-datetime->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate) " " + (pgdatetime-get-hour pgdate) ":" + (pgdatetime-get-minute pgdate)`)) + + + +;; map to 0 or 1 from a range of values +;; #f => 0 +;; #t => 1 +;; "0" => 0 +;; "1" => 1 +;; FALSE => 0 +;; TRUE => 1 +;; anything else => 1 +(define (lazy-bool val) + (case val + ((#f) 0) + ((#t) 1) + ((0) 0) + ((1) 1) + (else + (cond + ((string? val) + (let ((nval (string->number val))) + (if nval + (lazy-bool nval) + (cond + ((string=? val "FALSE") 0) + ((string=? val "TRUE") 1) + (else 1))))) + ((symbol? val) + (lazy-bool (symbol->string val))) + (else 1))))) +) ADDED dbi/dbi.setup Index: dbi/dbi.setup ================================================================== --- /dev/null +++ dbi/dbi.setup @@ -0,0 +1,11 @@ +;; Copyright 2007-2018, 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. + +;;;; dbi.setup +(standard-extension 'dbi "0.5") ADDED dbi/example.scm Index: dbi/example.scm ================================================================== --- /dev/null +++ dbi/example.scm @@ -0,0 +1,69 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2016 Matt Welland +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; WARNING: This example is basically useless, I'll rewrite it one of these days .... + +(require-library margs dbi) + +(define help "help me") + +(define remargs (args:get-args + (argv) + (list "-inf") + (list "-h") + args:arg-hash + 0)) + +;; define DBPATH in setup.scm +(include "setup.scm") + +(define (ftf:mk-db) + (let* ((fname (conc DBPATH "/ftfplan.db")) + (dbexists (file-exists? fname)) + (dbh (if dbexists (dbi:open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + ;; (print "fullname: " fullname) + (system (conc "mkdir -p " DBPATH)) ;; create the path + (set! dbh (dbi:open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + ;; (print sqry) + (dbi:exec dbh sqry)) + ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come... + (list + "CREATE TABLE pics (id INTEGER PRIMARY KEY,name TEXT,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + "CREATE TABLE dats (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);" + ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do: + ;; select where created_on < somedate order by created_on desc limit 1 + "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag + "CREATE TABLE revs (id INTEGER PRIMARY KEY,tag TEXT);" + ;; wikis is here for when postgresql support is added or if a sub wiki is created. + "CREATE TABLE wikis (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);")) + )) + dbh)) + +(define db (ftf:mk-db)) + +(dbi:exec db "INSERT INTO pics (name,owner_id) VALUES ('bob',1);") +(dbi:for-each-row (lambda (row)(print "Name: " (vector-ref row 0) ", owner_id: " (vector-ref row 1))) + db + "SELECT name,owner_id FROM pics;") + Index: envmod.scm ================================================================== --- envmod.scm +++ envmod.scm @@ -22,12 +22,12 @@ (declare (uses commonmod)) (module envmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme (chicken base)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") Index: ezstepsmod.scm ================================================================== --- ezstepsmod.scm +++ ezstepsmod.scm @@ -22,12 +22,12 @@ (declare (uses commonmod)) (module ezstepsmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme (chicken base)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") Index: itemsmod.scm ================================================================== --- itemsmod.scm +++ itemsmod.scm @@ -23,12 +23,12 @@ (declare (uses mtconfigf)) (module itemsmod * -(import scheme chicken data-structures extras) -(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme (chicken base)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) (import(prefix mtconfigf configf:)) ;; (use (prefix ulex ulex:)) ;; (include "common_records.scm") Index: mtargs/mtargs.scm ================================================================== --- mtargs/mtargs.scm +++ mtargs/mtargs.scm @@ -26,12 +26,12 @@ print-args any-defined? help ) -(import scheme chicken data-structures extras posix ports files) -(use srfi-69 srfi-1) +(import scheme (chicken base) (chicken port) (chicken file) (chicken process-context)) +(import srfi-69 srfi-1) (define arg-hash (make-hash-table)) (define help "") (define (get-arg arg . default) Index: mtconfigf/mtconfigf.scm ================================================================== --- mtconfigf/mtconfigf.scm +++ mtconfigf/mtconfigf.scm @@ -71,15 +71,16 @@ ;; misc realpath find-chicken-lib ) -(import scheme chicken data-structures extras ports files) -(use posix typed-records srfi-18 pathname-expand posix-extras) -(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 ) -(use srfi-69) -(import posix) +(import scheme (chicken base) (chicken string) (chicken file) (chicken port)) +(import typed-records srfi-18 pathname-expand) +(import regex regex-case srfi-69 srfi-1 directory-utils srfi-13 ) +(import (chicken io) (chicken condition) (chicken process-context)) +(import (chicken process) (chicken pathname) (chicken pretty-print) (chicken time)) +(import srfi-69 (chicken platform) (chicken sort)) ;; stub debug printers overridden by set-debug-printers (define (debug:print n e . args) (apply print args)) (define (debug:print-info n e . args) @@ -92,19 +93,19 @@ ;; FROM common.scm ;; ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) -(let-values (( (chicken-release-number chicken-major-version) - (apply values - (map string->number - (take - (string-split (chicken-version) ".") - 2))))) - (if (or (> chicken-release-number 4) - (and (eq? 4 chicken-release-number) (> chicken-major-version 9))) - (define ##sys#expand-home-path pathname-expand))) +;;;(let-values (( (chicken-release-number chicken-major-version) +;;; (apply values +;;; (map string->number +;;; (take +;;; (string-split (chicken-version) ".") +;;; 2))))) +;;; (if (or (> chicken-release-number 4) +;;; (and (eq? 4 chicken-release-number) (> chicken-major-version 9))) +;;; (define ##sys#expand-home-path pathname-expand))) ;;(define (set-verbosity v)(debug:set-verbosity v)) (define *default-log-port* (current-error-port)) @@ -216,11 +217,11 @@ (if (and (string? val) (string? key)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (setenv key val)) + (set-environment-variable! key val)) (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) ;; execute thunk in context of environment modified as per this list ;; restore env to prior state then return value of eval'd thunk. @@ -237,26 +238,26 @@ (new-val (let ((tmp (cdr env-pair))) (if (list? tmp) (car tmp) tmp))) (current-val (get-environment-variable env-var)) (restore-thunk (cond - ((not current-val) (lambda () (unsetenv env-var))) + ((not current-val) (lambda () (unset-environment-variable! env-var))) ((not (string? new-val)) #f) ((eq? current-val new-val) #f) (else - (lambda () (setenv env-var current-val)))))) + (lambda () (set-environment-variable! env-var current-val)))))) ;;(when (not (string? new-val)) ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) ;; (pp delta-env-alist) ;; (exit 1)) (cond ((not new-val) ;; modify env here - (unsetenv env-var)) + (unset-environment-variable! env-var)) ((string? new-val) - (setenv env-var new-val))) + (set-environment-variable! env-var new-val))) restore-thunk)) delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) @@ -683,11 +684,11 @@ (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (safe-file-exists? include-script)(file-execute-access? include-script)) + (if (and (safe-file-exists? include-script)(file-executable? include-script)) (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (cfgdat->env-alist curr-section-name res local-allow-system)) (new-inp-port (with-env-vars env-delta @@ -819,11 +820,11 @@ (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo))) (if toppath (change-directory toppath)) - (if (and toppath pathenvvar)(setenv pathenvvar toppath)) + (if (and toppath pathenvvar)(set-environment-variable! pathenvvar toppath)) (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (if set-fields (list (cons "^fields$" set-fields) ) '()) #f keep-filenames: keep-filenames)))) @@ -1051,11 +1052,11 @@ ;; returns (list dat msg) (define (read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (safe-file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) + (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) Index: odsmod.scm ================================================================== --- odsmod.scm +++ odsmod.scm @@ -22,11 +22,11 @@ (declare (uses commonmod)) (module odsmod * -(import scheme chicken data-structures extras csv-xml regex) +(import scheme (chicken base) (chicken string) (chicken port) (chicken io) (chicken file) csv-xml regex) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable srfi-13) (import commonmod) ;; (use (prefix ulex ulex:)) ADDED pathname-expand/pathname-expand.egg Index: pathname-expand/pathname-expand.egg ================================================================== --- /dev/null +++ pathname-expand/pathname-expand.egg @@ -0,0 +1,4 @@ +((license "BSD") + (category os) + (author "The CHICKEN team") + (components (extension pathname-expand))) ADDED pathname-expand/pathname-expand.meta Index: pathname-expand/pathname-expand.meta ================================================================== --- /dev/null +++ pathname-expand/pathname-expand.meta @@ -0,0 +1,8 @@ +;; -*-scheme-*- +((synopsis "Pathname expansion") + (license "BSD") + (category os) + (doc-from-wiki) + ;; No tests; this is very hard to do in a cross-platform way without + ;; writing a reimplementation of the functionality in our tests... + (author "The CHICKEN team")) ADDED pathname-expand/pathname-expand.scm Index: pathname-expand/pathname-expand.scm ================================================================== --- /dev/null +++ pathname-expand/pathname-expand.scm @@ -0,0 +1,112 @@ +;;; Pathname expansion, to replace the deprecated core functionality. +; +; Copyright (c) 2014, The CHICKEN Team +; All rights reserved. +; +; Redistribution and use in source and binary forms, with or without +; modification, are permitted provided that the following conditions +; are met: +; +; Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; +; Redistributions in binary form must reproduce the above copyright +; notice, this list of conditions and the following disclaimer in +; the documentation and/or other materials provided with the +; distribution. +; +; Neither the name of the author nor the names of its contributors +; may be used to endorse or promote products derived from this +; software without specific prior written permission. +; +; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +; OF THE POSSIBILITY OF SUCH DAMAGE. + +(module pathname-expand + (pathname-expand) + +(import (chicken base) (chicken pathname) (chicken condition) (chicken platform) scheme) +(import (chicken fixnum) (chicken process-context) (chicken process-context posix)) +(import srfi-13 (chicken file) ) + +;; Expand pathname starting with "~", and/or apply base directory to +;; relative pathname +; +; Inspired by Gambit's "path-expand" procedure. + +(define pathname-expand + (let* ((home + ;; Effective uid might be changed at runtime so this has to + ;; be a lambda, but we could try to cache the result on uid. + (lambda () + (cond-expand + ((and windows (not cygwin)) + (or (get-environment-variable "USERPROFILE") + (get-environment-variable "HOME") + ".")) + (else + (let ((info (user-information (current-effective-user-id)))) + (list-ref info 5)))))) + (slash + (cond-expand + ((and windows (not cygwin)) '(#\\ #\/)) + (else '(#\/)))) + (ts (string-append "~" (string (car slash)))) + (tts (string-append "~" ts))) + (lambda (path #!optional (base (current-directory))) + (if (absolute-pathname? path) + path + (let ((len (string-length path))) + (cond + ((or (string=? "~~" path) + (and (fx>= len 3) (string=? tts (substring path 0 3)))) + ;; Repository-path + (let ((rp (repository-path))) + (if rp + (string-append rp (substring path 2 len)) + (signal + (make-composite-condition + (make-property-condition + 'exn 'location 'pathname-expand + 'message "No repository path defined" + 'arguments (list path)) + (make-property-condition 'pathname-expand) + (make-property-condition 'repository-path)))))) + ((or (string=? "~" path) + (and (fx> len 2) (string=? ts (substring path 0 2)))) + ;; Current user's home dir + (string-append (home) (substring path 1 len))) + ((and (fx> len 0) (char=? #\~ (string-ref path 0))) + ;; Arbitrary user's home dir + (let ((rest (substring path 1 len))) + (if (and (fx> len 1) (memq (string-ref path 1) slash)) + (string-append (home) rest) + (let* ((p (string-index path (lambda (c) (memq c slash)))) + (user (substring path 1 (or p len))) + (info (user-information user))) + (if info + (let ((dir (list-ref info 5))) + (if p + (make-pathname dir (substring path p)) + dir)) + (signal + (make-composite-condition + (make-property-condition + 'exn 'location 'pathname-expand + 'message "Cannot expand homedir for user" + 'arguments (list path)) + (make-property-condition 'pathname-expand) + (make-property-condition 'username)))))))) + (else (make-pathname base path)))))))) + +) ADDED pathname-expand/pathname-expand.setup Index: pathname-expand/pathname-expand.setup ================================================================== --- /dev/null +++ pathname-expand/pathname-expand.setup @@ -0,0 +1,2 @@ +;; -*-scheme-*- +(standard-extension 'pathname-expand 0.1) Index: pkts/pkts.scm ================================================================== --- pkts/pkts.scm +++ pkts/pkts.scm @@ -162,12 +162,13 @@ ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) -(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras) -(use crypt sha1 message-digest (prefix dbi dbi:) typed-records) +(import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file)) +(import chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) ) +(import crypt sha1 message-digest (prefix dbi dbi:) typed-records) ;;====================================================================== ;; DATA MANIPULATION UTILS ;;====================================================================== Index: stml2/cookie.scm ================================================================== --- stml2/cookie.scm +++ stml2/cookie.scm @@ -45,11 +45,11 @@ ;; (declare (unit cookie)) (module cookie * -(import chicken scheme data-structures extras srfi-13 ports posix) +(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time 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)) Index: stml2/stml2.scm ================================================================== --- stml2/stml2.scm +++ stml2/stml2.scm @@ -12,14 +12,14 @@ ;; (declare (unit stml)) (module stml2 * -(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) +(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition)) (import cookie) -(use (prefix dbi dbi:) (prefix crypt c:) typed-records) +(import (prefix dbi dbi:) (prefix crypt c:) typed-records) ;; (declare (uses misc-stml)) (use regex) ;; The (usually global) sdat contains everything about the session Index: ulex/ulex.scm ================================================================== --- ulex/ulex.scm +++ ulex/ulex.scm @@ -58,12 +58,12 @@ ;; ;; system ;; get-normalized-cpu-load ;; ) -(import scheme posix chicken data-structures ports extras files mailbox) -(import rpc srfi-18 pkts matchable regex +(import scheme posix-groups (chicken base) queues (chicken port) (chicken io) (chicken file) mailbox) +(import srfi-18 pkts matchable regex typed-records srfi-69 srfi-1 srfi-4 regex-case (prefix sqlite3 sqlite3:) foreign tcp) ;; ulex-netutil)