Random Bits of Open Code

Check-in [36337aa670]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Removed dependency on sql-de-lite in mtcommon. Switched mtdb to sqlite3 from sql-de-lite as it seems to work better.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:36337aa6701073955f9ddf518f5846053f60593a
User & Date: matt 2018-05-22 05:53:36
Context
2018-06-07
20:41
Added primitive obfuscation mechanism for text based scripting languages (e.g. perl). check-in: 67253f99d7 user: mrwellan tags: trunk
2018-05-22
05:53
Removed dependency on sql-de-lite in mtcommon. Switched mtdb to sqlite3 from sql-de-lite as it seems to work better. check-in: 36337aa670 user: matt tags: trunk
2018-05-21
06:03
Fixed bad /tmp format bug check-in: b6a399e9a9 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtcommon/mtcommon.meta.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
(category misc)

; A list of eggs mpeg3 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 extras posix sql-de-lite md5 message-digest typed-records format srfi-1 srfi-69 pkts regex dbi regex-case matchable)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Megatest common functions used in many places."))







|






7
8
9
10
11
12
13
14
15
16
17
18
19
20
(category misc)

; A list of eggs mpeg3 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 extras posix md5 message-digest typed-records format srfi-1 srfi-69 pkts regex dbi regex-case matchable)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Megatest common functions used in many places."))

Changes to mtutils/mtcommon/mtcommon.scm.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
..
73
74
75
76
77
78
79


80
81
82
83
84
85
86
87
...
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
...
259
260
261
262
263
264
265
266

267
268
269
270
271
272
273
...
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
;; WARN: This module conflicts with db.scm as it uses sql-de-lite

(module mtcommon
        (
         get-create-writeable-dir
         print-error
         print-info
         log-event
         debug-setup
         debug-mode
         check-verbosity
         calc-verbosity
	 ;; pkts stuff
	 load-pkts-to-db	 
	 get-pkt-alists
................................................................................
	 args-get-target
	 ;; areas
	 get-area-name
	 get-area-path-signature
	 )

(import scheme chicken data-structures extras posix ports files)


(use (prefix sql-de-lite sql:) md5 message-digest posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable)
(use (prefix mtconfigf configf:) srfi-13 (prefix margs args:))

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
................................................................................
				    (conc verbosity))))))
  
(define (debug-print n e . params)
  (if (debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (ctrldat-toppath *log*) (apply conc params))
	      (apply print params)
	      )))))

;; more betterer implementation above?
;; (define (print-info n e . params)
;;   (apply debug-print n e "INFO: " params))

................................................................................

(define (print-error n e . params)
  ;; normal print
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (ctrldat-toppath *log*) (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (apply print "ERROR: " params)
	      ))))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
................................................................................

(define (print-info n e . params)
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		(log-event (ctrldat-toppath *log*) res))

	      (apply print "INFO: (" n ") " params) ;; res)
	      )))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))
................................................................................
	  '(0 "n/a")
	  all-files)))

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db toppath)
  (let* ((dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sql:open-database dbpath))
	 (handler   (sql:busy-timeout 136000))) ;; remove argument to override
    (sql:set-busy-handler! db handler)
    (if (not dbexists)
        (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
    (sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
    db))

(define (log-local-event toppath . loglst)
  (let ((logline (apply conc loglst)))
    (log-event (ctrldat-toppath *log*) logline)))

(define (log-event toppath logline)
  (let ((db (open-logging-db toppath)))
    (sql:exec
     (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
     logline
     (current-directory)
     (string-intersperse (argv) " ")
     (current-process-id))







|







 







>
>
|







 







|







 







|







 







|
>







 







|










|



|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
..
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
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
;; WARN: This module conflicts with db.scm as it uses sql-de-lite

(module mtcommon
        (
         get-create-writeable-dir
         print-error
         print-info
         ;; log-event
         debug-setup
         debug-mode
         check-verbosity
         calc-verbosity
	 ;; pkts stuff
	 load-pkts-to-db	 
	 get-pkt-alists
................................................................................
	 args-get-target
	 ;; areas
	 get-area-name
	 get-area-path-signature
	 )

(import scheme chicken data-structures extras posix ports files)
(use 
     ;; (prefix sql-de-lite sql:)
      md5 message-digest posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable)
(use (prefix mtconfigf configf:) srfi-13 (prefix margs args:))

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
................................................................................
				    (conc verbosity))))))
  
