| ︙ | | | ︙ | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
;;
;; 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"))))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; Contour actions
;; import : import pkts
|
|
|
|
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
;;
;; 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"))))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; Contour actions
;; import : import pkts
|
| ︙ | | | ︙ | |
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
(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)
|
|
|
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
(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)
|
| ︙ | | | ︙ | |
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
(define (load-pkts-to-db mtconf)
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
|
|
|
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
(define (load-pkts-to-db mtconf)
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (common:file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
|
| ︙ | | | ︙ | |
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
|
(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 set-ss archive kill)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
|
|
|
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
|
(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 set-ss archive kill)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
|
| ︙ | | | ︙ | |
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
|
(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))))))))
;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;
|
|
|
|
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
|
(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))))))))
;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;
|
| ︙ | | | ︙ | |