Megatest

Changes On Branch 80e66f4369f704fa
Login

Changes In Branch v1.70-refactor02-chicken5 Through [80e66f4369] Excluding Merge-Ins

This is equivalent to a diff from 850872189d to 80e66f4369

2020-01-04
16:45
Pulled in compilation fixes from refactor02. check-in: 337a4b27f1 user: matt tags: v1.70-captain-ulex, v1.70-defunct-try
2020-01-02
15:54
Fixes for autoload egg for chicken 5 check-in: 37f61c54ae user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
15:47
Updated DBI egg for chicken 5 check-in: 80e66f4369 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
15:45
Fixed pathname-expand egg for chicken 5 check-in: 2f7180aa77 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
13:56
Initial commit towards supporting chicken 5 in megatest check-in: 65df38ba3d user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
09:36
Fixed imports so dashboard launches Leaf check-in: 850872189d user: jmoon18 tags: v1.70-refactor02, v1.70-defunct-try
2019-12-31
16:19
Added runsmod to eval-string in megatest.scm check-in: 269f41c0b0 user: mrwellan tags: v1.70-refactor02, v1.70-defunct-try

Modified archivemod.scm from [4dfe611770] to [874489c882].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit archivemod))
(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 commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)







|
|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit archivemod))
(declare (uses commonmod))

(module archivemod
	*
	
(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 version [eeb95f11ac].



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
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 version [335bb94708].



























































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
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 version [ca258ae59c].















>
>
>
>
>
>
>
1
2
3
4
5
6
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)))

Modified clientmod.scm from [449944fa84] to [f47d133940].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit clientmod))
(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 commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)







|
|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit clientmod))
(declare (uses commonmod))

(module clientmod
	*
	
(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")


)

Modified common_records.scm from [5084b8d608] to [2591541cd3].

15
16
17
18
19
20
21
22
23
24
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

;; (use trace)
(use typed-records)

;; moved to commonmod







|


15
16
17
18
19
20
21
22
23
24
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

;; (use trace)
(import typed-records)

;; moved to commonmod

Added dbi/dbi.egg version [ce14ed7e9e].











>
>
>
>
>
1
2
3
4
5
((license "BSD")
 (category db)
 (dependencies autoload sql-null)
 (test-dependencies test)
 (components (extension dbi)))

Added dbi/dbi.meta version [df5803e479].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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 version [8881b5e958].















>
>
>
>
>
>
>
1
2
3
4
5
6
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 version [0d4d10831e].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
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 version [e37bd8290c].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
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 version [fa8cc725eb].











































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
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;")

Modified envmod.scm from [322fc41dfe] to [a2ad9fe426].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit envmod))
(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 commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)







|
|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit envmod))
(declare (uses commonmod))

(module envmod
	*
	
(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")


)

Modified ezstepsmod.scm from [b506cc05b8] to [bb1c5c176e].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit ezstepsmod))
(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 commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)







|
|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

(declare (unit ezstepsmod))
(declare (uses commonmod))

(module ezstepsmod
	*
	
(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")


)

Modified itemsmod.scm from [fc849e85b2] to [ca44098a8e].

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(declare (unit itemsmod))
(declare (uses commonmod))
(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 commonmod)
(import(prefix mtconfigf configf:))
;; (use (prefix ulex ulex:))

;; (include "common_records.scm")
;; (include "items-inc.scm")








|
|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(declare (unit itemsmod))
(declare (uses commonmod))
(declare (uses mtconfigf))

(module itemsmod
	*
	
(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")
;; (include "items-inc.scm")

Modified mtargs/mtargs.scm from [e2f1c247b7] to [a907d8beb0].

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
     usage
     get-args
     print-args
     any-defined?
     help
     )

(import scheme chicken data-structures extras posix ports files)
(use srfi-69 srfi-1)

(define arg-hash (make-hash-table))
(define help "")

(define (get-arg arg . default)
  (if (null? default)
      (hash-table-ref/default arg-hash arg #f)







|
|







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
     usage
     get-args
     print-args
     any-defined?
     help
     )

(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)
  (if (null? default)
      (hash-table-ref/default arg-hash arg #f)

Modified mtconfigf/mtconfigf.scm from [f14586a434] to [1f14c46c82].

69
70
71
72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
	 get-eval-string
         squelch-debug-prints
	 ;; 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)

;; stub debug printers overridden by set-debug-printers
(define (debug:print n e . args)
  (apply print args))
(define (debug:print-info n e . args)
  (apply print "INFO: " args))
(define (debug:print-error n e . args)
  (apply print "ERROR: " args))

;;(import (prefix mtdebug debug:))
;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; 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)))


 ;;(define (set-verbosity v)(debug:set-verbosity v))

 (define *default-log-port* (current-error-port))

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for







|
|
|
|
>
|
















|
|
|
|
|
|
|
|
|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
	 get-eval-string
         squelch-debug-prints
	 ;; misc
	 realpath
	 find-chicken-lib
         )

(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)
  (apply print "INFO: " args))