(define (debug-print n e . params)
  (if (debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      #f ;; (log-event (ctrldat-toppath *log*) (apply conc params))
	      (apply print params)
	      )))))

;; more betterer implementation above?
;; (define (print-info n e . params)
;;   (apply debug-print n e "INFO: " params))

................................................................................

(define (print-error n e . params)
  ;; normal print
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      #f ;; (log-event (ctrldat-toppath *log*) (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (apply print "ERROR: " params)
	      ))))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
................................................................................

(define (print-info n e . params)
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		#f ;; (log-event (ctrldat-toppath *log*) res)
		)
	      (apply print "INFO: (" n ") " params) ;; res)
	      )))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))
................................................................................
	  '(0 "n/a")
	  all-files)))

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

#;(define (open-logging-db toppath)
  (let* ((dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sql:open-database dbpath))
	 (handler   (sql:busy-timeout 136000))) ;; remove argument to override
    (sql:set-busy-handler! db handler)
    (if (not dbexists)
        (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
    (sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
    db))

#;(define (log-local-event toppath . loglst)
  (let ((logline (apply conc loglst)))
    (log-event (ctrldat-toppath *log*) logline)))

#;(define (log-event toppath logline)
  (let ((db (open-logging-db toppath)))
    (sql:exec
     (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
     logline
     (current-directory)
     (string-intersperse (argv) " ")
     (current-process-id))

Changes to mtutils/mtdb/mtdb.scm.

76
77
78
79
80
81
82

83
84
85
86
87
88
89
...
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
...
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
...
333
334
335
336
337
338
339

340




341
342
343
344
345
346
347
...
367
368
369
370
371
372
373
374


375
376
377
378
379
380
381
...
400
401
402
403
404
405
406





407
408
409
410
411
412
413
....
1199
1200
1201
1202
1203
1204
1205

1206
1207
1208
1209
1210
1211
1212
....
1798
1799
1800
1801
1802
1803
1804



1805
1806
1807
1808
1809
1810
1811

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
     get-tests-mindata
     get-tests-mindata-filtered

     
     ;; misc queries
     get-changed-record-ids
     ;; data structs - there must be an easy way to do this?
     ;; Megatest 1.X stuff
     get-run-info-1.X
     get-header
................................................................................
     get-last-run-version-number
     set-last-run-version
 
     )

(import scheme chicken data-structures extras ports srfi-69 srfi-1)
(use regex srfi-13 matchable
     (prefix sql-de-lite s:)
     ;; (prefix sqlite3 s:)
     (prefix dbi dbi:) posix typed-records
     (prefix mtcommon common:)
     (prefix mtconfigf configf:))

;; (use trace)

(define *default-log-port* (current-error-port))
................................................................................
        #f)))

;; open and if needed init a sqlite3 db with the schema
;; 
(define (mtdb-sqlite3-open path fbase)
  (let* ((fulln   (conc path "/" fbase ".db"))
	 (fexists (file-exists? fulln))
	 ;; (dbtype  'sqlite3) ;; 'sql-de-lite
	 (dbtype  'sql-de-lite)
	 (dbispec `((dbname . ,fulln)))
	 (dbh     (begin ;; I'm seeing wierd problems with sqlite3 trying to open stuff other than strings pointing to files
		    (assert (string? (alist-ref 'dbname dbispec)))
		    (dbi:open dbtype dbispec)))
	 (db      (dbi:db-conn dbh)))
    ;; WARNING: Race condition exists here.
       (if (not fexists)
................................................................................
	    dbh
	    (lambda ()
	      (for-each
	       (lambda (stmt)
		 (dbi:exec dbh stmt))
	       *sql-de-lite-schema*))))
       (case dbtype

	 ((sql-de-lite)(s:set-busy-handler! db (s:busy-timeout 10000))))




       (dbi:exec dbh "PRAGMA journal_mode=WAL")
       (dbi:exec dbh "PRAGMA synchronous=0")
       dbh))

;; do NOT close the db in the following three routines.

;; for sql-de-lite access we keep main and runs in separate files
................................................................................
      exn
      #f ;; just give up
    (let* ((mtdb        (adat-mtdb adat))
	   (path        (adat-path adat))
	   (dbispec    `((dbname . ,(conc path "/megatest.db"))))
	   (mt-dbh      (if mtdb
			    mtdb
			    (let ((db (dbi:open 'sql-de-lite dbispec)))


			      (adat-mtdb-set! adat db)
			      db)))
	   (res         (if proc (apply proc mt-dbh params) mt-dbh)))
      (dbi:get-one-row mt-dbh "SELECT * FROM tests LIMIT 1;") ;; ensure the db is whole
      res)))

;; for sql-de-lite access we keep main and runs in separate files
................................................................................
		      existing
		      (let* ((tmppath (adat-tmppath adat))
			     (dbh     (mtdb-sqlite3-open tmppath (conc run-id))))
			(hash-table-set! (adat-mtdb-runs adat) run-id dbh)
			dbh)))
	 (res     (if proc (proc dbh-run) dbh-run)))
    res))






