Megatest

Check-in [366b1b75fd]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:changed the config hash key for toppath from empty string to toppath
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.0001
Files: files | file ages | folders
SHA1: 366b1b75fd2ce415276aa0ad1665852331ac2c65
User & Date: mmgraham on 2022-02-10 12:19:50
Other Links: branch diff | manifest | tags
Context
2022-02-11
15:20
turned off env-to-use in scheme eval, removed erroneous setting of toppath check-in: aad18f28ae user: mmgraham tags: v2.0001
2022-02-10
12:19
changed the config hash key for toppath from empty string to toppath check-in: 366b1b75fd user: mmgraham tags: v2.0001
2022-02-02
18:07
corrected *configdat* to *runconfigdat* check-in: 3d2d201a06 user: mmgraham tags: v2.0001
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified configfmod.scm from [f1ce16c75f] to [b96bbf2b72].

︙
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
425
426
427
428
429
430
431


432
433
434
435
436
437
438

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
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439








-
-
+
+















-












+
+








      (let (;; (env-to-use (if env-to-use env-to-use (module-environment 'configfmod)))
	    (inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
	    (res        (let ((ht-in (if (not ht)
					 (make-hash-table)
					 ht)))
			  (if (not (configf:lookup ht-in "" "toppath"))
			      (configf:set-section-var ht-in "" "toppath" (pathname-directory path)))
			  (if (not (configf:lookup ht-in "toppath" "toppath"))
			        (configf:set-section-var ht-in "toppath" "toppath" (pathname-directory path)))
			  ht-in))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f))
            (process-wildcards  (lambda (res curr-section-name)
                                  (if (and apply-wildcards
                                           (or (string-contains curr-section-name "%")   ;; wildcard
                                               (string-match "/.*/" curr-section-name))) ;; regex
                                      (begin
                                        (configf:apply-wildcards res curr-section-name)
                                        (hash-table-delete! res curr-section-name))))))  ;; NOTE: if the section is a wild card it will be REMOVED from res 
	(let loop ((inl               (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings env-to-use)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
                ;; process last section for wildcards
                (process-wildcards res curr-section-name)
		(if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
		    (close-input-port inp))
		(if (list? sections) ;; delete all sections except given when sections is provided
		    (for-each
		     (lambda (section)
		       (if (not (member section sections))
			   (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
		     (hash-table-keys res)))


		(debug:print 9 *default-log-port* "END: " path)
                res
                ) ;; retval
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings env-to-use)
                                                            curr-section-name #f #f))
︙
1012
1013
1014
1015
1016
1017
1018

1019

1020
1021
1022
1023
1024
1025
1026

1013
1014
1015
1016
1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027
1028








+
-
+








		      (print var " " val)))
		  section-dat))))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (configf:set-section-var ht "toppath" "toppath" (getenv "PWD"))
    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "toppath" "default" target) #f))))

;;======================================================================
;; Config file handling
;;======================================================================

;; convert to param?
(define configf:std-imports "(import scheme big-chicken system-information simple-exceptions big-chicken configfmod commonmod rmtmod chicken.process-context.posix)(import (prefix mtargs args:))(define getenv get-environment-variable)")
︙
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050

1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075

1076
1077
1078
1079
1080
1081
1082

1037
1038
1039
1040
1041
1042
1043

1044
1045
1046
1047
1048
1049
1050
1051

1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062

1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076

1077
1078
1079
1080
1081
1082
1083
1084








-
+







-
+










-
+













