Megatest

Check-in [029eb76890]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed couple issues with runname generation
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64
Files: files | file ages | folders
SHA1: 029eb76890f8c379a165d4884579af1c0c695aa4
User & Date: matt on 2017-03-21 10:11:10
Other Links: branch diff | manifest | tags
Context
2017-03-21
15:15
Merged v1.63 into v1.64 check-in: d6966aee7c user: matt tags: v1.64
10:11
Fixed couple issues with runname generation check-in: 029eb76890 user: matt tags: v1.64
00:26
Uncommented some examples from megatest.config that were commented out during debug check-in: 3abe7045e8 user: matt tags: v1.64
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified .mtutil.scm from [e3cd2ca48d] to [dcf82d5ea0].

︙︙
15
16
17
18
19
20
21



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

37
38
39
40
41






42

43
44
45

46
47





48
49
50

					    (string->number (alist-ref "event_time" item equal?))))
				    dat)))
	       (sorted       (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
	       (last-name    (if (null? sorted)
				 #f
				 (caar sorted))))
	  last-name))))



 
;; example of how to set up and write target mappers
;;
(hash-table-set! *target-mappers*
		 'prefix-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc contour "/" target)))
(hash-table-set! *target-mappers*
		 'prefix-area-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc area "/" contour "/" target)))
  
(hash-table-set! *runname-mappers*
		 'corporate-ww
		 (lambda (target run-name area area-path reason contour mode-patt)

		   (let* ((last-name   (get-last-runname area-path target))
			  (last-letter (if (string? last-name)
					   (let ((len (string-length last-name)))
					     (substring last-name (- len 1) len))
					   "a"))






			  (next-letter (list->string

					(list
					 (integer->char
					  (+ (char->integer (string-ref last-letter 0)) 1)))))) ;; surely there is an easier way?

		     ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
		     (conc (seconds->wwdate (current-seconds)) next-letter))))






(print "Got here!")









>
>
>















>

|
|
|
|
>
>
>
>
>
>
|
>
|
|
|
>


>
>
>
>
>




15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

					    (string->number (alist-ref "event_time" item equal?))))
				    dat)))
	       (sorted       (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
	       (last-name    (if (null? sorted)
				 #f
				 (caar sorted))))
	  last-name))))

(define (str-first-char->number str)
  (char->integer (string-ref str 0)))
 
;; example of how to set up and write target mappers
;;
(hash-table-set! *target-mappers*
		 'prefix-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc contour "/" target)))
(hash-table-set! *target-mappers*
		 'prefix-area-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc area "/" contour "/" target)))
  
(hash-table-set! *runname-mappers*
		 'corporate-ww
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
		   (let* ((last-name   (get-last-runname area-path target))
			  (last-letter (let* ((ch (if (string? last-name)
						      (let ((len (string-length last-name)))
							(substring last-name (- len 1) len))
						      "a"))
					      (chnum (str-first-char->number ch))
					      (a     (str-first-char->number "a"))
					      (z     (str-first-char->number "z")))
					 (if (and (>= chnum a)(<= chnum z))
					     chnum
					     #f)))
			  (next-letter (if last-letter
					   (list->string
					    (list
					     (integer->char
					      (+ last-letter 1)))) ;; surely there is an easier way?
					   "a")))
		     ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
		     (conc (seconds->wwdate (current-seconds)) next-letter))))

(hash-table-set! *runname-mappers*
		 'auto
		 (lambda (target run-name area area-path reason contour mode-patt)
		   "auto-eh"))

(print "Got here!")

Modified mtut.scm from [19b97964aa] to [003fb104de].

︙︙
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463

464
465
466

467
468
469
470
471
472
473
474

(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 (area-xlatr (alist-ref 'targtrans area-dat))
	 (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			(print "callname=" callname " runtrans=" runtrans)
			(if (and callname
				 (not (equal? callname "auto"))
				 (not mapper))
			    (print "Failed to find runname mapper " callname " for area " area))
			(if mapper
			    (handle-exceptions
				exn
				(begin

				  (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
				  (print " message: " ((condition-property-accessor 'exn 'message) exn))
				  runname)

			      (mapper target runname area area-path reason contour mode-patt))
			    runname)))
	 (new-target (if area-xlatr 
			 (let ((xlatr-key (string->symbol area-xlatr)))
			   (if (hash-table-exists? *target-mappers* xlatr-key)
			       (begin
				 (print "Using target mapper: " area-xlatr)
				 (handle-exceptions








|








>



>
|








448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476

(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 (area-xlatr (alist-ref 'targtrans area-dat))
	 (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			(print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
			(if (and callname
				 (not (equal? callname "auto"))
				 (not mapper))
			    (print "Failed to find runname mapper " callname " for area " area))
			(if mapper
			    (handle-exceptions
				exn
				(begin
				  (print-call-chain)
				  (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
				  (print " message: " ((condition-property-accessor 'exn 'message) exn))
				  runname)
			      (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
			      (mapper runkey runname area area-path reason contour mode-patt))
			    runname)))
	 (new-target (if area-xlatr 
			 (let ((xlatr-key (string->symbol area-xlatr)))
			   (if (hash-table-exists? *target-mappers* xlatr-key)
			       (begin
				 (print "Using target mapper: " area-xlatr)
				 (handle-exceptions
︙︙

This page was generated in about 0.134s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00