(define (close-all-dbs adat)
  ;; megatest.db
  (if (adat-mtdb-main adat)(dbi:close (adat-mtdb-main adat)))
  (adat-mtdb-main-set! adat #f)
  ;; main.db
  (if (adat-mtdb adat)(dbi:close (adat-mtdb adat)))
................................................................................
			     (update-test run-dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
			   (begin 
			     (print "Inserting test with run-id: " run-id " and test-id: " test-id  " pgdb run id: " pgdb-run-id)
			     (insert-test run-dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
			     (set! pgdb-test-id (get-test-id adat2 pgdb-run-id test-name item-path))))
		       (hash-table-set! test-ht test-id pgdb-test-id))))
		 tests))))

	 (print "INFO: sync for run " run-id " completed in " (- (current-seconds) start-time) " seconds.")))
     run-ids)
    ;; close all database connections - sync can build up a lot of connections
    (close-all-dbs adat1)
    (close-all-dbs adat2)
    ))

................................................................................
(define (get-target-1.X adat run-id)
  (let* ((keyvals (get-key-vals-1.X adat run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if (string? x) x "-na-"))
					   (vector->list keyvals))
				      "/")))
    thekey))





;;======================================================================
;; The attic
;;======================================================================


)







>







 







|
|







 







|
|







 







>
|
>
>
>
>







 







|
>
>







 







>
>
>
>
>







 







>







 







>
>
>







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
...
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
...
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
....
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
....
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
     get-tests-mindata
     get-tests-mindata-filtered
     update-test
     
     ;; misc queries
     get-changed-record-ids
     ;; data structs - there must be an easy way to do this?
     ;; Megatest 1.X stuff
     get-run-info-1.X
     get-header
................................................................................
     get-last-run-version-number
     set-last-run-version
 
     )

(import scheme chicken data-structures extras ports srfi-69 srfi-1)
(use regex srfi-13 matchable
     ;; (prefix sql-de-lite s:)
     (prefix sqlite3 sql3:)
     (prefix dbi dbi:) posix typed-records
     (prefix mtcommon common:)
     (prefix mtconfigf configf:))

;; (use trace)

(define *default-log-port* (current-error-port))
................................................................................
        #f)))

