| ︙ | | | ︙ | |
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
;;
;; i. Check that owner of the file and calling user are same?
;; ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;; required to use .mtutil.scm.
;;
(if (common:file-exists? "megatest.config")
(if (common:file-exists? ".mtutil.so")
(load ".mtutil.so")
(if (common:file-exists? ".mtutil.scm")
(load ".mtutil.scm"))))
;; main three types of run
;; "-run" => initiate a run
;; "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run
;; "-rerun-all" => set all tests NOT_STARTED and kick off run again
|
|
|
|
|
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
;;
;; i. Check that owner of the file and calling user are same?
;; ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;; required to use .mtutil.scm.
;;
(if (file-exists? "megatest.config")
(if (file-exists? ".mtutil.so")
(load ".mtutil.so")
(if (file-exists? ".mtutil.scm")
(load ".mtutil.scm"))))
;; main three types of run
;; "-run" => initiate a run
;; "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run
;; "-rerun-all" => set all tests NOT_STARTED and kick off run again
|
| ︙ | | | ︙ | |
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(handle-exceptions
exn
(print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
(create-directory dest-dir #t))
(handle-exceptions
exn
(print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn))
(if (common:file-exists? targ-file)
(system (conc "fossil pull --once " url " -R " targ-file))
(system (conc "fossil clone " url " " targ-file))
))))
(define (fossil:last-change-node-and-time fossils-dir fossil-name branch)
(let* ((fossil-file (conc fossils-dir "/" fossil-name))
(timeline-port (if (file-read-access? fossil-file)
|
|
|
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(handle-exceptions
exn
(print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
(create-directory dest-dir #t))
(handle-exceptions
exn
(print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn))
(if (file-exists? targ-file)
(system (conc "fossil pull --once " url " -R " targ-file))
(system (conc "fossil clone " url " " targ-file))
))))
(define (fossil:last-change-node-and-time fossils-dir fossil-name branch)
(let* ((fossil-file (conc fossils-dir "/" fossil-name))
(timeline-port (if (file-read-access? fossil-file)
|
| ︙ | | | ︙ | |
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
|
(define (get-pkts-dir mtconf)
(let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
pktsdir))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(if *action*
(case (string->symbol *action*)
((run remove rerun rerun-clean rerun-all set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
|
|
|
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
|
(define (get-pkts-dir mtconf)
(let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
pktsdir))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(if *action*
(case (string->symbol *action*)
((run remove rerun rerun-clean rerun-all set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
|
| ︙ | | | ︙ | |
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
|
(if (null? remargs)
(print "ERROR: missing sub command for db command")
(let ((subcmd (car remargs)))
(case (string->symbol subcmd)
((pgschema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-pg.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((sqlite3schema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))
((tsend)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
|
|
|
|
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
|
(if (null? remargs)
(print "ERROR: missing sub command for db command")
(let ((subcmd (car remargs)))
(case (string->symbol subcmd)
((pgschema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-pg.sql")))
(if (file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((sqlite3schema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
(if (file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))
((tsend)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
|
| ︙ | | | ︙ | |