Megatest

Check-in [4cf5c411c5]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed silly issue caused by accidentally checking in changes made while discussing code for illustration purposes
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 4cf5c411c5aa9bb563e1ec80b33b5eca4ad55723
User & Date: matt on 2016-02-01 23:22:55
Other Links: branch diff | manifest | tags
Context
2016-02-02
07:52
Minor update to unit tests check-in: 928642b2fd user: mrwellan tags: v1.60
2016-02-01
23:22
Fixed silly issue caused by accidentally checking in changes made while discussing code for illustration purposes check-in: 4cf5c411c5 user: matt tags: v1.60
22:32
Set sretrieve to work with data visible to user but control data not accessible check-in: 031a5ee554 user: mrwellan tags: v1.60
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [b57ee1d8e2] to [faa48a9ca2].

︙
566
567
568
569
570
571
572
573

574
575
576
577
578
579
580

566
567
568
569
570
571
572

573
574
575
576
577
578
579
580








-
+








(define (nice-path dir)
  (normalize-pathname (if (absolute-pathname? dir)
			  dir
			  (conc (current-directory) "/" dir))))

(define (get-cpu-load)
  (car (common:get-cpu-load)))
;;   (let* ((load-res (cmd-run->list "uptime"))
;;   (let* ((load-res (process:cmd-run->list "uptime"))
;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
;; 	 (cpu-load #f))
;;     (for-each (lambda (l)
;; 		(let ((match (string-search load-rx l)))
;; 		  (if match
;; 		      (let ((newval (string->number (cadr match))))
;; 			(if (number? newval)
︙
621
622
623
624
625
626
627
628

629
630
631
632
633
634
635
636
637
638

639
640
641
642
643
644
645

621
622
623
624
625
626
627

628
629
630
631
632
633
634
635
636
637

638
639
640
641
642
643
644
645








-
+









-
+








;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload #!key (msg #f))
  (let ((num-cpus (common:get-num-cpus)))
    (common:wait-for-cpuload maxload num-cpus 15 msg: msg)))

(define (get-uname . params)
  (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))

;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
  ;; (cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
  ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
  ;; (let-values 
  ;;  (((inp oup pid) (process "readlink" (list "-f" inpath))))
  ;;  (with-input-from-port inp
  ;;    (let loop ((inl (read-line))
  ;;       	(res #f))
  ;;      (print "inl=" inl)
  ;;      (if (eof-object? inl)
︙
655
656
657
658
659
660
661
662

663
664
665
666
667
668
669

655
656
657
658
659
660
661

662
663
664
665
666
667
668
669








-
+








;; D I S K   S P A C E 
;;======================================================================

(define (common:get-disk-space-used fpath)
  (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))

(define (get-df path)
  (let* ((df-results (cmd-run->list (conc "df " path)))
  (let* ((df-results (process:cmd-run->list (conc "df " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freespc    #f))
    ;; (write df-results)
    (for-each (lambda (l)
		(let ((match (string-search space-rx l)))
		  (if match 
		      (let ((newval (string->number (cadr match))))
︙

Modified configf.scm from [1e6b64ea69] to [39c9b380ea].

︙
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25

11
12
13
14
15
16
17

18
19
20
21
22
23
24
25








-
+









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

(use regex regex-case) ;;  directory-utils)
(declare (unit configf))
;; (declare (uses process))
(declare (uses process))

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
︙
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59

45
46
47
48
49
50
51

52
53
54
55
56
57
58
59








-
+









(define (config:eval-string-in-environment str)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "ERROR: problem evaluating \"" str "\" in the shell environment")
     #f)
   (let ((cmdres (cmd-run->list (conc "echo " str))))
   (let ((cmdres (process:cmd-run->list (conc "echo " str))))
     (if (null? cmdres) ""
	 (caar cmdres)))))

;;======================================================================
;; Make the regexp's needed globally available
;;======================================================================
︙
116
117
118
119
120
121
122
123

124
125
126
127
128
129
130

116
117
118
119
120
121
122

123
124
125
126
127
128
129
130








-
+








			 (debug:print-info 9 "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result)))))
		(loop (conc prestr result poststr)))
	      res))
	res)))

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (cmd-run->list cmd))
  (let* ((output (process:cmd-run->list cmd))
	 (res    (car output))
	 (status (cadr output)))
    (if (equal? status 0)
	(let ((outres (string-intersperse 
		       res
		       "\n")))
	  (debug:print-info 4 "shell result:\n" outres)
︙
236
237
238
239
240
241
242
243

244
245
246
247
248
249
250

236
237
238
239
240
241
242

243
244
245
246
247
248
249
250








-
+








								      (member section-name sections))
								  section-name "") ;; stick everything into ""
							      #f #f)))
	       (configf:key-sys-pr ( x key cmd      ) (if allow-system
							  (let ((alist    (hash-table-ref/default res curr-section-name '()))
								(val-proc (lambda ()
									    (let* ((start-time (current-seconds))
										   (cmdres     (cmd-run->list cmd))
										   (cmdres     (process:cmd-run->list cmd))
										   (delta      (- (current-seconds) start-time))
										   (status     (cadr cmdres))
										   (res        (car  cmdres)))
									      (debug:print-info 4 "" inl "\n => " (string-intersperse res "\n"))
									      (if (not (eq? status 0))
										  (begin
										    (debug:print 0 "ERROR: problem with " inl ", return code " status
︙

Modified db.scm from [d4d9059231] to [725b61e04a].

︙
2080
2081
2082
2083
2084
2085
2086
2087

2088
2089
2090
2091
2092
2093
2094

2080
2081
2082
2083
2084
2085
2086

2087
2088
2089
2090
2091
2092
2093
2094








-
+








(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (if (not (number? run-id))
      (begin ;; no need to treat this as an error by default
	(debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id)
	;; (print-call-chain (current-error-port))
	'())
      (let* ((qryvalstr       (case qryvals
				((shortlist) "id,run_id,testname,state,status,item_path")
				((shortlist) "id,run_id,testname,item_path,state,status")
				((#f)        db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
				(else        qryvals)))
	     (res            '())
	     ;; if states or statuses are null then assume match all when not-in is false
	     (states-qry      (if (null? states) 
				  #f
				  (conc " state "
︙
2424
2425
2426
2427
2428
2429
2430
2431

2432
2433
2434
2435
2436
2437
2438

2424
2425
2426
2427
2428
2429
2430

2431
2432
2433
2434
2435
2436
2437
2438








-
+








   (lambda (db)
     (db:first-result-default 
      db
      "SELECT attemptnum FROM tests WHERE id=?;"
      #f
      test-id))))

(define db:test-record-fields '("id"           "run_id"        "testname"  "item_path" "state"      "status"      "event_time"
(define db:test-record-fields '("id"           "run_id"        "testname"  "state"      "status"      "event_time"
				"host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
                                "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"))

;; fields *must* be a non-empty list
;;
(define (db:field->number fieldname fields)
  (if (null? fields)
︙

Modified process.scm from [a74a40a846] to [2b748acd48].

︙
44
45
46
47
48
49
50
51

52
53
54
55
56
57
58

44
45
46
47
48
49
50

51
52
53
54
55
56
57
58








-
+








		 (append result (list curr)))
	   (begin
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
	     result))))) ;; )

(define (cmd-run-proc-each-line cmd proc . params)
(define (process:cmd-run-proc-each-line cmd proc . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
  (handle-exceptions
   exn
   (begin
     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "exn=" (condition->list exn))
︙
67
68
69
70
71
72
73
74

75
76
77
78
79
80

81
82
83
84
85
86
87

67
68
69
70
71
72
73

74
75
76
77
78
79

80
81
82
83
84
85
86
87








-
+





-
+








		 (append result (list (proc curr))))
	   (begin
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
	     result))))))

(define (cmd-run-proc-each-line-alt cmd proc)
(define (process:cmd-run-proc-each-line-alt cmd proc)
  (let* ((fh (open-input-pipe cmd))
         (res (port-proc->list fh proc))
         (status (close-input-pipe fh)))
    (if (eq? status 0) res #f)))

(define (cmd-run->list cmd)
(define (process:cmd-run->list cmd)
  (let* ((fh (open-input-pipe cmd))
         (res (port->list fh))
         (status (close-input-pipe fh)))
    (list res status)))

(define (port->list fh)
  (if (eof-object? fh) #f
︙

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