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