Megatest

Check-in [7d166acf1f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: 7d166acf1f19f0d5c8b77bc9b3ea8f7974e80100
User & Date: matt on 2021-04-05 23:18:18
Other Links: branch diff | manifest | tags
Context
2021-04-05
23:57
wip check-in: fb8e8050b3 user: matt tags: v1.6584-ck5
23:18
wip check-in: 7d166acf1f user: matt tags: v1.6584-ck5
2021-04-03
17:08
wip check-in: e0c6480079 user: matt tags: v1.6584-ck5
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified ducttape/ducttape-lib.scm from [59b0a2f94a] to [c4ffa8169c].

︙
47
48
49
50
51
52
53
54
55


56
57


58
59
60

61
62


63
64
65
66
67
68
69

47
48
49
50
51
52
53


54
55
56

57
58
59
60

61
62

63
64
65
66
67
68
69
70
71








-
-
+
+

-
+
+


-
+

-
+
+








     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

  (import scheme chicken extras ports data-structures )
  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
  (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix)
  (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339)
  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
  ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise
  (import directory-utils filepath srfi-19 ) ; linenoise

    ;; plugs a hole in posix-extras in latter chicken versions
  (use posix-extras pathname-expand files)
  (import pathname-expand chicken.file chicken.string)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
  (define (realpath x) (print "Path: " x) (normalize-pathname  (pathname-expand (or x "/dev/null")) ))
  ;;(define (realpath x) (pathname-expand (or x "/dev/null")))

  ;; (include "mimetypes.scm") ; provides ext->mimetype
  ;; (include "workweekdate.scm")

  ;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation
︙
839
840
841
842
843
844
845
846
847


848
849

850
851
852
853
854
855
856

841
842
843
844
845
846
847


848
849
850

851
852
853
854
855
856
857
858








-
-
+
+

-
+








("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

(use srfi-19)
(use test)
(import srfi-19)
(import test)
;;(use format)
(use regex)
(import regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
;; isodate   -> "2016-01-01"
;; wwdate -> "16ww01.5"
︙
1056
1057
1058
1059
1060
1061
1062
1063

1064
1065
1066
1067
1068
1069
1070

1058
1059
1060
1061
1062
1063
1064

1065
1066
1067
1068
1069
1070
1071
1072








-
+









      (let loop ((rest-path-items path-items))
        (if (null? rest-path-items)
            #f
            (let* ((this-dir (car rest-path-items))
                   (next-rest (cdr rest-path-items))
                   (candidate (conc this-dir "/" exe)))
              (if (file-execute-access? candidate)
              (if (file-executable? candidate)
                  candidate
                  (loop next-rest)))))))


  
;;;; define some handy globals
  ;; resolve fullpath to this script or binary.
︙
1245
1246
1247
1248
1249
1250
1251
1252
1253


1254
1255
1256

1257
1258
1259
1260
1261
1262
1263

1247
1248
1249
1250
1251
1252
1253


1254
1255
1256
1257

1258
1259
1260
1261
1262
1263
1264
1265








-
-
+
+


-
+








     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                         (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))

  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
︙
1358
1359
1360
1361
1362
1363
1364
1365

1366
1367
1368
1369
1370
1371
1372

1360
1361
1362
1363
1364
1365
1366

1367
1368
1369
1370
1371
1372
1373
1374








-
+








            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
            (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


  ;; log exit code
  (define (set-ducttape-log-exit-handler)
    (let ((orig-exit-handler (exit-handler)))
      (exit-handler
︙
1520
1521
1522
1523
1524
1525
1526


1527

1528
1529
1530
1531
1532
1533
1534

1522
1523
1524
1525
1526
1527
1528
1529
1530

1531
1532
1533
1534
1535
1536
1537
1538








+
+
-
+








                    )

    (define (sendmail-proc sendmail-port)
      (define (wl line-str)
        (write-line line-str sendmail-port))

      (define (get-uuid)
(print "ERROR in ducttape lib")
	"foo")
        (string-upcase (uuid->string (uuid-generate))))
        ;;(string-upcase (uuid->string (uuid-generate))))

      (let ((mailpart-uuid (get-uuid))
            (mailpart-body-uuid (get-uuid)))
        
        (define (boundary)
          (wl (conc "--" mailpart-uuid)))
︙
1700
1701
1702
1703
1704
1705
1706
1707

1708
1709
1710
1711
1712
1713
1714

1715
1716
1717
1718
1719
1720
1721

1722
1723
1724
1725
1726
1727
1728

1729
1730
1731
1732
1733
1734
1735
1736

1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755

1756
1757
1758
1759
1760
1761
1762
1763

1764
1765
1766
1767
1768
1769
1770

1704
1705
1706
1707
1708
1709
1710

1711
1712
1713
1714
1715
1716
1717

1718
1719
1720
1721
1722
1723
1724

1725
1726
1727
1728
1729
1730
1731

1732
1733
1734
1735
1736
1737
1738
1739

1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758

1759
1760
1761
1762
1763
1764
1765
1766

1767
1768
1769
1770
1771
1772
1773
1774








-
+






-
+






-
+






-
+







-
+


















-
+







-
+








  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

    ;; --quiet
    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
      (if (not (null? quiet-opts))
          (begin
            (setenv "DUCTTAPE_QUIET_MODE" "1")
            (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1")
            (ducttape-quiet-mode "1"))))

    ;; --silent
    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
      (if (not (null? silent-opts))
          (begin
            (setenv "DUCTTAPE_SILENT_MODE" "1")
            (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1")
            (ducttape-silent-mode "1"))))

    ;; -color
    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
      (if (not (null? color-opts))
          (begin
            (setenv "DUCTTAPE_COLORIZE" "1")
            (set-environment-variable! "DUCTTAPE_COLORIZE" "1")
            (ducttape-color-mode "1"))))

    ;; -nocolor
    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
      (if (not (null? nocolor-opts))
          (begin
            (unsetenv "DUCTTAPE_COLORIZE" )
            (unset-environment-variable! "DUCTTAPE_COLORIZE" )
            (ducttape-color-mode #f))))

    ;; -logfile
    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
      (if (not (null? logfile-opts))
          (begin
            (ducttape-log-file (car (reverse logfile-opts)))
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
            (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))

    ;; -d -dd -d#
    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
      (if (not (null? debug-opts))
          (begin
            (ducttape-debug-level
             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
               (if (null? opts)
                   debuglevel
                   (let*
                       ( (curopt (car opts))
                         (restopts (cdr opts))
                         (ds (string-match "-(d+)" curopt))
                         (dnum (string-match "-d(\\d+)" curopt)))
                     (cond
                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
            (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))


    ;; -dp <pat> / --debug-pattern <pat>
    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
      (if (not (null? debugpat-opts))
          (begin
            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 
            (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 


  ;;; following code commented out; side effects not wanted on startup
  ;; immediately activate logfile (will be noop if logfile disabled)
  ;;(ducttape-activate-logfile)
  ;;(set-ducttape-log-exit-handler)
︙

Modified ezsteps.scm from [5de5d166c7] to [bcc479ae26].

︙
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

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








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")


;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
;;      z3 csv typed-records pathname-expand matchable)
;; 
;; (declare (unit ezsteps))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; ;; (declare (uses sdb))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; 
;; 
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
︙

Modified launch.scm from [593217c335] to [914613830c].

︙
637
638
639
640
641
642
643
644

645
646
647
648
649
650
651

637
638
639
640
641
642
643

644
645
646
647
648
649
650
651








-
+








	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat
		      ((name content)
		       (with-output-to-file name
			 (lambda ()
			   (print content)
			   (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
			   (set-file-permissions! name (bitwise-ior perm/irwxg perm/irwxu)))))
		      (else
		       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
	     scripts))
	  ;; 
	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
︙

Modified megatest.scm from [1f366540e9] to [34900f3d4f].

︙
19
20
21
22
23
24
25


26
27
28
29
30
31
32

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34








+
+








(include "mutils/mutils.scm")
(include "autoload/autoload.scm")
(include "dbi/dbi.scm")
(include "stml2/cookie.scm")
(include "stml2/stml2.scm")
(include "pkts/pkts.scm")
(include "csv-xml/csv-xml.scm")
(include "ducttape/ducttape-lib.scm")

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module megatest-main
	*

	(import scheme
		chicken.base
︙
44
45
46
47
48
49
50

51
52
53
54
55

56
57

58
59
60
61
62
63
64

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69








+





+


+








		chicken.process-context
		chicken.process-context.posix
		chicken.process.signal
		chicken.random
		chicken.repl
		chicken.sort
		chicken.string
		chicken.tcp
		chicken.time
		chicken.time.posix
		
		(prefix sqlite3 sqlite3:)
		(prefix base64 base64:)
		address-info
		csv-abnf
		directory-utils
		fmt
		matchable
		md5
		message-digest
		queues
		regex
		regex-case
		sql-de-lite
︙
77
78
79
80
81
82
83

84
85
86
87
88
89
90

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96








+








		srfi-13
		srfi-98
		srfi-69

		;; local modules
		mutils
		csv-xml
		ducttape-lib
		
		)
	
;; (include "common.scm")
(include "megatest-version.scm")

;; fake out readline usage of toplevel-command
︙
142
143
144
145
146
147
148

149
150
151
152
153
154
155

148
149
150
151
152
153
154
155
156
157
158
159
160
161
162








+








(include "items.scm")
(include "subrun.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "mt.scm")
(include "api.scm")
(include "tasks.scm")
(include "ezsteps.scm")
(include "env.scm")
(include "diff-report.scm")
(include "cgisetup/models/pgdb.scm")
(include "runconfig.scm")
(include "archive.scm")
(include "ods.scm")
(include "http-transport.scm")
︙

Modified server.scm from [2787f97e38] to [0f1ce40290].

︙
228
229
230
231
232
233
234
235

236
237
238
239
240
241
242

228
229
230
231
232
233
234

235
236
237
238
239
240
241
242








-
+








		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
		  (directory-exists? (conc areapath "/logs")))
		'()))

        ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
	(let* ((server-logs-cmd  (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
               (server-logs   (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-all))))
               (server-logs   (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
	       (num-serv-logs (length server-logs)))
	  (if (or (null? server-logs) (= num-serv-logs 0))
              (let ()
                 (debug:print 1  *default-log-port* "There are no servers running")
	         '()
              )
	      (let loop ((hed  (string-chomp (car server-logs)))
︙

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