| ︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
|
(configf:section-var-set! torun contour runkey
(cons spec
(or (configf:lookup torun contour runkey)
'()))))
(define (fossil:clone-or-sync url name dest-dir)
(let ((targ-file (conc dest-dir "/" name))) ;; do not force usage of .fossil extension
(common:debug-handle-exceptions #t
(handle-exceptions
exn
(print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
(create-directory dest-dir #t))
(common:debug-handle-exceptions #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)
(common:debug-handle-exceptions #t
(handle-exceptions
exn
(begin
(print "ERROR: failed to get timeline from " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
#f)
(open-input-pipe (conc "fossil timeline -t ci -W 0 -n 0 -R " fossil-file)))
#f))
(get-line (lambda ()
(common:debug-handle-exceptions #t
(handle-exceptions
exn
(begin
(print "ERROR: failed to read from file " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
#f)
(read-line timeline-port))))
(date-rx (regexp "^=== (\\S+) ===$"))
(node-rx (regexp "^(\\S+) \\[(\\S+)\\].*\\(.*tags:\\s+([^\\)]+)\\)$")))
|
| ︙ | | |
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
|
-
+
|
(area-path (alist-ref 'path area-dat))
(area-xlatr (alist-ref 'targtrans area-dat))
(new-target (if area-xlatr
(let ((xlatr-key (string->symbol area-xlatr)))
(if (alist-ref xlatr-key *target-mappers*)
(begin
(print "Using target mapper: " area-xlatr)
(common:debug-handle-exceptions #t
(handle-exceptions
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
(print " function is: " (alist-ref xlatr-key *target-mappers*))
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
((alist-ref xlatr-key *target-mappers*)
|
| ︙ | | |
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
|
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
|
-
+
|
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
(lambda (cmd)
(print "cmd: " cmd)
(let* ((script (car cmd))
(params (cdr cmd))
(cmd (conc script " " contour " " runkey " " std-runname " " action " " params))
(res (common:debug-handle-exceptions #t
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
|
| ︙ | | |
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
|
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
|
-
+
|
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
(let ((logdir
(if (if (not (directory? "logs"))
(common:debug-handle-exceptions #t
(handle-exceptions
exn
#f
(create-directory "logs")
#t)
#t)
"logs"
"/tmp")))
|
| ︙ | | |