Megatest

Check-in [63be42f118]
Login
Overview
Comment:Additional updates for chicken 5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.70-refactor02-chicken5 | v1.70-defunct-try
Files: files | file ages | folders
SHA1: 63be42f11866cabc45da152c1e680a98b9560ccc
User & Date: jmoon18 on 2020-01-08 13:35:11
Other Links: branch diff | manifest | tags
Context
2020-01-08
14:43
Updates post Matt's merge check-in: 4e27bc6a19 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
13:35
Additional updates for chicken 5 check-in: 63be42f118 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
2020-01-02
16:47
Additional tweaks towards a chicken 5 version check-in: f953501529 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try
Changes

Modified commonmod.scm from [838137cf51] to [a8af5f2241].

23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37







-
+







;; (declare (uses stml2))
(declare (uses mtconfigf))
(declare (uses ulex))
(declare (uses pkts))
(module commonmod
	*
	
(import scheme chicken data-structures extras)
(import scheme (chicken base)) 

(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18
     srfi-1 files format srfi-13 matchable 
     srfi-69 ports
     (prefix base64 base64:)
     regex-case regex hostinfo srfi-4
     (prefix dbi dbi:)

Modified pkts/pkts.scm from [55a662356c] to [1f160e9533].

694
695
696
697
698
699
700
701

702
703
704
705
706
707
708
694
695
696
697
698
699
700

701
702
703
704
705
706
707
708







-
+







     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (file-exists? pktsdir))
	  (print "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	 ((not (file-readable? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  ;; (print "INFO: Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))

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

56
57
58
59
60
61
62
63

64
65
66
67
68
69











70
71
72
73
74
75
76
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







-
+




-
-
+
+
+
+
+
+
+
+
+
+
+







     ;;     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 scheme posix-groups (chicken base) queues (chicken port) (chicken io) (chicken file) mailbox system-information)
(import srfi-18 pkts matchable regex
	typed-records srfi-69 srfi-1
	srfi-4 regex-case
	(prefix sqlite3 sqlite3:)
	foreign
	tcp) ;; ulex-netutil)
	(chicken foreign)
    (chicken sort)
    (chicken process-context posix)
    (chicken process-context)
    (chicken file posix)
    (chicken random)
    (chicken pretty-print)
    (chicken string)
    (chicken time)
    (chicken condition)
	(chicken tcp)) ;; ulex-netutil)

;;======================================================================
;; D E B U G   H E L P E R S
;;======================================================================
    
(define (dbg> . args)
  (with-output-to-port (current-error-port)
240
241
242
243
244
245
246
247
248


249
250
251
252
253
254
255
249
250
251
252
253
254
255


256
257
258
259
260
261
262
263
264







-
-
+
+








(define (any->number num)
  (cond
   ((number? num) num)
   ((string? num) (string->number num))
   (else num)))

(use trace)
(trace-call-sites #t)
;;(use trace)
;;(trace-call-sites #t)

;;======================================================================
;; D A T A B A S E   H A N D L I N G 
;;======================================================================

;; look in dbhandles for a db, return it, else return #f
;;
272
273
274
275
276
277
278
279
280


281
282
283
284
285
286
287
281
282
283
284
285
286
287


288
289
290
291
292
293
294
295
296







-
-
+
+







;; open db's hash table
;; returns: the dbdat
;;
(define (open-db acfg fname)
  (let* ((fullname     (conc (area-dbdir acfg) "/" fname))
	 (exists       (file-exists? fullname))
	 (write-access (if exists
			   (file-write-access? fullname)
			   (file-write-access? (area-dbdir acfg))))
			   (file-writable? fullname)
			   (file-writable? (area-dbdir acfg))))
	 (db           (sqlite3:open-database fullname))
	 (handler      (sqlite3:make-busy-timeout 136000))
	 )
    (sqlite3:set-busy-handler! db handler)
    (sqlite3:execute db "PRAGMA synchronous = 0;")
    (if (not exists) ;; need to init the db
	(if write-access
364
365
366
367
368
369
370
371

372
373
374
375
376
377
378
373
374
375
376
377
378
379

380
381
382
383
384
385
386
387







-
+







;;======================================================================
;; W O R K   Q U E U E   H A N D L I N G 
;;======================================================================

(define (register-db-as-mine acfg dbname)
  (let ((ht (area-dbs acfg)))
    (if (not (hash-table-ref/default ht dbname #f))
	(hash-table-set! ht dbname (random 10000)))))
	(hash-table-set! ht dbname (pseudo-random-integer 10000)))))
	
(define (work-queue-add acfg fname witem)
  (let* ((work-queue-start (current-milliseconds))
	 (action           (witem-action witem)) ;; NB the action is the index into the rdat actions
	 (qdat             (or (hash-table-ref/default (area-wqueues acfg) fname #f)
			       (let ((newqdat (make-qdat)))
				 (hash-table-set! (area-wqueues acfg) fname newqdat)