Megatest

Diff
Login

Differences From Artifact [59b0a2f94a]:

To Artifact [9cc9c3469d]:


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







+
-
+







                    )

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

      (define (get-uuid)
	"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
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
1771
1772
1773







-
+






-
+






-
+






-
+







-
+


















-
+







-
+







  ;; 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)