-
+








	 (start-time (current-seconds))
	 (cmdsym  (string->symbol cmdtype))
	 (fullcmd
	  (if (member cmdsym '(scheme scm))
	      `(eval-needed
		,(conc  "(lambda (ht)"
			configf:std-imports
			"(set! *toppath* \""(configf:lookup ht "" "toppath")"\")"
			"(set! *toppath* \""(configf:lookup ht "toppath" "toppath")"\")"
			cmd ")"))
	      (case cmdsym
		((system)     `(noeval-needed  ,(conc (configf:system ht cmd))))
		;; ((shell sh)   `(noeval-needed  ,(conc (string-translate (shell quotedcmd) "\n" " "))))
		((shell sh)   `(noeval-needed  ,(conc (string-translate (shell cmd) "\n" " "))))
		((realpath rp)`(noeval-needed  ,(conc (common:nice-path quotedcmd))))
		((getenv gv)  `(noeval-needed  ,(conc (get-environment-variable cmd))))
		((mtrah)      `(noeval-needed  ,(configf:lookup ht "" "toppath")))
		((mtrah)      `(noeval-needed  ,(configf:lookup ht "toppath" "toppath")))
		((get g)   
		 (match
		  (string-split cmd)
		  ((sect var) `(noeval-needed ,(configf:lookup ht sect var)))
		  (else
		   (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
		   '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
		;;((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht cmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		(else `(#f ,(conc "cmd: " cmd " not recognised")))))))
    (match
     (match
     fullcmd
     (('eval-needed newres)
	 (if (or allow-system
		 (not (member cmdtype '("system" "shell" "sh"))))
	     (begin
	       ;; (debug:print 0 *default-log-port* "eval: "newres)
	       (with-input-from-string newres
		 (lambda ()
		   (set! result
			 (handle-exceptions
	       		  exn
	       		  (begin
	       		    (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", eval-needed, newres="newres", exn="(condition->list exn))
	       		    (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	       		    (debug:print 0 *default-log-port* " message1: " ((condition-property-accessor 'exn 'message) exn))
	       		    (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " newres)))
			  (if env-to-use
			      ((eval (read) env-to-use) ht)
			      ((eval (read)) ht)
			      ))))))
	     (set! result (conc "#{(" cmdtype ") "  cmd "}")))); )
     (('noeval-needed newres)(set! result newres))
︙
1133
1134
1135
1136
1137
1138
1139
1140

1141
1142
1143
1144
1145
1146
1147

1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149








-
+








			       ;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
			       (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
		   (debug:print 0 *default-log-port* " message2: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell" "sh"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result (if env-to-use
︙

Modified megatest.scm from [4231ff6ee0] to [17b2f9374a].

︙
193
194
195
196
197
198
199


200
201
202
203
204
205
206

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208








+
+








(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")
(include "ods.scm")

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

(set! *toppath* (get-environment-variable "PWD"))

;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================

(define (megatest:step step state status logfile msg)
  (if (not (get-environment-variable "MT_CMDINFO"))
︙
280
281
282
283
284
285
286
287

288
289
290
291
292
293
294

282
283
284
285
286
287
288

289
290
291
292
293
294
295
296








-
+








     			 status: #f
     			 new-state-status: "NOT_STARTED,n/a")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
     			       (if x (string->number x) #f)))
     	 (rerun-cnt (if config-reruns
     			config-reruns
     			1)))
    
    (debug:print 0 *default-log-port* "handle-run-requests *toppath* = " *toppath*) 
    (runs:run-tests target
     		    runname
     		    #f ;; (common:args-get-testpatt #f)
     		    ;; (or (args:get-arg "-testpatt")
     		    ;;     "%")
     		    (bdat-user *bdat*)
     		    args:arg-hash
︙
756
757
758
759
760
761
762
763


764
765
766
767





768
769
770
771
772
773
774

758
759
760
761
762
763
764

765
766
767
768
769

770
771
772
773
774
775
776
777
778
779
780
781








-
+
+



-
+
+
+
+
+








     
     ;; before doing anything else change to the start-dir if provided
     ;;
     (if (args:get-arg "-start-dir")
         (if (common:file-exists? (args:get-arg "-start-dir"))
             (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
               (set-environment-variable! "PWD" fullpath)
               (change-directory fullpath))
               (change-directory fullpath)
               (set! *toppath* fullpath))
     	(begin
     	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
     	  (exit 1))))
     
    
     (set! *toppath* (get-environment-variable "PWD"))
     


     ;; immediately set MT_TARGET if -reqtarg or -target are available
     ;;
     (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
       (if targ 
        (begin
          (set-environment-variable! "MT_TARGET" targ)
          (mytarget targ)
︙

Modified runsmod.scm from [727372ff23] to [988d978da0].

︙
376
377
378
379
380
381
382
383

384
385
386
387
388
389
390

376
377
378
379
380
381
382

383
384
385
386
387
388
389
390








-
+








	 (config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	 (allowed-tests      #f)
	 (runconf            #f))

    ;; check if readonly
    (when readonly-mode
      (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed.")
      (debug:print-error 0 *default-log-port* *toppath* ".db/main.db is readonly.  Cannot proceed.")
      (exit 1))

    ;; per user request. If less than 100Meg space on dbdir partition, bail out with error
    ;; this will reduce issues in database corruption
    (common:check-db-dir-and-exit-if-insufficient)

    ;; override the number of reruns from the configs
︙

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