Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -29,13 +29,13 @@
MSRCFILES = dbmod.scm rmtmod.scm commonmod.scm apimod.scm \
archivemod.scm clientmod.scm envmod.scm ezstepsmod.scm itemsmod.scm \
keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm \
runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm \
-megamod.scm
+pkts.scm mtargs.scm mtconfigf.scm ducttape-lib.scm megamod.scm
-GMSRCFILES = dcommonmod.scm vgmod.scm treemod.scm
+GMSRCFILES = dcommonmod.scm vgmod.scm treemod.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 \
@@ -59,11 +59,14 @@
GMOIMPFILES = $(GMSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc -unit $*.import -c $*.import.scm -o $*.import.o
-mofiles/%.o : %.scm
+# mofiles/ducttape-lib.o : ducttape-lib.scm ducttape/*scm
+# csc -I ducttape -J -c ducttape-lib.scm -o mofiles/ducttape-lib.o
+
+mofiles/%.o %.import.scm : %.scm
mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
# a.import.o : a.import.scm a.o
# csc -unit a.import -c a.import.scm -o $*.o
@@ -87,30 +90,30 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
-IMPORTO = apimod.import.o dbmod.import.o itemsmod.import.o \
-odsmod.import.o runsmod.import.o testsmod.import.o \
-archivemod.import.o keysmod.import.o processmod.import.o \
-servermod.import.o clientmod.import.o envmod.import.o \
-launchmod.import.o rmtmod.import.o subrunmod.import.o \
-commonmod.import.o ezstepsmod.import.o megamod.import.o \
-runconfigmod.import.o tasksmod.import.o
+# IMPORTO = apimod.import.o dbmod.import.o itemsmod.import.o \
+# odsmod.import.o runsmod.import.o testsmod.import.o \
+# archivemod.import.o keysmod.import.o processmod.import.o \
+# servermod.import.o clientmod.import.o envmod.import.o \
+# launchmod.import.o rmtmod.import.o subrunmod.import.o \
+# commonmod.import.o ezstepsmod.import.o megamod.import.o \
+# runconfigmod.import.o tasksmod.import.o pkts.import.o
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
# why were the files mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o listed on this target when MOFILES are there?
# Removed non module .o files (i.e. $(OFILES)
-mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES)
+mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) mofiles/ducttape-lib.o
csc $(CSCOPTS) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
# removing $(GOFILES)
-dboard : dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES)
+dboard : dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES)
csc $(CSCOPTS) dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard
ndboard : newdashboard.scm $(GOFILES)
csc $(CSCOPTS) $(GOFILES) newdashboard.scm -o ndboard
@@ -175,22 +178,41 @@
#
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
+#======================================================================
# Special dependencies for the includes
+#======================================================================
+
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \
archive.o megatest.o : db_records.scm migrate-fix.scm
+
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
+
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
+
tests.o tasks.o dashboard-tasks.o : task_records.scm
+
runs.o : test_records.scm
+
megatest.o : megatest-fossil-hash.scm
+
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
+
common_records.scm : altdb.scm
+
vg.o dashboard.o : vg_records.scm mofiles/dcommonmod.o
+
dcommon.o : run_records.scm migrate-fix.scm
+
+# special include based modules
+mofiles/pkts.o : pkts/pkts.scm
+mofiles/mtargs.o : mtargs/mtargs.scm
+mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
+# mofile/ducttape-lib.o : ducttape/ducttape-lib.scm
+
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
# for the modularized stuff
@@ -220,16 +242,21 @@
mofiles/runsmod.o \
mofiles/servermod.o \
mofiles/subrunmod.o \
mofiles/tasksmod.o \
mofiles/testsmod.o \
+ mofiles/pkts.o \
+ mofiles/mtargs.o \
+ mofiles/mtconfigf.o \
+ mofiles/ducttape-lib.o \
*-inc.scm
mofiles/dcommonmod.o : \
mofiles/vgmod.o \
mofiles/treemod.o \
- mofiles/ezstepsmod.o
+ mofiles/ezstepsmod.o \
+ mofiles/mtargs.o
# $(MOFILES) : mofiles/commonmod.o
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -23,15 +23,15 @@
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use ducttape-lib)
+;; (use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records
sparse-vectors srfi-18
- (prefix mtconfigf configf:)
- (prefix margs args:))
+ #;(prefix mtconfigf configf:)
+ )
(import (prefix sqlite3 sqlite3:))
;; (declare (uses common))
;; (declare (uses margs))
;; (declare (uses keys))
@@ -65,10 +65,17 @@
(declare (uses testsmod))
(import testsmod)
(declare (uses dcommonmod))
(import dcommonmod)
+(declare (uses mtargs))
+(import (prefix mtargs args:))
+(declare (uses ducttape-lib))
+(import ducttape-lib)
+(declare (uses mtconfigf))
+(import (prefix mtconfigf configf:))
+
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
@@ -80,10 +87,13 @@
(declare (uses testsmod.import))
(declare (uses rmtmod.import))
(declare (uses runsmod.import))
(declare (uses megamod.import))
(declare (uses dcommonmod.import))
+(declare (uses mtargs.import))
+(declare (uses ducttape-lib.import))
+(declare (uses mtconfigf.import))
(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
(configf:add-eval-string "(import megamod)(import commonmod)")
Index: dcommonmod.scm
==================================================================
--- dcommonmod.scm
+++ dcommonmod.scm
@@ -20,10 +20,11 @@
(declare (unit dcommonmod))
(declare (uses commonmod))
(declare (uses testsmod))
(declare (uses megamod))
+(declare (uses mtargs))
(module dcommonmod
*
(import scheme chicken data-structures extras)
@@ -86,10 +87,11 @@
(import testsmod)
(import megamod)
(import canvas-draw)
(import canvas-draw-iup)
(use (prefix iup iup:))
+(import (prefix mtargs args:))
(define *tim* (iup:timer))
;; (use (prefix ulex ulex:))
ADDED ducttape-lib.scm
Index: ducttape-lib.scm
==================================================================
--- /dev/null
+++ ducttape-lib.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit ducttape-lib))
+
+(include "ducttape/ducttape-lib.scm")
ADDED ducttape/Makefile
Index: ducttape/Makefile
==================================================================
--- /dev/null
+++ ducttape/Makefile
@@ -0,0 +1,34 @@
+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:
+ echo '(handle-exceptions exn (begin (print-call-chain) (exit 1)) (load "ducttape-lib.scm") (inote "hello")) (exit 0)' | csi
+ chicken-install -no-install
+ csc test_ducttape.scm
+
+ ./test_ducttape
+ 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/README
Index: ducttape/README
==================================================================
--- /dev/null
+++ ducttape/README
@@ -0,0 +1,8 @@
+This directory holds the "ducttape" chicken scheme egg used by megatest.
+
+Run "make test" to ensure this egg works on your system.
+
+Run "make install" as your admin user with chicken on your $PATH to install this egg.
+
+
+
ADDED ducttape/ducttape-lib.import.scm
Index: ducttape/ducttape-lib.import.scm
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.import.scm
@@ -0,0 +1,79 @@
+;;;; ducttape-lib.import.scm - GENERATED BY CHICKEN 4.10.0 -*- Scheme -*-
+
+(eval '(import
+ scheme
+ chicken
+ extras
+ ports
+ data-structures
+ posix
+ regex
+ ansi-escape-sequences
+ test
+ srfi-1
+ irregex
+ slice
+ srfi-13
+ rfc3339
+ directory-utils
+ uuid-lib
+ filepath
+ srfi-19
+ srfi-19
+ test
+ regex))
+(##sys#register-compiled-module
+ 'ducttape-lib
+ (list)
+ '((runs-ok . ducttape-lib#runs-ok)
+ (ducttape-debug-level . ducttape-lib#ducttape-debug-level)
+ (ducttape-debug-regex-filter . ducttape-lib#ducttape-debug-regex-filter)
+ (ducttape-silent-mode . ducttape-lib#ducttape-silent-mode)
+ (ducttape-quiet-mode . ducttape-lib#ducttape-quiet-mode)
+ (ducttape-log-file . ducttape-lib#ducttape-log-file)
+ (ducttape-color-mode . ducttape-lib#ducttape-color-mode)
+ (iputs-preamble . ducttape-lib#iputs-preamble)
+ (script-name . ducttape-lib#script-name)
+ (idbg . ducttape-lib#idbg)
+ (ierr . ducttape-lib#ierr)
+ (iwarn . ducttape-lib#iwarn)
+ (inote . ducttape-lib#inote)
+ (iputs . ducttape-lib#iputs)
+ (re-match? . ducttape-lib#re-match?)
+ (keyword-skim . ducttape-lib#keyword-skim)
+ (skim-cmdline-opts-noarg-by-regex
+ .
+ ducttape-lib#skim-cmdline-opts-noarg-by-regex)
+ (skim-cmdline-opts-withargs-by-regex
+ .
+ ducttape-lib#skim-cmdline-opts-withargs-by-regex)
+ (concat-lists . ducttape-lib#concat-lists)
+ (ducttape-process-command-line
+ .
+ ducttape-lib#ducttape-process-command-line)
+ (ducttape-append-logfile . ducttape-lib#ducttape-append-logfile)
+ (ducttape-activate-logfile . ducttape-lib#ducttape-activate-logfile)
+ (isys . ducttape-lib#isys)
+ (do-or-die . ducttape-lib#do-or-die)
+ (counter-maker . ducttape-lib#counter-maker)
+ (dir-is-writable? . ducttape-lib#dir-is-writable?)
+ (mktemp . ducttape-lib#mktemp)
+ (get-tmpdir . ducttape-lib#get-tmpdir)
+ (sendmail . ducttape-lib#sendmail)
+ (find-exe . ducttape-lib#find-exe)
+ (zeropad . ducttape-lib#zeropad)
+ (string-leftpad . ducttape-lib#string-leftpad)
+ (string-rightpad . ducttape-lib#string-rightpad)
+ (seconds->isodate . ducttape-lib#seconds->isodate)
+ (seconds->wwdate . ducttape-lib#seconds->wwdate)
+ (seconds->wwdate-values . ducttape-lib#seconds->wwdate-values)
+ (isodate->seconds . ducttape-lib#isodate->seconds)
+ (isodate->wwdate . ducttape-lib#isodate->wwdate)
+ (wwdate->seconds . ducttape-lib#wwdate->seconds)
+ (wwdate->isodate . ducttape-lib#wwdate->isodate)
+ (current-wwdate . ducttape-lib#current-wwdate)
+ (current-isodate . ducttape-lib#current-isodate))
+ (list)
+ (list))
+
+;; END OF FILE
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,1777 @@
+(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
+ get-cli-arg
+ get-cli-switch
+ concat-lists
+ ducttape-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
+ *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)
+ ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
+ (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
+
+ ;; plugs a hole in posix-extras in latter chicken versions
+ (use posix-extras pathname-expand files)
+ (define ##sys#expand-home-path pathname-expand)
+ (define (realpath x) (resolve-pathname (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
+
+(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")))
+
+(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))))
+
+
+(define (ext->mimetype ext)
+ (let ((x (assoc ext ducttape_ext2mimetype)))
+ (if x (cdr x) "text/plain")))
+
+
+ (define ducttape-lib-version 1.00)
+ (define (toplevel-command sym proc) (lambda () #f))
+
+ ;; 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 some handy globals
+ ;; resolve fullpath to this script or binary.
+ (define (__get-this-script-fullpath #!key (argv (argv)))
+ (let* ((this-script
+ (cond
+ ((and (> (length argv) 2)
+ (string-match "^(.*/csi|csi)$" (car argv))
+ (string-match "^-(s|ss|sx|script)$" (cadr argv)))
+ (caddr argv))
+ (else (car argv))))
+
+ ;;(foo (begin (print "hello "(find-exe "/bin/sh") #f)))
+ (fullpath (or (find-exe this-script) (realpath this-script))))
+ fullpath))
+
+ (define *this-exe-fullpath* (__get-this-script-fullpath))
+ (define *this-exe-dir* (pathname-directory *this-exe-fullpath*))
+ (define *this-exe-name* (pathname-strip-directory *this-exe-fullpath*))
+
+
+;;;; 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))))))
+
+
+ ;; 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)))
+
+
+ ;; log exit code
+ (define (set-ducttape-log-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)))))
+
+
+ (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))
+
+
+;;;; 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))))))
+
+
+ (define (get-cli-arg arg #!key (default #f) (is-list #f))
+ (let* ((temp (skim-cmdline-opts-withargs-by-regex arg)))
+ (if (> (length temp) 0)
+ (if is-list
+ temp
+ (car temp))
+ default)))
+
+ (define (get-cli-switch arg)
+ (let ((temp (skim-cmdline-opts-noarg-by-regex arg)))
+ (if (> (length temp) 0)
+ (car temp)
+ #f)))
+
+
+
+
+ ;; 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)
+ ;; WARNING: this defines command line arguments that may clash with your program. Only call this if you
+ ;; 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")
+ (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))))))
+
+
+ ;;; 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)
+
+ ;; TODO: hook exception handler so we can log exception before we sign off.
+
+ ;; 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)
+ (ducttape-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: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -41,10 +41,14 @@
;; (declare (uses servermod))
;; (declare (uses subrunmod))
;; (declare (uses tasksmod))
(declare (uses testsmod))
;; (declare (uses vgmod))
+(declare (uses pkts))
+(declare (uses mtargs))
+(declare (uses mtconfigf))
+(declare (uses ducttape-lib))
(module megamod
*
(import scheme chicken data-structures extras)
@@ -69,11 +73,11 @@
irregex
matchable
md5
message-digest
pathname-expand
- pkts
+ ;; pkts
ports
posix
;; queue
regex
regex-case
@@ -95,11 +99,11 @@
udp
uri-common
z3
)
-(use (prefix mtconfigf configf:))
+(import (prefix mtconfigf configf:))
(define read-config configf:read-config)
(define find-and-read-config configf:find-and-read-config)
(define config:eval-string-in-environment configf:eval-string-in-environment)
(import spiffy)
@@ -124,10 +128,13 @@
;; (import servermod)
;; (import subrunmod)
;; (import tasksmod)
(import testsmod)
;; (import vgmod)
+(import pkts)
+(import (prefix mtargs args:))
+(import ducttape-lib)
(use (prefix ulex ulex:))
(include "common_records.scm")
(include "db_records.scm")
@@ -170,11 +177,11 @@
(include "env-inc.scm")
(include "http-transport-inc.scm")
(include "items-inc.scm")
;; (include "keys-inc.scm")
(include "launch-inc.scm") ;; L1
-(include "margs-inc.scm")
+;; (include "margs-inc.scm")
(include "mt-inc.scm")
(include "ods-inc.scm") ;; L1
(include "pgdb-inc.scm")
(include "portlogger-inc.scm")
(include "process-inc.scm") ;; L6
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -59,17 +59,26 @@
(import runsmod)
(declare (uses testsmod))
(import testsmod)
(declare (uses megamod))
(import megamod)
+(declare (uses mtargs))
+(import (prefix mtargs args:))
+(declare (uses mtconfigf))
+(import (prefix mtconfigf configf:))
+(declare (uses ducttape-lib))
+(import ducttape-lib)
;; invoke the imports
(declare (uses commonmod.import))
(declare (uses testsmod.import))
(declare (uses rmtmod.import))
(declare (uses runsmod.import))
(declare (uses megamod.import))
+(declare (uses mtargs.import))
+(declare (uses mtconfigf.import))
+(declare (uses ducttape-lib.import))
(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
;; (declare (uses tdb))
;; (declare (uses mt))
ADDED mtargs.scm
Index: mtargs.scm
==================================================================
--- /dev/null
+++ mtargs.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit mtargs))
+
+(include "mtargs/mtargs.scm")
ADDED mtargs/Makefile
Index: mtargs/Makefile
==================================================================
--- /dev/null
+++ mtargs/Makefile
@@ -0,0 +1,22 @@
+# Copyright 2007-2010, Matthew Welland.
+#
+# This program is made available under the GNU GPL version 2.0 or
+# greater. See the accompanying file COPYING for details.
+#
+# This program is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.
+
+# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")
+
+all : uptodate.log # $(TARGDIR)/mtargs.so
+
+uptodate.log : mtargs.scm mtargs.setup
+ chicken-install | tee uptodate.log
+
+$(TARGDIR)/mtargs.so : mtargs.so
+ @echo installing to $(TARGDIR)
+ cp mtargs.so $(TARGDIR)
+
+mtargs.so : mtargs.scm
+ csc -s mtargs.scm
ADDED mtargs/mtargs.meta
Index: mtargs/mtargs.meta
==================================================================
--- /dev/null
+++ mtargs/mtargs.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "LGPL")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category misc)
+
+; A list of eggs mpeg3 depends on. If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs srfi-69 srfi-1)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Primitive argument processor."))
ADDED mtargs/mtargs.scm
Index: mtargs/mtargs.scm
==================================================================
--- /dev/null
+++ mtargs/mtargs.scm
@@ -0,0 +1,94 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This file is part of mtargs.
+;;
+;; mtargs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; mtargs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with mtargs. If not, see .
+
+
+(module mtargs
+ (
+ arg-hash
+ get-arg
+ get-arg-from
+ usage
+ get-args
+ print-args
+ any-defined?
+ help
+ )
+
+(import scheme chicken data-structures extras posix ports files)
+(use srfi-69 srfi-1)
+
+(define arg-hash (make-hash-table))
+(define help "")
+
+(define (get-arg arg . default)
+ (if (null? default)
+ (hash-table-ref/default arg-hash arg #f)
+ (hash-table-ref/default arg-hash arg (car default))))
+
+(define (any-defined? . args)
+ (not (null? (filter (lambda (x) x)
+ (map get-arg args)))))
+
+(define (get-arg-from ht arg . default)
+ (if (null? default)
+ (hash-table-ref/default ht arg #f)
+ (hash-table-ref/default ht arg (car default))))
+
+(define (usage . args)
+ (if (> (length args) 0)
+ (apply print "ERROR: " args))
+ (if (string? help)
+ (print help)
+ (print "Usage: " (car (argv)) " ... "))
+ (exit 0))
+
+(define (get-args args params switches arg-hash num-needed)
+ (let* ((numtargs (length args))
+ (adj-num-needed (if num-needed (+ num-needed 2) #f)))
+ (if (< numtargs (if adj-num-needed adj-num-needed 2))
+ (if (>= num-needed 1)
+ (usage "No arguments provided")
+ '())
+ (let loop ((arg (cadr args))
+ (tail (cddr args))
+ (remtargs '()))
+ (cond
+ ((member arg params) ;; args with params
+ (if (< (length tail) 1)
+ (usage "param given without argument " arg)
+ (let ((val (car tail))
+ (newtail (cdr tail)))
+ (hash-table-set! arg-hash arg val)
+ (if (null? newtail) remtargs
+ (loop (car newtail)(cdr newtail) remtargs)))))
+ ((member arg switches) ;; args with no params (i.e. switches)
+ (hash-table-set! arg-hash arg #t)
+ (if (null? tail) remtargs
+ (loop (car tail)(cdr tail) remtargs)))
+ (else
+ (if (null? tail)(append remtargs (list arg)) ;; return the non-used args
+ (loop (car tail)(cdr tail)(append remtargs (list arg))))))))
+ ))
+
+(define (print-args remtargs arg-hash)
+ (print "ARGS: " remtargs)
+ (for-each (lambda (arg)
+ (print " " arg " " (hash-table-ref/default arg-hash arg #f)))
+ (hash-table-keys arg-hash)))
+
+
+)
ADDED mtargs/mtargs.setup
Index: mtargs/mtargs.setup
==================================================================
--- /dev/null
+++ mtargs/mtargs.setup
@@ -0,0 +1,18 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;;;; mtargs.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate mtargs.so)
+(compile -s mtargs.scm)
+
+;; Install as extension library
+(standard-extension 'mtargs "mtargs.so")
+
ADDED mtconfigf.scm
Index: mtconfigf.scm
==================================================================
--- /dev/null
+++ mtconfigf.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit mtconfigf))
+
+(include "mtconfigf/mtconfigf.scm")
ADDED mtconfigf/Makefile
Index: mtconfigf/Makefile
==================================================================
--- /dev/null
+++ mtconfigf/Makefile
@@ -0,0 +1,2 @@
+test:
+ env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm
ADDED mtconfigf/mtconfigf.meta
Index: mtconfigf/mtconfigf.meta
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "LGPL")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category misc)
+
+; A list of eggs mpeg3 depends on. If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs srfi-1 srfi-69 regex regex-case directory-utils extras srfi-13 posix typed-records)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Megatest config file (ini-space format) with many enhancements."))
ADDED mtconfigf/mtconfigf.scm
Index: mtconfigf/mtconfigf.scm
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.scm
@@ -0,0 +1,1170 @@
+;;======================================================================
+;; Copyright 2006-2018, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+;; NOTE: This is the configf module, long term it will replace configf.scm.
+
+(module mtconfigf
+ (
+ set-debug-printers
+ lazy-convert
+ assoc-safe-add
+ section-var-set!
+ safe-file-exists?
+ read-link-f
+ nice-path
+ eval-string-in-environment
+ safe-setenv
+ with-env-vars
+ cmd-run->list
+ port->list
+ configf:system
+ process-line
+ shell
+ configf:read-line
+ cfgdat->env-alist
+ calc-allow-system
+ apply-wildcards
+ val->alist
+ section->val-alist
+ read-config
+ find-config
+ find-and-read-config
+ lookup
+ var-is?
+ lookup-number
+ section-vars
+ get-section
+ set-section-var
+ compress-multi-lines
+ expand-multi-lines
+ file->list
+ write-config
+ write-merge-config
+ read-refdb
+ map-all-hier-alist
+ config->alist
+ alist->config
+ read-alist
+ write-alist
+ config->ini
+ ;;set-verbosity
+ add-eval-string
+ get-eval-string
+ squelch-debug-prints
+ ;; misc
+ realpath
+ find-chicken-lib
+ )
+
+(import scheme chicken data-structures extras ports files)
+(use posix typed-records srfi-18 pathname-expand posix-extras)
+(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )
+(use srfi-69)
+(import posix)
+
+;; stub debug printers overridden by set-debug-printers
+(define (debug:print n e . args)
+ (apply print args))
+(define (debug:print-info n e . args)
+ (apply print "INFO: " args))
+(define (debug:print-error n e . args)
+ (apply print "ERROR: " args))
+
+;;(import (prefix mtdebug debug:))
+;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module
+
+
+;; FROM common.scm
+;;
+;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
+(let-values (( (chicken-release-number chicken-major-version)
+ (apply values
+ (map string->number
+ (take
+ (string-split (chicken-version) ".")
+ 2)))))
+ (if (or (> chicken-release-number 4)
+ (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
+ (define ##sys#expand-home-path pathname-expand)))
+
+
+ ;;(define (set-verbosity v)(debug:set-verbosity v))
+
+ (define *default-log-port* (current-error-port))
+
+ (define (debug:print-error n . args) ;;; n available to end-users but ignored for
+ ;; default provided function
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: "args))))
+
+(define (set-debug-printers normal-fn info-fn error-fn default-port)
+ (if error-fn (set! debug:print-error error-fn))
+ (if info-fn (set! debug:print-info info-fn))
+ (if normal-fn (set! debug:print normal-fn))
+ (if default-port (set! *default-log-port* default-port)))
+
+(define (squelch-debug-prints)
+ (let ((noop (lambda x #f)))
+ (set! debug:print noop)
+ (set! debug:print-info noop)))
+
+
+;; if it looks like a number -> convert it to a number, else return it
+;;
+(define (lazy-convert inval)
+ (let* ((as-num (if (string? inval)(string->number inval) #f)))
+ (or as-num inval)))
+
+
+(define *eval-string* "")
+(define (add-eval-string str)
+ (if (not (string-contains *eval-string* str))
+ (set! *eval-string* (conc *eval-string* " " str))))
+(define (get-eval-string) *eval-string*)
+
+;; Moved to common
+;;
+;; return list (path fullpath configname)
+(define (find-config configname #!key (toppath #f))
+ (if toppath
+ (let ((cfname (conc toppath "/" configname)))
+ (if (safe-file-exists? cfname)
+ (list toppath cfname configname)
+ (list #f #f #f)))
+ (let* ((cwd (string-split (current-directory) "/")))
+ (let loop ((dir cwd))
+ (let* ((path (conc "/" (string-intersperse dir "/")))
+ (fullpath (conc path "/" configname)))
+ (if (safe-file-exists? fullpath)
+ (list path fullpath configname)
+ (let ((remcwd (take dir (- (length dir) 1))))
+ (if (null? remcwd)
+ (list #f #f #f) ;; #f #f)
+ (loop remcwd)))))))))
+
+(define (assoc-safe-add alist key val #!key (metadata #f))
+ (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+ (append newalist (list (if metadata
+ (list key val metadata)
+ (list key val))))))
+
+(define (section-var-set! cfgdat section-name var value #!key (metadata #f))
+ (hash-table-set! cfgdat section-name
+ (assoc-safe-add
+ (hash-table-ref/default cfgdat section-name '())
+ var value metadata: metadata)))
+;;======================================================================
+;; Environment handling stuff
+;;======================================================================
+
+(define (safe-file-exists? path)
+ (handle-exceptions exn #f (file-exists? path)))
+
+(define (read-link-f path)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.")
+ path) ;; just give up
+ (with-input-from-pipe
+ (conc "/bin/readlink -f " path)
+ (lambda ()
+ (read-line)))))
+
+;; return a nice clean pathname made absolute
+(define (nice-path dir)
+ (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+ (if match ;; using ~ for home?
+ (nice-path (conc #;(read-link-f (cadr match))
+ (realpath (cadr match))
+ "/" (caddr match)))
+ (normalize-pathname (if (absolute-pathname? dir)
+ dir
+ (conc (current-directory) "/" dir))))))
+
+(define (eval-string-in-environment str)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
+ #f)
+ (let ((cmdres (cmd-run->list (conc "echo " str))))
+ (if (null? cmdres) ""
+ (caar cmdres)))))
+
+(define (safe-setenv key val)
+ (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
+ (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
+ (if (and (string? val)
+ (string? key))
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
+ (setenv key val))
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
+
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
+;; execute thunk in context of environment modified as per this list
+;; restore env to prior state then return value of eval'd thunk.
+;; ** this is not thread safe **
+(define (with-env-vars delta-env-alist-or-hash-table thunk)
+ (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+ (hash-table->alist delta-env-alist-or-hash-table)
+ delta-env-alist-or-hash-table))
+ (restore-thunks
+ (filter
+ identity
+ (map (lambda (env-pair)
+ (let* ((env-var (car env-pair))
+ (new-val (let ((tmp (cdr env-pair)))
+ (if (list? tmp) (car tmp) tmp)))
+ (current-val (get-environment-variable env-var))
+ (restore-thunk
+ (cond
+ ((not current-val) (lambda () (unsetenv env-var)))
+ ((not (string? new-val)) #f)
+ ((eq? current-val new-val) #f)
+ (else
+ (lambda () (setenv env-var current-val))))))
+ ;;(when (not (string? new-val))
+ ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+ ;; (pp delta-env-alist)
+ ;; (exit 1))
+
+
+ (cond
+ ((not new-val) ;; modify env here
+ (unsetenv env-var))
+ ((string? new-val)
+ (setenv env-var new-val)))
+ restore-thunk))
+ delta-env-alist))))
+ (let ((rv (thunk)))
+ (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+ rv)))
+
+(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+ (with-env-vars
+ delta-env-alist-or-hash-table
+ (lambda ()
+ (let* ((fh (open-input-pipe cmd))
+ (res (port->list fh))
+ (status (close-input-pipe fh)))
+ (list res status)))))
+
+(define (port->list fh)
+ (if (eof-object? fh) #f
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ result))))
+
+;;======================================================================
+;; Make the regexp's needed globally available
+;;======================================================================
+
+(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
+(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
+(define configf:blank-l-rx (regexp "^\\s*$"))
+(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
+(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
+(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
+(define configf:comment-rx (regexp "^\\s*#.*"))
+(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
+(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
+(define configf:initstr-rx (regexp "^\\[configf:initstr\\s+(.*)\\]\\s*$"))
+
+;; read a line and process any #{ ... } constructs
+
+(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
+
+(define (configf:system ht cmd)
+ (system cmd)
+ )
+
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;;
+(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
+ (let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+ (if targ
+ (or (lookup config targ var)
+ (lookup config "default" var))
+ (lookup config "default" var))))
+
+(define (realpath x)
+ (let ((currdir (current-directory)))
+ (handle-exceptions
+ exn
+ (begin
+ (change-directory currdir)
+ x) ;; anything goes wrong - return given path
+ (change-directory x)
+ (let ((result (current-directory)))
+ (change-directory currdir)
+ result))))
+
+;; (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+
+(define (common:get-this-exe-fullpath #!key (argv (argv)))
+ (let* ((this-script
+ (cond
+ ((and (> (length argv) 2)
+ (string-match "^(.*/csi|csi)$" (car argv))
+ (string-match "^-(s|ss|sx|script)$" (cadr argv)))
+ (caddr argv))
+ (else (car argv))))
+ (fullpath (realpath this-script)))
+ fullpath))
+
+;; (use trace)
+;; (trace-call-sites #t)
+;; (trace realpath common:get-this-exe-fullpath)
+
+(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
+(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
+(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
+
+(define (find-chicken-lib)
+ (let* ((ckhome (chicken-home))
+ (libpath-number (car (reverse (string-split (repository-path) "/"))))
+ (libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/" libpath-number)))
+ (if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
+ (directory-exists? libpath))
+ (conc "(repository-path \""libpath"\") ")
+ "")))
+
+(define (process-line l ht allow-system #!key (linenum #f)(extend-eval ""))
+ (let loop ((res l))
+ (if (string? res)
+ (let ((matchdat (string-search configf:var-expand-regex res)))
+ (if matchdat
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-milliseconds))
+ (cmdsym (string->symbol cmdtype))
+ (presnip (conc "(import posix)(import directory-utils)"
+ "(set! getenv get-environment-variable)"
+ ))
+ (allsnip (conc "(import posix)(import directory-utils)"
+ "(set! getenv get-environment-variable)"
+ (find-chicken-lib)
+ "(import (prefix mtconfigf configf:))"
+ "(import mtconfigf)"
+ *eval-string*))
+ (fullcmd (case cmdsym
+ ((scheme scm) (conc "(lambda (ht)" allsnip "" cmd "))"))
+ ((system) (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
+ ((shell sh) (conc "(lambda (ht)" allsnip "(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
+ ((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
+ ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
+ ((mtrah) (conc "(lambda (ht)"
+ allsnip
+ " (let ((extra \"" cmd "\"))"
+ " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+ " (if (string-null? extra) \"\" \"/\")"
+ " extra)))"))
+ ((get g)
+ (let* ((parts (string-split cmd))
+ (sect (car parts))
+ (var (cadr parts)))
+ (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
+ ;;((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))
+ ((runconfigs-get rget)
+ (runconfigs-get ht cmd))
+ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
+
+ (handle-exceptions
+ exn
+ (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
+ (message ((condition-property-accessor 'exn 'message) exn))
+ (allstr (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
+ (debug:print 0 *default-log-port* " message: " message
+ (if arguments
+ (conc "; " (string-intersperse (map conc arguments) ", "))
+ ""))
+ (debug:print 0 *default-log-port* "INFO: allstr is\n" allstr)
+ ;; (debug:print 0 *default-log-port* "exn=" (condition->list exn))
+ (set! result allstr))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (if (member cmdsym '(runconfigs-get rget))
+ (begin
+ (set! result fullcmd)
+ fullcmd)
+ (with-input-from-string fullcmd
+ (lambda ()
+ (set! result ((eval (read)
+ ;;(module-environment 'mtconfigf)
+ ) ht)))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (case cmdsym
+ ((system shell scheme scm sh)
+ (let ((delta (- (current-milliseconds) start-time)))
+ (if (> delta 2000)
+ (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " (/ delta 1000) " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " (/ delta 1000) " seconds to run with output:\n " result)))))
+ (loop (conc prestr result poststr)))
+ res))
+ res)))
+
+;; Run a shell command and return the output as a string
+(define (shell cmd)
+ (let* ((output (cmd-run->list cmd))
+ (res (car output))
+ (status (cadr output)))
+ (if (equal? status 0)
+ (let ((outres (string-intersperse
+ res
+ "\n")))
+ (debug:print-info 4 *default-log-port* "shell result:\n" outres)
+ outres)
+ (begin
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print "ERROR: " cmd " returned bad exit code " status)))
+ ""))))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings #!key ....)
+ (let loop ((inl (read-line p)))
+ (let ((cont-line (and (string? inl)
+ (not (string-null? inl))
+ (equal? "\\" (string-take-right inl 1)))))
+ (if cont-line ;; last character is \
+ (let ((nextl (read-line p)))
+ (if (not (eof-object? nextl))
+ (loop (string-append (if cont-line
+ (string-take inl (- (string-length inl) 1))
+ inl)
+ nextl))))
+ (let ((res (case allow-processing ;; if (and allow-processing
+ ;; (not (eq? allow-processing 'return-string)))
+ ((#t #f)
+ (process-line inl ht allow-processing))
+ ((return-string)
+ inl)
+ (else
+ (process-line inl ht allow-processing)))))
+ (if (string? res)
+ (let* ((r1 (if (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))
+ (string-substitute "\\s+$" "" res)
+ res))
+ (r2 (if (not (equal? (hash-table-ref/default settings "line-end-comments" "no") "no"))
+ (string-substitute "\\s*#+[^\\{]*.*$" "" r1)
+ r1)))
+ r2)
+ res))))))
+
+(define (cfgdat->env-alist section cfgdat-ht allow-system)
+ (filter
+ (lambda (pair)
+ (let* ((var (car pair))
+ (val (cdr pair)))
+ (cons var
+ (cond
+ ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
+ (val))
+ ((procedure? val) #f)
+ ((string? val) val)
+ (else "#f")))))
+ (append
+ (hash-table-ref/default cfgdat-ht "default" '())
+ (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
+
+(define (calc-allow-system allow-system section sections)
+ (if sections
+ (and (or (equal? "default" section)
+ (member section sections))
+ allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
+ allow-system))
+
+;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
+;; remove the section when done so that there is no downstream clobbering
+;;
+(define (apply-wildcards ht section-name)
+ (if (hash-table-exists? ht section-name)
+ (let* ((vars (hash-table-ref ht section-name))
+ (rxstr (if (string-contains section-name "%")
+ (string-substitute (regexp "%") ".*" section-name)
+ (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
+ (rx (regexp rxstr)))
+ ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
+ (for-each
+ (lambda (section)
+ (if section
+ (let ((same-section (string=? section-name section))
+ (rx-match (string-match rx section)))
+ ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
+ (if (and (not same-section) rx-match)
+ (for-each
+ (lambda (bundle)
+ ;; (print "bundle: " bundle)
+ (let ((key (car bundle))
+ (val (cadr bundle))
+ (meta (if (> (length bundle) 2)(caddr bundle) #f)))
+ (hash-table-set! ht section (assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
+ vars)))))
+ (hash-table-keys ht))))
+ ht)
+
+;;======================================================================
+;; Extended config lines, allows storing more hierarchial data in the config lines
+;; ABC a=1; b=hello world; c=a
+;;
+;; NOTE: implementation is quite limited. You currently cannot have
+;; semicolons in your string values.
+;;======================================================================
+
+;; convert string a=1; b=2; c=a silly thing; d=
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (val->alist val #!key (convert #f))
+ (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+ (if val-list
+ (map (lambda (x)
+ (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+ (case (length f)
+ ((0) `(,#f)) ;; null string case
+ ((1) `(,(string->symbol (car f))))
+ ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+ (if convert (lazy-convert inval) inval))))
+ (else f))))
+ val-list)
+ '())))
+
+;; I don't want configf to turn into a weak yaml format but this extention is really useful
+;;
+(define (section->val-alist cfgdat section-name #!key (convert #f))
+ (let ((section (get-section cfgdat section-name)))
+ (map (lambda (item)
+ (let ((key (car item))
+ (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this.
+ (cons key (val->alist val convert: convert))))
+ section)))
+
+;; read a config file, returns hash table of alists
+
+;; read a config file, returns hash table of alists
+;; adds to ht if given (must be #f otherwise)
+;; allow-system:
+;; #f - do not evaluate [system
+;; #t - immediately evaluate [system and store result as string
+;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
+;; envion-patt is a regex spec that identifies sections that will be eval'd
+;; in the environment on the fly
+;; sections: #f => get all, else list of sections to gather
+;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
+;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
+;;
+;; NOTE: apply-wild variable is intentional (but a better name would be good)
+;;
+(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
+ (sections #f) (settings (make-hash-table)) (keep-filenames #f)
+ (post-section-procs '()) (apply-wild #t) )
+ (debug:print 9 *default-log-port* "BB> read-config > keep-filenames: " keep-filenames)
+ (debug:print 9 *default-log-port* "START: " path)
+;; (if *configdat*
+;; (common:save-pkt `((action . read-config)
+;; (f . ,(cond ((string? path) path)
+;; ((port? path) "port")
+;; (else (conc path))))
+;; (T . configf))
+;; *configdat* #t add-only: #t))
+ (if (and (not (port? path))
+ (not (safe-file-exists? path))) ;; for case where we are handed a port
+ (begin
+ (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
+ ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
+ #f) ;; (if (not ht)(make-hash-table) ht))
+ (let* ((have-file (string? path))
+ (inp (if have-file
+ (open-input-file path)
+ path)) ;; we can be handed a port
+ (res (if (not ht)(make-hash-table) ht))
+ (metapath (if keep-filenames
+ path #f))
+ (process-wildcards (lambda (res curr-section-name)
+ (if (and apply-wild
+ (or (string-contains curr-section-name "%") ;; wildcard
+ (string-match "/.*/" curr-section-name))) ;; regex
+ (begin
+ (apply-wildcards res curr-section-name)
+ (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
+ (curr-section-name (if curr-section curr-section "default"))
+ (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
+ (lead #f))
+ (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (if (eof-object? inl)
+ (begin
+ ;; process last section for wildcards
+ (process-wildcards res curr-section-name)
+ (if have-file ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
+ (if (list? sections) ;; delete all sections except given when sections is provided
+ (for-each
+ (lambda (section)
+ (if (not (member section sections))
+ (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
+ (hash-table-keys res)))
+ (debug:print 9 *default-log-port* "END: " path)
+ res
+ ) ;; retval
+ (regex-case
+ inl
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+ (configf:settings ( x setting val )
+ (begin
+ (hash-table-set! settings setting val)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:initstr-rx ( x initstr )
+ (begin
+ (add-eval-string initstr)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:include-rx ( x include-file )
+ (let* ((curr-conf-dir (pathname-directory path))
+ (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
+ include-file
+ (nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file))))
+ (all-matches (sort (handle-exceptions exn (list) (glob full-conf)) string<=?)))
+ (if (null? all-matches)
+ (begin
+ (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf))
+ (for-each
+ (lambda (fpath)
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config fpath res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames))
+ all-matches))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+ (configf:script-rx ( x include-script params);; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
+ ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (if (and (safe-file-exists? include-script)(file-execute-access? include-script))
+ (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (cfgdat->env-alist curr-section-name res local-allow-system))
+ (new-inp-port
+ (with-env-vars
+ env-delta
+ (lambda ()
+ (open-input-pipe (conc include-script " " params))))))
+ (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+ ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
+ (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+ (close-input-port new-inp-port)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ ) ;; )
+ (configf:section-rx ( x section-name )
+ (begin
+ ;; call post-section-procs
+ (for-each
+ (lambda (dat)
+ (let ((patt (car dat))
+ (proc (cdr dat)))
+ (if (string-match patt curr-section-name)
+ (proc curr-section-name section-name res path))))
+ post-section-procs)
+ ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+ ;; NOTE: we are processing the curr-section-name, NOT section-name.
+ (process-wildcards res curr-section-name)
+ (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ ;; if we have the sections list then force all settings into "" and delete it later?
+ ;; (if (or (not sections)
+ ;; (member section-name sections))
+ ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+ section-name
+ #f #f)))
+ (configf:key-sys-pr ( x key cmd )
+ (if (calc-allow-system allow-system curr-section-name sections)
+ (let ((alist (hash-table-ref/default res curr-section-name '()))
+ (val-proc (lambda ()
+ (let* ((start-time (current-seconds))
+ (local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (cfgdat->env-alist curr-section-name res local-allow-system))
+ (cmdres (cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
+ (delta (- (current-seconds) start-time))
+ (status (cadr cmdres))
+ (res (car cmdres)))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+ (if (not (eq? status 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+ " output: " cmdres)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (if (null? res)
+ ""
+ (string-intersperse res " "))))))
+ (hash-table-set! res curr-section-name
+ (assoc-safe-add alist
+ key
+ (case (calc-allow-system allow-system curr-section-name sections)
+ ((return-procs) val-proc)
+ ((return-string) cmd)
+ (else (val-proc)))
+ metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name #f #f)))
+
+ (configf:key-no-val ( x key val)
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name key #f)))
+
+ (configf:key-val-pr ( x key unk1 val unk2 )
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (envar (and environ-patt
+ (string-search (regexp environ-patt) curr-section-name)
+ (and (not (string-null? key))
+ (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+ ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+ ))
+ (realval (if envar
+ (eval-string-in-environment val)
+ val)))
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (if envar (safe-setenv key realval))
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
+ (hash-table-set! res curr-section-name
+ (assoc-safe-add alist key realval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name key #f)))
+ ;; if a continued line
+ (configf:cont-ln-rx ( x whsp val )
+ (let ((alist (hash-table-ref/default res curr-section-name '())))
+ (if var-flag ;; if set to a string then we have a continued var
+ (let ((newval (conc
+ (lookup res curr-section-name var-flag) "\n"
+ ;; trim lead from the incoming whsp to support some indenting.
+ (if lead
+ (string-substitute (regexp lead) "" whsp)
+ "")
+ val)))
+ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
+ (hash-table-set! res curr-section-name
+ (assoc-safe-add alist var-flag newval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
+ (set! var-flag #f)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ ) ;; end loop
+ )))
+
+;; look at common:set-fields for an example of how to use the set-fields proc
+;; pathenvvar will set the named var to the path of the config
+;;
+(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
+ (let* ((curr-dir (current-directory))
+ (configinfo (find-config fname toppath: given-toppath))
+ (toppath (car configinfo))
+ (configfile (cadr configinfo)))
+ (if toppath (change-directory toppath))
+ (if (and toppath pathenvvar)(setenv pathenvvar toppath))
+ (let ((configdat (if configfile
+ (read-config configfile #f #t environ-patt: environ-patt
+ post-section-procs: (if set-fields (list (cons "^fields$" set-fields) ) '())
+ #f
+ keep-filenames: keep-filenames))))
+ (if toppath (change-directory curr-dir))
+ (list configdat toppath configfile fname))))
+
+(define (lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+;; use to have definitive setting:
+;; [foo]
+;; var yes
+;;
+;; (var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (var-is? cfgdat section var expected-val)
+ (equal? (lookup cfgdat section var) expected-val))
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (lookup-number cfgdat section varname #!key (default #f))
+ (let* ((val (lookup cfgdat section varname))
+ (res (if val
+ (string->number (string-substitute "\\s+" "" val #t))
+ #f)))
+ (cond
+ (res res)
+ (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+ (else default))))
+
+(define (section-vars cfgdat section)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ '()
+ (map car sectdat))))
+
+(define (get-section cfgdat section)
+ (hash-table-ref/default cfgdat section '()))
+
+(define (set-section-var cfgdat section var val)
+ (let ((sectdat (get-section cfgdat section)))
+ (hash-table-set! cfgdat section
+ (assoc-safe-add sectdat var val))))
+
+ ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+ ;; (list var val))))
+
+;; moved to common
+;; (define (setup)
+;; (let* ((configf (find-config "megatest.config"))
+;; (config (if configf (read-config configf #f #t) #f)))
+;; (if config
+;; (setenv "RUN_AREA_HOME" (pathname-directory configf)))
+;; config))
+
+;;======================================================================
+;; Non destructive writing of config file
+;;======================================================================
+
+(define (compress-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (cur "")
+ (led #f)
+ (res '()))
+ ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
+ ;; 1. remove led whitespace
+ ;; 2. tack on to hed with "\n"
+ (let ((match (string-match configf:cont-ln-rx hed)))
+ (if match ;; blast! have to deal with a multiline
+ (let* ((lead (cadr match))
+ (lval (caddr match))
+ (newl (conc cur "\n" lval)))
+ (if (not led)(set! led lead))
+ (if (null? tal)
+ (set! fdat (append fdat (list newl)))
+ (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
+ (let ((newres (if led
+ (append res (list cur hed))
+ (append res (list hed)))))
+ ;; prev was a multiline
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) "" #f newres))))))))
+
+;; note: I'm cheating a little here. I merely replace "\n" with "\n "
+(define (expand-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (res '()))
+ (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+(define (file->list fname)
+ (if (safe-file-exists? fname)
+ (let ((inp (open-input-file fname)))
+ (let loop ((inl (read-line inp))
+ (res '()))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (reverse res))
+ (loop (read-line inp)(cons inl res)))))
+ '()))
+
+;; raw basic write config in ini format
+;;
+(define (write-config cfgdat fname)
+ (with-output-to-file fname
+ (lambda ()
+ (config->ini cfgdat))))
+
+;; (for-each
+;; (lambda (section)
+;; (let ((sec-dat (hash-table-ref cfgdat section)))
+;; (for-each (lambda (entry)(print (car entry) " " (cadr entry))) sec-dat)))
+;; (sort (hash-table-keys cfgdat) (lambda (a b)(string<= a b)))))))
+
+;;======================================================================
+;; Write a config
+;; 0. Given a refererence data structure "indat"
+;; 1. Open the output file and read it into a list
+;; 2. Flatten any multiline entries
+;; 3. Modify values per contents of "indat" and remove absent values
+;; 4. Append new values to the section (immediately after last legit entry)
+;; 5. Write out the new list
+;;======================================================================
+
+(define (write-merge-config indat fname #!key (required-sections '()))
+ (let* (;; step 1: Open the output file and read it into a list
+ (fdat (file->list fname))
+ (refdat (make-hash-table))
+ (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
+ (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
+ (secname #f))
+
+ ;; step 2: Flatten multiline entries
+ (if (not (null? fdat))(set! fdat (compress-multi-lines fdat)))
+
+ ;; step 3: Modify values per contents of "indat" and remove absent values
+ (if (not (null? fdat))
+ (let loop ((hed (car fdat))
+ (tal (cadr fdat))
+ (res '())
+ (lnum 0))
+ (regex-case
+ hed
+ (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
+ (if (not section-hash)
+ (let ((newhash (make-hash-table)))
+ (hash-table-set! refdat section-name newhash)
+ (set! sechash newhash))
+ (set! sechash section-hash))
+ (set! new hed) ;; will append this at the bottom of the loop
+ (set! secname section-name)
+ ))
+ ;; No need to process key cmd, let it fall though to key val
+ (configf:key-val-pr ( x key val )
+ (let ((newval (lookup indat secname key))) ;; secname was sec. I think that was a bug
+ ;; can handle newval == #f here => that means key is removed
+ (cond
+ ((equal? newval val)
+ (set! res (append res (list hed))))
+ ((not newval) ;; key has been removed
+ (set! new #f))
+ ((not (equal? newval val))
+ (hash-table-set! sechash key newval)
+ (set! new (conc key " " newval)))
+ (else
+ (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
+ (else
+ (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
+ ;; drop to here when done processing, res contains modified list of lines
+ (set! fdat res)))
+
+ ;; step 4: Append new values to the section
+ (for-each
+ (lambda (section)
+ (let ((sdat '()) ;; append needed bits here
+ (svars (section-vars indat section)))
+ (for-each
+ (lambda (var)
+ (let ((val (lookup refdat section var)))
+ (if (not val) ;; this one is new
+ (begin
+ (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
+ (set! sdat (append sdat (list (conc var " " val))))))))
+ svars)
+ (set! fdat (append fdat sdat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
+
+ ;; step 5: Write out new file
+ (with-output-to-file fname
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (print line))
+ (expand-multi-lines fdat))))))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;; returns (list dat msg)
+(define (read-refdb refdb-path)
+ (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
+ (if (not (safe-file-exists? sheets-file))
+ (list #f (conc "ERROR: no refdb found at " refdb-path))
+ (if (not (file-read-access? sheets-file))
+ (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+ (let* ((sheets (with-input-from-file sheets-file
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (loop (read-line)(cons inl res)))))))
+ (data '()))
+ (for-each
+ (lambda (sheet-name)
+ (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
+ (ref-dat (read-config dat-path #f #t))
+ (ref-assoc (map (lambda (key)
+ (list key (hash-table-ref ref-dat key)))
+ (hash-table-keys ref-dat))))
+ ;; (hash-table->alist ref-dat)))
+ ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+ (set! data (cons (list sheet-name ref-assoc) data))))
+ sheets)
+ (list data "NO ERRORS"))))))
+
+;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
+;;
+(define (map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
+ (for-each
+ (lambda (sheetname)
+ (let* ((sheettmp (assoc sheetname data))
+ (sheetdat (if sheettmp (cadr sheettmp) '())))
+ (if initproc1 (initproc1 sheetname))
+ (for-each
+ (lambda (sectionname)
+ (let* ((sectiontmp (assoc sectionname sheetdat))
+ (sectiondat (if sectiontmp (cadr sectiontmp) '())))
+ (if initproc2 (initproc2 sheetname sectionname))
+ (for-each
+ (lambda (varname)
+ (let* ((valtmp (assoc varname sectiondat))
+ (val (if valtmp (cadr valtmp) "")))
+ (proc sheetname sectionname varname val)))
+ (map car sectiondat))))
+ (map car sheetdat))))
+ (map car data))
+ data)
+
+;;======================================================================
+;; C O N F I G T O / F R O M A L I S T
+;;======================================================================
+
+(define (config->alist cfgdat)
+ (hash-table->alist cfgdat))
+
+(define (alist->config adat)
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (section)
+ (hash-table-set! ht (car section)(cdr section)))
+ adat)
+ ht))
+
+;; if
+(define (read-alist fname)
+ (handle-exceptions
+ exn
+ #f
+ (alist->config
+ (with-input-from-file fname read))))
+
+(define (write-alist cdat fname #!key (locker #f)(unlocker #f))
+ (if (and locker (not (locker fname)))
+ (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
+ (let* ((dat (config->alist cdat))
+ (res
+ (begin
+ (with-output-to-file fname ;; first write out the file
+ (lambda ()
+ (pp dat)))
+
+ (if (file-exists? fname) ;; now verify it is readable
+ (if (read-alist fname)
+ #t ;; data is good.
+ (begin
+ (handle-exceptions
+ exn
+ #f
+ (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
+ (delete-file fname))
+ #f))
+ #f))))
+ (if unlocker (unlocker fname))
+ res))
+
+;; convert config hash-table/list data to ini format
+;;
+(define (config->ini data)
+ (map
+ (lambda (section)
+ (let ((section-name (car section))
+ (section-dat (cdr section)))
+ (print "\n[" section-name "]")
+ (map (lambda (dat-pair)
+ (let* ((var (car dat-pair))
+ (val (cadr dat-pair))
+ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
+ (if fname (print "# " var "=>" fname))
+ (print var " " val)))
+ section-dat))) ;; (print "section-dat: " section-dat))
+ (hash-table->alist data)))
+
+;(use trace)
+;(trace-call-sites #t)
+;(trace read-config)
+
+)
ADDED mtconfigf/mtconfigf.setup
Index: mtconfigf/mtconfigf.setup
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.setup
@@ -0,0 +1,16 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;;;; mtconfig.setup
+
+;; compile the code into dynamically loadable shared objects
+;; and install as modules
+
+(compile -s mtconfigf.scm)
+(standard-extension 'mtconfigf "mtconfigf.so")
ADDED mtconfigf/tests/run.scm
Index: mtconfigf/tests/run.scm
==================================================================
--- /dev/null
+++ mtconfigf/tests/run.scm
@@ -0,0 +1,48 @@
+(load "../mtdebug/mtdebug.scm")
+(import mtdebug)
+(load "mtconfigf.scm")
+(import (prefix mtconfigf config:))
+
+(use mtdebug)
+;; configure mtconfigf
+(let* ((normal-fn debug:print)
+ (info-fn debug:print-info)
+ (error-fn debug:print-error)
+ (default-port (current-output-port)))
+ (config:set-debug-printers normal-fn info-fn error-fn default-port))
+
+
+(use test)
+
+(let* ((cfgdat
+ (config:read-config "tests/test.config" #f #f)))
+
+
+ (test #f "value" (config:lookup cfgdat "basic" "key"))
+ (test #f 2 (config:lookup-number cfgdat "basic" "two"))
+
+ )
+
+(config:add-eval-string "(define (customfunc) \"hello\")")
+(let* ((cfgdat
+ (config:read-config "tests/test2.config" #f #f)))
+ (test #f "bar" (config:lookup cfgdat "schemy" "rgetreftarget"))
+ (test #f "baz" (config:lookup cfgdat "schemy" "rgetrefdefault"))
+ (test #f "2" (config:lookup cfgdat "schemy" "addup"))
+ (test #f 2 (config:lookup-number cfgdat "schemy" "addup"))
+ (test #f "hello" (config:lookup cfgdat "schemy" "custom"))
+ )
+
+(test #f
+ (conc "hello " (get-environment-variable "USER"))
+ (config:eval-string-in-environment "hello $USER"))
+
+(let* ((cfgdat
+ (config:read-config "tests/test3.config" #f #t)))
+ (test #f "hello" (config:lookup cfgdat "systemic" "hello"))
+ (test #f
+ (conc "hello " (get-environment-variable "USER"))
+ (config:lookup cfgdat "systemic" "hellouser"))
+
+ )
+
ADDED mtconfigf/tests/test.config
Index: mtconfigf/tests/test.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test.config
@@ -0,0 +1,3 @@
+[basic]
+key value
+two 2
ADDED mtconfigf/tests/test2.config
Index: mtconfigf/tests/test2.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test2.config
@@ -0,0 +1,15 @@
+[default]
+deffoo baz
+
+[a-target]
+foo bar
+
+[.dvars]
+target a-target
+
+
+[schemy]
+addup #{scheme (+ 1 1)}
+custom #{scheme (customfunc)}
+rgetreftarget #{rget foo}
+rgetrefdefault #{rget deffoo}
ADDED mtconfigf/tests/test3.config
Index: mtconfigf/tests/test3.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test3.config
@@ -0,0 +1,3 @@
+[systemic]
+hello [system echo hello]
+hellouser [system echo hello $USER]
ADDED pkts.scm
Index: pkts.scm
==================================================================
--- /dev/null
+++ pkts.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit pkts))
+
+(include "pkts/pkts.scm")
ADDED pkts/pktrec.scm
Index: pkts/pktrec.scm
==================================================================
--- /dev/null
+++ pkts/pktrec.scm
@@ -0,0 +1,196 @@
+(define-syntax define-record-type
+ (syntax-rules ()
+ ((define-record-type type
+ (constructor constructor-tag ...)
+ predicate
+ (field-tag accessor . more) ...)
+ (begin
+ (define type
+ (make-record-type 'type '(field-tag ...)))
+ (define constructor
+ (record-constructor type '(constructor-tag ...)))
+ (define predicate
+ (record-predicate type))
+ (define-record-field type field-tag accessor . more)
+ ...))))
+
+; An auxilliary macro for define field accessors and modifiers.
+; This is needed only because modifiers are optional.
+
+(define-syntax define-record-field
+ (syntax-rules ()
+ ((define-record-field type field-tag accessor)
+ (define accessor (record-accessor type 'field-tag)))
+ ((define-record-field type field-tag accessor modifier)
+ (begin
+ (define accessor (record-accessor type 'field-tag))
+ (define modifier (record-modifier type 'field-tag))))))
+
+; Record types
+
+; We define the following procedures:
+;
+; (make-record-type ) ->
+; (record-constructor ) ->
+; (record-predicate ) ->
+; (record-accessor ) ->
+; (record-modifier ) ->
+; where
+; ( ...) ->
+; ( ) ->
+; ( ) ->
+; ( ) ->
+
+; Record types are implemented using vector-like records. The first
+; slot of each record contains the record's type, which is itself a
+; record.
+
+(define (record-type record)
+ (record-ref record 0))
+
+;----------------
+; Record types are themselves records, so we first define the type for
+; them. Except for problems with circularities, this could be defined as:
+; (define-record-type :record-type
+; (make-record-type name field-tags)
+; record-type?
+; (name record-type-name)
+; (field-tags record-type-field-tags))
+; As it is, we need to define everything by hand.
+
+(define :record-type (make-record 3))
+(record-set! :record-type 0 :record-type) ; Its type is itself.
+(record-set! :record-type 1 ':record-type)
+(record-set! :record-type 2 '(name field-tags))
+
+; Now that :record-type exists we can define a procedure for making more
+; record types.
+
+(define (make-record-type name field-tags)
+ (let ((new (make-record 3)))
+ (record-set! new 0 :record-type)
+ (record-set! new 1 name)
+ (record-set! new 2 field-tags)
+ new))
+
+; Accessors for record types.
+
+(define (record-type-name record-type)
+ (record-ref record-type 1))
+
+(define (record-type-field-tags record-type)
+ (record-ref record-type 2))
+
+;----------------
+; A utility for getting the offset of a field within a record.
+
+(define (field-index type tag)
+ (let loop ((i 1) (tags (record-type-field-tags type)))
+ (cond ((null? tags)
+ (error "record type has no such field" type tag))
+ ((eq? tag (car tags))
+ i)
+ (else
+ (loop (+ i 1) (cdr tags))))))
+
+;----------------
+; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
+; procedures used by the macro expansion of DEFINE-RECORD-TYPE.
+
+(define (record-constructor type tags)
+ (let ((size (length (record-type-field-tags type)))
+ (arg-count (length tags))
+ (indexes (map (lambda (tag)
+ (field-index type tag))
+ tags)))
+ (lambda args
+ (if (= (length args)
+ arg-count)
+ (let ((new (make-record (+ size 1))))
+ (record-set! new 0 type)
+ (for-each (lambda (arg i)
+ (record-set! new i arg))
+ args
+ indexes)
+ new)
+ (error "wrong number of arguments to constructor" type args)))))
+
+(define (record-predicate type)
+ (lambda (thing)
+ (and (record? thing)
+ (eq? (record-type thing)
+ type))))
+
+(define (record-accessor type tag)
+ (let ((index (field-index type tag)))
+ (lambda (thing)
+ (if (and (record? thing)
+ (eq? (record-type thing)
+ type))
+ (record-ref thing index)
+ (error "accessor applied to bad value" type tag thing)))))
+
+(define (record-modifier type tag)
+ (let ((index (field-index type tag)))
+ (lambda (thing value)
+ (if (and (record? thing)
+ (eq? (record-type thing)
+ type))
+ (record-set! thing index value)
+ (error "modifier applied to bad value" type tag thing)))))
+
+Records
+
+; This implements a record abstraction that is identical to vectors,
+; except that they are not vectors (VECTOR? returns false when given a
+; record and RECORD? returns false when given a vector). The following
+; procedures are provided:
+; (record? ) ->
+; (make-record ) ->
+; (record-ref ) ->
+; (record-set! ) ->
+;
+; These can implemented in R5RS Scheme as vectors with a distinguishing
+; value at index zero, providing VECTOR? is redefined to be a procedure
+; that returns false if its argument contains the distinguishing record
+; value. EVAL is also redefined to use the new value of VECTOR?.
+
+; Define the marker and redefine VECTOR? and EVAL.
+
+(define record-marker (list 'record-marker))
+
+(define real-vector? vector?)
+
+(define (vector? x)
+ (and (real-vector? x)
+ (or (= 0 (vector-length x))
+ (not (eq? (vector-ref x 0)
+ record-marker)))))
+
+; This won't work if ENV is the interaction environment and someone has
+; redefined LAMBDA there.
+
+(define eval
+ (let ((real-eval eval))
+ (lambda (exp env)
+ ((real-eval `(lambda (vector?) ,exp))
+ vector?))))
+
+; Definitions of the record procedures.
+
+(define (record? x)
+ (and (real-vector? x)
+ (< 0 (vector-length x))
+ (eq? (vector-ref x 0)
+ record-marker)))
+
+(define (make-record size)
+ (let ((new (make-vector (+ size 1))))
+ (vector-set! new 0 record-marker)
+ new))
+
+(define (record-ref record index)
+ (vector-ref record (+ index 1)))
+
+(define (record-set! record index value)
+ (vector-set! record (+ index 1) value))
ADDED pkts/pkts.meta
Index: pkts/pkts.meta
==================================================================
--- /dev/null
+++ pkts/pkts.meta
@@ -0,0 +1,21 @@
+;; -*- scheme -*-
+(
+; Your egg's license:
+(license "BSD")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category db)
+
+; A list of eggs pkts depends on. If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+;; (needs (autoload "3.0"))
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "A sha1-chain based datastore built on packets consisting of single line cards modeled loosely on the fossil scm datastore."))
ADDED pkts/pkts.release-info
Index: pkts/pkts.release-info
==================================================================
--- /dev/null
+++ pkts/pkts.release-info
@@ -0,0 +1,3 @@
+(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
+(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
+(release "1.0")
ADDED pkts/pkts.scm
Index: pkts/pkts.scm
==================================================================
--- /dev/null
+++ pkts/pkts.scm
@@ -0,0 +1,1075 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Pkts
+;;
+;; Pkts is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Pkts is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Pkts. If not, see .
+;;
+
+;; CARDS:
+;;
+;; A card is a line of text, the first two characters are a letter followed by a
+;; space. The letter is the card type.
+;;
+;; PKTS:
+;;
+;; A pkt is a sorted list of cards with a final card Z that contains the shar1 hash
+;; of all of the preceding cards.
+;;
+;; APKT:
+;;
+;; An alist mapping card types to card data
+;; '((T . "pkttype")
+;; (a . "some content"))
+;;
+;; EPKT:
+;;
+;; Extended packet using friendly keys. Must use a pktspec to convert to/from epkts
+;; '((ptype . "pkttype")
+;; (adata . "some content))
+;;
+;; DPKT:
+;;
+;; pkts pulled from the database have this format:
+;;
+;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
+;; (t . "v1.63/tip/dev")
+;; (c . "QUICKPATT")
+;; (T . "runstart")
+;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
+;; (D . "1488995096.0"))
+;; (id . 8)
+;; (group-id . 0)
+;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
+;; (parent . "")
+;; (pkt-type . "runstart")
+;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
+;;
+;; pktspec is alist of alists mapping types and nicekeys to keys
+;;
+;; '((posting . ((title . t)
+;; (url . u)
+;; (blurb . b)))
+;; (comment . ((comment . c)
+;; (score . s))))
+
+;; Reserved cards:
+;; P : pkt parent
+;; R : reference pkt containing mapping of short string -> sha1sum strings
+;; T : pkt type
+;; D : current time from (current-time), unless provided
+;; Z : shar1 hash of the packet
+
+;; Example usage:
+;;
+;; Create a pkt:
+;;
+;; (use pkts)
+;; (define-values (uuid pkt)
+;; (alist->pkt
+;; '((fruit . "apple") (meat . "beef")) ;; this is the data to convert
+;; '((foods (fruit . f) (meat . m))) ;; this is the pkt spec
+;; ptype:
+;; 'foods))
+;;
+;; Add to pkt queue:
+;;
+;; (define db (open-queue-db "/tmp/pkts" "pkts.db"))
+;; (add-to-queue db pkt uuid 'foods #f 0) ;; no parent and use group_id of 0
+;;
+;; Retrieve the packet from the db and extract a value:
+;;
+;; (alist-ref
+;; 'meat
+;; (dpkt->alist
+;; (car (get-dpkts db #f 0 #f))
+;; '((foods (fruit . f)
+;; (meat . m)))))
+;; => "beef"
+;;
+
+(module pkts
+(
+;; cards, util and misc
+;; sort-cards
+;; calc-shar1
+;;
+;; low-level constructor procs, exposed only for development/testing, will be removed
+construct-sdat
+construct-pkt
+card->type/value
+add-z-card
+
+;; queue database procs
+open-queue-db
+add-to-queue
+create-and-queue
+lookup-by-uuid
+lookup-by-id
+get-dpkts
+get-not-processed-pkts
+get-related
+find-pkts
+process-pkts
+get-descendents
+get-ancestors
+get-pkts
+get-last-descendent
+with-queue-db
+load-pkts-to-db
+
+;; procs that operate directly on pkts, sdat, apkts, dpkts etc.
+pkt->alist ;; pkt -> apkt (i.e. alist)
+pkt->sdat ;; pkt -> '("a aval" "b bval" ...)
+sdat->alist ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...)
+dblst->dpkts ;; convert list of tuples from queue db into dpkts
+dpkt->alist ;; flatten a dpkt into an alist containing all db fields and the pkt alist
+dpkts->alists ;; apply dpkt->alist to a list of alists using a pkt-spec
+alist->pkt ;; returns two values uuid, pkt
+get-value ;; looks up a value given a key in a dpkt
+flatten-all ;; merge the list of values from a query which includes a pkt into a flat alist <== really useful!
+check-pkt
+
+;; pkt alists
+write-alist->pkt
+read-pkt->alist
+
+;; archive database
+archive-open-db
+write-archive-pkts
+archive-pkts
+mark-processed
+
+;; pktsdb
+pktdb-conn ;; useful
+pktdb-fname
+pktsdb-open
+pktsdb-close
+pktsdb-add-record
+;; temporary
+pktdb-pktspec
+
+;; utility procs
+increment-string ;; used to get indexes for strings in ref pkts
+make-report ;; make a .dot file
+)
+
+(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
+(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)
+
+;;======================================================================
+;; DATA MANIPULATION UTILS
+;;======================================================================
+
+(define-inline (unescape-data data)
+ (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))
+
+(define-inline (escape-data data)
+ (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\"))))
+
+(define-inline (make-card type data)
+ (conc type " " (escape-data (->string data))))
+
+;; reverse an alist for doing pktkey -> external key conversions
+;;
+(define-inline (reverse-aspec aspec)
+ (map (lambda (dat)
+ (cons (cdr dat)(car dat)))
+ aspec))
+
+;; add a card to the list of cards, sdat
+;; if type is #f return only sdat
+;; if data is #f return only sdat
+;;
+(define-inline (add-card sdat type data)
+ (if (and type data)
+ (cons (make-card type data) sdat)
+ sdat))
+
+;;======================================================================
+;; STRING AS FUNKY NUMBER
+;;======================================================================
+
+;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a
+;; ref, instead the P parent card is used.
+;; Question: Why does it matter to remove PTDZ?
+;; To make the ref easier to use the ref strings will be the keys
+;; so we cannot have overlap with any actual keys. But this is a
+;; bit silly. What we need to do instead is reject keys of length
+;; one where the char is in PTDZ
+;;
+;; This is basically base92
+;;
+(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~"))
+;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|"))
+
+(define (char-incr inchar)
+ (let* ((carry #f)
+ (next-char (let ((rem (member inchar string-num-chars)))
+ (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list
+ (begin
+ (set! carry #t)
+ (car string-num-chars))
+ (cadr rem)))))
+ (values next-char carry)))
+
+(define (increment-string str)
+ (if (string-null? str)
+ "0"
+ (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd
+ (list->string
+ (let loop ((hed (car strlst))
+ (tal (cdr strlst))
+ (res '()))
+ (let-values (((newhed carry)(char-incr hed)))
+ ;; (print "newhed: " newhed " carry: " carry " tal: " tal)
+ (let ((newres (cons newhed res)))
+ (if carry ;; we'll have to propagate the carry
+ (if (null? tal) ;; at the end, tack on "0" (which is really a "1")
+ (cons (car string-num-chars) newres)
+ (loop (car tal)(cdr tal) newres))
+ (append (reverse tal) newres)))))))))
+
+;;======================================================================
+;; P K T S D B I N T E R F A C E
+;;
+;; INTEGER, REAL, TEXT
+;;======================================================================
+;;
+;; spec
+;; ( (tablename1 . (field1name L1 TYPE)
+;; (field2name L2 TYPE) ... )
+;; (tablename2 ... ))
+;;
+;; Example: (tests (testname n TEXT)
+;; (rundir r TEXT)
+;; ... )
+;;
+;; pkt keys are taken from the first letter, if that is not unique
+;; then look at the next letter and so on
+;;
+
+;; use this struct to hold the pktspec and the db handle
+;;
+(defstruct pktdb
+ (fname #f)
+ (pktsdb-spec #f)
+ (pktspec #f) ;; cache the pktspec
+ (field-keys #f) ;; cache the field->key mapping (field1 . k1) ...
+ (key-fields #f) ;; cache the key->field mapping
+ (conn #f)
+ )
+
+;; WARNING: There is a simplification in the pktsdb spec w.r.t. pktspec.
+;; The field specs are the cdr of the table list - not a full
+;; list. The extra list level in pktspec is gratuitous and should
+;; be removed.
+;;
+(define (pktsdb-spec->pktspec tables-spec)
+ (map (lambda (tablespec)
+ (list (car tablespec)
+ (map (lambda (field-spec)
+ (cons (car field-spec)(cadr field-spec)))
+ (cdr tablespec))))
+ tables-spec))
+
+(define (pktsdb-open dbfname pktsdb-spec)
+ (let* ((pdb (make-pktdb))
+ (dbexists (file-exists? dbfname))
+ (db (dbi:open 'sqlite3 `((dbname . ,dbfname)))))
+ (pktdb-pktsdb-spec-set! pdb pktsdb-spec)
+ (pktdb-pktspec-set! pdb (pktsdb-spec->pktspec pktsdb-spec))
+ (pktdb-fname-set! pdb dbfname)
+ (pktdb-conn-set! pdb db)
+ (if (not dbexists)
+ (pktsdb-init pdb))
+ pdb))
+
+(define (pktsdb-init pktsdb)
+ (let* ((db (pktdb-conn pktsdb))
+ (pktsdb-spec (pktdb-pktsdb-spec pktsdb)))
+ ;; create a table for the pkts themselves
+ (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, pkt TEXT);")
+ (for-each
+ (lambda (table)
+ (let* ((table-name (car table))
+ (fields (cdr table))
+ (stmt (conc "CREATE TABLE IF NOT EXISTS "
+ table-name
+ " (id INTEGER PRIMARY KEY,"
+ (string-intersperse
+ (map (lambda (fieldspec)
+ (conc (car fieldspec) " "
+ (caddr fieldspec)))
+ fields)
+ ",")
+ ");")))
+ (dbi:exec db stmt)))
+ pktsdb-spec)))
+
+;; create pkt from the data and insert into pkts table
+;;
+;; data is assoc list of (field . value) ...
+;; tablename is a symbol matching the table name
+;;
+(define (pktsdb-add-record pktsdb tablename data #!optional (parent #f))
+ (let*-values (((zkey pkt) (alist->pkt data (pktdb-pktspec pktsdb) ptype: tablename)))
+ ;; have the data as alist so insert it into appropriate table also
+ (let* ((db (pktdb-conn pktsdb)))
+ ;; TODO: Address collisions
+ (dbi:exec db "INSERT INTO pkts (zkey,pkt,record_id) VALUES (?,?,?);"
+ zkey pkt -1)
+ (let* (;; (pktid (pktsdb-pktkey->pktid pktsdb pktkey))
+ (record-id (pktsdb-insert pktsdb tablename data)))
+ (dbi:exec db "UPDATE pkts SET record_id=? WHERE zkey=?;"
+ record-id zkey)
+ ))))
+
+;;
+(define (pktsdb-insert pktsdb tablename data)
+ (let* ((db (pktdb-conn pktsdb))
+ (stmt (conc "INSERT INTO " tablename
+ " (" (string-intersperse (map conc (map car data)) ",")
+ ") VALUES ('"
+ ;; TODO: Add lookup of data type and do not
+ ;; wrap integers with quotes
+ (string-intersperse (map conc (map cdr data)) "','")
+ "');")))
+ (print "stmt: " stmt)
+ (dbi:exec db stmt)
+ ;; lookup the record-id and return it
+
+ ))
+
+
+(define (pktsdb-close pktsdb)
+ (dbi:close (pktdb-conn pktsdb)))
+
+;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1))))
+
+;;======================================================================
+;; CARDS, MISC and UTIL
+;;======================================================================
+
+;; given string (likely multi-line) "dat" return shar1 hash
+;;
+(define-inline (calc-shar1 instr)
+ (message-digest-string
+ (sha1-primitive)
+ instr))
+
+;; given a single card return its type and value
+;;
+(define (card->type/value card)
+ (let ((ctype (substring card 0 1))
+ (cval (substring card 2 (string-length card))))
+ (values (string->symbol ctype) cval)))
+
+;;======================================================================
+;; SDAT procs
+;; sdat is legacy/internal usage. Intention is to remove sdat calls from
+;; the exposed calls.
+;;======================================================================
+
+;; sort list of cards
+;;
+(define-inline (sort-cards sdat)
+ (sort sdat string<=?))
+
+;; pkt rules
+;; 1. one card per line
+;; 2. at least one card
+;; 3. no blank lines
+
+;; given sdat, a list of cards return uuid, packet (as sdat)
+;;
+(define (add-z-card sdat)
+ (let* ((sorted-sdat (sort-cards sdat))
+ (dat (string-intersperse sorted-sdat "\n"))
+ (uuid (calc-shar1 dat)))
+ (values
+ uuid
+ (conc
+ dat
+ "\nZ "
+ uuid))))
+
+(define (check-pkt pkt)
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - call it a crappy pkt
+ (let* ((sdat (string-split pkt "\n"))
+ (rdat (reverse sdat)) ;; reversed
+ (zdat (car rdat))
+ (Z (cadr (string-split zdat)))
+ (cdat (string-intersperse (reverse (cdr rdat)) "\n")))
+ (equal? Z (calc-shar1 cdat)))))
+
+;;======================================================================
+;; APKTs
+;;======================================================================
+
+;; convert a sdat (list of cards) to an alist
+;;
+(define (sdat->alist sdat)
+ (let loop ((hed (car sdat))
+ (tal (cdr sdat))
+ (res '()))
+ (let-values (( (ctype cval)(card->type/value hed) ))
+ ;; if this card is not one of the common ones tack it on to rem
+ (let* ((oldval (alist-ref ctype res))
+ (newres (cons (cons ctype
+ (if oldval ;; list or string
+ (if (list? oldval)
+ (cons cval oldval)
+ (cons cval (list oldval)))
+ cval))
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
+;; (t . "v1.63/tip/dev")
+;; (c . "QUICKPATT")
+;; (T . "runstart")
+;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
+;; (D . "1488995096.0"))
+;; (id . 8)
+;; (group-id . 0)
+;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
+;; (parent . "")
+;; (pkt-type . "runstart")
+;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
+;;
+;; pktspec is alist of alists mapping types and nicekeys to keys
+;;
+;; '((posting . ((title . t)
+;; (url . u)
+;; (blurb . b)))
+;; (comment . ((comment . c)
+;; (score . s))))
+
+;; DON'T USE?
+;;
+(define (get-value field dpkt . spec-in)
+ (if (null? spec-in)
+ (alist-ref field dpkt)
+ (let* ((spec (car spec-in))
+ (apkt (alist-ref 'apkt dpkt))) ;; get the pkt alist
+ (if (and apkt spec)
+ (let* ((ptype (alist-ref 'pkt-type dpkt))
+ (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of pkt
+ (and pspec
+ (let* ((key (alist-ref field pspec)))
+ (and key (alist-ref key apkt)))))
+ #f))))
+
+;; convert a dpkt to a pure alist given a pktspec
+;; this flattens out the alist to include the data from
+;; the queue database record
+;;
+(define (dpkt->alist dpkt pktspec)
+ (let* ((apkt (alist-ref 'apkt dpkt))
+ (pkt-type (or (alist-ref 'pkt-type dpkt) ;; pkt-type is from the database field pkt_type
+ (alist-ref 'T apkt)))
+ (pkt-fields (alist-ref (string->symbol pkt-type) pktspec))
+ (rev-fields (if pkt-fields
+ (reverse-aspec pkt-fields)
+ '())))
+ (append (map (lambda (entry)
+ (let* ((pkt-key (car entry))
+ (new-key (or (alist-ref pkt-key rev-fields) pkt-key)))
+ `(,new-key . ,(cdr entry))))
+ apkt)
+ dpkt)))
+
+;; convert a list of dpkts into a list of alists using pkt-spec
+;;
+(define (dpkts->alists dpkts pkt-spec)
+ (map (lambda (x)
+ (dpkt->alist x pkt-spec))
+ dpkts))
+
+;; Generic flattener, make the tuple and pkt into a single flat alist
+;;
+;; qry-result-spec is a list of symbols corresponding to each field
+;;
+(define (flatten-all inlst pktspec . qry-result-spec)
+ (map
+ (lambda (tuple)
+ (dpkt->alist
+ (apply dblst->dpkts tuple qry-result-spec)
+ pktspec))
+ inlst))
+
+;; call like this:
+;; (construct-sdat 'a "a data" 'S "S data" ...)
+;; returns list of cards
+;; ( "A a value" "D 12345678900" ...)
+;;
+(define (construct-sdat . alldat)
+ (let ((have-D-card #f)) ;; flag
+ (if (even? (length alldat))
+ (let loop ((type (car alldat))
+ (data (cadr alldat))
+ (tail (cddr alldat))
+ (res '()))
+ (if (eq? type 'D)(set! have-D-card #t))
+ (if (null? tail)
+ (if have-D-card ;; return the constructed pkt, add a D card if none found
+ (add-card res type data)
+ (add-card
+ (add-card res 'D (current-seconds))
+ type data))
+ (loop (car tail)
+ (cadr tail)
+ (cddr tail)
+ (add-card res type data))))
+ #f))) ;; #f means it failed to create the sdat
+
+(define (construct-pkt . alldat)
+ (add-z-card
+ (apply construct-sdat alldat)))
+
+;;======================================================================
+;; CONVERTERS
+;;======================================================================
+
+(define (pkt->sdat pkt)
+ (map unescape-data (string-split pkt "\n")))
+
+;; given a pure pkt return an alist
+;;
+(define (pkt->alist pkt #!key (pktspec #f))
+ (let ((sdat (cond
+ ((string? pkt) (pkt->sdat pkt))
+ ((list? pkt) pkt)
+ (else #f))))
+ (if pkt
+ (if pktspec
+ (dpkt->alist (list (cons 'apkt (sdat->alist sdat))) pktspec)
+ (sdat->alist sdat))
+ #f)))
+
+;; convert an alist to an sdat
+;; in: '((a . "blah")(b . "foo"))
+;; out: '("a blah" "b foo")
+;;
+(define (alist->sdat adat)
+ (map (lambda (dat)
+ (conc (car dat) " " (cdr dat)))
+ adat))
+
+;; adat is the incoming alist, aspec is the mapping
+;; from incoming key to the pkt key (usually one
+;; letter to keep data tight) see the pktspec at the
+;; top of this file
+;;
+;; NOTE: alists can contain multiple instances of the same key (supported fine by pkts)
+;; but you (obviously I suppose) cannot use alist-ref to access those entries.
+;;
+(define (alist->pkt adat aspec #!key (ptype #f))
+ (let* ((pkt-type (or ptype
+ (alist-ref 'T adat) ;; can provide in the incoming alist
+ #f))
+ (pkt-spec (if pkt-type ;; alist of external-key -> key
+ (or (alist-ref pkt-type aspec) '())
+ (if (null? aspec)
+ '()
+ (cdar aspec)))) ;; default to first one if nothing specified
+ (new-alist (map (lambda (dat)
+ (let* ((key (car dat))
+ (val (cdr dat))
+ (newkey (or (alist-ref key pkt-spec)
+ key)))
+ (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines.
+ adat))
+ (new-with-type (if (alist-ref 'T new-alist)
+ new-alist
+ (cons `(T . ,pkt-type) new-alist)))
+ (with-d-card (if (alist-ref 'D new-with-type)
+ new-with-type
+ (cons `(D . ,(current-seconds))
+ new-with-type))))
+ (add-z-card
+ (alist->sdat with-d-card))))
+
+;;======================================================================
+;; D B Q U E U E I N T E R F A C E
+;;======================================================================
+
+;; pkts (
+;; id SERIAL PRIMARY KEY,
+;; uuid TEXT NOT NULL,
+;; parent_uuid TEXT default '',
+;; pkt_type INTEGER DEFAULT 0,
+;; group_id INTEGER NOT NULL,
+;; pkt TEXT NOT NULL
+
+;; schema is list of SQL statements - can be used to extend db with more tables
+;;
+(define (open-queue-db dbpath dbfile #!key (schema '()))
+ (let* ((dbfname (conc dbpath "/" dbfile))
+ (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
+ (db (dbi:open 'sqlite3 (list (cons 'dbname dbfname)))))
+ ;; (set-busy-handler! db (busy-timeout 10000))
+ (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
+ (for-each
+ (lambda (stmt)
+ (dbi:exec db stmt))
+ (cons "CREATE TABLE IF NOT EXISTS pkts
+ (id INTEGER PRIMARY KEY,
+ group_id INTEGER NOT NULL,
+ uuid TEXT NOT NULL,
+ parent_uuid TEXT TEXT DEFAULT '',
+ pkt_type TEXT NOT NULL,
+ pkt TEXT NOT NULL,
+ processed INTEGER DEFAULT 0)"
+ schema))) ;; 0=not processed, 1=processed, 2... for expansion
+ db))
+
+(define (add-to-queue db pkt uuid pkt-type parent-uuid group-id)
+ (dbi:exec db "INSERT INTO pkts (uuid,parent_uuid,pkt_type,pkt,group_id)
+ VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);"
+ uuid
+ (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid.
+ (if pkt-type (conc pkt-type) "")
+ pkt
+ group-id))
+
+;; given all needed parameters create a pkt and store it in the queue
+;; procs is an alist that maps pkt-type to a function that takes a list of pkt params
+;; in data and returns the uuid and pkt
+;;
+(define (create-and-queue conn procs pkt-type parent-uuid group-id data)
+ (let ((proc (alist-ref pkt-type procs)))
+ (if proc
+ (let-values (( (uuid pkt) (proc data) ))
+ (add-to-queue conn pkt uuid pkt-type parent-uuid group-id)
+ uuid)
+ #f)))
+
+;; given uuid get pkt, if group-id is specified use it (reduces probablity of
+;; being messed up by a uuid collision)
+;;
+(define (lookup-by-uuid db pkt-uuid group-id)
+ (if group-id
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE group_id=? AND uuid=?;" group-id pkt-uuid)
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE uuid=?;" pkt-uuid)))
+
+;; find a packet by its id
+;;
+(define (lookup-by-id db id)
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE id=?;" id))
+
+;; apply a proc to the open db handle for a pkt db in pdbpath
+;;
+(define (with-queue-db pdbpath proc #!key (schema #f))
+ (cond
+ ((not (equal? (file-owner pdbpath)(current-effective-user-id)))
+ (print "ERROR: directory " pdbpath " is not owned by " (current-effective-user-name)))
+ (else
+ (let* ((pdb (open-queue-db pdbpath "pkts.db"
+ schema: schema)) ;; '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
+ (res (proc pdb)))
+ (dbi:close pdb)
+ res))))
+
+(define (load-pkts-to-db pktsdirs pdbpath #!key (schema #f))
+ (with-queue-db
+ pdbpath
+ (lambda (pdb)
+ (for-each
+ (lambda (pktsdir) ;; look at all
+ (cond
+ ((not (file-exists? pktsdir))
+ (print "ERROR: packets directory " pktsdir " does not exist."))
+ ((not (directory? pktsdir))
+ (print "ERROR: packets directory path " pktsdir " is not a directory."))
+ ((not (file-read-access? pktsdir))
+ (print "ERROR: packets directory path " pktsdir " is not readable."))
+ (else
+ ;; (print "INFO: Loading packets found in " pktsdir)
+ (let ((pkts (glob (conc pktsdir "/*.pkt"))))
+ (for-each
+ (lambda (pkt)
+ (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
+ (exists (lookup-by-uuid pdb uuid #f)))
+ (if (not exists)
+ (let* ((pktdat (string-intersperse
+ (with-input-from-file pkt read-lines)
+ "\n"))
+ (apkt (pkt->alist pktdat))
+ (ptype (alist-ref 'T apkt)))
+ (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0))
+ ;; (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
+ ;; (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
+ )))
+ pkts)))))
+ pktsdirs))))
+
+;;======================================================================
+;; P R O C E S S P K T S
+;;======================================================================
+
+;; given a list of field values pulled from the queue db generate a list
+;; of dpkt's
+;;
+(define (dblst->dpkts lst . altmap)
+ (let* ((maplst (if (null? altmap)
+ '(id group-id uuid parent pkt-type pkt processed)
+ altmap))
+ (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist
+ (cons `(apkt . ,(pkt->alist (alist-ref 'pkt res)))
+ res)))
+
+;; NB// ptypes is a list of symbols, '() or #f find all types
+;;
+(define (get-dpkts db ptypes group-id parent-uuid #!key (uuid #f))
+ (let* ((ptype-qry (if (and ptypes
+ (not (null? ptypes)))
+ (conc " IN ('" (string-intersperse (map conc ptypes) "','") "')")
+ (conc " LIKE '%' ")))
+ (rows (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE pkt_type " ptype-qry " AND group_id=?
+ AND processed=0 "
+ (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "")
+ (if uuid (conc "AND uuid='" uuid "' ") "")
+ "ORDER BY id DESC;")
+ group-id)))
+ (map dblst->dpkts (map vector->list rows))))
+
+;; get N pkts not yet processed for group-id
+;;
+(define (get-not-processed-pkts db group-id pkt-type limit offset)
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE pkt_type = ? AND group_id = ? AND processed=0
+ LIMIT ? OFFSET ?;"
+ (conc pkt-type) ;; convert symbols to string
+ group-id
+ limit
+ offset
+ ))))
+
+;; given a uuid, get not processed child pkts
+;;
+(define (get-related db group-id uuid)
+ (map dblst->dpkts
+ (dbi:get-rows
+ db
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE parent_uuid=? AND group_id=? AND processed=0;"
+ uuid group-id)))
+
+;; generic pkt processor
+;;
+;; find all packets in group-id of type in ptypes and apply proc to pktdat
+;;
+(define (process-pkts conn group-id ptypes parent-uuid proc)
+ (let* ((pkts (get-dpkts conn ptypes group-id parent-uuid)))
+ (map proc pkts)))
+
+;; criteria is an alist ((k . valpatt) ...)
+;; - valpatt is a regex
+;; - ptypes is a list of types (symbols expected)
+;; match-type: 'any or 'all
+;;
+(define (find-pkts db ptypes criteria #!key (processed #f)(match-type 'any)(pkt-spec #f)) ;; processed=#f, don't use, else use
+ (let* ((pkts (get-dpkts db ptypes 0 #f))
+ (match-rules (lambda (pktdat) ;; returns a list of matching rules
+ (filter (lambda (c)
+ ;; (print "c: " c)
+ (let* ((ctype (car c)) ;; card type
+ (rx (cdr c)) ;; card pattern
+ ;; (t (alist-ref 'pkt-type pktdat))
+ (pkt (alist-ref 'pkt pktdat))
+ (apkt (pkt->alist pkt))
+ (cdat (alist-ref ctype apkt)))
+ ;; (print "cdat: " cdat) ;; " apkt: " apkt)
+ (if cdat
+ (string-match rx cdat)
+ #f)))
+ criteria)))
+ (res (filter (lambda (pktdat)
+ (if (null? criteria) ;; looking for all pkts
+ #t
+ (case match-type
+ ((any)(not (null? (match-rules pktdat))))
+ ((all)(eq? (length (match-rules pktdat))(length criteria)))
+ (else
+ (print "ERROR: bad match type " match-type ", expecting any or all.")))))
+ pkts)))
+ (if pkt-spec
+ (dpkts->alists res pkt-spec)
+ res)))
+
+;; get descendents of parent-uuid
+;;
+;; NOTE: Should be doing something like the following:
+;;
+;; given a uuid, get not processed child pkts
+;; processed:
+;; #f => get all
+;; 0 => get not processed
+;; 1 => get processed
+;;
+(define (get-ancestors db group-id uuid #!key (processed #f))
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
+ FROM pkts
+ WHERE uuid IN
+ (WITH RECURSIVE
+ tree(uuid,parent_uuid)
+ AS
+ (
+ SELECT uuid, parent_uuid
+ FROM pkts
+ WHERE uuid = ?
+ UNION ALL
+ SELECT t.uuid, t.parent_uuid
+ FROM pkts t
+ JOIN tree ON t.uuid = tree.parent_uuid
+ )
+ SELECT uuid FROM tree)
+ AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
+ uuid group-id))))
+
+;; Untested
+;;
+(define (get-descendents db group-id uuid #!key (processed #f))
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
+ FROM pkts
+ WHERE uuid IN
+ (WITH RECURSIVE
+ tree(uuid,parent_uuid)
+ AS
+ (
+ SELECT uuid, parent_uuid
+ FROM pkts
+ WHERE uuid = ?
+ UNION ALL
+ SELECT t.uuid, t.parent_uuid
+ FROM pkts t
+ JOIN tree ON t.parent_uuid = tree.uuid
+ )
+ SELECT uuid FROM tree)
+ AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
+ uuid group-id))))
+
+;; look up descendents based on given info unless passed in a list via inlst
+;;
+(define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f))
+ (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed))))
+ (if (null? descendents)
+ #f
+ (last descendents))))
+
+;;======================================================================
+;; A R C H I V E S - always to a sqlite3 db
+;;======================================================================
+
+;; open an archive db
+;; path: archive-dir//month.db
+;;
+(define (archive-open-db archive-dir)
+ (let* ((curr-time (seconds->local-time (current-seconds)))
+ (dbpath (conc archive-dir "/" (time->string curr-time "%Y")))
+ (dbfile (conc dbpath "/" (time->string curr-time "%m") ".db"))
+ (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f))))
+ (let ((db (dbi:open 'sqlite3 (list (cons 'dbname dbfile)))))
+ ;; (set-busy-handler! db (busy-timeout 10000))
+ (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
+ (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts
+ (id INTEGER,
+ group_id INTEGER,
+ uuid TEXT,
+ parent_uuid TEXT,
+ pkt_type TEXT,
+ pkt TEXT,
+ processed INTEGER DEFAULT 0)"))
+ db)))
+
+;; turn on transactions! otherwise this will be painfully slow
+;;
+(define (write-archive-pkts src-db db pkt-ids)
+ (let ((pkts (dbi:get-rows
+ src-db
+ (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt FROM pkts WHERE id IN ("
+ (string-intersperse (map conc pkt-ids) ",") ")"))))
+ ;; (dbi:with-transaction
+ ;; db
+ (lambda ()
+ (for-each
+ (lambda (pkt)
+ (apply dbi:exec db "INSERT INTO pkts (id,group_id,uuid,parent_uuid,pkt_type,pkt)
+ VALUES (?,?,?,?,?,?)"
+ pkt))
+ pkts)))) ;; )
+
+;; given a list of uuids and lists of uuids move all to
+;; the sqlite3 db for the current archive period
+;;
+(define (archive-pkts conn pkt-ids archive-dir)
+ (let ((db (archive-open-db archive-dir)))
+ (write-archive-pkts conn db pkt-ids)
+ (dbi:close db))
+ ;; (pg:with-transaction
+ ;; conn
+ ;; (lambda ()
+ (for-each
+ (lambda (id)
+ (dbi:get-one
+ conn
+ "DELETE FROM pkts WHERE id=?" id))
+ pkt-ids)) ;; ))
+
+;; given a list of ids mark all as processed
+;;
+(define (mark-processed conn pkt-ids)
+ ;; (pg:with-transaction
+ ;; conn
+ ;; (lambda ()
+ (for-each
+ (lambda (id)
+ (dbi:get-one
+ conn
+ "UPDATE pkts SET processed=1 WHERE id=?;" id))
+ pkt-ids)) ;; x))
+
+;; a generic pkt getter, gets from the pkts db
+;;
+(define (get-pkts conn ptypes)
+ (let* ((ptypes-str (if (null? ptypes)
+ ""
+ (conc " WHERE pkt_type IN ('" (string-intersperse ptypes ",") "') ")))
+ (qry-str (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts" ptypes-str)))
+ (map vector->list (dbi:get-rows conn qry-str))))
+
+;; make a report of the pkts in the db
+;; ptypes of '() gets all pkts
+;; display-fields
+;;
+(define (make-report dest conn pktspec display-fields . ptypes)
+ (let* (;; (conn (dbi:db-conn (s:db)))
+ (all-rows (get-pkts conn ptypes))
+ (all-pkts (flatten-all
+ all-rows
+ pktspec
+ 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
+ (by-uuid (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (pkt)
+ (let ((uuid (alist-ref 'uuid pkt)))
+ (hash-table-set! ht uuid pkt)))
+ all-pkts)
+ ht))
+ (by-parent (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (pkt)
+ (let ((parent (alist-ref 'parent pkt)))
+ (hash-table-set! ht parent (cons pkt (hash-table-ref/default ht parent '())))))
+ all-pkts)
+ ht))
+ (oup (if dest (open-output-file dest) (current-output-port))))
+
+ (with-output-to-port
+ oup
+ (lambda ()
+ (print "digraph megatest_state_status {
+ // ranksep=0.05
+ rankdir=LR;
+ node [shape=\"box\"];
+")
+ ;; first all the names
+ (for-each
+ (lambda (pkt)
+ (let* ((uuid (alist-ref 'uuid pkt))
+ (shortuuid (substring uuid 0 4))
+ (type (alist-ref 'pkt-type pkt))
+ (processed (alist-ref 'processed pkt)))
+
+ (print "\"" uuid "\" [label=\"" shortuuid ", ("
+ type ", "
+ (if processed "processed" "not processed") ")")
+ (for-each
+ (lambda (key-field)
+ (let ((val (alist-ref key-field pkt)))
+ (if val
+ (print key-field "=" val))))
+ display-fields)
+ (print "\" ];")))
+ all-pkts)
+ ;; now for parent-child relationships
+ (for-each
+ (lambda (pkt)
+ (let ((uuid (alist-ref 'uuid pkt))
+ (parent (alist-ref 'parent pkt)))
+ (if (not (equal? parent ""))
+ (print "\"" parent "\" -> \"" uuid"\";"))))
+ all-pkts)
+
+ (print "}")
+ ))
+ (if dest
+ (begin
+ (close-output-port oup)
+ (system "dot -Tpdf out.dot -o out.pdf")))
+
+ ))
+
+;;======================================================================
+;; Read ref pkts into a vector < laststr hash table >
+;;======================================================================
+
+
+
+;;======================================================================
+;; Read/write packets to files (convience functions)
+;;======================================================================
+
+;; write alist to a pkt file
+;;
+(define (write-alist->pkt targdir dat #!key (pktspec '())(ptype #f))
+ (let-values (((uuid pkt)(alist->pkt dat pktspec ptype: ptype)))
+ (with-output-to-file (conc targdir "/" uuid ".pkt")
+ (lambda ()
+ (print pkt)))
+ uuid)) ;; return the uuid
+
+;; read pkt into alist
+;;
+(define (read-pkt->alist pkt-file #!key (pktspec #f))
+ (pkt->alist (with-input-from-file
+ pkt-file
+ read-string)
+ pktspec: pktspec))
+
+
+) ;; module pkts
ADDED pkts/pkts.setup
Index: pkts/pkts.setup
==================================================================
--- /dev/null
+++ pkts/pkts.setup
@@ -0,0 +1,11 @@
+;; Copyright 2007-2017, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;;;; pkts.setup
+(standard-extension 'pkts "1.0")
ADDED pkts/tests/run.scm
Index: pkts/tests/run.scm
==================================================================
--- /dev/null
+++ pkts/tests/run.scm
@@ -0,0 +1,139 @@
+(use test)
+
+;; (use (prefix pkts pkts:))
+(use pkts (prefix dbi dbi:))
+;; (use trace)(trace sdat->alist pkt->alist)
+
+(if (file-exists? "queue.db")(delete-file "queue.db"))
+
+(test-begin "pkts and pkt archives")
+
+;;======================================================================
+;; Basic pkt creation, parsing and conversion routines
+;;======================================================================
+
+(test-begin "basic packets")
+(test #f '(A "This is a packet") (let-values (((t v)
+ (card->type/value "A This is a packet")))
+ (list t v)))
+(test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e"
+ (let-values (((uuid res)
+ (add-z-card '("A A"))))
+ res))
+(test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)
+ string<=?))
+(define pkt-example #f)
+(test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
+ (let-values (((uuid res)
+ (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)))
+ (set! pkt-example (cons uuid res))
+ res))
+(test-end "basic packets")
+
+;;======================================================================
+;; Sqlite and postgresql based queue of pkts
+;;======================================================================
+
+(test-begin "pkt queue")
+(define db #f)
+(test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db")))
+ (set! db dbh)
+ (dbi:db-dbtype dbh)))
+(test #f (cdr pkt-example)
+ (begin
+ (add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0)
+ (lookup-by-uuid db (car pkt-example) 0)))
+(test #f (cdr pkt-example)
+ (lookup-by-id db 1))
+(test #f 1 (length (find-pkts db '(basic) '())))
+
+(test-end "pkt queue")
+
+
+;;======================================================================
+;; Process groups of pkts
+;;======================================================================
+
+(test-begin "lists of packets")
+(test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5))
+ (dblst->dpkts '(1 2 3 4 5)))
+(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
+ ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ (get-dpkts db '(basic) 0 #f))
+(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
+ ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ (get-not-processed-pkts db 0 'basic 1000 0))
+(test-end "lists of packets")
+
+(test-begin "pkts as alists")
+(define pktspec '((posting . ((title . t) ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ...
+ (url . u)
+ (blurb . b)))
+ (comment . ((comment . c)
+ (score . s)))
+ (basic . ((b-field . b)
+ (a-field . a)))))
+(define pktlst (find-pkts db '(basic) '()))
+(define dpkt (car pktlst))
+(test #f "A" (get-value 'a-field dpkt pktspec))
+
+(test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec)))
+
+(define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b))))
+(define test-pkt '((foo . "fooval")(bar . "barval")))
+(let*-values (((u p) (alist->pkt test-pkt basic-spec ptype: 'basic))
+ ((apkt) (pkt->alist p))
+ ((bpkt) (pkt->alist p pktspec: basic-spec)))
+ (test #f "fooval" (alist-ref 'f apkt))
+ (test #f "fooval" (alist-ref 'foo bpkt))
+ (test #f #f (alist-ref 'f bpkt)))
+
+(test-end "pkts as alists")
+
+(test-begin "descendents and ancestors")
+
+(define (get-uuid pkt)(alist-ref 'uuid pkt))
+
+;; add a child to 263e
+(let-values (((uuid pkt)
+ (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
+ 'D "1486332719.0")))
+ (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0))
+
+(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
+ (map (lambda (x)(alist-ref 'uuid x))
+ (get-descendents
+ db 0
+ "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+
+(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
+ (map (lambda (x)(alist-ref 'uuid x))
+ (get-ancestors
+ db 0
+ "818fe30988c9673441b8f203972a8bda6af682f8")))
+
+(test-end "descendents and ancestors")
+
+(test-end "pkts and pkt archives")
+
+(test-begin "pktsdb")
+
+(define spec '((tests (testname n TEXT)
+ (testpath p TEXT)
+ (duration d INTEGER))))
+;; (define pktsdb (make-pktdb))
+;; (pktdb-pktsdb-spec-set! pktsdb spec)
+
+(define pktsdb #f)
+
+(test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec)))
+ (set! pktsdb pdb)
+ (pktdb-conn pdb))))
+;; (pp (pktdb-pktspec pktsdb))
+(test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1"))))
+
+(pktsdb-close pktsdb)
+
+(test-end "pktsdb")
Index: rmt-inc.scm
==================================================================
--- rmt-inc.scm
+++ rmt-inc.scm
@@ -72,141 +72,141 @@
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
(rmt:open-qry-close-locally cmd 0 params))
-
-
-#;(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
- #;(common:telemetry-log (conc "rmt:"(->string cmd))
- payload: `((rid . ,rid)
- (params . ,params)))
-
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
- ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
- ;; 3. do the query, if on homehost use local access
- ;;
- (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
- (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
- (runremote (or area-dat
- *runremote*))
- (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
-
- ;; ensure we have a record for our connection for given area
- (if (not runremote) ;; can remove this one. should never get here.
- (begin
- (set! *runremote* (make-remote))
- (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; ensure we have a homehost record
- (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
- (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
- (remote-hh-dat-set! runremote (common:get-homehost)))
-
- ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
- (cond
- ;; give up if more than 15 attempts
- ((> attemptnum 15)
- (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
- (exit 1))
-
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;; reset the connection if it has been unused too long
- ((and runremote
- (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections area-dat: runremote)
- (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (member cmd api:read-only-queries)) ;; this is a read
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;; on homehost and this is a write, we already have a server, but server has died
- ((and (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote) ;; have a server
- (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (make-remote))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote)) ;; have a server
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if server-url
- (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*))))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
- (not (remote-conndat runremote)))) ;; and no connection
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;; not on homehost, do server query
- (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
+;;
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; #;(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
+;; ;;
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; payload: `((rid . ,rid)
+;; ;; (params . ,params)))
+;; ;;
+;; ;; do all the prep locked under the rmt-mutex
+;; (mutex-lock! *rmt-mutex*)
+;;
+;; ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
+;; ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+;; ;; 3. do the query, if on homehost use local access
+;; ;;
+;; (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
+;; (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
+;; (runremote (or area-dat
+;; *runremote*))
+;; (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
+;;
+;; ;; ensure we have a record for our connection for given area
+;; (if (not runremote) ;; can remove this one. should never get here.
+;; (begin
+;; (set! *runremote* (make-remote))
+;; (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
+;;
+;; ;; ensure we have a homehost record
+;; (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
+;; (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
+;; (remote-hh-dat-set! runremote (common:get-homehost)))
+;;
+;; ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+;; (cond
+;; ;; give up if more than 15 attempts
+;; ((> attemptnum 15)
+;; (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
+;; (exit 1))
+;;
+;; ;; readonly mode, read request- handle it - case 2
+;; ((and readonly-mode
+;; (member cmd api:read-only-queries))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
+;; (rmt:open-qry-close-locally cmd 0 params)
+;; )
+;;
+;; ;; readonly mode, write request. Do nothing, return #f
+;; (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
+;;
+;; ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+;; ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+;; ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+;; ;;
+;; ;; reset the connection if it has been unused too long
+;; ((and runremote
+;; (remote-conndat runremote)
+;; (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+;; (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
+;; (remote-server-timeout runremote))))
+;; (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+;; (http-transport:close-connections area-dat: runremote)
+;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
+;; (mutex-unlock! *rmt-mutex*)
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;; on homehost and this is a read
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (member cmd api:read-only-queries)) ;; this is a read
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;; on homehost and this is a write, we already have a server, but server has died
+;; ((and (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; (remote-server-url runremote) ;; have a server
+;; (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
+;; (set! *runremote* (make-remote))
+;; (remote-force-server-set! runremote (common:force-server?))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;; on homehost and this is a write, we already have a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; (remote-server-url runremote)) ;; have a server
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;; on homehost, no server contact made and this is a write, passively start a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; have homehost
+;; (not (remote-server-url runremote)) ;; no connection yet
+;; (not (member cmd api:read-only-queries))) ;; not a read-only query
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
+;; (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+;; (if server-url
+;; (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
+;; (if (common:force-server?)
+;; (server:start-and-wait *toppath*)
+;; (server:kind-run *toppath*))))
+;; (remote-force-server-set! runremote (common:force-server?))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
+;; (not (remote-conndat runremote)))
+;; (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
+;; (not (remote-conndat runremote)))) ;; and no connection
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+;; (mutex-unlock! *rmt-mutex*)
+;; (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
+;; (server:start-and-wait *toppath*))
+;; (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+;;
+;; ;; all set up if get this far, dispatch the query
+;; ((and (not (remote-force-server runremote))
+;; (cdr (remote-hh-dat runremote))) ;; we are on homehost
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
+;; (rmt:open-qry-close-locally cmd (if rid rid 0) params))
+;;
+;; ;; not on homehost, do server query
+;; (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
;; bunch of small functions factored out of send-receive to make debug easier
;;
(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)