(define (debug:print-error n e . args)
  (apply print "ERROR: " args))

;;(import (prefix mtdebug debug:))
;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; 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)))


 ;;(define (set-verbosity v)(debug:set-verbosity v))

 (define *default-log-port* (current-error-port))

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
  (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
      (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))
	  (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.
;;   ** this is not thread safe **
(define (with-env-vars delta-env-alist-or-hash-table thunk)
  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
                              (hash-table->alist delta-env-alist-or-hash-table)
                              delta-env-alist-or-hash-table))
         (restore-thunks
          (filter
           identity
           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (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 (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else 
                            (lambda () (setenv 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))
                     ((string? new-val)
                      (setenv 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)))

(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))







|




















|



|








|

|







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
  (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
      (if (and (string? val)
	       (string? key))
	  (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" 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.
;;   ** this is not thread safe **
(define (with-env-vars delta-env-alist-or-hash-table thunk)
  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
                              (hash-table->alist delta-env-alist-or-hash-table)
                              delta-env-alist-or-hash-table))
         (restore-thunks
          (filter
           identity
           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (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 () (unset-environment-variable! env-var)))
                           ((not (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else 
                            (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
                      (unset-environment-variable! env-var))
                     ((string? 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)))

(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
					     curr-section-name #f #f)))
	       (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))
                                      (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
                                               (lambda ()
                                                 (open-input-pipe (conc include-script " " params))))))







|







682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
					     curr-section-name #f #f)))
	       (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-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
                                               (lambda ()
                                                 (open-input-pipe (conc include-script " " params))))))
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
;;
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
  (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))
    (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))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))







|







818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
;;
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
  (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)(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))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063

;; reads a refdb into an assoc array of assoc arrays
;;   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))
	    (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 '()))
				 (if (eof-object? inl)
				     (reverse res)







|







1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064

;; reads a refdb into an assoc array of assoc arrays
;;   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-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 '()))
				 (if (eof-object? inl)
				     (reverse res)

Modified odsmod.scm from [f8aba8b41f] to [bb53b8595f].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

(declare (unit odsmod))
(declare (uses commonmod))

(module odsmod
	*
	
(import scheme chicken data-structures extras 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:))

(define ods:dirs
  '("Configurations2"







|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

(declare (unit odsmod))
(declare (uses commonmod))

(module odsmod
	*
	
(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:))

(define ods:dirs
  '("Configurations2"

Added pathname-expand/pathname-expand.egg version [39095f0126].









>
>
>
>
1
2
3
4
((license "BSD")
 (category os)
 (author "The CHICKEN team")
 (components (extension pathname-expand)))

Added pathname-expand/pathname-expand.meta version [89e94e5069].

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
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 version [9bc2d4d6ac].

































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
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 version [b6d5471d8e].





>
>
1
2
;; -*-scheme-*-
(standard-extension 'pathname-expand 0.1)

Modified pkts/pkts.scm from [d1cd1cb6f6] to [55a662356c].

160
161
162
163
164
165
166

167
168
169
170
171
172
173
174
175
pktdb-pktspec

;; 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)

;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))







>
|
|







160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
pktdb-pktspec

;; utility procs
increment-string ;; used to get indexes for strings in ref pkts
make-report      ;; make a .dot file 
)

(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
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

Modified stml2/cookie.scm from [d78a525a3a] to [fba413a4c8].

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (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))

;; #>
;; #include <time.h>







|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(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))

;; #>
;; #include <time.h>

Modified stml2/stml2.scm from [ee4c13898d] to [3dca2d569e].

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 

(import cookie)
(use (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat







|


|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition)) 

(import cookie)
(import (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat

Modified ulex/ulex.scm from [ef093072a2] to [1e0838dba7].

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
     ;;     pl-is-port-available
     ;;     pl-get-port-state
     ;;     ;; system
     ;;     get-normalized-cpu-load
	 
     ;; )

(import scheme posix chicken data-structures ports extras files mailbox)
(import rpc srfi-18 pkts matchable regex
	typed-records srfi-69 srfi-1
	srfi-4 regex-case
	(prefix sqlite3 sqlite3:)
	foreign
	tcp) ;; ulex-netutil)

;;======================================================================







|
|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
     ;;     pl-is-port-available
     ;;     pl-get-port-state
     ;;     ;; system
     ;;     get-normalized-cpu-load
	 
     ;; )

(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)

;;======================================================================