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