Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -10,11 +10,11 @@
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm filedb.scm \
client.scm synchash.scm daemon.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm tdb.scm rpc-transport.scm \
- portlogger.scm archive.scm env.scm
+ portlogger.scm archive.scm env.scm diff-report.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
ADDED diff-report.scm
Index: diff-report.scm
==================================================================
--- /dev/null
+++ diff-report.scm
@@ -0,0 +1,408 @@
+
+(declare (unit diff-report))
+(declare (uses common))
+(declare (uses rmt))
+
+(include "common_records.scm")
+(use matchable)
+(use fmt)
+(use ducttape-lib)
+(define css "")
+
+(define (diff:tests-mindat->hash tests-mindat)
+ (let* ((res (make-hash-table)))
+ (for-each
+ (lambda (item)
+ (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
+ (value (list-ref item 2)))
+ (hash-table-set! res test-name+item-path value)))
+ tests-mindat)
+ res))
+
+;; return 1 if status1 is better
+;; return 0 if status1 and 2 are equally good
+;; return -1 if status2 is better
+(define (diff:status-compare3 status1 status2)
+ (let*
+ ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
+ (mem1 (member status1 status-goodness-ranking))
+ (mem2 (member status2 status-goodness-ranking))
+ )
+ (cond
+ ((and (not mem1) (not mem2)) 0)
+ ((not mem1) -1)
+ ((not mem2) 1)
+ ((= (length mem1) (length mem2)) 0)
+ ((> (length mem1) (length mem2)) 1)
+ (else -1))))
+
+
+(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f))
+ (let* ((src-hash (diff:tests-mindat->hash src-tests-mindat))
+ (dest-hash (diff:tests-mindat->hash dest-tests-mindat))
+ (all-keys
+ (reverse (sort
+ (delete-duplicates
+ (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
+
+ (lambda (a b)
+ (cond
+ ((< 0 (string-compare3 (car a) (car b))) #t)
+ ((> 0 (string-compare3 (car a) (car b))) #f)
+ ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
+ (else #f)))
+
+ ))))
+ (let ((res
+ (map ;; TODO: rename xor to delta globally in dcommon and dashboard
+ (lambda (key)
+ (let* ((test-name (car key))
+ (item-path (cdr key))
+
+ (dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
+ (dest-test-id (list-ref dest-value 0))
+ (dest-state (list-ref dest-value 1))
+ (dest-status (list-ref dest-value 2))
+
+ (src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
+ (src-test-id (list-ref src-value 0))
+ (src-state (list-ref src-value 1))
+ (src-status (list-ref src-value 2))
+
+ (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
+
+ (dest-complete
+ (and dest-value dest-state dest-status
+ (equal? dest-state "COMPLETED")
+ (not (member dest-status incomplete-statuses))))
+ (src-complete
+ (and src-value src-state src-status
+ (equal? src-state "COMPLETED")
+ (not (member src-status incomplete-statuses))))
+ (status-compare-result (diff:status-compare3 src-status dest-status))
+ (xor-new-item
+ (cond
+ ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
+ ;; neither complete -> bad
+
+ ;; src !complete, dest complete -> better
+ ((and (not dest-complete) (not src-complete))
+ (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value)
+ ((not dest-complete)
+ (list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value)
+ ((not src-complete)
+ (list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value)
+ ((and
+ (equal? src-state dest-state)
+ (equal? src-status dest-status))
+ (if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN"))))
+ (list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value)
+ (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)))
+ ;; better or worse: pass > warn > waived > skip > fail > abort
+ ;; pass > warn > waived > skip > fail > abort
+
+ ((= 1 status-compare-result) ;; src is better, dest is worse
+ (list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value))
+ (else
+ (list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value)))))
+ (list test-name item-path xor-new-item)))
+ all-keys)))
+
+ (if hide-clean
+ (filter
+ (lambda (item)
+ (not
+ (equal?
+ "CLEAN"
+ (list-ref (list-ref item 2) 1))))
+ res)
+ res))))
+
+(define (diff:run-name->run-id run-name)
+ (if (number? run-name)
+ run-name
+ (let* ((qry-res (rmt:get-runs run-name 1 0 '())))
+ (if (eq? 2 (vector-length qry-res))
+ (vector-ref (car (vector-ref qry-res 1)) 1)
+ #f))))
+
+(define (diff:target+run-name->run-id target run-name)
+ (let* ((keys (rmt:get-keys))
+ (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys))))
+ (if (not (eq? (length keys) (length keys)))
+ (begin
+ (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys)
+ #f)
+ (let* ((target-map (zip keys target-parts))
+ (qry-res (rmt:get-runs run-name 1 0 target-map)))
+
+ (if (eq? 2 (vector-length qry-res))
+ (let ((first-ent (vector-ref qry-res 1)))
+ (if (> (length first-ent) 0)
+ (vector-ref (car first-ent) 1)
+ #f))
+ #f)))))
+
+(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%"))
+ (let* ((states '())
+ (statuses '())
+ (offset #f)
+ (limit #f)
+ (not-in #t)
+ (sort-by #f)
+ (sort-order #f)
+ (qryvals "id,testname,item_path,state,status")
+ (qryvals "id,testname,item_path,state,status")
+ (last-update 0)
+ (mode #f)
+ )
+ (map
+ ;; (lambda (row)
+ ;; (match row
+ ;; ((#(id test-name item-path state status)
+ ;; (list test-name item-path (list id state status))))
+ ;; (else #f)))
+ (lambda (row)
+ (let* ((id (vector-ref row 0))
+ (test-name (vector-ref row 1))
+ (item-path (vector-ref row 2))
+ (state (vector-ref row 3))
+ (status (vector-ref row 4)))
+ (list test-name item-path (list id state status))))
+
+ (rmt:get-tests-for-run run-id
+ testpatt states statuses
+ offset limit
+ not-in sort-by sort-order
+ qryvals
+ last-update
+ mode))))
+
+
+(define (diff:diff-runs src-run-id dest-run-id)
+ (let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id))
+ (dest-tests-mindat (diff:run-id->tests-mindat dest-run-id)))
+ (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t)))
+
+
+(define (diff:rundiff-find-by-state run-diff state)
+ (filter
+ (lambda (x)
+ (equal? (list-ref (caddr x) 1) state))
+ run-diff))
+
+(define (diff:rundiff-clean-breakdown run-diff)
+ (map
+ (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (list test-name item-path "CLEAN" src-status))
+ (else "")))
+ (diff:rundiff-find-by-state run-diff "CLEAN")))
+
+(define (diff:summarize-run-diff run-diff)
+
+ (let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" )))
+ (map
+ (lambda (state)
+ (list state
+ (length (diff:rundiff-find-by-state run-diff state))))
+ diff-states)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Presentation code below, business logic above ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (diff:stml->string in-stml)
+ (with-output-to-string
+ (lambda ()
+ (s:output-new
+ (current-output-port)
+ in-stml))))
+
+(define (diff:state-status->bgcolor state status)
+ (match (list state status)
+ (("CLEAN" _) "#88ff88")
+ (("BETTER" _) "#33ff33")
+ (("WORSE" _) "#ff3333")
+ (("BOTH-BAD" _) "#ff3333")
+ ((_ "WARN") "#ffff88")
+ ((_ "FAIL") "#ff8888")
+ ((_ "ABORT") "#ff0000")
+ ((_ "PASS") "#88ff88")
+ ((_ "SKIP") "#ffff00")
+ (else "#ffffff")))
+
+(define (diff:test-state-status->diff-report-cell state status)
+ (s:td 'bgcolor (diff:state-status->bgcolor state status) status))
+
+(define (diff:diff-state-status->diff-report-cell state status)
+ (s:td state 'bgcolor (diff:state-status->bgcolor state status)))
+
+
+(define (diff:megatest-html-logo)
+
+ "
+___ ___ _ _
+| \\/ | ___ __ _ __ _| |_ ___ ___| |_
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
+| | | | __/ (_| | (_| | || __/\\__ \\ |_
+|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
+ |___/
+
")
+
+(define (diff:megatest-html-diff-logo)
+ "
+___ ___ _ _
+| \\/ | ___ __ _ __ _| |_ ___ ___| |_ | _ \\(_)/ _|/ _|
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
+| | | | __/ (_| | (_| | || __/\\__ \\ |_ | |_| | | _| _|
+|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
+ |___/
+
")
+
+
+(define (diff:run-id->target+run-name+starttime run-id)
+ (let* ((target (rmt:get-target run-id))
+ (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector)
+ (info-hash (alist->hash-table
+ (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash
+ (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1))))))
+ (run-name (hash-table-ref/default info-hash "runname" "N/A"))
+ (start-time (hash-table-ref/default info-hash "event_time" 0)))
+ (list target run-name start-time)))
+
+(define (diff:deliver-diff-report src-run-id dest-run-id
+ #!key
+ (html-output-file #f)
+ (email-subject-prefix "[MEGATEST DIFF]")
+ (email-recipients-list '()) )
+ (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id))
+ (src-target (car src-info))
+ (src-run-name (cadr src-info))
+ (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation)))
+ (dest-info (diff:run-id->target+run-name+starttime dest-run-id))
+ (dest-target (car dest-info))
+ (dest-run-name (cadr dest-info))
+ (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation)))
+
+
+ (run-diff (diff:diff-runs src-run-id dest-run-id ))
+ (test-count (length run-diff))
+ (summary-table
+ (apply s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th "Diff type")
+ (s:th "% share")
+ (s:th "Count"))
+
+ (map
+ (lambda (state-count)
+ (s:tr
+ (diff:diff-state-status->diff-report-cell (car state-count) #f)
+ (s:td 'align "right" (fmt #f
+ (decimal-align 3
+ (fix 2
+ (num/fit 6
+ (* 100 (/ (cadr state-count) test-count)))))))
+ (s:td 'align "right" (cadr state-count))))
+ (diff:summarize-run-diff run-diff))))
+ (meta-table
+ (s:table 'cellspacing "0" 'border "1"
+
+ (s:tr
+ (s:td 'colspan "2"
+ (s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN"))
+ (s:tr
+ (s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start))
+ (s:tr
+ (s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target))
+ (s:tr
+ (s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name)))))))
+
+ (main-table
+ (apply s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th "Test name")
+ (s:th "Item Path")
+ (s:th (conc "SOURCE"))
+ (s:th (conc "DEST"))
+ (s:th "Diff"))
+ (map
+ (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (s:tr
+ (s:td test-name)
+ (s:td item-path)
+ (diff:test-state-status->diff-report-cell src-state src-status)
+ (diff:test-state-status->diff-report-cell dest-state dest-status)
+ (diff:diff-state-status->diff-report-cell diff-state diff-status)))
+ (else "")))
+ (filter (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (not (equal? diff-state "CLEAN")))
+ (else #f)))
+ run-diff))))
+ (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name))
+ (html-body (diff:stml->string (s:body
+ (diff:megatest-html-diff-logo)
+ (s:h2 "Summary")
+ (s:table 'border "0"
+ (s:tr
+ (s:td "Diff calculated at")
+ (s:td (conc (seconds->string) " " (local-timezone-abbreviation))))
+ (s:tr
+ (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*))
+ (s:tr 'valign "TOP"
+ (s:td summary-table)
+ (s:td meta-table)))
+ (s:h2 "Diffs + consistently failing tests")
+ main-table)))
+
+ )
+ (if html-output-file
+ (with-output-to-file html-output-file (lambda () (print html-body))))
+ (when (and email-recipients-list (> (length email-recipients-list) 0))
+ (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t))
+ html-body))
+
+
+
+
+
+;; (let* ((src-run-name "all57")
+;; (dest-run-name "all60")
+;; (src-run-id (diff:run-name->run-id src-run-name))
+;; (dest-run-id (diff:run-name->run-id dest-run-name))
+;; (to-list (list "bjbarcla")))
+;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html")
+;; )
+
+(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw)
+ (let* (;;(src-target "nope%")
+ ;;(src-runname "all57")
+ ;;(dest-target "%")
+ ;;(dest-runname "all60")
+ (src-run-id (diff:target+run-name->run-id src-target src-runname))
+ (dest-run-id (diff:target+run-name->run-id dest-target dest-runname))
+ ;(html-file "/tmp/bjbarcla/zippy.html")
+ (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f))
+ )
+
+ (cond
+ ((not src-run-id)
+ (print "No match for source target/runname="src-target"/"src-runname)
+ (print "Cannot proceed.")
+ #f)
+ ((not dest-run-id)
+ (print "No match for source target/runname="dest-target"/"dest-runname)
+ (print "Cannot proceed.")
+ #f)
+ (else
+ (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file)))))
+
+
ADDED ducttape/MANIFEST
Index: ducttape/MANIFEST
==================================================================
--- /dev/null
+++ ducttape/MANIFEST
@@ -0,0 +1,10 @@
+MANIFEST
+Makefile
+ducttape-lib.scm
+ducttape-lib.setup
+mimetypes.scm
+sample_ducttape.scm
+test_ducttape.scm
+test_example.scm
+useargs-example.scm
+workweekdate.scm
ADDED ducttape/Makefile
Index: ducttape/Makefile
==================================================================
--- /dev/null
+++ ducttape/Makefile
@@ -0,0 +1,35 @@
+SHELL=/bin/tcsh -f
+
+help:
+ @echo ""
+ @echo "make targets:"
+ @echo "============="
+ @echo "install - build and install general_lib egg as icfadm"
+ @echo "test - run unit tests on ducttape-lib.scm (tests code, not egg)"
+ @echo "eggs-info - show chicken-install commands to get eggs upon which ducttape-lib depends"
+ @echo "test_example - compile an example scm against installed general_lib egg"
+ @echo "clean - remove binaries and other build artifacts"
+ @echo ""
+
+clean:
+ rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o
+
+install:
+ chicken-install
+
+test:
+ chicken-install -no-install
+ csc test_ducttape.scm
+
+ ./test_ducttape
+ if (-e foo) rm -f foo
+
+test_example:
+ @csc test_example.scm
+ @./test_example
+ @rm test_example
+
+eggs-info:
+ @echo chicken-install ansi-escape-sequences
+ @echo chicken-install slice
+ @echo chicken-install rfc3339
ADDED ducttape/ducttape-lib.meta
Index: ducttape/ducttape-lib.meta
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.meta
@@ -0,0 +1,13 @@
+;;; ducttape-lib.meta -*- Hen -*-
+
+((egg "ducttape-lib.egg")
+ (synopsis "Miscellaneous tool and standard print routines.")
+ (category env)
+ (author "Brandon Barclay")
+ (doc-from-wiki)
+ (license "GPL-2")
+ ;; srfi-69, posix, srfi-18
+ (depends regex)
+ (test-depends test)
+ ; suspicious - (files "ducttape-lib")
+ )
ADDED ducttape/ducttape-lib.scm
Index: ducttape/ducttape-lib.scm
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.scm
@@ -0,0 +1,812 @@
+(module ducttape-lib
+ (
+ runs-ok
+ ducttape-debug-level
+ ducttape-debug-regex-filter
+ ducttape-silent-mode
+ ducttape-quiet-mode
+ ducttape-log-file
+ ducttape-color-mode
+ iputs-preamble
+ script-name
+ idbg
+ ierr
+ iwarn
+ inote
+ iputs
+ re-match?
+ ; launch-repl
+ keyword-skim
+ skim-cmdline-opts-noarg-by-regex
+ skim-cmdline-opts-withargs-by-regex
+ concat-lists
+ process-command-line
+ ducttape-append-logfile
+ ducttape-activate-logfile
+ isys
+ do-or-die
+ counter-maker
+ dir-is-writable?
+ mktemp
+ get-tmpdir
+ sendmail
+ find-exe
+
+ zeropad
+ string-leftpad
+ string-rightpad
+ seconds->isodate
+ seconds->wwdate
+ seconds->wwdate-values
+ isodate->seconds
+ isodate->wwdate
+ wwdate->seconds
+ wwdate->isodate
+ current-wwdate
+ current-isodate
+
+ )
+
+ (import scheme chicken extras ports data-structures )
+ (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339 scsh-process directory-utils uuid-lib filepath srfi-19 ) ; linenoise
+ (include "mimetypes.scm") ; provides ext->mimetype
+ (include "workweekdate.scm")
+ (define ducttape-lib-version 1.00)
+ (define (toplevel-command sym proc) (lambda () #f))
+;;;; utility procedures
+
+ ;; begin credit: megatest's process.scm
+ (define (port->list fh )
+ (if (eof-object? fh) #f
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ result))))
+
+ (define (conservative-read port)
+ (let loop ((res ""))
+ (if (not (eof-object? (peek-char port)))
+ (loop (conc res (read-char port)))
+ res)))
+ ;; end credit: megatest's process.scm
+
+ (define (counter-maker)
+ (let ((acc 0))
+ (lambda ( #!optional (increment 1) )
+ (set! acc (+ increment acc))
+ acc)))
+
+ (define (port->string port #!optional ) ; todo - add newline
+ (let ((linelist (port->list port)))
+ (if linelist
+ (string-join linelist "\n")
+ "")))
+
+
+ (define (outport->foreach outport foreach-thunk)
+ (let loop ((line (foreach-thunk)))
+ (if line
+ (begin
+ (write-line line outport)
+ (loop (foreach-thunk))
+ )
+ (begin
+ ;;http://bugs.call-cc.org/ticket/766
+ ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
+ ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
+ (close-output-port outport)
+ #f))))
+
+ ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
+ (define (my-alist-ref key alist)
+ (let ((res (assoc key alist)))
+ (if res (cdr res) #f)))
+
+ (define (keyword-skim-alist args alist)
+ (let loop ((result-alist '()) (result-args args) (rest-alist alist))
+ (cond
+ ((null? rest-alist) (values result-alist result-args))
+ (else
+ (let ((keyword (caar rest-alist))
+ (defval (cdar rest-alist)))
+ (let-values (((kwval result-args2)
+ (keyword-skim
+ keyword
+ defval
+ result-args)))
+ (loop
+ (cons (cons keyword kwval) result-alist)
+ result-args2
+ (cdr rest-alist))))))))
+
+ (define (isys command . rest-args)
+ (let-values
+ (((opt-alist args)
+ (keyword-skim-alist
+ rest-args
+ '( ( foreach-stdout-thunk: . #f )
+ ( foreach-stdin-thunk: . #f )
+ ( stdin-proc: . #f ) ) )))
+ (let* ((foreach-stdout-thunk
+ (my-alist-ref foreach-stdout-thunk: opt-alist))
+ (foreach-stdin-thunk
+ (my-alist-ref foreach-stdin-thunk: opt-alist))
+ (stdin-proc
+ (if foreach-stdin-thunk
+ (lambda (port)
+ (outport->foreach port foreach-stdin-thunk))
+ (my-alist-ref stdin-proc: opt-alist))))
+
+ ;; TODO: support command is list.
+
+ (let-values (((stdout stdin pid stderr)
+ (if (null? args)
+ (process* command)
+ (process* command args))))
+
+ ;(if foreach-stdin-thunk
+ ; (set! stdin-proc
+ ; (lambda (port)
+ ; (outport->foreach port foreach-stdin-thunk))))
+
+ (if stdin-proc
+ (stdin-proc stdin))
+
+ (let ((stdout-res
+ (if foreach-stdout-thunk ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
+ (begin
+ (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
+ "foreach-stdout-thunk ate stdout"
+ )
+ (if stdin-proc
+ "foreach-stdin-thunk/stdin-proc blocks stdout"
+ (port->string stdout))))
+ (stderr-res
+ (if stdin-proc
+ "foreach-stdin-thunk/stdin-proc blocks stdout"
+ (port->string stderr))))
+
+ ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close. don't close them again. (so sad - we lost stdout and stderr contents when we write to stdin)
+ ;; see - http://bugs.call-cc.org/ticket/766
+ (if (not stdin-proc)
+ (close-input-port stdout)
+ (close-input-port stderr))
+
+ (let-values (((anotherpid normalexit? exitstatus) (process-wait pid)))
+ (values exitstatus stdout-res stderr-res)))))))
+
+ (define (do-or-die command #!key nodie (foreach-stdout #f) (stdin-proc #f))
+ (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
+ (if (equal? 0 exit-code)
+ stdout-str
+ (begin
+ (ierr (conc "Command > " command " " "< failed with " exit-code " because: \n" stderr-str) )
+ (if nodie #f (exit exit-code))))))
+
+
+
+
+ ;; this is broken. one day i will fix it and thus understand run/collecting... don't use isys-broken.
+ (define (isys-broken command-list)
+
+ (let-values ( ( (rv outport errport) (run/collecting (1 2) ("ls" "-l") ) ) )
+ (print "rv is " rv)
+ (print "op is " outport)
+ (print "ep is " errport)
+ (values rv (port->string outport) (port->string errport))))
+
+
+
+ ;; runs-ok: evaluate expression while suppressing exceptions.
+ ; on caught exception, returns #f
+ ; otherwise, returns expression value
+ (define (runs-ok thunk)
+ (handle-exceptions exn #f (begin (thunk) #t)))
+
+ ;; concat-lists: result list = lista + listb
+ (define (concat-lists lista listb) ;; ok, I just reimplemented append...
+ (foldr cons listb lista))
+
+
+;;; setup general_lib env var parameters
+
+ ;; show warning/note/error/debug prefixes using ansi colors
+ (define ducttape-color-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))
+
+ ;; if defined, has number value. if number value > 0, show debug messages
+ ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
+ (define ducttape-debug-level
+ (make-parameter
+ (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")))
+ num-debug-level) ; it was set and > 0, mode is value
+ (begin
+ (unsetenv "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
+ (define ducttape-debug-regex-filter
+ (make-parameter
+ (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
+ (if raw-debug-pattern
+ raw-debug-pattern
+ "."))))
+
+ ;; silent mode suppresses Note and Warning type messages
+ (define ducttape-silent-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))
+
+ ;; quiet mode suppresses Note type messages
+ (define ducttape-quiet-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))
+
+ ;; if log file is defined, warning/note/error/debug messages are appended
+ ;; to named logfile.
+ (define ducttape-log-file
+ (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))
+
+
+
+
+
+
+;;; standard messages printing implementation
+
+ ; get the name of the current script/binary being run
+ (define (script-name)
+ (car (reverse (string-split (car (argv)) "/"))))
+
+ (define (ducttape-timestamp)
+ (rfc3339->string (time->rfc3339 (seconds->local-time))))
+
+
+ (define (iputs-preamble msg-type #!optional (suppress-color #f))
+ (let ((do-color (and
+ (not suppress-color)
+ (ducttape-color-mode)
+ (terminal-port? (current-error-port)))))
+ (case msg-type
+ ((note)
+ (if do-color
+ (set-text (list 'fg-green 'bg-black 'bold) "Note:")
+ "Note:"
+ ))
+ ((warn)
+ (if do-color
+ (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
+ "Warning:"
+ ))
+ ((err)
+ (if do-color
+ (set-text (list 'fg-red 'bg-black 'bold) "Error:")
+ "Error:"
+ ))
+ ((dbg)
+ (if do-color
+ (set-text (list 'fg-blue 'bg-magenta) "Debug:")
+ "Debug:"
+ )))))
+
+ (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
+ (let
+ ((txt
+ (string-join
+ (list
+ (ducttape-timestamp)
+ (script-name)
+ (if suppress-preamble
+ message
+ (string-join (list (iputs-preamble msg-type #t) message) " ")))
+ " | ")))
+
+ (if (ducttape-log-file)
+ (runs-ok
+ (call-with-output-file (ducttape-log-file)
+ (lambda (output-port)
+ (format output-port "~A ~%" txt)
+ )
+ #:append))
+ #t)))
+
+ (define (ducttape-activate-logfile #!optional (logfile #f))
+ ;; from python ducttape-lib.py
+ ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
+ (let ((pid (number->string (current-process-id)))
+ (ppid (number->string (parent-process-id)))
+ (argv
+ (string-join
+ (map
+ (lambda (x)
+ (string-join (list "\"" x "\"") "" ))
+ (argv))
+ " "))
+ (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))))
+ (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)))
+
+ ;; immediately activate logfile (will be noop if logfile disabled)
+ (ducttape-activate-logfile)
+
+ ;; log exit code
+ (define (set-exit-handler)
+ (let ((orig-exit-handler (exit-handler)))
+ (exit-handler
+ (lambda (exitcode)
+ (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
+ (orig-exit-handler exitcode)))))
+ (set-exit-handler)
+
+ ;; TODO: hook exception handler so we can log exception before we sign off.
+
+ (define (idbg first-message . rest-args)
+ (let* ((debug-level-threshold
+ (if (> (length rest-args) 0) (car rest-args) 1))
+ (message-list
+ (if (> (length rest-args) 1)
+ (cons first-message (cdr rest-args))
+ (list first-message)) )
+ (message (apply conc
+ (map ->string message-list))))
+
+ (ducttape-append-logfile 'dbg message)
+ (if (ducttape-debug-level)
+ (if (<= debug-level-threshold (ducttape-debug-level))
+ (if (string-search (ducttape-debug-regex-filter) message)
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))
+
+ (define (ierr message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'err message)
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))
+
+ (define (iwarn message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'warn message)
+ (if (not (ducttape-silent-mode))
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))
+
+ (define (inote message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'note message)
+ (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))
+
+
+ (define (iputs kind message #!optional (debug-level-threshold 1))
+ (cond
+ ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
+ ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
+ ((member kind
+ (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
+ (iwarn message))
+ ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
+ (idbg message debug-level-threshold))))
+
+ (define (mkdir-recursive path-so-far hier-list-to-create)
+ (if (null? hier-list-to-create)
+ path-so-far
+ (let* ((next-hier-item (car hier-list-to-create))
+ (rest-hier-items (cdr hier-list-to-create))
+ (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
+ (if (runs-ok (lambda () (create-directory path-to-mkdir)))
+ (mkdir-recursive path-to-mkdir rest-hier-items)
+ #f))))
+
+ ; ::mkdir-if-not-exists::
+ ; make a dir recursively if it does not
+ ; already exist.
+ ; on success - returns path
+ ; on fail - returns #f
+ (define (mkdirp-if-not-exists the-dir)
+ (let ( (path-list (string-split the-dir "/")))
+ (mkdir-recursive "/" path-list)))
+
+ ; ::mkdir-if-not-exists::
+ ; make a dir recursively if it does not
+ ; already exist.
+ ; on success - returns path
+ ; on fail - returns #f
+
+
+ (define (mkdirp-if-not-exists the-dir)
+ (let ( (path-list (string-split the-dir "/")))
+ (mkdir-recursive "/" path-list)))
+
+ (define (dir-is-writable? the-dir)
+ (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
+ (and
+ (file-exists? the-dir)
+ (cond
+ ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
+ (begin
+ (runs-ok (lambda () (delete-file dummy-file) ))
+ the-dir))
+ (else #f)))))
+
+
+ (define (get-tmpdir )
+ (let* ((tmproot
+ (dir-is-writable?
+ (or
+ (get-environment-variable "TMPDIR")
+ "/tmp")))
+
+ (user
+ (or
+ (get-environment-variable "USER")
+ "USER_Envvar_not_set"))
+ (tmppath
+ (string-concatenate
+ (list tmproot "/env21-general-" user ))))
+
+ (dir-is-writable?
+ (mkdirp-if-not-exists
+ tmppath))))
+
+ (define (mktemp
+ #!optional
+ (prefix "general_lib_tmpfile")
+ (dir #f))
+ (let-values
+ (((fd path)
+ (file-mkstemp
+ (conc
+ (if dir dir (get-tmpdir))
+ "/" prefix ".XXXXXX"))))
+ (close-output-port (open-output-file* fd))
+ path))
+
+
+
+ ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
+ ;; write send-email using:
+ ;; - isys-foreach-stdin-line
+ ;; - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
+ (define (sendmail to_addr subject body
+ #!key
+ (from_addr "admin")
+ cc_addr
+ bcc_addr
+ more-headers
+ use_html
+ (attach-files-list '())
+ (images-with-content-id-alist '())
+ )
+
+ (define (sendmail-proc sendmail-port)
+ (define (wl line-str)
+ (write-line line-str sendmail-port))
+
+ (define (get-uuid)
+ (string-upcase (uuid->string (uuid-generate))))
+
+ (let ((mailpart-uuid (get-uuid))
+ (mailpart-body-uuid (get-uuid)))
+
+ (define (boundary)
+ (wl (conc "--" mailpart-uuid)))
+
+ (define (body-boundary)
+ (wl (conc "--" mailpart-body-uuid)))
+
+
+ (define (email-mime-header)
+ (wl (conc "From: " from_addr))
+ (wl (conc "To: " to_addr))
+ (if cc_addr
+ (wl (conc "Cc: " cc_addr)))
+ (if bcc_addr
+ (wl (conc "Bcc: " bcc_addr)))
+ (if more-headers
+ (wl more-headers))
+ (wl (conc "Subject: " subject))
+ (wl "MIME-Version: 1.0")
+ (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
+ (wl "")
+ (boundary)
+ (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
+ (wl "")
+ )
+
+
+ (define (email-text-body)
+ (body-boundary)
+ (wl "Content-Type: text/plain; charset=ISO-8859-1")
+ (wl "Content-Disposition: inline")
+ (wl "")
+ (wl body)
+ (body-boundary))
+
+ (define (email-html-body)
+ (body-boundary)
+ (wl "Content-Type: text/plain; charset=ISO-8859-1")
+ (wl "")
+ (wl "You need to enable HTML option for email")
+ (body-boundary)
+ (wl "Content-Type: text/html; charset=ISO-8859-1")
+ (wl "Content-Disposition: inline")
+ (wl "")
+ (wl body)
+ (body-boundary))
+
+ (define (attach-file file #!key (content-id #f))
+ (let* ((filename
+ (filepath:take-file-name file))
+ (ext-with-dot
+ (filepath:take-extension file))
+ (ext (string-take-right
+ ext-with-dot
+ (- (string-length ext-with-dot) 1)))
+ (mimetype (ext->mimetype ext))
+ (uuencode-command (conc "uuencode " file " " filename)))
+ (boundary)
+ (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
+ (wl "Content-Transfer-Encoding: uuencode")
+ (if content-id
+ (wl (conc "Content-Id: " content-id)))
+ (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
+ (wl "")
+ (do-or-die
+ uuencode-command
+ foreach-stdout:
+ (lambda (line)
+ (wl line)))))
+
+ (define (embed-image file+content-id)
+ (let ((file (car file+content-id))
+ (content-id (cdr file+content-id)))
+ (attach-file file content-id: content-id)))
+
+ ;; send the email
+ (email-mime-header)
+ (if use_html
+ (email-html-body)
+ (email-text-body))
+ (for-each attach-file attach-files-list)
+ (for-each embed-image images-with-content-id-alist)
+ (boundary)
+ (close-output-port sendmail-port)))
+
+ (do-or-die "/usr/sbin/sendmail -t"
+ stdin-proc: sendmail-proc))
+
+ ;; like shell "which" command
+ (define (find-exe exe)
+ (let* ((path-items
+ (string-split
+ (or
+ (get-environment-variable "PATH") "")
+ ":")))
+
+ (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)
+ candidate
+ (loop next-rest)))))))
+
+
+
+
+ ;; (define (launch-repl )
+ ;; (use linenoise)
+ ;; (current-input-port (make-linenoise-port))
+
+ ;; (let ((histfile (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "-hist")))
+
+ ;; (set-history-length! 30000)
+
+ ;; (load-history-from-file histfile)
+
+ ;; (let loop ((l (linenoise "> ")))
+ ;; (cond ((equal? l "bye")
+ ;; (save-history-to-file histfile)
+ ;; "Bye!")
+ ;; ((eof-object? l)
+ ;; (save-history-to-file histfile)
+ ;; (exit))
+ ;; (else
+ ;; (display l)
+ ;; (handle-exceptions exn
+ ;; ;;(print-call-chain (current-error-port))
+ ;; (let ((message ((condition-property-accessor 'exn 'message) exn)))
+ ;; (print "exn> " message )
+ ;; ;;(pp (condition->list exn))
+ ;; ;;(exit)
+ ;; ;;(display "Went wrong")
+ ;; (newline))
+ ;; (print (eval l)))))
+ ;; (newline)
+ ;; (history-add l)
+ ;; (loop (linenoise "> ")))))
+
+ ;; (define (launch-repl2 )
+ ;; (use readline)
+ ;; (use apropos)
+ ;; (use trace)
+ ;; ;(import csi)
+ ;; (current-input-port (make-readline-port (conc (script-name) "> ") "... "))
+ ;; ; (install-history-file #f (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "_history"))
+ ;; (parse-and-bind "set editing-mode emacs")
+ ;; (install-history-file)
+ ;; (let loop ((foo #f))
+
+ ;; (let ((expr (read)))
+ ;; (cond
+ ;; ((eof-object? expr) (exit))
+ ;; (else
+ ;; (handle-exceptions exn
+ ;; ;;(print-call-chain (current-error-port))
+ ;; (let ((message ((condition-property-accessor 'exn 'message) exn)))
+ ;; (print "exn> " message )
+ ;; ;;(pp (condition->list exn))
+ ;; ;;(exit)
+ ;; ;;(display "Went wrong")
+ ;; (newline))
+ ;; (print (eval expr))))))
+ ;; (loop #f))
+ ;; )
+
+;;;; process command line options
+
+ ;; get command line switches (have no subsequent arg; eg. [-foo])
+ ;; assumes these are switches without arguments
+ ;; will return list of matches
+ ;; removes matches from command-line-arguments parameter
+ (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
+ (let* (
+ (irr (irregex switch-pattern))
+ (matches (filter
+ (lambda (x)
+ (irregex-match irr x))
+ (command-line-arguments)))
+ (non-matches (filter
+ (lambda (x)
+ (not (member x matches)))
+ (command-line-arguments))))
+
+ (command-line-arguments non-matches)
+ matches))
+
+ (define (keyword-skim keyword default args #!optional (eqpred equal?))
+ (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
+ (cond
+ ((null? args-remaining)
+ (values
+ (if (list? kwval) (reverse kwval) kwval)
+ (reverse args-to-return)))
+ ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
+ (if (list? default)
+ (if (equal? default kwval)
+ (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
+ (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
+ (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
+ (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))
+
+
+
+ ;; get command line switches (have a subsequent arg; eg. [-foo bar])
+ ;; assumes these are switches without arguments
+ ;; will return list of arguments to matches
+ ;; removes matches from command-line-arguments parameter
+
+ (define (re-match? re str)
+ (irregex-match re str))
+
+ (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
+ (let-values
+ (((result new-cmdline-args)
+ (keyword-skim switch-pattern
+ '()
+ (command-line-arguments)
+ re-match?
+ )))
+ (command-line-arguments new-cmdline-args)
+ result))
+
+
+
+ ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
+ ;; - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
+ ;; - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
+ ;; * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas. Use (command-line-arguments)
+ (define (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")
+ (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")
+ (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")
+ (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" )
+ (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)))))
+
+ ;; -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))))))
+
+
+ ;; -dp / --debug-pattern
+ (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))))))
+
+ ;; handle command line immediately;
+ (process-command-line)
+
+
+ ) ; end module
ADDED ducttape/ducttape-lib.setup
Index: ducttape/ducttape-lib.setup
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.setup
@@ -0,0 +1,1 @@
+(standard-extension 'ducttape-lib '1.0.0)
ADDED ducttape/mimetypes.scm
Index: ducttape/mimetypes.scm
==================================================================
--- /dev/null
+++ ducttape/mimetypes.scm
@@ -0,0 +1,782 @@
+;; gathered from macosx:
+;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
+;; + manual manipulation
+
+(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
+("aw" . "application/applixware")
+("atom" . "application/atom+xml")
+("atomcat" . "application/atomcat+xml")
+("atomsvc" . "application/atomsvc+xml")
+("ccxml" . "application/ccxml+xml")
+("cdmia" . "application/cdmi-capability")
+("cdmic" . "application/cdmi-container")
+("cdmid" . "application/cdmi-domain")
+("cdmio" . "application/cdmi-object")
+("cdmiq" . "application/cdmi-queue")
+("cu" . "application/cu-seeme")
+("davmount" . "application/davmount+xml")
+("dbk" . "application/docbook+xml")
+("dssc" . "application/dssc+der")
+("xdssc" . "application/dssc+xml")
+("ecma" . "application/ecmascript")
+("emma" . "application/emma+xml")
+("epub" . "application/epub+zip")
+("exi" . "application/exi")
+("pfr" . "application/font-tdpfr")
+("gml" . "application/gml+xml")
+("gpx" . "application/gpx+xml")
+("gxf" . "application/gxf")
+("stk" . "application/hyperstudio")
+("ink" . "application/inkml+xml")
+("ipfix" . "application/ipfix")
+("jar" . "application/java-archive")
+("ser" . "application/java-serialized-object")
+("class" . "application/java-vm")
+("js" . "application/javascript")
+("json" . "application/json")
+("jsonml" . "application/jsonml+json")
+("lostxml" . "application/lost+xml")
+("hqx" . "application/mac-binhex40")
+("cpt" . "application/mac-compactpro")
+("mads" . "application/mads+xml")
+("mrc" . "application/marc")
+("mrcx" . "application/marcxml+xml")
+("ma" . "application/mathematica")
+("mathml" . "application/mathml+xml")
+("mbox" . "application/mbox")
+("mscml" . "application/mediaservercontrol+xml")
+("metalink" . "application/metalink+xml")
+("meta4" . "application/metalink4+xml")
+("mets" . "application/mets+xml")
+("mods" . "application/mods+xml")
+("m21" . "application/mp21")
+("mp4s" . "application/mp4")
+("doc" . "application/msword")
+("mxf" . "application/mxf")
+("bin" . "application/octet-stream")
+("oda" . "application/oda")
+("opf" . "application/oebps-package+xml")
+("ogx" . "application/ogg")
+("omdoc" . "application/omdoc+xml")
+("onetoc" . "application/onenote")
+("oxps" . "application/oxps")
+("xer" . "application/patch-ops-error+xml")
+("pdf" . "application/pdf")
+("pgp" . "application/pgp-encrypted")
+("asc" . "application/pgp-signature")
+("prf" . "application/pics-rules")
+("p10" . "application/pkcs10")
+("p7m" . "application/pkcs7-mime")
+("p7s" . "application/pkcs7-signature")
+("p8" . "application/pkcs8")
+("ac" . "application/pkix-attr-cert")
+("cer" . "application/pkix-cert")
+("crl" . "application/pkix-crl")
+("pkipath" . "application/pkix-pkipath")
+("pki" . "application/pkixcmp")
+("pls" . "application/pls+xml")
+("ai" . "application/postscript")
+("cww" . "application/prs.cww")
+("pskcxml" . "application/pskc+xml")
+("rdf" . "application/rdf+xml")
+("rif" . "application/reginfo+xml")
+("rnc" . "application/relax-ng-compact-syntax")
+("rl" . "application/resource-lists+xml")
+("rld" . "application/resource-lists-diff+xml")
+("rs" . "application/rls-services+xml")
+("gbr" . "application/rpki-ghostbusters")
+("mft" . "application/rpki-manifest")
+("roa" . "application/rpki-roa")
+("rsd" . "application/rsd+xml")
+("rss" . "application/rss+xml")
+("rtf" . "application/rtf")
+("sbml" . "application/sbml+xml")
+("scq" . "application/scvp-cv-request")
+("scs" . "application/scvp-cv-response")
+("spq" . "application/scvp-vp-request")
+("spp" . "application/scvp-vp-response")
+("sdp" . "application/sdp")
+("setpay" . "application/set-payment-initiation")
+("setreg" . "application/set-registration-initiation")
+("shf" . "application/shf+xml")
+("smi" . "application/smil+xml")
+("rq" . "application/sparql-query")
+("srx" . "application/sparql-results+xml")
+("gram" . "application/srgs")
+("grxml" . "application/srgs+xml")
+("sru" . "application/sru+xml")
+("ssdl" . "application/ssdl+xml")
+("ssml" . "application/ssml+xml")
+("tei" . "application/tei+xml")
+("tfi" . "application/thraud+xml")
+("tsd" . "application/timestamped-data")
+("plb" . "application/vnd.3gpp.pic-bw-large")
+("psb" . "application/vnd.3gpp.pic-bw-small")
+("pvb" . "application/vnd.3gpp.pic-bw-var")
+("tcap" . "application/vnd.3gpp2.tcap")
+("pwn" . "application/vnd.3m.post-it-notes")
+("aso" . "application/vnd.accpac.simply.aso")
+("imp" . "application/vnd.accpac.simply.imp")
+("acu" . "application/vnd.acucobol")
+("atc" . "application/vnd.acucorp")
+("air" . "application/vnd.adobe.air-application-installer-package+zip")
+("fcdt" . "application/vnd.adobe.formscentral.fcdt")
+("fxp" . "application/vnd.adobe.fxp")
+("xdp" . "application/vnd.adobe.xdp+xml")
+("xfdf" . "application/vnd.adobe.xfdf")
+("ahead" . "application/vnd.ahead.space")
+("azf" . "application/vnd.airzip.filesecure.azf")
+("azs" . "application/vnd.airzip.filesecure.azs")
+("azw" . "application/vnd.amazon.ebook")
+("acc" . "application/vnd.americandynamics.acc")
+("ami" . "application/vnd.amiga.ami")
+("apk" . "application/vnd.android.package-archive")
+("cii" . "application/vnd.anser-web-certificate-issue-initiation")
+("fti" . "application/vnd.anser-web-funds-transfer-initiation")
+("atx" . "application/vnd.antix.game-component")
+("mpkg" . "application/vnd.apple.installer+xml")
+("m3u8" . "application/vnd.apple.mpegurl")
+("swi" . "application/vnd.aristanetworks.swi")
+("iota" . "application/vnd.astraea-software.iota")
+("aep" . "application/vnd.audiograph")
+("mpm" . "application/vnd.blueice.multipass")
+("bmi" . "application/vnd.bmi")
+("rep" . "application/vnd.businessobjects")
+("cdxml" . "application/vnd.chemdraw+xml")
+("mmd" . "application/vnd.chipnuts.karaoke-mmd")
+("cdy" . "application/vnd.cinderella")
+("cla" . "application/vnd.claymore")
+("rp9" . "application/vnd.cloanto.rp9")
+("c4g" . "application/vnd.clonk.c4group")
+("c11amc" . "application/vnd.cluetrust.cartomobile-config")
+("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
+("csp" . "application/vnd.commonspace")
+("cdbcmsg" . "application/vnd.contact.cmsg")
+("cmc" . "application/vnd.cosmocaller")
+("clkx" . "application/vnd.crick.clicker")
+("clkk" . "application/vnd.crick.clicker.keyboard")
+("clkp" . "application/vnd.crick.clicker.palette")
+("clkt" . "application/vnd.crick.clicker.template")
+("clkw" . "application/vnd.crick.clicker.wordbank")
+("wbs" . "application/vnd.criticaltools.wbs+xml")
+("pml" . "application/vnd.ctc-posml")
+("ppd" . "application/vnd.cups-ppd")
+("car" . "application/vnd.curl.car")
+("pcurl" . "application/vnd.curl.pcurl")
+("dart" . "application/vnd.dart")
+("rdz" . "application/vnd.data-vision.rdz")
+("uvf" . "application/vnd.dece.data")
+("uvt" . "application/vnd.dece.ttml+xml")
+("uvx" . "application/vnd.dece.unspecified")
+("uvz" . "application/vnd.dece.zip")
+("fe_launch" . "application/vnd.denovo.fcselayout-link")
+("dna" . "application/vnd.dna")
+("mlp" . "application/vnd.dolby.mlp")
+("dpg" . "application/vnd.dpgraph")
+("dfac" . "application/vnd.dreamfactory")
+("kpxx" . "application/vnd.ds-keypoint")
+("ait" . "application/vnd.dvb.ait")
+("svc" . "application/vnd.dvb.service")
+("geo" . "application/vnd.dynageo")
+("mag" . "application/vnd.ecowin.chart")
+("nml" . "application/vnd.enliven")
+("esf" . "application/vnd.epson.esf")
+("msf" . "application/vnd.epson.msf")
+("qam" . "application/vnd.epson.quickanime")
+("slt" . "application/vnd.epson.salt")
+("ssf" . "application/vnd.epson.ssf")
+("es3" . "application/vnd.eszigno3+xml")
+("ez2" . "application/vnd.ezpix-album")
+("ez3" . "application/vnd.ezpix-package")
+("fdf" . "application/vnd.fdf")
+("mseed" . "application/vnd.fdsn.mseed")
+("seed" . "application/vnd.fdsn.seed")
+("gph" . "application/vnd.flographit")
+("ftc" . "application/vnd.fluxtime.clip")
+("fm" . "application/vnd.framemaker")
+("fnc" . "application/vnd.frogans.fnc")
+("ltf" . "application/vnd.frogans.ltf")
+("fsc" . "application/vnd.fsc.weblaunch")
+("oas" . "application/vnd.fujitsu.oasys")
+("oa2" . "application/vnd.fujitsu.oasys2")
+("oa3" . "application/vnd.fujitsu.oasys3")
+("fg5" . "application/vnd.fujitsu.oasysgp")
+("bh2" . "application/vnd.fujitsu.oasysprs")
+("ddd" . "application/vnd.fujixerox.ddd")
+("xdw" . "application/vnd.fujixerox.docuworks")
+("xbd" . "application/vnd.fujixerox.docuworks.binder")
+("fzs" . "application/vnd.fuzzysheet")
+("txd" . "application/vnd.genomatix.tuxedo")
+("ggb" . "application/vnd.geogebra.file")
+("ggt" . "application/vnd.geogebra.tool")
+("gex" . "application/vnd.geometry-explorer")
+("gxt" . "application/vnd.geonext")
+("g2w" . "application/vnd.geoplan")
+("g3w" . "application/vnd.geospace")
+("gmx" . "application/vnd.gmx")
+("kml" . "application/vnd.google-earth.kml+xml")
+("kmz" . "application/vnd.google-earth.kmz")
+("gqf" . "application/vnd.grafeq")
+("gac" . "application/vnd.groove-account")
+("ghf" . "application/vnd.groove-help")
+("gim" . "application/vnd.groove-identity-message")
+("grv" . "application/vnd.groove-injector")
+("gtm" . "application/vnd.groove-tool-message")
+("tpl" . "application/vnd.groove-tool-template")
+("vcg" . "application/vnd.groove-vcard")
+("hal" . "application/vnd.hal+xml")
+("zmm" . "application/vnd.handheld-entertainment+xml")
+("hbci" . "application/vnd.hbci")
+("les" . "application/vnd.hhe.lesson-player")
+("hpgl" . "application/vnd.hp-hpgl")
+("hpid" . "application/vnd.hp-hpid")
+("hps" . "application/vnd.hp-hps")
+("jlt" . "application/vnd.hp-jlyt")
+("pcl" . "application/vnd.hp-pcl")
+("pclxl" . "application/vnd.hp-pclxl")
+("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
+("mpy" . "application/vnd.ibm.minipay")
+("afp" . "application/vnd.ibm.modcap")
+("irm" . "application/vnd.ibm.rights-management")
+("sc" . "application/vnd.ibm.secure-container")
+("icc" . "application/vnd.iccprofile")
+("igl" . "application/vnd.igloader")
+("ivp" . "application/vnd.immervision-ivp")
+("ivu" . "application/vnd.immervision-ivu")
+("igm" . "application/vnd.insors.igm")
+("xpw" . "application/vnd.intercon.formnet")
+("i2g" . "application/vnd.intergeo")
+("qbo" . "application/vnd.intu.qbo")
+("qfx" . "application/vnd.intu.qfx")
+("rcprofile" . "application/vnd.ipunplugged.rcprofile")
+("irp" . "application/vnd.irepository.package+xml")
+("xpr" . "application/vnd.is-xpr")
+("fcs" . "application/vnd.isac.fcs")
+("jam" . "application/vnd.jam")
+("rms" . "application/vnd.jcp.javame.midlet-rms")
+("jisp" . "application/vnd.jisp")
+("joda" . "application/vnd.joost.joda-archive")
+("ktz" . "application/vnd.kahootz")
+("karbon" . "application/vnd.kde.karbon")
+("chrt" . "application/vnd.kde.kchart")
+("kfo" . "application/vnd.kde.kformula")
+("flw" . "application/vnd.kde.kivio")
+("kon" . "application/vnd.kde.kontour")
+("kpr" . "application/vnd.kde.kpresenter")
+("ksp" . "application/vnd.kde.kspread")
+("kwd" . "application/vnd.kde.kword")
+("htke" . "application/vnd.kenameaapp")
+("kia" . "application/vnd.kidspiration")
+("kne" . "application/vnd.kinar")
+("skp" . "application/vnd.koan")
+("sse" . "application/vnd.kodak-descriptor")
+("lasxml" . "application/vnd.las.las+xml")
+("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
+("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
+("123" . "application/vnd.lotus-1-2-3")
+("apr" . "application/vnd.lotus-approach")
+("pre" . "application/vnd.lotus-freelance")
+("nsf" . "application/vnd.lotus-notes")
+("org" . "application/vnd.lotus-organizer")
+("scm" . "application/vnd.lotus-screencam")
+("lwp" . "application/vnd.lotus-wordpro")
+("portpkg" . "application/vnd.macports.portpkg")
+("mcd" . "application/vnd.mcd")
+("mc1" . "application/vnd.medcalcdata")
+("cdkey" . "application/vnd.mediastation.cdkey")
+("mwf" . "application/vnd.mfer")
+("mfm" . "application/vnd.mfmp")
+("flo" . "application/vnd.micrografx.flo")
+("igx" . "application/vnd.micrografx.igx")
+("mif" . "application/vnd.mif")
+("daf" . "application/vnd.mobius.daf")
+("dis" . "application/vnd.mobius.dis")
+("mbk" . "application/vnd.mobius.mbk")
+("mqy" . "application/vnd.mobius.mqy")
+("msl" . "application/vnd.mobius.msl")
+("plc" . "application/vnd.mobius.plc")
+("txf" . "application/vnd.mobius.txf")
+("mpn" . "application/vnd.mophun.application")
+("mpc" . "application/vnd.mophun.certificate")
+("xul" . "application/vnd.mozilla.xul+xml")
+("cil" . "application/vnd.ms-artgalry")
+("cab" . "application/vnd.ms-cab-compressed")
+("xls" . "application/vnd.ms-excel")
+("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
+("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
+("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
+("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
+("eot" . "application/vnd.ms-fontobject")
+("chm" . "application/vnd.ms-htmlhelp")
+("ims" . "application/vnd.ms-ims")
+("lrm" . "application/vnd.ms-lrm")
+("thmx" . "application/vnd.ms-officetheme")
+("cat" . "application/vnd.ms-pki.seccat")
+("stl" . "application/vnd.ms-pki.stl")
+("ppt" . "application/vnd.ms-powerpoint")
+("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
+("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
+("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
+("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
+("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
+("mpp" . "application/vnd.ms-project")
+("docm" . "application/vnd.ms-word.document.macroenabled.12")
+("dotm" . "application/vnd.ms-word.template.macroenabled.12")
+("wps" . "application/vnd.ms-works")
+("wpl" . "application/vnd.ms-wpl")
+("xps" . "application/vnd.ms-xpsdocument")
+("mseq" . "application/vnd.mseq")
+("mus" . "application/vnd.musician")
+("msty" . "application/vnd.muvee.style")
+("taglet" . "application/vnd.mynfc")
+("nlu" . "application/vnd.neurolanguage.nlu")
+("ntf" . "application/vnd.nitf")
+("nnd" . "application/vnd.noblenet-directory")
+("nns" . "application/vnd.noblenet-sealer")
+("nnw" . "application/vnd.noblenet-web")
+("ngdat" . "application/vnd.nokia.n-gage.data")
+("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
+("rpst" . "application/vnd.nokia.radio-preset")
+("rpss" . "application/vnd.nokia.radio-presets")
+("edm" . "application/vnd.novadigm.edm")
+("edx" . "application/vnd.novadigm.edx")
+("ext" . "application/vnd.novadigm.ext")
+("odc" . "application/vnd.oasis.opendocument.chart")
+("otc" . "application/vnd.oasis.opendocument.chart-template")
+("odb" . "application/vnd.oasis.opendocument.database")
+("odf" . "application/vnd.oasis.opendocument.formula")
+("odft" . "application/vnd.oasis.opendocument.formula-template")
+("odg" . "application/vnd.oasis.opendocument.graphics")
+("otg" . "application/vnd.oasis.opendocument.graphics-template")
+("odi" . "application/vnd.oasis.opendocument.image")
+("oti" . "application/vnd.oasis.opendocument.image-template")
+("odp" . "application/vnd.oasis.opendocument.presentation")
+("otp" . "application/vnd.oasis.opendocument.presentation-template")
+("ods" . "application/vnd.oasis.opendocument.spreadsheet")
+("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
+("odt" . "application/vnd.oasis.opendocument.text")
+("odm" . "application/vnd.oasis.opendocument.text-master")
+("ott" . "application/vnd.oasis.opendocument.text-template")
+("oth" . "application/vnd.oasis.opendocument.text-web")
+("xo" . "application/vnd.olpc-sugar")
+("dd2" . "application/vnd.oma.dd2+xml")
+("oxt" . "application/vnd.openofficeorg.extension")
+("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
+("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
+("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
+("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
+("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
+("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
+("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
+("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
+("mgp" . "application/vnd.osgeo.mapguide.package")
+("dp" . "application/vnd.osgi.dp")
+("esa" . "application/vnd.osgi.subsystem")
+("pdb" . "application/vnd.palm")
+("paw" . "application/vnd.pawaafile")
+("str" . "application/vnd.pg.format")
+("ei6" . "application/vnd.pg.osasli")
+("efif" . "application/vnd.picsel")
+("wg" . "application/vnd.pmi.widget")
+("plf" . "application/vnd.pocketlearn")
+("pbd" . "application/vnd.powerbuilder6")
+("box" . "application/vnd.previewsystems.box")
+("mgz" . "application/vnd.proteus.magazine")
+("qps" . "application/vnd.publishare-delta-tree")
+("ptid" . "application/vnd.pvi.ptid1")
+("qxd" . "application/vnd.quark.quarkxpress")
+("bed" . "application/vnd.realvnc.bed")
+("mxl" . "application/vnd.recordare.musicxml")
+("musicxml" . "application/vnd.recordare.musicxml+xml")
+("cryptonote" . "application/vnd.rig.cryptonote")
+("cod" . "application/vnd.rim.cod")
+("rm" . "application/vnd.rn-realmedia")
+("rmvb" . "application/vnd.rn-realmedia-vbr")
+("link66" . "application/vnd.route66.link66+xml")
+("st" . "application/vnd.sailingtracker.track")
+("see" . "application/vnd.seemail")
+("sema" . "application/vnd.sema")
+("semd" . "application/vnd.semd")
+("semf" . "application/vnd.semf")
+("ifm" . "application/vnd.shana.informed.formdata")
+("itp" . "application/vnd.shana.informed.formtemplate")
+("iif" . "application/vnd.shana.informed.interchange")
+("ipk" . "application/vnd.shana.informed.package")
+("twd" . "application/vnd.simtech-mindmapper")
+("mmf" . "application/vnd.smaf")
+("teacher" . "application/vnd.smart.teacher")
+("sdkm" . "application/vnd.solent.sdkm+xml")
+("dxp" . "application/vnd.spotfire.dxp")
+("sfs" . "application/vnd.spotfire.sfs")
+("sdc" . "application/vnd.stardivision.calc")
+("sda" . "application/vnd.stardivision.draw")
+("sdd" . "application/vnd.stardivision.impress")
+("smf" . "application/vnd.stardivision.math")
+("sdw" . "application/vnd.stardivision.writer")
+("sgl" . "application/vnd.stardivision.writer-global")
+("smzip" . "application/vnd.stepmania.package")
+("sm" . "application/vnd.stepmania.stepchart")
+("sxc" . "application/vnd.sun.xml.calc")
+("stc" . "application/vnd.sun.xml.calc.template")
+("sxd" . "application/vnd.sun.xml.draw")
+("std" . "application/vnd.sun.xml.draw.template")
+("sxi" . "application/vnd.sun.xml.impress")
+("sti" . "application/vnd.sun.xml.impress.template")
+("sxm" . "application/vnd.sun.xml.math")
+("sxw" . "application/vnd.sun.xml.writer")
+("sxg" . "application/vnd.sun.xml.writer.global")
+("stw" . "application/vnd.sun.xml.writer.template")
+("sus" . "application/vnd.sus-calendar")
+("svd" . "application/vnd.svd")
+("sis" . "application/vnd.symbian.install")
+("xsm" . "application/vnd.syncml+xml")
+("bdm" . "application/vnd.syncml.dm+wbxml")
+("xdm" . "application/vnd.syncml.dm+xml")
+("tao" . "application/vnd.tao.intent-module-archive")
+("pcap" . "application/vnd.tcpdump.pcap")
+("tmo" . "application/vnd.tmobile-livetv")
+("tpt" . "application/vnd.trid.tpt")
+("mxs" . "application/vnd.triscape.mxs")
+("tra" . "application/vnd.trueapp")
+("ufd" . "application/vnd.ufdl")
+("utz" . "application/vnd.uiq.theme")
+("umj" . "application/vnd.umajin")
+("unityweb" . "application/vnd.unity")
+("uoml" . "application/vnd.uoml+xml")
+("vcx" . "application/vnd.vcx")
+("vsd" . "application/vnd.visio")
+("vis" . "application/vnd.visionary")
+("vsf" . "application/vnd.vsf")
+("wbxml" . "application/vnd.wap.wbxml")
+("wmlc" . "application/vnd.wap.wmlc")
+("wmlsc" . "application/vnd.wap.wmlscriptc")
+("wtb" . "application/vnd.webturbo")
+("nbp" . "application/vnd.wolfram.player")
+("wpd" . "application/vnd.wordperfect")
+("wqd" . "application/vnd.wqd")
+("stf" . "application/vnd.wt.stf")
+("xar" . "application/vnd.xara")
+("xfdl" . "application/vnd.xfdl")
+("hvd" . "application/vnd.yamaha.hv-dic")
+("hvs" . "application/vnd.yamaha.hv-script")
+("hvp" . "application/vnd.yamaha.hv-voice")
+("osf" . "application/vnd.yamaha.openscoreformat")
+("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
+("saf" . "application/vnd.yamaha.smaf-audio")
+("spf" . "application/vnd.yamaha.smaf-phrase")
+("cmp" . "application/vnd.yellowriver-custom-menu")
+("zir" . "application/vnd.zul")
+("zaz" . "application/vnd.zzazz.deck+xml")
+("vxml" . "application/voicexml+xml")
+("wgt" . "application/widget")
+("hlp" . "application/winhlp")
+("wsdl" . "application/wsdl+xml")
+("wspolicy" . "application/wspolicy+xml")
+("7z" . "application/x-7z-compressed")
+("abw" . "application/x-abiword")
+("ace" . "application/x-ace-compressed")
+("dmg" . "application/x-apple-diskimage")
+("aab" . "application/x-authorware-bin")
+("aam" . "application/x-authorware-map")
+("aas" . "application/x-authorware-seg")
+("bcpio" . "application/x-bcpio")
+("torrent" . "application/x-bittorrent")
+("blb" . "application/x-blorb")
+("bz" . "application/x-bzip")
+("bz2" . "application/x-bzip2")
+("cbr" . "application/x-cbr")
+("vcd" . "application/x-cdlink")
+("cfs" . "application/x-cfs-compressed")
+("chat" . "application/x-chat")
+("pgn" . "application/x-chess-pgn")
+("nsc" . "application/x-conference")
+("cpio" . "application/x-cpio")
+("csh" . "application/x-csh")
+("deb" . "application/x-debian-package")
+("dgc" . "application/x-dgc-compressed")
+("dir" . "application/x-director")
+("wad" . "application/x-doom")
+("ncx" . "application/x-dtbncx+xml")
+("dtb" . "application/x-dtbook+xml")
+("res" . "application/x-dtbresource+xml")
+("dvi" . "application/x-dvi")
+("evy" . "application/x-envoy")
+("eva" . "application/x-eva")
+("bdf" . "application/x-font-bdf")
+("gsf" . "application/x-font-ghostscript")
+("psf" . "application/x-font-linux-psf")
+("otf" . "application/x-font-otf")
+("pcf" . "application/x-font-pcf")
+("snf" . "application/x-font-snf")
+("ttf" . "application/x-font-ttf")
+("pfa" . "application/x-font-type1")
+("woff" . "application/x-font-woff")
+("arc" . "application/x-freearc")
+("spl" . "application/x-futuresplash")
+("gca" . "application/x-gca-compressed")
+("ulx" . "application/x-glulx")
+("gnumeric" . "application/x-gnumeric")
+("gramps" . "application/x-gramps-xml")
+("gtar" . "application/x-gtar")
+("hdf" . "application/x-hdf")
+("install" . "application/x-install-instructions")
+("iso" . "application/x-iso9660-image")
+("jnlp" . "application/x-java-jnlp-file")
+("latex" . "application/x-latex")
+("lzh" . "application/x-lzh-compressed")
+("mie" . "application/x-mie")
+("prc" . "application/x-mobipocket-ebook")
+("m3u8" . "application/x-mpegurl")
+("application" . "application/x-ms-application")
+("lnk" . "application/x-ms-shortcut")
+("wmd" . "application/x-ms-wmd")
+("wmz" . "application/x-ms-wmz")
+("xbap" . "application/x-ms-xbap")
+("mdb" . "application/x-msaccess")
+("obd" . "application/x-msbinder")
+("crd" . "application/x-mscardfile")
+("clp" . "application/x-msclip")
+("exe" . "application/x-msdownload")
+("mvb" . "application/x-msmediaview")
+("wmf" . "application/x-msmetafile")
+("mny" . "application/x-msmoney")
+("pub" . "application/x-mspublisher")
+("scd" . "application/x-msschedule")
+("trm" . "application/x-msterminal")
+("wri" . "application/x-mswrite")
+("nc" . "application/x-netcdf")
+("nzb" . "application/x-nzb")
+("p12" . "application/x-pkcs12")
+("p7b" . "application/x-pkcs7-certificates")
+("p7r" . "application/x-pkcs7-certreqresp")
+("rar" . "application/x-rar-compressed")
+("ris" . "application/x-research-info-systems")
+("sh" . "application/x-sh")
+("shar" . "application/x-shar")
+("swf" . "application/x-shockwave-flash")
+("xap" . "application/x-silverlight-app")
+("sql" . "application/x-sql")
+("sit" . "application/x-stuffit")
+("sitx" . "application/x-stuffitx")
+("srt" . "application/x-subrip")
+("sv4cpio" . "application/x-sv4cpio")
+("sv4crc" . "application/x-sv4crc")
+("t3" . "application/x-t3vm-image")
+("gam" . "application/x-tads")
+("tar" . "application/x-tar")
+("tcl" . "application/x-tcl")
+("tex" . "application/x-tex")
+("tfm" . "application/x-tex-tfm")
+("texinfo" . "application/x-texinfo")
+("obj" . "application/x-tgif")
+("ustar" . "application/x-ustar")
+("src" . "application/x-wais-source")
+("der" . "application/x-x509-ca-cert")
+("fig" . "application/x-xfig")
+("xlf" . "application/x-xliff+xml")
+("xpi" . "application/x-xpinstall")
+("xz" . "application/x-xz")
+("z1" . "application/x-zmachine")
+("xaml" . "application/xaml+xml")
+("xdf" . "application/xcap-diff+xml")
+("xenc" . "application/xenc+xml")
+("xhtml" . "application/xhtml+xml")
+("xml" . "application/xml")
+("dtd" . "application/xml-dtd")
+("xop" . "application/xop+xml")
+("xpl" . "application/xproc+xml")
+("xslt" . "application/xslt+xml")
+("xspf" . "application/xspf+xml")
+("mxml" . "application/xv+xml")
+("yang" . "application/yang")
+("yin" . "application/yin+xml")
+("zip" . "application/zip")
+("adp" . "audio/adpcm")
+("au" . "audio/basic")
+("mid" . "audio/midi")
+("mp4a" . "audio/mp4")
+("m4a" . "audio/mp4a-latm")
+("mpga" . "audio/mpeg")
+("oga" . "audio/ogg")
+("s3m" . "audio/s3m")
+("sil" . "audio/silk")
+("uva" . "audio/vnd.dece.audio")
+("eol" . "audio/vnd.digital-winds")
+("dra" . "audio/vnd.dra")
+("dts" . "audio/vnd.dts")
+("dtshd" . "audio/vnd.dts.hd")
+("lvp" . "audio/vnd.lucent.voice")
+("pya" . "audio/vnd.ms-playready.media.pya")
+("ecelp4800" . "audio/vnd.nuera.ecelp4800")
+("ecelp7470" . "audio/vnd.nuera.ecelp7470")
+("ecelp9600" . "audio/vnd.nuera.ecelp9600")
+("rip" . "audio/vnd.rip")
+("weba" . "audio/webm")
+("aac" . "audio/x-aac")
+("aif" . "audio/x-aiff")
+("caf" . "audio/x-caf")
+("flac" . "audio/x-flac")
+("mka" . "audio/x-matroska")
+("m3u" . "audio/x-mpegurl")
+("wax" . "audio/x-ms-wax")
+("wma" . "audio/x-ms-wma")
+("ram" . "audio/x-pn-realaudio")
+("rmp" . "audio/x-pn-realaudio-plugin")
+("wav" . "audio/x-wav")
+("xm" . "audio/xm")
+("cdx" . "chemical/x-cdx")
+("cif" . "chemical/x-cif")
+("cmdf" . "chemical/x-cmdf")
+("cml" . "chemical/x-cml")
+("csml" . "chemical/x-csml")
+("xyz" . "chemical/x-xyz")
+("bmp" . "image/bmp")
+("cgm" . "image/cgm")
+("g3" . "image/g3fax")
+("gif" . "image/gif")
+("ief" . "image/ief")
+("jp2" . "image/jp2")
+("jpeg" . "image/jpeg")
+("ktx" . "image/ktx")
+("pict" . "image/pict")
+("png" . "image/png")
+("btif" . "image/prs.btif")
+("sgi" . "image/sgi")
+("svg" . "image/svg+xml")
+("tiff" . "image/tiff")
+("psd" . "image/vnd.adobe.photoshop")
+("uvi" . "image/vnd.dece.graphic")
+("sub" . "image/vnd.dvb.subtitle")
+("djvu" . "image/vnd.djvu")
+("dwg" . "image/vnd.dwg")
+("dxf" . "image/vnd.dxf")
+("fbs" . "image/vnd.fastbidsheet")
+("fpx" . "image/vnd.fpx")
+("fst" . "image/vnd.fst")
+("mmr" . "image/vnd.fujixerox.edmics-mmr")
+("rlc" . "image/vnd.fujixerox.edmics-rlc")
+("mdi" . "image/vnd.ms-modi")
+("wdp" . "image/vnd.ms-photo")
+("npx" . "image/vnd.net-fpx")
+("wbmp" . "image/vnd.wap.wbmp")
+("xif" . "image/vnd.xiff")
+("webp" . "image/webp")
+("3ds" . "image/x-3ds")
+("ras" . "image/x-cmu-raster")
+("cmx" . "image/x-cmx")
+("fh" . "image/x-freehand")
+("ico" . "image/x-icon")
+("pntg" . "image/x-macpaint")
+("sid" . "image/x-mrsid-image")
+("pcx" . "image/x-pcx")
+("pic" . "image/x-pict")
+("pnm" . "image/x-portable-anymap")
+("pbm" . "image/x-portable-bitmap")
+("pgm" . "image/x-portable-graymap")
+("ppm" . "image/x-portable-pixmap")
+("qtif" . "image/x-quicktime")
+("rgb" . "image/x-rgb")
+("tga" . "image/x-tga")
+("xbm" . "image/x-xbitmap")
+("xpm" . "image/x-xpixmap")
+("xwd" . "image/x-xwindowdump")
+("eml" . "message/rfc822")
+("igs" . "model/iges")
+("msh" . "model/mesh")
+("dae" . "model/vnd.collada+xml")
+("dwf" . "model/vnd.dwf")
+("gdl" . "model/vnd.gdl")
+("gtw" . "model/vnd.gtw")
+("mts" . "model/vnd.mts")
+("vtu" . "model/vnd.vtu")
+("wrl" . "model/vrml")
+("x3db" . "model/x3d+binary")
+("x3dv" . "model/x3d+vrml")
+("x3d" . "model/x3d+xml")
+("manifest" . "text/cache-manifest")
+("appcache" . "text/cache-manifest")
+("ics" . "text/calendar")
+("css" . "text/css")
+("csv" . "text/csv")
+("html" . "text/html")
+("n3" . "text/n3")
+("txt" . "text/plain")
+("dsc" . "text/prs.lines.tag")
+("rtx" . "text/richtext")
+("sgml" . "text/sgml")
+("tsv" . "text/tab-separated-values")
+("t" . "text/troff")
+("ttl" . "text/turtle")
+("uri" . "text/uri-list")
+("vcard" . "text/vcard")
+("curl" . "text/vnd.curl")
+("dcurl" . "text/vnd.curl.dcurl")
+("scurl" . "text/vnd.curl.scurl")
+("mcurl" . "text/vnd.curl.mcurl")
+("sub" . "text/vnd.dvb.subtitle")
+("fly" . "text/vnd.fly")
+("flx" . "text/vnd.fmi.flexstor")
+("gv" . "text/vnd.graphviz")
+("3dml" . "text/vnd.in3d.3dml")
+("spot" . "text/vnd.in3d.spot")
+("jad" . "text/vnd.sun.j2me.app-descriptor")
+("wml" . "text/vnd.wap.wml")
+("wmls" . "text/vnd.wap.wmlscript")
+("s" . "text/x-asm")
+("c" . "text/x-c")
+("f" . "text/x-fortran")
+("java" . "text/x-java-source")
+("opml" . "text/x-opml")
+("p" . "text/x-pascal")
+("nfo" . "text/x-nfo")
+("etx" . "text/x-setext")
+("sfv" . "text/x-sfv")
+("uu" . "text/x-uuencode")
+("vcs" . "text/x-vcalendar")
+("vcf" . "text/x-vcard")
+("3gp" . "video/3gpp")
+("3g2" . "video/3gpp2")
+("h261" . "video/h261")
+("h263" . "video/h263")
+("h264" . "video/h264")
+("jpgv" . "video/jpeg")
+("jpm" . "video/jpm")
+("mj2" . "video/mj2")
+("ts" . "video/mp2t")
+("mp4" . "video/mp4")
+("mpeg" . "video/mpeg")
+("ogv" . "video/ogg")
+("qt" . "video/quicktime")
+("uvh" . "video/vnd.dece.hd")
+("uvm" . "video/vnd.dece.mobile")
+("uvp" . "video/vnd.dece.pd")
+("uvs" . "video/vnd.dece.sd")
+("uvv" . "video/vnd.dece.video")
+("dvb" . "video/vnd.dvb.file")
+("fvt" . "video/vnd.fvt")
+("mxu" . "video/vnd.mpegurl")
+("pyv" . "video/vnd.ms-playready.media.pyv")
+("uvu" . "video/vnd.uvvu.mp4")
+("viv" . "video/vnd.vivo")
+("dv" . "video/x-dv")
+("webm" . "video/webm")
+("f4v" . "video/x-f4v")
+("fli" . "video/x-fli")
+("flv" . "video/x-flv")
+("m4v" . "video/x-m4v")
+("mkv" . "video/x-matroska")
+("mng" . "video/x-mng")
+("asf" . "video/x-ms-asf")
+("vob" . "video/x-ms-vob")
+("wm" . "video/x-ms-wm")
+("wmv" . "video/x-ms-wmv")
+("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")))
+
+(define (ext->mimetype ext)
+ (let ((x (assoc ext ducttape_ext2mimetype)))
+ (if x (cdr x) "text/plain")))
ADDED ducttape/sample_ducttape.scm
Index: ducttape/sample_ducttape.scm
==================================================================
--- /dev/null
+++ ducttape/sample_ducttape.scm
@@ -0,0 +1,4 @@
+(include "ducttape-lib.scm")
+(import ducttape-lib)
+(inote "hello world")
+(exit 0)
ADDED ducttape/test_ducttape.scm
Index: ducttape/test_ducttape.scm
==================================================================
--- /dev/null
+++ ducttape/test_ducttape.scm
@@ -0,0 +1,355 @@
+#!/usr/bin/env csi -script
+(use test)
+(include "ducttape-lib.scm")
+(import ducttape-lib)
+(import ansi-escape-sequences)
+(use trace)
+(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
+;(trace skim-cmdline-opts-withargs-by-regex)
+;(trace keyword-skim)
+;(trace re-match?)
+(define (reset-ducttape)
+ (unsetenv "ducttape_DEBUG_LEVEL")
+ (ducttape-debug-level #f)
+
+ (unsetenv "ducttape_DEBUG_PATTERN")
+ (ducttape-debug-regex-filter ".")
+
+ (unsetenv "ducttape_LOG_FILE")
+ (ducttape-log-file #f)
+
+ (unsetenv "ducttape_SILENT_MODE")
+ (ducttape-silent-mode #f)
+
+ (unsetenv "ducttape_QUIET_MODE")
+ (ducttape-quiet-mode #f)
+
+ (unsetenv "ducttape_COLOR_MODE")
+ (ducttape-color-mode #f)
+)
+
+(define (reset-ducttape-with-cmdline-list cmdline-list)
+ (reset-ducttape)
+
+ (command-line-arguments cmdline-list)
+ (process-command-line)
+)
+
+
+(define (direct-iputs-test)
+ (ducttape-color-mode #f)
+ (ierr "I'm an error")
+ (iwarn "I'm a warning")
+ (inote "I'm a note")
+
+ (ducttape-debug-level 1)
+ (idbg "I'm a debug statement")
+ (ducttape-debug-level #f)
+ (idbg "I'm a hidden debug statement")
+
+ (ducttape-silent-mode #t)
+ (iwarn "I shouldn't show up")
+ (inote "I shouldn't show up either")
+ (ierr "I should show up 1")
+ (ducttape-silent-mode #f)
+
+ (ducttape-quiet-mode #t)
+ (iwarn "I should show up 2")
+ (inote "I shouldn't show up though")
+ (ierr "I should show up 3")
+ (ducttape-quiet-mode #f)
+
+ (ducttape-debug-level 1)
+ (idbg "foo")
+ (iputs "dbg" "debug message")
+ (iputs "e" "error message")
+ (iputs "w" "warning message")
+ (iputs "n" "note message")
+
+ (ducttape-color-mode #t)
+ (ierr "I'm an error COLOR")
+ (iwarn "I'm a warning COLOR")
+ (inote "I'm a note COLOR")
+ (idbg "I'm a debug COLOR")
+
+
+ )
+
+(define (test-argprocessor-funcs)
+
+ (test-group
+ "Command line processor utility functions"
+
+ (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
+ (command-line-arguments testargs1)
+ (set! expected_result '("-d" "-d" "-d3" "-ddd"))
+ (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
+
+ (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
+ (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))
+
+
+
+ (command-line-arguments testargs1)
+ (set! expected_result '("fooarg" "fooarg2" ))
+ (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
+ (test
+ "skim-cmdline-opts-withargs-by-regex result"
+ expected_result
+ (skim-cmdline-opts-withargs-by-regex "--?foo"))
+
+ (test
+ "skim-cmdline-opts-withargs-by-regex sideeffect"
+ expected_sideeffect
+ (command-line-arguments))
+
+ ))
+
+(define (test-misc)
+ (test-group
+ "misc"
+ (let ((tmpfile (mktemp)))
+ (test-assert "mktemp: temp file created" (file-exists? tmpfile))
+ (if (file-exists? tmpfile)
+ (delete-file tmpfile))
+
+ )))
+
+
+
+(define (test-systemstuff)
+ (test-group
+ "system commands"
+
+ (let-values (((ec o e) (isys (find-exe "true"))))
+ (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
+ (let-values (((ec o e) (isys (find-exe "false"))))
+ (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))
+
+ (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
+ (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
+ (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
+
+ (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
+ (let ((expected-code
+ (if (equal? systype "Darwin") 1 2))
+ (expected-err
+ (if (equal? systype "Darwin")
+ "ls: /zzzzz: No such file or directory"
+ "/bin/ls: cannot access /zzzzz: No such file or directory"))
+
+ )
+ (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
+ (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
+ (test
+ "isys: /bin/ls /zzzzz should have stderr"
+ expected-err
+ e))
+ )
+
+ (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
+ (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
+ (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
+ (test
+ "isys: /bin/ls /etc/passwd should have empty stderr"
+ ""
+ e))
+
+ (let ((res (do-or-die "/bin/ls /etc/passwd")))
+ (test
+ "do-or-die: ls /etc/passwd should work"
+ "/etc/passwd" res ))
+
+ (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
+ (test
+ "do-or-die: ls /zzzzz should die"
+ #f res ))
+
+ ; test reading from process stdout line at a time
+ (let* (
+ (lineno (counter-maker))
+
+ ; print each line with an index
+ (eachline-fn (lambda (line)
+ (print "GOTLINE " (lineno) "> " line)))
+
+ (res
+ (do-or-die "/bin/ls -l /etc | head; true"
+ foreach-stdout: eachline-fn )))
+
+ (test-assert "ls -l /etc should not be empty"
+ (not (equal? res ""))))
+ ;; test writing to process stdout line at a time
+
+ (let* ((tmpfile (mktemp))
+ (cmd (conc "cat > " tmpfile)))
+ (let-values (((c o e)
+ (isys cmd stdin-proc:
+ (lambda (myport)
+ (write-line "hello" myport)
+ (write-line "hello2" myport)
+ (close-output-port myport)))))
+ (test "isys-sp: cat should exit 0" 0 c)
+ (let ((mycmd (conc "cat " tmpfile)))
+ (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))
+
+ (delete-file tmpfile)
+ ))
+
+ (let* ((tmpfile (mktemp))
+ (cmd (conc "cat > " tmpfile)))
+ (do-or-die cmd stdin-proc:
+ (lambda (myport)
+ (write-line "hello" myport)
+ (write-line "hello2" myport)
+ (close-output-port myport))
+ cmd)
+ (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
+ (delete-file tmpfile))
+
+
+
+
+
+ (let*
+ ((thefile (conc "/tmp/" (get-environment-variable "USER") "9-lines"))
+ (counter (counter-maker))
+ (stdin-writer
+ (lambda ()
+ (if (< (counter) 10)
+ (number->string (counter 0))
+ #f)))
+ (cmd (conc "cat > " thefile)))
+ (let-values
+ (((c o e)
+ (isys cmd foreach-stdin-thunk: stdin-writer)))
+
+ (test-assert "isys-fsl: cat should return 0" (equal? c 0))
+
+ (test-assert
+ "isys-fsl: cat should have written a file"
+ (file-exists? thefile))
+
+ (if
+ (file-exists? thefile)
+ (begin
+ (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
+ (delete-file thefile)))))
+
+ ) ; end test-group
+ ) ; end define
+
+
+(define (test-argprocessor )
+ (test-group
+ "Command line processor parameter settings"
+
+ (reset-ducttape-with-cmdline-list '())
+ (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
+ (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
+ (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
+ (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
+ (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
+ (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))
+
+ (reset-ducttape-with-cmdline-list '("-d"))
+ (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))
+
+ (reset-ducttape-with-cmdline-list '("-dd"))
+ (test "-dd: debug level should be 2" 2 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-ddd"))
+ (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-d2"))
+ (test "-d2: debug level should be 2" 2 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-d3"))
+ (test "-d3: debug level should be 3" 3 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-dp" "foo"))
+ (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
+ (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
+ (test "-dp foo -dp bar: debug pattern should be 'foo|bar'" "foo|bar" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("--quiet"))
+ (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))
+
+ (reset-ducttape-with-cmdline-list '("--silent"))
+ (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))
+
+ (reset-ducttape-with-cmdline-list '("--color"))
+ (test-assert "-color: color mode should be active" (ducttape-color-mode))
+
+ (reset-ducttape-with-cmdline-list '("--log" "foo"))
+ (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))
+
+))
+
+(define (test-wwdate)
+ (test-group
+ "wwdate conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((wwdate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->wwdate "isodate ") => "wwdate)
+ wwdate
+ (isodate->wwdate isodate))
+
+ (test
+ (conc "(wwdate->isodate "wwdate ") => "isodate)
+ isodate
+ (wwdate->isodate wwdate))))
+ test-table))))
+
+(define (main)
+ ;; (test )
+
+; (test-group "silly settext group"
+; (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
+; (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
+; )
+
+ ; visually inspect this
+ (direct-iputs-test)
+
+ ; following use unit test test-egg
+ (reset-ducttape)
+ (test-argprocessor-funcs)
+ (reset-ducttape)
+ (test-argprocessor)
+ (test-systemstuff)
+ (test-misc)
+ (test-wwdate)
+ ) ; end main()
+
+(main)
+(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body" )
+
+(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
+ (cid "mtlogo")
+ (image-alist (list (cons image-file cid)))
+ (body (conc "Hello world
![\"test]()
bye!")))
+
+ (sendmail "brandon.j.barclay@intel.com" "7hello subject" body use_html: #t images-with-content-id-alist: image-alist)
+ (print "sent image mail"))
+;(sendmail "bjbarcla" "2hello subject html" "test bodyhello
italics" use_html: #t)
+;(sendmail "bb" "4hello attach subject html" "hmm
" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )
+
+;(launch-repl)
+(test-exit)
ADDED ducttape/test_example.scm
Index: ducttape/test_example.scm
==================================================================
--- /dev/null
+++ ducttape/test_example.scm
@@ -0,0 +1,3 @@
+(use ducttape-lib)
+
+(inote "Hello world")
ADDED ducttape/useargs-example.scm
Index: ducttape/useargs-example.scm
==================================================================
--- /dev/null
+++ ducttape/useargs-example.scm
@@ -0,0 +1,19 @@
+(use ducttape-lib)
+
+(let (
+ (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
+ (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
+ )
+ (print "your customers are " customers)
+ (if (null? magicmode)
+ (print "no unicorns for you")
+ (print "magic!")
+ )
+ )
+
+(idbg "hello")
+(idbg "hello2" 2)
+(idbg "hello2" 3)
+(inote "note")
+(iwarn "warn")
+(ierr "err")
ADDED ducttape/workweekdate.scm
Index: ducttape/workweekdate.scm
==================================================================
--- /dev/null
+++ ducttape/workweekdate.scm
@@ -0,0 +1,193 @@
+(use srfi-19)
+(use test)
+;;(use format)
+(use 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"
+;; seconds -> 1451631600
+
+;; procedures provided:
+;; ====================
+;; seconds->isodate
+;; seconds->wwdate
+;;
+;; isodate->seconds
+;; isodate->wwdate
+;;
+;; wwdate->seconds
+;; wwdate->isodate
+
+;; srfi-19 used extensively; this doc is better tha the eggref:
+;; http://srfi.schemers.org/srfi-19/srfi-19.html
+
+;; Author: brandon.j.barclay@intel.com 16ww18.6
+
+(define (date->seconds date)
+ (inexact->exact
+ (string->number
+ (date->string date "~s"))))
+
+(define (seconds->isodate seconds)
+ (let* ((date (seconds->date seconds))
+ (result (date->string date "~Y-~m-~d")))
+ result))
+
+(define (isodate->seconds isodate)
+ "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
+ (let* ((numlist (map string->number (string-split isodate "-")))
+ (raw-year (car numlist))
+ (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
+ (month (list-ref numlist 1))
+ (day (list-ref numlist 2))
+ (date (make-date 0 0 0 0 day month year))
+ (seconds (date->seconds date)))
+
+ seconds))
+
+;; adapted from perl Intel::WorkWeek perl module
+;; workweek year consists of numbered weeks starting from week 1
+;; days of week are numbered starting from 0 on sunday
+;; weeks begin on sunday- day number 0 and end saturday- day 6
+;; week 1 is defined as the week containing jan 1 of the year
+;; workweek year does not match calendar year in workweek 1
+;; since workweek 1 contains jan1 and workweek begins sunday,
+;; days prior to jan1 in workweek 1 belong to the next workweek year
+(define (seconds->wwdate-values seconds)
+ (define (date-difference->seconds d1 d2)
+ (- (date->seconds d1) (date->seconds d2)))
+
+ (let* ((thisdate (seconds->date seconds))
+ (thisdow (string->number (date->string thisdate "~w")))
+
+ (year (date-year thisdate))
+ ;; intel workweek 1 begins on sunday of week containing jan1
+ (jan1 (make-date 0 0 0 0 1 1 year))
+ (jan1dow (date-week-day jan1))
+ (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
+
+ (ww01_delta_seconds (date-difference->seconds thisdate ww01))
+ (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
+
+ ;; we could be in ww1 of next year
+ (this-saturday (seconds->date
+ (+ seconds
+ (* 60 60 24 (- 6 thisdow)))))
+ (this-week-ends-next-year?
+ (> (date-year this-saturday) year))
+ (intelyear
+ (if this-week-ends-next-year?
+ (add1 year)
+ year))
+ (intelweek
+ (if this-week-ends-next-year?
+ 1
+ wwnum_initial)))
+ (values intelyear intelweek thisdow)))
+
+(define (string-leftpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc padding unpadded-str)))
+
+(define (string-rightpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc unpadded-str padding)))
+
+(define (zeropad num width)
+ (string-leftpad num width #\0))
+
+(define (seconds->wwdate seconds)
+
+ (let-values (((intelyear intelweek day-of-week-num)
+ (seconds->wwdate-values seconds)))
+ (let ((intelyear-str
+ (zeropad
+ (->string
+ (if (> intelyear 1999)
+ (- intelyear 2000) intelyear))
+ 2))
+ (intelweek-str
+ (zeropad (->string intelweek) 2))
+ (dow-str (->string day-of-week-num)))
+ (conc intelyear-str "ww" intelweek-str "." dow-str))))
+
+(define (isodate->wwdate isodate)
+ (seconds->wwdate
+ (isodate->seconds isodate)))
+
+(define (wwdate->seconds wwdate)
+ (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
+ (if
+ (not match)
+ #f
+ (let* (
+ (intelyear-raw (string->number (list-ref match 1)))
+ (intelyear (if (< intelyear-raw 100)
+ (+ intelyear-raw 2000)
+ intelyear-raw))
+ (intelww (string->number (list-ref match 2)))
+ (dayofweek (string->number (list-ref match 3)))
+
+ (day-of-seconds (* 60 60 24 ))
+ (week-of-seconds (* day-of-seconds 7))
+
+
+ ;; get seconds at ww1.0
+ (new-years-date (make-date 0 0 0 0 1 1 intelyear))
+ (new-years-seconds
+ (date->seconds new-years-date))
+ (new-years-dayofweek (date-week-day new-years-date))
+ (ww1.0_seconds (- new-years-seconds
+ (* day-of-seconds
+ new-years-dayofweek)))
+ (workweek-adjustment (* week-of-seconds (sub1 intelww)))
+ (weekday-adjustment (* dayofweek day-of-seconds))
+
+ (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
+ result))))
+
+(define (wwdate->isodate wwdate)
+ (seconds->isodate (wwdate->seconds wwdate)))
+
+(define (current-wwdate)
+ (seconds->wwdate (current-seconds)))
+
+(define (current-isodate)
+ (seconds->isodate (current-seconds)))
+
+(define (wwdate-tests)
+ (test-group
+ "date conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((wwdate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->wwdate "isodate ") => "wwdate)
+ wwdate
+ (isodate->wwdate isodate))
+
+ (test
+ (conc "(wwdate->isodate "wwdate ") => "isodate)
+ isodate
+ (wwdate->isodate wwdate))))
+ test-table))))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -43,10 +43,11 @@
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
+(declare (uses diff-report))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -175,10 +176,18 @@
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
cmd: keep-html, restore, save, save-remove
-generate-html : create a simple html tree for browsing your runs
+Diff report
+ -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
+ and either -diff-email or -diff-html)
+ -src-target
+ -src-runname
+ -diff-email : comma separated list of email addresses to send diff report
+ -diff-html : path to html file to generate
+
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
@@ -267,10 +276,15 @@
"-fields"
"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
"-sort"
"-target-db"
"-source-db"
+
+ "-src-target"
+ "-src-runname"
+ "-diff-email"
+ "-diff-html"
)
(list "-h" "-help" "--help"
"-manual"
"-version"
"-force"
@@ -326,11 +340,13 @@
"-sync-to-megatest.db"
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
- )
+
+ "-diff-rep"
+ )
args:arg-hash
0))
;; Add args that use remargs here
;;
@@ -1868,10 +1884,30 @@
;;======================================================================
;; fakeout readline
(include "readline-fix.scm")
+
+(when (args:get-arg "-diff-rep")
+ (when (and
+ (not (args:get-arg "-diff-html"))
+ (not (args:get-arg "-diff-email")))
+ (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
+ (set! *didsomething* 1)
+ (exit 1))
+
+ (let* ((toppath (launch:setup)))
+ (do-diff-report
+ (args:get-arg "-src-target")
+ (args:get-arg "-src-runname")
+ (args:get-arg "-target")
+ (args:get-arg "-runname")
+ (args:get-arg "-diff-html")
+ (args:get-arg "-diff-email"))
+ (set! *didsomething* #t)
+ (exit 0)))
+
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
(dbstruct (if (and toppath