;; open and if needed init a sqlite3 db with the schema
;; 
(define (mtdb-sqlite3-open path fbase)
  (let* ((fulln   (conc path "/" fbase ".db"))
	 (fexists (file-exists? fulln))
	 (dbtype  'sqlite3) ;; 'sql-de-lite
	 ;; (dbtype  'sql-de-lite)
	 (dbispec `((dbname . ,fulln)))
	 (dbh     (begin ;; I'm seeing wierd problems with sqlite3 trying to open stuff other than strings pointing to files
		    (assert (string? (alist-ref 'dbname dbispec)))
		    (dbi:open dbtype dbispec)))
	 (db      (dbi:db-conn dbh)))
    ;; WARNING: Race condition exists here.
       (if (not fexists)
................................................................................
	    dbh
	    (lambda ()
	      (for-each
	       (lambda (stmt)
		 (dbi:exec dbh stmt))
	       *sql-de-lite-schema*))))
       (case dbtype
	 ((sql-de-lite)
	  ;; (s:set-busy-handler! db (s:busy-timeout 10000))
	  ;; (s:prepared-cache-size 0)
	  #f)
	 ((sqlite3)
	  (sql3:set-busy-handler! db (sql3:make-busy-timeout 2000))))
       (dbi:exec dbh "PRAGMA journal_mode=WAL")
       (dbi:exec dbh "PRAGMA synchronous=0")
       dbh))

;; do NOT close the db in the following three routines.

;; for sql-de-lite access we keep main and runs in separate files
................................................................................
      exn
      #f ;; just give up
    (let* ((mtdb        (adat-mtdb adat))
	   (path        (adat-path adat))
	   (dbispec    `((dbname . ,(conc path "/megatest.db"))))
	   (mt-dbh      (if mtdb
			    mtdb
			    (let ((db (dbi:open ;; 'sql-de-lite
				       'sqlite3
				       dbispec)))
			      (adat-mtdb-set! adat db)
			      db)))
	   (res         (if proc (apply proc mt-dbh params) mt-dbh)))
      (dbi:get-one-row mt-dbh "SELECT * FROM tests LIMIT 1;") ;; ensure the db is whole
      res)))

;; for sql-de-lite access we keep main and runs in separate files
................................................................................
		      existing
		      (let* ((tmppath (adat-tmppath adat))
			     (dbh     (mtdb-sqlite3-open tmppath (conc run-id))))
			(hash-table-set! (adat-mtdb-runs adat) run-id dbh)
			dbh)))
	 (res     (if proc (proc dbh-run) dbh-run)))
    res))

(define (close-run-db adat run-id)
  (let ((dbh (hash-table-ref/default (adat-mtdb-runs adat) run-id #f)))
    (hash-table-delete! (adat-mtdb-runs adat) run-id)
    (if dbh (dbi:close dbh))))

(define (close-all-dbs adat)
  ;; megatest.db
  (if (adat-mtdb-main adat)(dbi:close (adat-mtdb-main adat)))
  (adat-mtdb-main-set! adat #f)
  ;; main.db
  (if (adat-mtdb adat)(dbi:close (adat-mtdb adat)))
................................................................................
			     (update-test run-dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
			   (begin 
			     (print "Inserting test with run-id: " run-id " and test-id: " test-id  " pgdb run id: " pgdb-run-id)
			     (insert-test run-dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
			     (set! pgdb-test-id (get-test-id adat2 pgdb-run-id test-name item-path))))
		       (hash-table-set! test-ht test-id pgdb-test-id))))
		 tests))))
	 (close-run-db adat2 pgdb-run-id)
	 (print "INFO: sync for run " run-id " completed in " (- (current-seconds) start-time) " seconds.")))
     run-ids)
    ;; close all database connections - sync can build up a lot of connections
    (close-all-dbs adat1)
    (close-all-dbs adat2)
    ))

................................................................................
(define (get-target-1.X adat run-id)
  (let* ((keyvals (get-key-vals-1.X adat run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if (string? x) x "-na-"))
					   (vector->list keyvals))
				      "/")))
    thekey))

#;(use trace)
#;(trace with-run-db update-test get-runs-info get-test-id run-id->mtpg-run-id)
#;(trace-call-sites #t)

;;======================================================================
;; The attic
;;======================================================================


)