Artifact
4335bf3320c29fbbc80d6afcb0067f8dc054c2d1:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 75 73 65 20 PURPOSE...(use
0150: 64 65 66 73 74 72 75 63 74 29 0a 0a 3b 3b 20 28 defstruct)..;; (
0160: 75 73 65 20 73 73 61 78 29 0a 3b 3b 20 28 75 73 use ssax).;; (us
0170: 65 20 73 78 6d 6c 2d 73 65 72 69 61 6c 69 7a 65 e sxml-serialize
0180: 72 29 0a 3b 3b 20 28 75 73 65 20 73 78 6d 6c 2d r).;; (use sxml-
0190: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 73 29 0a 3b modifications).;
01a0: 3b 20 28 75 73 65 20 72 65 67 65 78 29 0a 3b 3b ; (use regex).;;
01b0: 20 28 75 73 65 20 73 72 66 69 2d 36 39 29 0a 3b (use srfi-69).;
01c0: 3b 20 28 75 73 65 20 72 65 67 65 78 2d 63 61 73 ; (use regex-cas
01d0: 65 29 0a 3b 3b 20 28 75 73 65 20 70 6f 73 69 78 e).;; (use posix
01e0: 29 0a 3b 3b 20 28 75 73 65 20 6a 73 6f 6e 29 0a ).;; (use json).
01f0: 3b 3b 20 28 75 73 65 20 63 73 76 29 0a 3b 3b 20 ;; (use csv).;;
0200: 28 75 73 65 20 64 69 72 65 63 74 6f 72 79 2d 75 (use directory-u
0210: 74 69 6c 73 29 0a 28 75 73 65 20 73 72 66 69 2d tils).(use srfi-
0220: 31 38 29 0a 28 75 73 65 20 66 6f 72 6d 61 74 29 18).(use format)
0230: 0a 0a 3b 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 ..;; (require-li
0240: 62 72 61 72 79 20 69 6e 69 2d 66 69 6c 65 29 0a brary ini-file).
0250: 3b 3b 20 28 69 6d 70 6f 72 74 20 28 70 72 65 66 ;; (import (pref
0260: 69 78 20 69 6e 69 2d 66 69 6c 65 20 69 6e 69 3a ix ini-file ini:
0270: 29 29 0a 0a 28 75 73 65 20 73 71 6c 2d 64 65 2d ))..(use sql-de-
0280: 6c 69 74 65 20 73 72 66 69 2d 31 20 70 6f 73 69 lite srfi-1 posi
0290: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
02a0: 73 65 20 73 72 66 69 2d 36 39 29 0a 3b 3b 20 28 se srfi-69).;; (
02b0: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 import (prefix s
02c0: 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 qlite3 sqlite3:)
02d0: 29 0a 3b 3b 20 0a 28 64 65 63 6c 61 72 65 20 28 ).;; .(declare (
02e0: 75 73 65 73 20 63 6f 6e 66 69 67 66 29 29 0a 3b uses configf)).;
02f0: 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ; (declare (uses
0300: 20 74 72 65 65 29 29 0a 28 64 65 63 6c 61 72 65 tree)).(declare
0310: 20 28 75 73 65 73 20 6d 61 72 67 73 29 29 0a 3b (uses margs)).;
0320: 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ; (declare (uses
0330: 20 64 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 28 64 dcommon)).;; (d
0340: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c 61 75 eclare (uses lau
0350: 6e 63 68 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 nch)).;; (declar
0360: 65 20 28 75 73 65 73 20 67 75 74 69 6c 73 29 29 e (uses gutils))
0370: 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 .;; (declare (us
0380: 65 73 20 64 62 29 29 0a 3b 3b 20 28 64 65 63 6c es db)).;; (decl
0390: 61 72 65 20 28 75 73 65 73 20 73 79 6e 63 68 61 are (uses syncha
03a0: 73 68 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 sh)).;; (declare
03b0: 20 28 75 73 65 73 20 73 65 72 76 65 72 29 29 0a (uses server)).
03c0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d (declare (uses m
03d0: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 29 egatest-version)
03e0: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
03f0: 73 65 73 20 74 62 64 29 29 0a 0a 28 69 6e 63 6c ses tbd))..(incl
0400: 75 64 65 20 22 6d 65 67 61 74 65 73 74 2d 66 6f ude "megatest-fo
0410: 73 73 69 6c 2d 68 61 73 68 2e 73 63 6d 22 29 0a ssil-hash.scm").
0420: 0a 3b 3b 0a 3b 3b 20 47 4c 4f 42 41 4c 53 0a 3b .;;.;; GLOBALS.;
0430: 3b 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f ;.(define *verbo
0440: 73 69 74 79 2a 20 31 29 0a 28 64 65 66 69 6e 65 sity* 1).(define
0450: 20 2a 6c 6f 67 67 69 6e 67 2a 20 23 66 29 0a 28 *logging* #f).(
0460: 64 65 66 69 6e 65 20 2a 65 78 65 2d 6e 61 6d 65 define *exe-name
0470: 2a 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 * (pathname-file
0480: 20 28 63 61 72 20 28 61 72 67 76 29 29 29 29 0a (car (argv)))).
0490: 28 64 65 66 69 6e 65 20 2a 73 72 65 74 72 69 65 (define *sretrie
04a0: 76 65 3a 63 75 72 72 65 6e 74 2d 74 61 62 2d 6e ve:current-tab-n
04b0: 75 6d 62 65 72 2a 20 30 29 0a 28 64 65 66 69 6e umber* 0).(defin
04c0: 65 20 2a 61 72 67 73 2d 68 61 73 68 2a 20 28 6d e *args-hash* (m
04d0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
04e0: 0a 28 64 65 66 69 6e 65 20 73 72 65 74 72 69 65 .(define sretrie
04f0: 76 65 3a 68 65 6c 70 20 28 63 6f 6e 63 20 22 55 ve:help (conc "U
0500: 73 61 67 65 3a 20 22 20 2a 65 78 65 2d 6e 61 6d sage: " *exe-nam
0510: 65 2a 20 22 20 5b 61 63 74 69 6f 6e 20 5b 70 61 e* " [action [pa
0520: 72 61 6d 73 20 2e 2e 2e 5d 5d 0a 0a 20 20 6c 73 rams ...]].. ls
0530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0540: 20 20 20 20 20 3a 20 6c 69 73 74 20 63 6f 6e 74 : list cont
0550: 65 6e 74 73 20 6f 66 20 74 61 72 67 65 74 20 61 ents of target a
0560: 72 65 61 0a 20 20 67 65 74 20 3c 72 65 6c 76 65 rea. get <relve
0570: 72 73 69 6f 6e 3e 20 20 20 20 20 20 20 3a 20 72 rsion> : r
0580: 65 74 72 69 65 76 65 20 64 61 74 61 20 66 6f 72 etrieve data for
0590: 20 72 65 6c 65 61 73 65 20 3c 76 65 72 73 69 6f release <versio
05a0: 6e 3e 0a 20 20 20 20 2d 6d 20 5c 22 6d 65 73 73 n>. -m \"mess
05b0: 61 67 65 5c 22 20 20 20 20 20 20 20 3a 20 77 68 age\" : wh
05c0: 79 20 72 65 74 72 69 65 76 65 64 3f 0a 20 20 63 y retrieved?. c
05d0: 70 20 3c 72 65 6c 61 74 69 76 65 20 70 61 74 68 p <relative path
05e0: 3e 20 20 20 20 20 3a 20 63 6f 70 79 20 66 69 6c > : copy fil
05f0: 65 20 74 6f 20 63 75 72 72 65 6e 74 20 64 69 72 e to current dir
0600: 65 63 74 6f 72 79 20 0a 20 20 6c 6f 67 20 20 20 ectory . log
0610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0620: 20 3a 20 67 65 74 20 6c 69 73 74 69 6e 67 20 6f : get listing o
0630: 66 20 72 65 63 65 6e 74 20 64 6f 77 6e 6c 6f 61 f recent downloa
0640: 64 73 0a 20 20 73 68 65 6c 6c 20 20 20 20 20 20 ds. shell
0650: 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 73 74 : st
0660: 61 72 74 20 61 20 73 68 65 6c 6c 2d 6c 69 6b 65 art a shell-like
0670: 20 69 6e 74 65 72 66 61 63 65 0a 0a 50 61 72 74 interface..Part
0680: 20 6f 66 20 74 68 65 20 4d 65 67 61 74 65 73 74 of the Megatest
0690: 20 74 6f 6f 6c 20 73 75 69 74 65 2e 0a 4c 65 61 tool suite..Lea
06a0: 72 6e 20 6d 6f 72 65 20 61 74 20 68 74 74 70 3a rn more at http:
06b0: 2f 2f 77 77 77 2e 6b 69 61 74 6f 61 2e 63 6f 6d //www.kiatoa.com
06c0: 2f 66 6f 73 73 69 6c 73 2f 6d 65 67 61 74 65 73 /fossils/megates
06d0: 74 0a 0a 56 65 72 73 69 6f 6e 3a 20 22 20 6d 65 t..Version: " me
06e0: 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 gatest-fossil-ha
06f0: 73 68 29 29 20 3b 3b 20 22 0a 0a 3b 3b 3d 3d 3d sh)) ;; "..;;===
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 0a 3b 3b 20 52 45 43 4f 52 44 53 0a 3b ===.;; RECORDS.;
0750: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 0a 3b 3b 20 44 42 0a 3b 3b 3d 3d 3d 3d 3d 3d =.;; DB.;;======
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 0a 0a 3b 3b 20 72 65 70 6c 61 63 65 20 28 73 74 ..;; replace (st
0840: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
0850: 27 29 29 2c 20 77 69 74 68 20 64 61 74 65 74 69 ')), with dateti
0860: 6d 65 28 27 6e 6f 77 27 29 29 0a 28 64 65 66 69 me('now')).(defi
0870: 6e 65 20 28 73 72 65 74 72 69 65 76 65 3a 69 6e ne (sretrieve:in
0880: 69 74 69 61 6c 69 7a 65 2d 64 62 20 64 62 29 0a itialize-db db).
0890: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 28 (for-each. (
08a0: 6c 61 6d 62 64 61 20 28 71 72 79 29 0a 20 20 20 lambda (qry).
08b0: 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 (exec (sql db
08c0: 71 72 79 29 29 29 0a 20 20 20 28 6c 69 73 74 20 qry))). (list
08d0: 0a 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 . "CREATE TAB
08e0: 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
08f0: 20 61 63 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 actions.
0900: 20 20 28 69 64 20 20 20 20 20 20 20 20 20 20 20 (id
0910: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
0920: 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 61 KEY,. a
0930: 63 74 69 6f 6e 20 20 20 20 20 20 20 54 45 58 54 ction TEXT
0940: 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 NOT NULL,.
0950: 20 20 20 20 20 72 65 74 72 69 65 76 65 72 20 20 retriever
0960: 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c TEXT NOT NULL,
0970: 0a 20 20 20 20 20 20 20 20 20 20 64 61 74 65 74 . datet
0980: 69 6d 65 20 20 20 20 20 54 49 4d 45 53 54 41 4d ime TIMESTAM
0990: 50 20 44 45 46 41 55 4c 54 20 28 64 61 74 65 74 P DEFAULT (datet
09a0: 69 6d 65 28 27 6e 6f 77 27 2c 27 6c 6f 63 61 6c ime('now','local
09b0: 74 69 6d 65 27 29 29 2c 0a 20 20 20 20 20 20 20 time')),.
09c0: 20 20 20 73 72 63 70 61 74 68 20 20 20 20 20 20 srcpath
09d0: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 TEXT NOT NULL,.
09e0: 20 20 20 20 20 20 20 20 20 63 6f 6d 6d 65 6e 74 comment
09f0: 20 20 20 20 20 20 54 45 58 54 20 44 45 46 41 55 TEXT DEFAU
0a00: 4c 54 20 27 27 20 4e 4f 54 20 4e 55 4c 4c 2c 0a LT '' NOT NULL,.
0a10: 20 20 20 20 20 20 20 20 20 20 73 74 61 74 65 20 state
0a20: 20 20 20 20 20 20 20 54 45 58 54 20 44 45 46 41 TEXT DEFA
0a30: 55 4c 54 20 27 6e 65 77 27 29 3b 22 0a 20 20 20 ULT 'new');".
0a40: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
0a50: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 62 75 6e F NOT EXISTS bun
0a60: 64 6c 65 73 0a 20 20 20 20 20 20 20 20 20 28 69 dles. (i
0a70: 64 20 20 20 20 20 20 20 20 20 20 20 49 4e 54 45 d INTE
0a80: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
0a90: 0a 20 20 20 20 20 20 20 20 20 20 62 75 6e 64 6c . bundl
0aa0: 65 20 20 20 20 20 20 20 54 45 58 54 20 4e 4f 54 e TEXT NOT
0ab0: 20 4e 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 NULL,.
0ac0: 20 72 65 6c 65 61 73 65 20 20 20 20 20 20 54 45 release TE
0ad0: 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 XT NOT NULL,.
0ae0: 20 20 20 20 20 20 20 73 74 61 74 75 73 20 20 20 status
0af0: 20 20 20 20 54 45 58 54 20 4e 4f 54 20 4e 55 4c TEXT NOT NUL
0b00: 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 65 76 65 L,. eve
0b10: 6e 74 5f 64 61 74 65 20 20 20 54 45 58 54 20 4e nt_date TEXT N
0b20: 4f 54 20 4e 55 4c 4c 29 3b 22 0a 20 20 20 20 29 OT NULL);". )
0b30: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 72 65 ))..(define (sre
0b40: 74 72 69 65 76 65 3a 72 65 67 69 73 74 65 72 2d trieve:register-
0b50: 61 63 74 69 6f 6e 20 64 62 20 61 63 74 69 6f 6e action db action
0b60: 20 73 75 62 6d 69 74 74 65 72 20 73 6f 75 72 63 submitter sourc
0b70: 65 2d 70 61 74 68 20 63 6f 6d 6d 65 6e 74 29 0a e-path comment).
0b80: 20 20 28 70 72 69 6e 74 20 22 28 73 72 65 74 72 (print "(sretr
0b90: 69 65 76 65 3a 72 65 67 69 73 74 65 72 2d 61 63 ieve:register-ac
0ba0: 74 69 6f 6e 20 64 62 20 22 20 64 62 20 22 20 61 tion db " db " a
0bb0: 63 74 69 6f 6e 20 22 20 61 63 74 69 6f 6e 20 22 ction " action "
0bc0: 20 73 75 62 6d 69 74 74 65 72 20 22 20 73 75 62 submitter " sub
0bd0: 6d 69 74 74 65 72 20 22 20 73 6f 75 72 63 65 2d mitter " source-
0be0: 70 61 74 68 20 22 20 73 6f 75 72 63 65 2d 70 61 path " source-pa
0bf0: 74 68 20 22 20 63 6f 6d 6d 65 6e 74 20 22 20 63 th " comment " c
0c00: 6f 6d 6d 65 6e 74 29 0a 20 20 28 65 78 65 63 20 omment). (exec
0c10: 28 73 71 6c 20 64 62 20 22 49 4e 53 45 52 54 20 (sql db "INSERT
0c20: 49 4e 54 4f 20 61 63 74 69 6f 6e 73 20 28 61 63 INTO actions (ac
0c30: 74 69 6f 6e 2c 72 65 74 72 69 65 76 65 72 2c 73 tion,retriever,s
0c40: 72 63 70 61 74 68 2c 63 6f 6d 6d 65 6e 74 29 0a rcpath,comment).
0c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c60: 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 29 VALUES(?,?,?,?)
0c70: 22 29 0a 09 61 63 74 69 6f 6e 0a 09 73 75 62 6d ")..action..subm
0c80: 69 74 74 65 72 0a 09 73 6f 75 72 63 65 2d 70 61 itter..source-pa
0c90: 74 68 0a 09 28 6f 72 20 63 6f 6d 6d 65 6e 74 20 th..(or comment
0ca0: 22 22 29 29 29 0a 0a 3b 3b 20 28 63 61 6c 6c 2d "")))..;; (call-
0cb0: 77 69 74 68 2d 64 61 74 61 62 61 73 65 0a 3b 3b with-database.;;
0cc0: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 3b (lambda (db).;
0cd0: 3b 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 ; (set-busy-ha
0ce0: 6e 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d ndler! db (busy-
0cf0: 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 20 timeout 10000))
0d00: 3b 20 31 30 20 73 65 63 6f 6e 64 20 74 69 6d 65 ; 10 second time
0d10: 6f 75 74 0a 3b 3b 20 20 20 2e 2e 2e 29 29 0a 0a out.;; ...))..
0d20: 3b 3b 20 43 72 65 61 74 65 20 74 68 65 20 73 71 ;; Create the sq
0d30: 6c 69 74 65 20 64 62 0a 28 64 65 66 69 6e 65 20 lite db.(define
0d40: 28 73 72 65 74 72 69 65 76 65 3a 64 62 2d 64 6f (sretrieve:db-do
0d50: 20 63 6f 6e 66 69 67 64 61 74 20 70 72 6f 63 29 configdat proc)
0d60: 20 0a 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 .. (let ((path
0d70: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
0d80: 20 63 6f 6e 66 69 67 64 61 74 20 22 64 61 74 61 configdat "data
0d90: 62 61 73 65 22 20 22 6c 6f 63 61 74 69 6f 6e 22 base" "location"
0da0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
0db0: 20 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 path)..(begin..
0dc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
0dd0: 20 23 66 20 22 5b 64 61 74 61 62 61 73 65 5d 5c #f "[database]\
0de0: 6e 6c 6f 63 61 74 69 6f 6e 20 2f 73 6f 6d 65 2f nlocation /some/
0df0: 70 61 74 68 5c 6e 5c 6e 20 49 73 20 6d 69 73 73 path\n\n Is miss
0e00: 69 6e 67 20 66 72 6f 6d 20 74 68 65 20 63 6f 6e ing from the con
0e10: 66 69 67 20 66 69 6c 65 21 22 29 0a 09 20 20 28 fig file!").. (
0e20: 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 28 69 exit 1))). (i
0e30: 66 20 28 61 6e 64 20 70 61 74 68 0a 09 20 20 20 f (and path..
0e40: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 (directory? pa
0e50: 74 68 29 0a 09 20 20 20 20 20 28 66 69 6c 65 2d th).. (file-
0e60: 72 65 61 64 2d 61 63 63 65 73 73 3f 20 70 61 74 read-access? pat
0e70: 68 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 70 h))..(let* ((dbp
0e80: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 70 61 74 ath (conc pat
0e90: 68 20 22 2f 22 20 2a 65 78 65 2d 6e 61 6d 65 2a h "/" *exe-name*
0ea0: 20 22 2e 64 62 22 29 29 0a 09 20 20 20 20 20 20 ".db"))..
0eb0: 20 28 77 72 69 74 65 61 62 6c 65 20 28 66 69 6c (writeable (fil
0ec0: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
0ed0: 64 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 dbpath))..
0ee0: 20 28 64 62 65 78 69 73 74 73 20 20 28 66 69 6c (dbexists (fil
0ef0: 65 2d 65 78 69 73 74 73 3f 20 64 62 70 61 74 68 e-exists? dbpath
0f00: 29 29 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 ))).. (handle-e
0f10: 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 xceptions.. ex
0f20: 6e 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 n.. (begin..
0f30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0f40: 32 20 23 66 20 22 45 52 52 4f 52 3a 20 70 72 6f 2 #f "ERROR: pro
0f50: 62 6c 65 6d 20 61 63 63 65 73 73 69 6e 67 20 64 blem accessing d
0f60: 62 20 22 20 64 62 70 61 74 68 0a 09 09 09 20 20 b " dbpath....
0f70: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0f80: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
0f90: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
0fa0: 29 29 0a 09 20 20 20 20 20 28 65 78 69 74 20 31 )).. (exit 1
0fb0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b )). ;
0fc0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 ;(debug:print 0
0fd0: 23 66 20 22 63 61 6c 6c 69 6e 67 20 70 72 6f 63 #f "calling proc
0fe0: 20 22 20 70 72 6f 63 20 22 64 62 20 70 61 74 68 " proc "db path
0ff0: 20 22 20 64 62 70 61 74 68 20 29 0a 09 20 20 20 " dbpath )..
1000: 28 63 61 6c 6c 2d 77 69 74 68 2d 64 61 74 61 62 (call-with-datab
1010: 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ase.
1020: 64 62 70 61 74 68 0a 09 20 20 20 20 28 6c 61 6d dbpath.. (lam
1030: 62 64 61 20 28 64 62 29 0a 09 20 20 20 20 20 20 bda (db)..
1040: 20 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;;(debug:print
1050: 30 20 23 66 20 22 63 61 6c 6c 69 6e 67 20 70 72 0 #f "calling pr
1060: 6f 63 20 22 20 70 72 6f 63 20 22 20 6f 6e 20 64 oc " proc " on d
1070: 62 20 22 20 64 62 29 0a 09 20 20 20 20 20 20 28 b " db).. (
1080: 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 set-busy-handler
1090: 21 20 64 62 20 28 62 75 73 79 2d 74 69 6d 65 6f ! db (busy-timeo
10a0: 75 74 20 31 30 30 30 30 29 29 20 3b 3b 20 31 30 ut 10000)) ;; 10
10b0: 20 73 65 63 20 74 69 6d 65 6f 75 74 0a 09 20 20 sec timeout..
10c0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 64 62 65 (if (not dbe
10d0: 78 69 73 74 73 29 28 73 72 65 74 72 69 65 76 65 xists)(sretrieve
10e0: 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 64 62 20 64 :initialize-db d
10f0: 62 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 b)).. (proc
1100: 20 64 62 29 29 29 29 29 0a 09 28 64 65 62 75 67 db)))))..(debug
1110: 3a 70 72 69 6e 74 20 30 20 23 66 20 22 45 52 52 :print 0 #f "ERR
1120: 4f 52 3a 20 69 6e 76 61 6c 69 64 20 70 61 74 68 OR: invalid path
1130: 20 66 6f 72 20 73 74 6f 72 69 6e 67 20 64 61 74 for storing dat
1140: 61 62 61 73 65 3a 20 22 20 70 61 74 68 29 29 29 abase: " path)))
1150: 29 0a 0a 3b 3b 20 63 6f 70 79 20 69 6e 20 64 69 )..;; copy in di
1160: 72 65 63 74 6f 72 79 20 74 6f 20 64 65 73 74 2c rectory to dest,
1170: 20 76 61 6c 69 64 61 74 69 6f 6e 20 69 73 20 64 validation is d
1180: 6f 6e 65 20 42 45 46 4f 52 45 20 63 61 6c 6c 69 one BEFORE calli
1190: 6e 67 20 74 68 69 73 0a 3b 3b 0a 28 64 65 66 69 ng this.;;.(defi
11a0: 6e 65 20 28 73 72 65 74 72 69 65 76 65 3a 67 65 ne (sretrieve:ge
11b0: 74 20 63 6f 6e 66 69 67 64 61 74 20 72 65 74 72 t configdat retr
11c0: 69 65 76 65 72 20 76 65 72 73 69 6f 6e 20 63 6f iever version co
11d0: 6d 6d 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 mment). (let* (
11e0: 28 62 61 73 65 2d 64 69 72 20 20 28 63 6f 6e 66 (base-dir (conf
11f0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
1200: 67 64 61 74 20 22 73 65 74 74 69 6e 67 73 22 20 gdat "settings"
1210: 22 62 61 73 65 2d 64 69 72 22 29 29 0a 09 20 28 "base-dir")).. (
1220: 64 61 74 61 64 69 72 20 20 20 28 63 6f 6e 63 20 datadir (conc
1230: 62 61 73 65 2d 64 69 72 20 22 2f 22 20 76 65 72 base-dir "/" ver
1240: 73 69 6f 6e 29 29 29 0a 20 20 20 20 28 69 66 20 sion))). (if
1250: 28 6f 72 20 28 6e 6f 74 20 62 61 73 65 2d 64 69 (or (not base-di
1260: 72 29 0a 09 20 20 20 20 28 6e 6f 74 20 28 66 69 r).. (not (fi
1270: 6c 65 2d 65 78 69 73 74 73 3f 20 62 61 73 65 2d le-exists? base-
1280: 64 69 72 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 dir)))..(begin..
1290: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
12a0: 20 23 66 20 22 45 52 52 4f 52 3a 20 42 61 64 20 #f "ERROR: Bad
12b0: 63 6f 6e 66 69 67 75 72 61 74 69 6f 6e 21 20 62 configuration! b
12c0: 61 73 65 2d 64 69 72 20 22 20 62 61 73 65 2d 64 ase-dir " base-d
12d0: 69 72 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 ir " not found")
12e0: 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 .. (exit 1))).
12f0: 20 20 20 28 70 72 69 6e 74 20 64 61 74 61 64 69 (print datadi
1300: 72 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 r). (if (not
1310: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 61 (file-exists? da
1320: 74 61 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a tadir))..(begin.
1330: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1340: 30 20 23 66 20 22 45 52 52 4f 52 3a 20 42 61 64 0 #f "ERROR: Bad
1350: 20 76 65 72 73 69 6f 6e 20 28 22 20 76 65 72 73 version (" vers
1360: 69 6f 6e 20 22 29 2c 20 6e 6f 20 64 61 74 61 20 ion "), no data
1370: 66 6f 75 6e 64 20 61 74 20 22 20 64 61 74 61 64 found at " datad
1380: 69 72 20 22 2e 22 20 29 0a 09 20 20 28 65 78 69 ir "." ).. (exi
1390: 74 20 31 29 29 29 0a 20 20 20 20 0a 20 20 20 20 t 1))). .
13a0: 28 73 72 65 74 72 69 65 76 65 3a 64 62 2d 64 6f (sretrieve:db-do
13b0: 0a 20 20 20 20 20 63 6f 6e 66 69 67 64 61 74 0a . configdat.
13c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 (lambda (db
13d0: 29 0a 20 20 20 20 20 20 20 28 73 72 65 74 72 69 ). (sretri
13e0: 65 76 65 3a 72 65 67 69 73 74 65 72 2d 61 63 74 eve:register-act
13f0: 69 6f 6e 20 64 62 20 22 67 65 74 22 20 72 65 74 ion db "get" ret
1400: 72 69 65 76 65 72 20 64 61 74 61 64 69 72 20 63 riever datadir c
1410: 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 20 20 omment))).
1420: 28 73 72 65 74 72 69 65 76 65 3a 64 6f 2d 61 73 (sretrieve:do-as
1430: 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 -calling-user.
1440: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
1450: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 64 69 (if (di
1460: 72 65 63 74 6f 72 79 3f 20 64 61 74 61 64 69 72 rectory? datadir
1470: 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 20 20 09 ).. (begin. .
1480: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
1490: 63 74 6f 72 79 20 64 61 74 61 64 69 72 29 0a 09 ctory datadir)..
14a0: 20 20 20 20 28 6c 65 74 20 28 28 66 69 6c 65 73 (let ((files
14b0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
14c0: 20 28 78 29 0a 09 09 09 09 28 6e 6f 74 20 28 6d (x).....(not (m
14d0: 65 6d 62 65 72 20 78 20 27 28 22 2e 22 20 22 2e ember x '("." ".
14e0: 2e 22 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 ."))))....
14f0: 28 67 6c 6f 62 20 22 2a 22 20 22 2e 2a 22 29 29 (glob "*" ".*"))
1500: 29 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 )).. (print
1510: 22 66 69 6c 65 73 3a 20 22 20 66 69 6c 65 73 29 "files: " files)
1520: 0a 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d .. (process-
1530: 65 78 65 63 75 74 65 20 22 2f 62 69 6e 2f 74 61 execute "/bin/ta
1540: 72 22 20 28 61 70 70 65 6e 64 20 28 61 70 70 65 r" (append (appe
1550: 6e 64 20 28 6c 69 73 74 20 20 22 63 68 66 76 22 nd (list "chfv"
1560: 20 22 2d 22 29 20 66 69 6c 65 73 29 20 28 6c 69 "-") files) (li
1570: 73 74 20 22 2d 2d 69 67 6e 6f 72 65 2d 66 61 69 st "--ignore-fai
1580: 6c 65 64 2d 72 65 61 64 22 29 29 29 29 29 0a 20 led-read"))))).
1590: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
15a0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
15b0: 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 6e 74 (let* ((parent
15c0: 2d 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 -dir (pathname-d
15d0: 69 72 65 63 74 6f 72 79 20 64 61 74 61 64 69 72 irectory datadir
15e0: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ) ).
15f0: 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 6e (filen
1600: 61 6d 65 20 20 28 63 6f 6e 63 28 70 61 74 68 6e ame (conc(pathn
1610: 61 6d 65 2d 66 69 6c 65 20 64 61 74 61 64 69 72 ame-file datadir
1620: 29 20 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d ) "." (pathname-
1630: 65 78 74 65 6e 73 69 6f 6e 20 64 61 74 61 64 69 extension datadi
1640: 72 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 r)))).
1650: 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d (change-
1660: 64 69 72 65 63 74 6f 72 79 20 70 61 72 65 6e 74 directory parent
1670: 2d 64 69 72 29 20 20 0a 20 20 20 20 20 20 20 20 -dir) .
1680: 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 65 (proce
1690: 73 73 2d 65 78 65 63 75 74 65 20 22 2f 62 69 6e ss-execute "/bin
16a0: 2f 74 61 72 22 20 28 6c 69 73 74 20 22 63 68 66 /tar" (list "chf
16b0: 76 22 20 22 2d 22 20 66 69 6c 65 6e 61 6d 65 29 v" "-" filename)
16c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 29 ). )
16d0: 29 29 0a 29 29 0a 29 29 0a 0a 0a 3b 3b 20 63 6f )).)).))...;; co
16e0: 70 79 20 69 6e 20 66 69 6c 65 20 74 6f 20 64 65 py in file to de
16f0: 73 74 2c 20 76 61 6c 69 64 61 74 69 6f 6e 20 69 st, validation i
1700: 73 20 64 6f 6e 65 20 42 45 46 4f 52 45 20 63 61 s done BEFORE ca
1710: 6c 6c 69 6e 67 20 74 68 69 73 0a 3b 3b 0a 28 64 lling this.;;.(d
1720: 65 66 69 6e 65 20 28 73 72 65 74 72 69 65 76 65 efine (sretrieve
1730: 3a 63 70 20 63 6f 6e 66 69 67 64 61 74 20 72 65 :cp configdat re
1740: 74 72 69 65 76 65 72 20 66 69 6c 65 20 63 6f 6d triever file com
1750: 6d 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 ment). (let* ((
1760: 62 61 73 65 2d 64 69 72 20 20 28 63 6f 6e 66 69 base-dir (confi
1770: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
1780: 64 61 74 20 22 73 65 74 74 69 6e 67 73 22 20 22 dat "settings" "
1790: 62 61 73 65 2d 64 69 72 22 29 29 0a 20 20 20 20 base-dir")).
17a0: 20 20 20 20 20 28 61 6c 6c 6f 77 65 64 2d 73 75 (allowed-su
17b0: 62 2d 70 61 74 68 73 20 28 63 6f 6e 66 69 67 66 b-paths (configf
17c0: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
17d0: 74 20 22 73 65 74 74 69 6e 67 73 22 20 22 61 6c t "settings" "al
17e0: 6c 6f 77 65 64 2d 73 75 62 2d 70 61 74 68 73 22 lowed-sub-paths"
17f0: 29 29 20 20 20 20 0a 09 20 28 64 61 74 61 64 69 )) .. (datadi
1800: 72 20 20 20 28 63 6f 6e 63 20 62 61 73 65 2d 64 r (conc base-d
1810: 69 72 20 22 2f 22 20 66 69 6c 65 29 29 0a 20 20 ir "/" file)).
1820: 20 20 20 20 20 20 20 28 66 69 6c 65 6e 61 6d 65 (filename
1830: 20 20 28 63 6f 6e 63 28 70 61 74 68 6e 61 6d 65 (conc(pathname
1840: 2d 66 69 6c 65 20 64 61 74 61 64 69 72 29 20 22 -file datadir) "
1850: 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 65 78 74 ." (pathname-ext
1860: 65 6e 73 69 6f 6e 20 64 61 74 61 64 69 72 29 29 ension datadir))
1870: 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 )). (if (or (
1880: 6e 6f 74 20 62 61 73 65 2d 64 69 72 29 0a 09 20 not base-dir)..
1890: 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 (not (file-ex
18a0: 69 73 74 73 3f 20 62 61 73 65 2d 64 69 72 29 29 ists? base-dir))
18b0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
18c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 bug:print 0 #f "
18d0: 45 52 52 4f 52 3a 20 42 61 64 20 63 6f 6e 66 69 ERROR: Bad confi
18e0: 67 75 72 61 74 69 6f 6e 21 20 62 61 73 65 2d 64 guration! base-d
18f0: 69 72 20 22 20 62 61 73 65 2d 64 69 72 20 22 20 ir " base-dir "
1900: 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 28 not found").. (
1910: 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 28 70 exit 1))). (p
1920: 72 69 6e 74 20 64 61 74 61 64 69 72 29 0a 20 20 rint datadir).
1930: 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 (if (not (file
1940: 2d 65 78 69 73 74 73 3f 20 64 61 74 61 64 69 72 -exists? datadir
1950: 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 ))..(begin.. (d
1960: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 ebug:print 0 #f
1970: 22 45 52 52 4f 52 3a 20 46 69 6c 65 20 20 28 22 "ERROR: File ("
1980: 20 66 69 6c 65 20 22 29 2c 20 6e 6f 74 20 66 6f file "), not fo
1990: 75 6e 64 20 61 74 20 22 20 62 61 73 65 2d 64 69 und at " base-di
19a0: 72 20 22 2e 22 20 29 0a 09 20 20 28 65 78 69 74 r "." ).. (exit
19b0: 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 64 1))). (if (d
19c0: 69 72 65 63 74 6f 72 79 3f 20 64 61 74 61 64 69 irectory? datadi
19d0: 72 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 r)..(begin.. (d
19e0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 ebug:print 0 #f
19f0: 22 45 52 52 4f 52 3a 20 28 22 20 66 69 6c 65 20 "ERROR: (" file
1a00: 22 29 20 69 73 20 61 20 64 69 72 63 74 6f 72 79 ") is a dirctory
1a10: 21 21 20 63 70 20 63 6d 64 20 77 6f 72 6b 73 20 !! cp cmd works
1a20: 6f 6e 6c 79 20 6f 6e 20 66 69 6c 65 73 20 2e 22 only on files ."
1a30: 20 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 ).. (exit 1)))
1a40: 0a 20 20 20 20 28 69 66 28 6e 6f 74 20 28 73 74 . (if(not (st
1a50: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
1a60: 78 70 20 20 61 6c 6c 6f 77 65 64 2d 73 75 62 2d xp allowed-sub-
1a70: 70 61 74 68 73 29 20 66 69 6c 65 29 29 0a 20 20 paths) file)).
1a80: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 (begin..
1a90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 (debug:print 0 #
1aa0: 66 20 22 45 52 52 4f 52 3a 20 41 63 63 65 73 73 f "ERROR: Access
1ab0: 20 64 65 6e 69 65 64 20 74 6f 20 66 69 6c 65 20 denied to file
1ac0: 28 22 20 66 69 6c 65 20 22 29 21 21 20 22 20 29 (" file ")!! " )
1ad0: 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 .. (exit 1))).
1ae0: 20 20 20 20 0a 20 20 20 20 20 28 73 72 65 74 72 . (sretr
1af0: 69 65 76 65 3a 64 62 2d 64 6f 0a 20 20 20 20 20 ieve:db-do.
1b00: 63 6f 6e 66 69 67 64 61 74 0a 20 20 20 20 20 28 configdat. (
1b10: 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 lambda (db).
1b20: 20 20 20 28 73 72 65 74 72 69 65 76 65 3a 72 65 (sretrieve:re
1b30: 67 69 73 74 65 72 2d 61 63 74 69 6f 6e 20 64 62 gister-action db
1b40: 20 22 63 70 22 20 72 65 74 72 69 65 76 65 72 20 "cp" retriever
1b50: 64 61 74 61 64 69 72 20 63 6f 6d 6d 65 6e 74 29 datadir comment)
1b60: 29 29 0a 20 20 20 20 20 20 28 73 72 65 74 72 69 )). (sretri
1b70: 65 76 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e eve:do-as-callin
1b80: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 3b 3b 20 g-user. ;;
1b90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1ba0: 23 66 20 22 70 68 3a 20 20 22 28 70 61 74 68 6e #f "ph: "(pathn
1bb0: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 61 ame-directory da
1bc0: 74 61 64 69 72 29 20 20 22 21 21 20 22 20 29 0a tadir) "!! " ).
1bd0: 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 (change-d
1be0: 69 72 65 63 74 6f 72 79 20 28 70 61 74 68 6e 61 irectory (pathna
1bf0: 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 64 61 74 me-directory dat
1c00: 61 64 69 72 29 29 20 20 0a 20 20 20 20 20 20 20 adir)) .
1c10: 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ;;(debug:print 0
1c20: 20 23 66 20 22 70 68 3a 20 2f 62 69 6e 2f 74 61 #f "ph: /bin/ta
1c30: 72 22 20 28 6c 69 73 74 20 22 63 68 66 76 22 20 r" (list "chfv"
1c40: 22 2d 22 20 66 69 6c 65 6e 61 6d 65 29 20 29 0a "-" filename) ).
1c50: 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d 65 (process-e
1c60: 78 65 63 75 74 65 20 22 2f 62 69 6e 2f 74 61 72 xecute "/bin/tar
1c70: 22 20 28 6c 69 73 74 20 22 63 68 66 76 22 20 22 " (list "chfv" "
1c80: 2d 22 20 66 69 6c 65 6e 61 6d 65 29 29 29 0a 20 -" filename))).
1c90: 20 20 20 20 20 29 29 0a 0a 3b 3b 20 6c 73 20 69 ))..;; ls i
1ca0: 6e 20 66 69 6c 65 20 74 6f 20 64 65 73 74 2c 20 n file to dest,
1cb0: 76 61 6c 69 64 61 74 69 6f 6e 20 69 73 20 64 6f validation is do
1cc0: 6e 65 20 42 45 46 4f 52 45 20 63 61 6c 6c 69 6e ne BEFORE callin
1cd0: 67 20 74 68 69 73 0a 3b 3b 0a 28 64 65 66 69 6e g this.;;.(defin
1ce0: 65 20 28 73 72 65 74 72 69 65 76 65 3a 6c 73 20 e (sretrieve:ls
1cf0: 63 6f 6e 66 69 67 64 61 74 20 72 65 74 72 69 65 configdat retrie
1d00: 76 65 72 20 66 69 6c 65 20 63 6f 6d 6d 65 6e 74 ver file comment
1d10: 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 61 73 65 ). (let* ((base
1d20: 2d 64 69 72 20 20 28 63 6f 6e 66 69 67 66 3a 6c -dir (configf:l
1d30: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
1d40: 22 73 65 74 74 69 6e 67 73 22 20 22 62 61 73 65 "settings" "base
1d50: 2d 64 69 72 22 29 29 0a 20 20 20 20 20 20 20 20 -dir")).
1d60: 20 28 61 6c 6c 6f 77 65 64 2d 73 75 62 2d 70 61 (allowed-sub-pa
1d70: 74 68 73 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ths (configf:loo
1d80: 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 kup configdat "s
1d90: 65 74 74 69 6e 67 73 22 20 22 61 6c 6c 6f 77 65 ettings" "allowe
1da0: 64 2d 73 75 62 2d 70 61 74 68 73 22 29 29 20 20 d-sub-paths"))
1db0: 20 20 0a 09 20 28 64 61 74 61 64 69 72 20 20 20 .. (datadir
1dc0: 28 63 6f 6e 63 20 62 61 73 65 2d 64 69 72 20 22 (conc base-dir "
1dd0: 2f 22 20 66 69 6c 65 29 29 0a 20 20 20 20 20 20 /" file)).
1de0: 20 20 20 28 66 69 6c 65 6e 61 6d 65 20 20 28 63 (filename (c
1df0: 6f 6e 63 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c onc(pathname-fil
1e00: 65 20 64 61 74 61 64 69 72 29 20 22 2e 22 20 28 e datadir) "." (
1e10: 70 61 74 68 6e 61 6d 65 2d 65 78 74 65 6e 73 69 pathname-extensi
1e20: 6f 6e 20 64 61 74 61 64 69 72 29 29 29 29 0a 20 on datadir)))).
1e30: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
1e40: 62 61 73 65 2d 64 69 72 29 0a 09 20 20 20 20 28 base-dir).. (
1e50: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
1e60: 3f 20 62 61 73 65 2d 64 69 72 29 29 29 0a 09 28 ? base-dir)))..(
1e70: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
1e80: 70 72 69 6e 74 20 30 20 23 66 20 22 45 52 52 4f print 0 #f "ERRO
1e90: 52 3a 20 42 61 64 20 63 6f 6e 66 69 67 75 72 61 R: Bad configura
1ea0: 74 69 6f 6e 21 20 62 61 73 65 2d 64 69 72 20 22 tion! base-dir "
1eb0: 20 62 61 73 65 2d 64 69 72 20 22 20 6e 6f 74 20 base-dir " not
1ec0: 66 6f 75 6e 64 22 29 0a 09 20 20 28 65 78 69 74 found").. (exit
1ed0: 20 31 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 1))). (print
1ee0: 20 64 61 74 61 64 69 72 29 0a 20 20 20 20 28 69 datadir). (i
1ef0: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
1f00: 73 74 73 3f 20 64 61 74 61 64 69 72 29 29 0a 09 sts? datadir))..
1f10: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
1f20: 3a 70 72 69 6e 74 20 30 20 23 66 20 22 45 52 52 :print 0 #f "ERR
1f30: 4f 52 3a 20 46 69 6c 65 20 20 28 22 20 66 69 6c OR: File (" fil
1f40: 65 20 22 29 2c 20 6e 6f 74 20 66 6f 75 6e 64 20 e "), not found
1f50: 61 74 20 22 20 62 61 73 65 2d 64 69 72 20 22 2e at " base-dir ".
1f60: 22 20 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 " ).. (exit 1))
1f70: 29 0a 20 20 20 20 20 20 28 69 66 28 6e 6f 74 20 ). (if(not
1f80: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 (string-match (r
1f90: 65 67 65 78 70 20 20 61 6c 6c 6f 77 65 64 2d 73 egexp allowed-s
1fa0: 75 62 2d 70 61 74 68 73 29 20 66 69 6c 65 29 29 ub-paths) file))
1fb0: 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a . (begin.
1fc0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1fd0: 30 20 23 66 20 22 45 52 52 4f 52 3a 20 41 63 63 0 #f "ERROR: Acc
1fe0: 65 73 73 20 64 65 6e 69 65 64 20 74 6f 20 66 69 ess denied to fi
1ff0: 6c 65 20 28 22 20 66 69 6c 65 20 22 29 21 21 20 le (" file ")!!
2000: 22 20 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 " ).. (exit 1))
2010: 29 0a 20 20 20 0a 20 20 20 20 20 20 20 20 28 73 ). . (s
2020: 72 65 74 72 69 65 76 65 3a 64 6f 2d 61 73 2d 63 retrieve:do-as-c
2030: 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 alling-user.
2040: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
2050: 20 3b 3b 28 63 68 61 6e 67 65 2d 64 69 72 65 63 ;;(change-direc
2060: 74 6f 72 79 20 64 61 74 61 64 69 72 29 0a 20 20 tory datadir).
2070: 20 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ;; (debug
2080: 3a 70 72 69 6e 74 20 30 20 23 66 20 20 22 2f 75 :print 0 #f "/u
2090: 73 72 2f 62 69 6e 2f 66 69 6e 64 22 20 28 6c 69 sr/bin/find" (li
20a0: 73 74 20 64 61 74 61 64 69 72 20 22 2d 6c 73 22 st datadir "-ls"
20b0: 20 22 7c 22 20 22 67 72 65 70 22 20 22 2d 45 22 "|" "grep" "-E"
20c0: 20 22 27 22 61 6c 6c 6f 77 65 64 2d 66 69 6c 65 "'"allowed-file
20d0: 2d 70 61 74 74 22 27 22 29 29 0a 20 20 20 20 20 -patt"'")).
20e0: 20 20 20 20 3b 3b 20 28 73 74 61 74 75 73 20 28 ;; (status (
20f0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
2100: 70 69 70 65 20 22 66 69 6e 64 20 22 20 64 61 74 pipe "find " dat
2110: 61 64 69 72 20 22 20 2d 6c 73 20 7c 20 67 72 65 adir " -ls | gre
2120: 70 20 2d 45 20 27 22 20 61 6c 6c 6f 77 65 64 2d p -E '" allowed-
2130: 66 69 6c 65 2d 70 61 74 74 20 22 27 22 20 28 6c file-patt "'" (l
2140: 61 6d 62 64 61 20 28 29 20 28 72 65 61 64 2d 6c ambda () (read-l
2150: 69 6e 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 ine)))).
2160: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
2170: 20 30 20 23 66 20 73 74 61 74 75 73 29 20 0a 09 0 #f status) ..
2180: 20 20 28 70 72 6f 63 65 73 73 2d 65 78 65 63 75 (process-execu
2190: 74 65 20 22 2f 62 69 6e 2f 6c 73 22 20 28 6c 69 te "/bin/ls" (li
21a0: 73 74 20 22 2d 6c 73 22 20 20 22 2d 6c 72 74 22 st "-ls" "-lrt"
21b0: 20 64 61 74 61 64 69 72 20 29 29 0a 20 29 29 29 datadir )). )))
21c0: 29 0a 0a 0a 0a 3b 3b 28 66 69 6c 74 65 72 20 28 )....;;(filter (
21d0: 6c 61 6d 62 64 61 20 28 78 29 0a 3b 3b 09 09 09 lambda (x).;;...
21e0: 09 09 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6d .... (not (m
21f0: 65 6d 62 65 72 20 78 20 27 28 22 2e 22 20 22 2e ember x '("." ".
2200: 2e 22 29 29 29 29 0a 3b 3b 09 09 09 09 09 09 09 .")))).;;.......
2210: 20 20 20 28 67 6c 6f 62 20 22 2a 22 20 22 2e 2a (glob "*" ".*
2220: 22 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 "))))))))..(defi
2230: 6e 65 20 28 73 72 65 74 72 69 65 76 65 3a 76 61 ne (sretrieve:va
2240: 6c 69 64 61 74 65 20 74 61 72 67 65 74 2d 64 69 lidate target-di
2250: 72 20 74 61 72 67 2d 6d 6b 29 0a 20 20 28 6c 65 r targ-mk). (le
2260: 74 2a 20 28 28 6e 6f 72 6d 61 6c 2d 70 61 74 68 t* ((normal-path
2270: 20 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 (normalize-path
2280: 6e 61 6d 65 20 74 61 72 67 2d 6d 6b 29 29 0a 20 name targ-mk)).
2290: 20 20 20 20 20 20 20 28 74 61 72 67 2d 70 61 74 (targ-pat
22a0: 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d 64 h (conc target-d
22b0: 69 72 20 22 2f 22 20 6e 6f 72 6d 61 6c 2d 70 61 ir "/" normal-pa
22c0: 74 68 29 29 29 0a 20 20 20 20 28 69 66 20 28 73 th))). (if (s
22d0: 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 20 tring-contains
22e0: 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 22 2e 2e normal-path "..
22f0: 22 29 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 "). (begin.
2300: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2310: 20 30 20 23 66 20 22 45 52 52 4f 52 3a 20 50 61 0 #f "ERROR: Pa
2320: 74 68 20 20 22 20 74 61 72 67 2d 6d 6b 20 22 20 th " targ-mk "
2330: 72 65 73 6f 6c 76 65 64 20 6f 75 74 73 69 64 65 resolved outside
2340: 20 74 61 72 67 65 74 20 61 72 65 61 20 22 20 20 target area "
2350: 74 61 72 67 65 74 2d 64 69 72 20 29 0a 20 20 20 target-dir ).
2360: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 0a 20 (exit 1)))..
2370: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 74 72 (if (not (str
2380: 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 74 61 72 ing-contains tar
2390: 67 2d 70 61 74 68 20 74 61 72 67 65 74 2d 64 69 g-path target-di
23a0: 72 29 29 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 r)). (begin.
23b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
23c0: 74 20 30 20 23 66 20 22 45 52 52 4f 52 3a 20 59 t 0 #f "ERROR: Y
23d0: 6f 75 20 63 61 6e 6e 6f 74 20 75 70 64 61 74 65 ou cannot update
23e0: 20 64 61 74 61 20 6f 75 74 73 69 64 65 20 22 20 data outside "
23f0: 74 61 72 67 65 74 2d 64 69 72 20 22 2e 22 29 0a target-dir ".").
2400: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
2410: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2420: 74 20 30 20 23 66 20 22 50 61 74 68 20 22 20 74 t 0 #f "Path " t
2430: 61 72 67 2d 6d 6b 20 22 20 69 73 20 76 61 6c 69 arg-mk " is vali
2440: 64 2e 22 29 20 20 20 0a 20 29 29 0a 3b 3b 20 6d d.") . )).;; m
2450: 61 6b 65 20 64 69 72 65 63 74 6f 72 79 20 69 6e ake directory in
2460: 20 64 65 73 74 0a 3b 3b 0a 0a 28 64 65 66 69 6e dest.;;..(defin
2470: 65 20 28 73 72 65 74 72 69 65 76 65 3a 6d 6b 64 e (sretrieve:mkd
2480: 69 72 20 63 6f 6e 66 69 67 64 61 74 20 73 75 62 ir configdat sub
2490: 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d 64 69 mitter target-di
24a0: 72 20 74 61 72 67 2d 6d 6b 20 63 6f 6d 6d 65 6e r targ-mk commen
24b0: 74 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 t). (let ((targ
24c0: 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 72 67 -path (conc targ
24d0: 65 74 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d et-dir "/" targ-
24e0: 6d 6b 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 mk))). . (
24f0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
2500: 20 74 61 72 67 2d 70 61 74 68 29 0a 09 28 62 65 targ-path)..(be
2510: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
2520: 69 6e 74 20 30 20 23 66 20 22 45 52 52 4f 52 3a int 0 #f "ERROR:
2530: 20 74 61 72 67 65 74 20 44 69 72 65 63 74 6f 72 target Director
2540: 79 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 20 y " targ-path "
2550: 61 6c 72 65 61 64 79 20 65 78 69 73 74 21 21 22 already exist!!"
2560: 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 0a ).. (exit 1))).
2570: 20 20 20 20 28 73 72 65 74 72 69 65 76 65 3a 64 (sretrieve:d
2580: 62 2d 64 6f 0a 20 20 20 20 20 63 6f 6e 66 69 67 b-do. config
2590: 64 61 74 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 dat. (lambda
25a0: 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 73 72 (db). (sr
25b0: 65 74 72 69 65 76 65 3a 72 65 67 69 73 74 65 72 etrieve:register
25c0: 2d 61 63 74 69 6f 6e 20 64 62 20 22 6d 6b 64 69 -action db "mkdi
25d0: 72 22 20 73 75 62 6d 69 74 74 65 72 20 74 61 72 r" submitter tar
25e0: 67 2d 6d 6b 20 63 6f 6d 6d 65 6e 74 29 29 29 0a g-mk comment))).
25f0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 31 20 (let* ((th1
2600: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 (make-th
2610: 72 65 61 64 0a 09 09 09 20 28 6c 61 6d 62 64 61 read.... (lambda
2620: 20 28 29 0a 09 09 09 20 20 20 28 63 72 65 61 74 ().... (creat
2630: 65 2d 64 69 72 65 63 74 6f 72 79 20 74 61 72 67 e-directory targ
2640: 2d 70 61 74 68 20 23 74 29 0a 09 09 09 20 20 20 -path #t)....
2650: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 (debug:print 0 #
2660: 66 20 22 20 2e 2e 2e 20 64 69 72 20 22 20 74 61 f " ... dir " ta
2670: 72 67 2d 70 61 74 68 20 22 20 63 72 65 61 74 65 rg-path " create
2680: 64 22 29 29 0a 09 09 09 20 22 6d 6b 64 69 72 20 d")).... "mkdir
2690: 74 68 72 65 61 64 22 29 29 0a 09 20 20 20 28 74 thread")).. (t
26a0: 68 32 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 h2 (make
26b0: 2d 74 68 72 65 61 64 0a 09 09 09 20 28 6c 61 6d -thread.... (lam
26c0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 28 6c 65 bda ().... (le
26d0: 74 20 6c 6f 6f 70 20 28 29 0a 09 09 09 20 20 20 t loop ()....
26e0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
26f0: 20 31 35 29 0a 09 09 09 20 20 20 20 20 28 64 69 15).... (di
2700: 73 70 6c 61 79 20 22 2e 22 29 0a 09 09 09 20 20 splay ".")....
2710: 20 20 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 74 (flush-output
2720: 29 0a 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 29 ).... (loop)
2730: 29 29 0a 09 09 09 20 22 61 63 74 69 6f 6e 20 69 )).... "action i
2740: 73 20 68 61 70 70 65 6e 69 6e 67 20 74 68 72 65 s happening thre
2750: 61 64 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 ad"))). (th
2760: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
2770: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
2780: 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 tart! th2).
2790: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
27a0: 68 31 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 23 h1)). (cons #
27b0: 74 20 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 t "Successfully
27c0: 73 61 76 65 64 20 64 61 74 61 22 29 29 29 0a 0a saved data")))..
27d0: 3b 3b 20 63 72 65 61 74 65 20 61 20 73 79 6d 6c ;; create a syml
27e0: 69 6e 6b 20 69 6e 20 64 65 73 74 0a 3b 3b 0a 28 ink in dest.;;.(
27f0: 64 65 66 69 6e 65 20 28 73 72 65 74 72 69 65 76 define (sretriev
2800: 65 3a 6c 6e 20 63 6f 6e 66 69 67 64 61 74 20 73 e:ln configdat s
2810: 75 62 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d ubmitter target-
2820: 64 69 72 20 74 61 72 67 2d 6c 69 6e 6b 20 6c 69 dir targ-link li
2830: 6e 6b 2d 6e 61 6d 65 20 63 6f 6d 6d 65 6e 74 29 nk-name comment)
2840: 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 70 . (let ((targ-p
2850: 61 74 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 ath (conc target
2860: 2d 64 69 72 20 22 2f 22 20 6c 69 6e 6b 2d 6e 61 -dir "/" link-na
2870: 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 me))). (if (f
2880: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
2890: 2d 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 -path)..(begin..
28a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
28b0: 20 23 66 20 22 45 52 52 4f 52 3a 20 74 61 72 67 #f "ERROR: targ
28c0: 65 74 20 66 69 6c 65 20 22 20 74 61 72 67 2d 70 et file " targ-p
28d0: 61 74 68 20 22 20 61 6c 72 65 61 64 79 20 65 78 ath " already ex
28e0: 69 73 74 21 21 22 29 0a 09 20 20 28 65 78 69 74 ist!!").. (exit
28f0: 20 31 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 1))). (if (
2900: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
2910: 3f 20 74 61 72 67 2d 6c 69 6e 6b 20 29 29 0a 09 ? targ-link ))..
2920: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
2930: 3a 70 72 69 6e 74 20 30 20 23 66 20 22 45 52 52 :print 0 #f "ERR
2940: 4f 52 3a 20 74 61 72 67 65 74 20 66 69 6c 65 20 OR: target file
2950: 22 20 74 61 72 67 2d 6c 69 6e 6b 20 22 20 64 6f " targ-link " do
2960: 65 73 20 6e 6f 74 20 65 78 69 73 74 21 21 22 29 es not exist!!")
2970: 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 .. (exit 1))).
2980: 0a 20 20 20 20 28 73 72 65 74 72 69 65 76 65 3a . (sretrieve:
2990: 64 62 2d 64 6f 0a 20 20 20 20 20 63 6f 6e 66 69 db-do. confi
29a0: 67 64 61 74 0a 20 20 20 20 20 28 6c 61 6d 62 64 gdat. (lambd
29b0: 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 73 a (db). (s
29c0: 72 65 74 72 69 65 76 65 3a 72 65 67 69 73 74 65 retrieve:registe
29d0: 72 2d 61 63 74 69 6f 6e 20 64 62 20 22 6c 6e 22 r-action db "ln"
29e0: 20 73 75 62 6d 69 74 74 65 72 20 6c 69 6e 6b 2d submitter link-
29f0: 6e 61 6d 65 20 63 6f 6d 6d 65 6e 74 29 29 29 0a name comment))).
2a00: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 31 20 (let* ((th1
2a10: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 (make-th
2a20: 72 65 61 64 0a 09 09 09 20 28 6c 61 6d 62 64 61 read.... (lambda
2a30: 20 28 29 0a 09 09 09 20 20 20 28 63 72 65 61 74 ().... (creat
2a40: 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 e-symbolic-link
2a50: 74 61 72 67 2d 6c 69 6e 6b 20 74 61 72 67 2d 70 targ-link targ-p
2a60: 61 74 68 20 20 29 0a 09 09 09 20 20 20 28 64 65 ath ).... (de
2a70: 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 bug:print 0 #f "
2a80: 20 2e 2e 2e 20 6c 69 6e 6b 20 22 20 74 61 72 67 ... link " targ
2a90: 2d 70 61 74 68 20 22 20 63 72 65 61 74 65 64 22 -path " created"
2aa0: 29 29 0a 09 09 09 20 22 73 79 6d 6c 69 6e 6b 20 )).... "symlink
2ab0: 74 68 72 65 61 64 22 29 29 0a 09 20 20 20 28 74 thread")).. (t
2ac0: 68 32 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 h2 (make
2ad0: 2d 74 68 72 65 61 64 0a 09 09 09 20 28 6c 61 6d -thread.... (lam
2ae0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 28 6c 65 bda ().... (le
2af0: 74 20 6c 6f 6f 70 20 28 29 0a 09 09 09 20 20 20 t loop ()....
2b00: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
2b10: 20 31 35 29 0a 09 09 09 20 20 20 20 20 28 64 69 15).... (di
2b20: 73 70 6c 61 79 20 22 2e 22 29 0a 09 09 09 20 20 splay ".")....
2b30: 20 20 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 74 (flush-output
2b40: 29 0a 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 29 ).... (loop)
2b50: 29 29 0a 09 09 09 20 22 61 63 74 69 6f 6e 20 69 )).... "action i
2b60: 73 20 68 61 70 70 65 6e 69 6e 67 20 74 68 72 65 s happening thre
2b70: 61 64 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 ad"))). (th
2b80: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
2b90: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
2ba0: 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 tart! th2).
2bb0: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
2bc0: 68 31 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 23 h1)). (cons #
2bd0: 74 20 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 t "Successfully
2be0: 73 61 76 65 64 20 64 61 74 61 22 29 29 29 0a 0a saved data")))..
2bf0: 0a 3b 3b 20 72 65 6d 6f 76 65 20 63 6f 70 79 20 .;; remove copy
2c00: 6f 66 20 66 69 6c 65 20 69 6e 20 64 65 73 74 0a of file in dest.
2c10: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 72 65 74 ;;.(define (sret
2c20: 72 69 65 76 65 3a 72 6d 20 63 6f 6e 66 69 67 64 rieve:rm configd
2c30: 61 74 20 73 75 62 6d 69 74 74 65 72 20 74 61 72 at submitter tar
2c40: 67 65 74 2d 64 69 72 20 74 61 72 67 2d 66 69 6c get-dir targ-fil
2c50: 65 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 6c 65 e comment). (le
2c60: 74 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 63 t ((targ-path (c
2c70: 6f 6e 63 20 74 61 72 67 65 74 2d 64 69 72 20 22 onc target-dir "
2c80: 2f 22 20 74 61 72 67 2d 66 69 6c 65 29 29 29 0a /" targ-file))).
2c90: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
2ca0: 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 2d le-exists? targ-
2cb0: 70 61 74 68 29 29 0a 09 28 62 65 67 69 6e 0a 09 path))..(begin..
2cc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2cd0: 20 23 66 20 22 45 52 52 4f 52 3a 20 74 61 72 67 #f "ERROR: targ
2ce0: 65 74 20 66 69 6c 65 20 22 20 74 61 72 67 2d 70 et file " targ-p
2cf0: 61 74 68 20 22 20 6e 6f 74 20 66 6f 75 6e 64 2c ath " not found,
2d00: 20 6e 6f 74 68 69 6e 67 20 74 6f 20 72 65 6d 6f nothing to remo
2d10: 76 65 2e 22 29 0a 09 20 20 28 65 78 69 74 20 31 ve.").. (exit 1
2d20: 29 29 29 0a 20 20 20 20 28 73 72 65 74 72 69 65 ))). (sretrie
2d30: 76 65 3a 64 62 2d 64 6f 0a 20 20 20 20 20 63 6f ve:db-do. co
2d40: 6e 66 69 67 64 61 74 0a 20 20 20 20 20 28 6c 61 nfigdat. (la
2d50: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
2d60: 20 28 73 72 65 74 72 69 65 76 65 3a 72 65 67 69 (sretrieve:regi
2d70: 73 74 65 72 2d 61 63 74 69 6f 6e 20 64 62 20 22 ster-action db "
2d80: 72 6d 22 20 73 75 62 6d 69 74 74 65 72 20 74 61 rm" submitter ta
2d90: 72 67 2d 66 69 6c 65 20 63 6f 6d 6d 65 6e 74 29 rg-file comment)
2da0: 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 74 )). (let* ((t
2db0: 68 31 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 h1 (make
2dc0: 2d 74 68 72 65 61 64 0a 09 09 09 20 28 6c 61 6d -thread.... (lam
2dd0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 28 64 65 bda ().... (de
2de0: 6c 65 74 65 2d 66 69 6c 65 20 74 61 72 67 2d 70 lete-file targ-p
2df0: 61 74 68 29 0a 09 09 09 20 20 20 28 64 65 62 75 ath).... (debu
2e00: 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 20 2e g:print 0 #f " .
2e10: 2e 2e 20 66 69 6c 65 20 22 20 74 61 72 67 2d 70 .. file " targ-p
2e20: 61 74 68 20 22 20 72 65 6d 6f 76 65 64 22 29 29 ath " removed"))
2e30: 0a 09 09 09 20 22 72 6d 20 74 68 72 65 61 64 22 .... "rm thread"
2e40: 29 29 0a 09 20 20 20 28 74 68 32 20 20 20 20 20 )).. (th2
2e50: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
2e60: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
2e70: 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
2e80: 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 ().... (thre
2e90: 61 64 2d 73 6c 65 65 70 21 20 31 35 29 0a 09 09 ad-sleep! 15)...
2ea0: 09 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 . (display "
2eb0: 2e 22 29 0a 09 09 09 20 20 20 20 20 28 66 6c 75 .").... (flu
2ec0: 73 68 2d 6f 75 74 70 75 74 29 0a 09 09 09 20 20 sh-output)....
2ed0: 20 20 20 28 6c 6f 6f 70 29 29 29 0a 09 09 09 20 (loop)))....
2ee0: 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 70 65 "action is happe
2ef0: 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 29 0a ning thread"))).
2f00: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
2f10: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 art! th1).
2f20: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
2f30: 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h2). (threa
2f40: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 20 20 d-join! th1)).
2f50: 20 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 63 (cons #t "Succ
2f60: 65 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 64 essfully saved d
2f70: 61 74 61 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 ata")))..(define
2f80: 20 28 73 72 65 74 72 69 65 76 65 3a 62 61 63 6b (sretrieve:back
2f90: 75 70 2d 6d 6f 76 65 20 70 61 74 68 29 0a 20 20 up-move path).
2fa0: 28 6c 65 74 2a 20 28 28 74 72 61 73 68 64 69 72 (let* ((trashdir
2fb0: 20 20 28 63 6f 6e 63 20 28 70 61 74 68 6e 61 6d (conc (pathnam
2fc0: 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 74 68 e-directory path
2fd0: 29 20 22 2f 2e 74 72 61 73 68 22 29 29 0a 09 20 ) "/.trash"))..
2fe0: 28 74 72 61 73 68 66 69 6c 65 20 28 63 6f 6e 63 (trashfile (conc
2ff0: 20 74 72 61 73 68 64 69 72 20 22 2f 22 20 28 63 trashdir "/" (c
3000: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3010: 22 2d 22 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 "-" (pathname-fi
3020: 6c 65 20 70 61 74 68 29 29 29 29 0a 20 20 20 20 le path)))).
3030: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
3040: 79 20 74 72 61 73 68 64 69 72 20 23 74 29 0a 20 y trashdir #t).
3050: 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 (if (director
3060: 79 3f 20 70 61 74 68 29 0a 09 28 73 79 73 74 65 y? path)..(syste
3070: 6d 20 28 63 6f 6e 63 20 22 6d 76 20 22 20 70 61 m (conc "mv " pa
3080: 74 68 20 22 20 22 20 74 72 61 73 68 66 69 6c 65 th " " trashfile
3090: 29 29 0a 09 28 66 69 6c 65 2d 6d 6f 76 65 20 70 ))..(file-move p
30a0: 61 74 68 20 74 72 61 73 68 2d 66 69 6c 65 29 29 ath trash-file))
30b0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 72 ))...(define (sr
30c0: 65 74 72 69 65 76 65 3a 6c 73 74 2d 3e 70 61 74 etrieve:lst->pat
30d0: 68 20 70 61 74 68 6c 73 74 29 0a 20 20 28 63 6f h pathlst). (co
30e0: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
30f0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
3100: 63 6f 6e 63 20 70 61 74 68 6c 73 74 29 20 22 2f conc pathlst) "/
3110: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ")))..(define (s
3120: 72 65 74 72 69 65 76 65 3a 70 61 74 68 2d 3e 6c retrieve:path->l
3130: 73 74 20 70 61 74 68 29 0a 20 20 28 73 74 72 69 st path). (stri
3140: 6e 67 2d 73 70 6c 69 74 20 70 61 74 68 20 22 2f ng-split path "/
3150: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 72 "))..(define (sr
3160: 65 74 72 69 65 76 65 3a 70 61 74 68 64 61 74 2d etrieve:pathdat-
3170: 61 70 70 6c 79 2d 68 65 75 72 69 73 74 69 63 73 apply-heuristics
3180: 20 63 6f 6e 66 69 67 64 61 74 20 70 61 74 68 29 configdat path)
3190: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 66 69 . (cond. ((fi
31a0: 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 74 68 29 le-exists? path)
31b0: 20 22 66 6f 75 6e 64 22 29 0a 20 20 20 28 65 6c "found"). (el
31c0: 73 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 20 se (conc path "
31d0: 6e 6f 74 20 69 6e 73 74 61 6c 6c 65 64 22 29 29 not installed"))
31e0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
31f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
3230: 4d 49 53 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d MISC.;;=========
3240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
3280: 64 65 66 69 6e 65 20 28 73 72 65 74 72 69 65 76 define (sretriev
3290: 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d e:do-as-calling-
32a0: 75 73 65 72 20 70 72 6f 63 29 0a 20 20 28 6c 65 user proc). (le
32b0: 74 20 28 28 65 69 64 20 28 63 75 72 72 65 6e 74 t ((eid (current
32c0: 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d -effective-user-
32d0: 69 64 29 29 0a 20 20 20 20 20 20 20 20 28 63 69 id)). (ci
32e0: 64 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d d (current-user-
32f0: 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e id))). (if (n
3300: 6f 74 20 28 65 71 3f 20 65 69 64 20 63 69 64 29 ot (eq? eid cid)
3310: 29 20 3b 3b 20 72 75 6e 6e 69 6e 67 20 73 75 69 ) ;; running sui
3320: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 d. (s
3330: 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 66 66 et! (current-eff
3340: 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 29 20 ective-user-id)
3350: 63 69 64 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 cid)). ;; (de
3360: 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 bug:print 0 #f "
3370: 72 75 6e 6e 69 6e 67 20 61 73 20 22 20 28 63 75 running as " (cu
3380: 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d rrent-effective-
3390: 75 73 65 72 2d 69 64 29 29 0a 20 20 20 20 28 70 user-id)). (p
33a0: 72 6f 63 29 0a 20 20 20 20 28 69 66 20 28 6e 6f roc). (if (no
33b0: 74 20 28 65 71 3f 20 65 69 64 20 63 69 64 29 29 t (eq? eid cid))
33c0: 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 28 . (set! (
33d0: 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 current-effectiv
33e0: 65 2d 75 73 65 72 2d 69 64 29 20 65 69 64 29 29 e-user-id) eid))
33f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 72 65 ))..(define (sre
3400: 74 72 69 65 76 65 3a 66 69 6e 64 20 6e 61 6d 65 trieve:find name
3410: 20 70 61 74 68 73 29 0a 20 20 28 69 66 20 28 6e paths). (if (n
3420: 75 6c 6c 3f 20 70 61 74 68 73 29 0a 20 20 20 20 ull? paths).
3430: 20 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 20 #f. (let
3440: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
3450: 70 61 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 paths))... (tal
3460: 28 63 64 72 20 70 61 74 68 73 29 29 29 0a 09 28 (cdr paths)))..(
3470: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
3480: 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 22 20 6e (conc hed "/" n
3490: 61 6d 65 29 29 0a 09 20 20 20 20 68 65 64 0a 09 ame)).. hed..
34a0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
34b0: 61 6c 29 0a 09 09 23 66 0a 09 09 28 6c 6f 6f 70 al)...#f...(loop
34c0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
34d0: 61 6c 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 al)))))))..(defi
34e0: 6e 65 20 28 73 72 65 74 72 69 65 76 65 3a 73 74 ne (sretrieve:st
34f0: 64 65 72 72 2d 70 72 69 6e 74 20 2e 20 61 72 67 derr-print . arg
3500: 73 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 s). (with-outpu
3510: 74 2d 74 6f 2d 70 6f 72 74 20 28 63 75 72 72 65 t-to-port (curre
3520: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 20 nt-error-port).
3530: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
3540: 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 (apply print
3550: 20 61 72 67 73 29 29 29 29 0a 0a 3b 3b 3d 3d 3d args))))..;;===
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35a0: 3d 3d 3d 0a 3b 3b 20 53 48 45 4c 4c 0a 3b 3b 3d ===.;; SHELL.;;=
35b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35f0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
3600: 74 6f 70 6c 65 76 65 6c 2d 63 6f 6d 6d 61 6e 64 toplevel-command
3610: 20 2e 20 61 72 67 73 29 20 23 66 29 0a 28 64 65 . args) #f).(de
3620: 66 69 6e 65 20 28 73 72 65 74 72 69 65 76 65 3a fine (sretrieve:
3630: 73 68 65 6c 6c 29 0a 20 20 28 75 73 65 20 72 65 shell). (use re
3640: 61 64 6c 69 6e 65 29 0a 20 20 28 6c 65 74 2a 20 adline). (let*
3650: 28 28 70 61 74 68 20 20 20 20 20 20 27 28 29 29 ((path '())
3660: 0a 09 20 28 70 72 6f 6d 70 74 20 20 20 20 22 3e .. (prompt ">
3670: 20 22 29 0a 09 20 28 74 6f 70 2d 61 72 65 61 73 ").. (top-areas
3680: 20 27 28 22 6d 72 77 65 6c 6c 61 6e 22 20 22 70 '("mrwellan" "p
3690: 6a 68 61 74 77 61 6c 22 20 22 62 6a 62 61 72 63 jhatwal" "bjbarc
36a0: 6c 61 22 20 22 72 69 74 69 6b 61 61 67 22 20 22 la" "ritikaag" "
36b0: 6a 6d 6f 6f 6e 31 38 22 29 29 0a 09 20 28 69 70 jmoon18")).. (ip
36c0: 6f 72 74 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 ort (make-re
36d0: 61 64 6c 69 6e 65 2d 70 6f 72 74 20 70 72 6f 6d adline-port prom
36e0: 70 74 29 29 29 0a 20 20 20 20 28 69 6e 73 74 61 pt))). (insta
36f0: 6c 6c 2d 68 69 73 74 6f 72 79 2d 66 69 6c 65 29 ll-history-file)
3700: 20 3b 3b 20 20 5b 68 6f 6d 65 64 69 72 5d 20 5b ;; [homedir] [
3710: 66 69 6c 65 6e 61 6d 65 5d 20 5b 6e 6c 69 6e 65 filename] [nline
3720: 73 5d 29 0a 20 20 20 20 28 77 69 74 68 2d 69 6e s]). (with-in
3730: 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 70 put-from-port ip
3740: 6f 72 74 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 ort. (lambd
3750: 61 20 28 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 a ()..(let loop
3760: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
3770: 29 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 ))).. (if (not
3780: 28 6f 72 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (or (eof-object?
3790: 20 69 6e 6c 29 0a 09 09 20 20 20 20 20 20 20 28 inl)... (
37a0: 65 71 75 61 6c 3f 20 69 6e 6c 20 22 65 78 69 74 equal? inl "exit
37b0: 22 29 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 "))).. (let
37c0: 2a 20 28 28 70 61 72 74 73 20 28 73 74 72 69 6e * ((parts (strin
37d0: 67 2d 73 70 6c 69 74 20 69 6e 6c 29 29 0a 09 09 g-split inl))...
37e0: 20 20 20 20 20 28 63 6d 64 20 20 20 28 69 66 20 (cmd (if
37f0: 28 6e 75 6c 6c 3f 20 70 61 72 74 73 29 20 23 66 (null? parts) #f
3800: 20 28 63 61 72 20 70 61 72 74 73 29 29 29 29 0a (car parts)))).
3810: 09 09 28 69 66 20 28 6e 6f 74 20 63 6d 64 29 0a ..(if (not cmd).
3820: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 .. (loop (rea
3830: 64 2d 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 28 d-line))... (
3840: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
3850: 6d 62 6f 6c 20 63 6d 64 29 0a 09 09 20 20 20 20 mbol cmd)...
3860: 20 20 28 28 63 64 29 0a 09 09 20 20 20 20 20 20 ((cd)...
3870: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
3880: 70 61 72 74 73 29 20 31 29 20 3b 3b 20 68 61 76 parts) 1) ;; hav
3890: 65 20 61 20 70 61 72 61 6d 65 74 65 72 0a 09 09 e a parameter...
38a0: 09 20 20 20 28 73 65 74 21 20 70 61 74 68 20 28 . (set! path (
38b0: 61 70 70 65 6e 64 20 70 61 74 68 20 28 73 74 72 append path (str
38c0: 69 6e 67 2d 73 70 6c 69 74 20 28 63 61 64 72 20 ing-split (cadr
38d0: 70 61 72 74 73 29 29 29 29 20 3b 3b 20 6e 6f 74 parts)))) ;; not
38e0: 20 63 6f 72 72 65 63 74 20 66 6f 72 20 72 65 6c correct for rel
38f0: 61 74 69 76 65 20 70 61 74 68 73 0a 09 09 09 20 ative paths....
3900: 20 20 28 73 65 74 21 20 70 61 74 68 20 27 28 29 (set! path '()
3910: 29 29 29 0a 09 09 20 20 20 20 20 20 28 28 6c 73 )))... ((ls
3920: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a )... (let*
3930: 20 28 28 74 68 65 70 61 74 68 20 28 69 66 20 28 ((thepath (if (
3940: 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 > (length parts)
3950: 20 31 29 20 3b 3b 20 68 61 76 65 20 61 20 70 61 1) ;; have a pa
3960: 72 61 6d 65 74 65 72 0a 09 09 09 09 09 20 20 20 rameter......
3970: 28 63 64 72 20 70 61 72 74 73 29 0a 09 09 09 09 (cdr parts).....
3980: 09 20 20 20 70 61 74 68 29 29 0a 09 09 09 20 20 . path))....
3990: 20 20 20 20 28 70 6c 65 6e 20 20 20 20 28 6c 65 (plen (le
39a0: 6e 67 74 68 20 74 68 65 70 61 74 68 29 29 29 0a ngth thepath))).
39b0: 09 09 09 20 28 63 6f 6e 64 0a 09 09 09 20 20 28 ... (cond.... (
39c0: 28 6e 75 6c 6c 3f 20 74 68 65 70 61 74 68 29 0a (null? thepath).
39d0: 09 09 09 20 20 20 28 70 72 69 6e 74 20 28 73 74 ... (print (st
39e0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
39f0: 20 74 6f 70 2d 61 72 65 61 73 20 22 20 22 29 29 top-areas " "))
3a00: 29 0a 09 09 09 20 20 28 28 61 6e 64 20 28 3c 20 ).... ((and (<
3a10: 70 6c 65 6e 20 32 29 0a 09 09 09 09 28 6d 65 6d plen 2).....(mem
3a20: 62 65 72 20 28 63 61 72 20 74 68 65 70 61 74 68 ber (car thepath
3a30: 29 20 74 6f 70 2d 61 72 65 61 73 29 29 0a 09 09 ) top-areas))...
3a40: 09 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e . (system (con
3a50: 63 20 22 6c 73 20 2f 70 2f 66 64 6b 2f 67 77 61 c "ls /p/fdk/gwa
3a60: 2f 22 20 28 63 61 72 20 74 68 65 70 61 74 68 29 /" (car thepath)
3a70: 29 29 29 0a 09 09 09 20 20 28 65 6c 73 65 20 3b ))).... (else ;
3a80: 3b 20 68 61 76 65 20 61 20 6c 6f 6e 67 20 70 61 ; have a long pa
3a90: 74 68 0a 09 09 09 20 20 20 3b 3b 20 63 68 65 63 th.... ;; chec
3aa0: 6b 20 66 6f 72 20 61 63 63 65 73 73 20 72 69 67 k for access rig
3ab0: 68 74 73 20 68 65 72 65 0a 09 09 09 20 20 20 28 hts here.... (
3ac0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6c 73 system (conc "ls
3ad0: 20 2f 70 2f 66 64 6b 2f 67 77 61 2f 22 20 28 73 /p/fdk/gwa/" (s
3ae0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
3af0: 65 20 74 68 65 70 61 74 68 20 22 2f 22 29 29 29 e thepath "/")))
3b00: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 65 6c ))))... (el
3b10: 73 65 20 0a 09 09 20 20 20 20 20 20 20 28 70 72 se ... (pr
3b20: 69 6e 74 20 22 47 6f 74 20 63 6f 6d 6d 61 6e 64 int "Got command
3b30: 3a 20 22 20 69 6e 6c 29 29 29 29 0a 09 09 28 6c : " inl))))...(l
3b40: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 oop (read-line))
3b50: 29 29 29 29 29 29 29 0a 20 20 20 20 0a 0a 3b 3b ))))))). ..;;
3b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ba0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 41 49 4e 0a 3b ======.;; MAIN.;
3bb0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bf0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
3c00: 20 28 73 72 65 74 72 69 65 76 65 3a 6c 6f 61 64 (sretrieve:load
3c10: 2d 63 6f 6e 66 69 67 20 65 78 65 2d 64 69 72 20 -config exe-dir
3c20: 65 78 65 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 exe-name). (let
3c30: 2a 20 28 28 66 6e 61 6d 65 20 20 20 28 63 6f 6e * ((fname (con
3c40: 63 20 65 78 65 2d 64 69 72 20 22 2f 2e 22 20 65 c exe-dir "/." e
3c50: 78 65 2d 6e 61 6d 65 20 22 2e 63 6f 6e 66 69 67 xe-name ".config
3c60: 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 69 6e 69 "))). ;; (ini
3c70: 3a 70 72 6f 70 65 72 74 79 2d 73 65 70 61 72 61 :property-separa
3c80: 74 6f 72 2d 70 61 74 74 20 22 20 2a 20 20 2a 22 tor-patt " * *"
3c90: 29 0a 20 20 20 20 3b 3b 20 28 69 6e 69 3a 70 72 ). ;; (ini:pr
3ca0: 6f 70 65 72 74 79 2d 73 65 70 61 72 61 74 6f 72 operty-separator
3cb0: 20 23 5c 73 70 61 63 65 29 0a 20 20 20 20 28 69 #\space). (i
3cc0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
3cd0: 66 6e 61 6d 65 29 0a 09 3b 3b 20 28 69 6e 69 3a fname)..;; (ini:
3ce0: 72 65 61 64 2d 69 6e 69 20 66 6e 61 6d 65 29 0a read-ini fname).
3cf0: 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 66 6e .(read-config fn
3d00: 61 6d 65 20 23 66 20 23 74 29 0a 09 28 6d 61 6b ame #f #t)..(mak
3d10: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 e-hash-table))))
3d20: 0a 0a 3b 3b 20 70 61 63 6b 61 67 65 2d 74 79 70 ..;; package-typ
3d30: 65 20 69 73 20 22 6d 65 67 61 74 65 73 74 22 2c e is "megatest",
3d40: 20 22 62 75 69 6c 64 73 22 2c 20 22 6b 69 74 73 "builds", "kits
3d50: 22 20 65 74 63 2e 0a 3b 3b 0a 28 64 65 66 69 6e " etc..;;.(defin
3d60: 65 20 28 73 72 65 74 72 69 65 76 65 3a 6c 6f 61 e (sretrieve:loa
3d70: 64 2d 70 61 63 6b 61 67 65 73 20 63 6f 6e 66 69 d-packages confi
3d80: 67 64 61 74 20 65 78 65 2d 64 69 72 20 70 61 63 gdat exe-dir pac
3d90: 6b 61 67 65 2d 74 79 70 65 29 0a 20 20 28 70 75 kage-type). (pu
3da0: 73 68 2d 64 69 72 65 63 74 6f 72 79 20 65 78 65 sh-directory exe
3db0: 2d 64 69 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 -dir). (let* ((
3dc0: 70 61 63 6b 61 67 65 73 2d 6d 65 74 61 64 69 72 packages-metadir
3dd0: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
3de0: 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 p configdat "set
3df0: 74 69 6e 67 73 22 20 22 70 61 63 6b 61 67 65 73 tings" "packages
3e00: 2d 6d 65 74 61 64 69 72 22 29 29 0a 09 20 28 63 -metadir")).. (c
3e10: 6f 6e 76 65 72 73 69 6f 6e 2d 73 63 72 69 70 74 onversion-script
3e20: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
3e30: 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 74 configdat "sett
3e40: 69 6e 67 73 22 20 22 63 6f 6e 76 65 72 73 69 6f ings" "conversio
3e50: 6e 2d 73 63 72 69 70 74 22 29 29 0a 09 20 28 75 n-script")).. (u
3e60: 70 73 74 72 65 61 6d 2d 66 69 6c 65 20 20 20 20 pstream-file
3e70: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
3e80: 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 74 configdat "sett
3e90: 69 6e 67 73 22 20 22 75 70 73 74 72 65 61 6d 2d ings" "upstream-
3ea0: 66 69 6c 65 22 29 29 0a 09 20 28 70 61 63 6b 61 file")).. (packa
3eb0: 67 65 2d 63 6f 6e 66 69 67 20 20 20 20 28 63 6f ge-config (co
3ec0: 6e 63 20 70 61 63 6b 61 67 65 73 2d 6d 65 74 61 nc packages-meta
3ed0: 64 69 72 20 22 2f 22 20 70 61 63 6b 61 67 65 2d dir "/" package-
3ee0: 74 79 70 65 20 22 2e 63 6f 6e 66 69 67 22 29 29 type ".config"))
3ef0: 29 0a 20 20 20 20 3b 3b 20 74 68 69 73 20 73 65 ). ;; this se
3f00: 63 74 69 6f 6e 20 68 65 72 65 20 64 6f 65 73 20 ction here does
3f10: 61 20 74 69 6d 65 73 74 61 6d 70 20 62 61 73 65 a timestamp base
3f20: 64 20 72 65 62 75 69 6c 64 20 6f 66 20 74 68 65 d rebuild of the
3f30: 0a 20 20 20 20 3b 3b 20 20 20 3c 70 61 63 6b 61 . ;; <packa
3f40: 67 65 73 2d 6d 65 74 61 64 69 72 3e 2f 3c 70 61 ges-metadir>/<pa
3f50: 63 6b 61 67 65 2d 74 79 70 65 3e 2e 63 6f 6e 66 ckage-type>.conf
3f60: 69 67 20 66 69 6c 65 20 75 73 69 6e 67 0a 20 20 ig file using.
3f70: 20 20 3b 3b 20 20 20 3c 75 70 73 74 72 65 61 6d ;; <upstream
3f80: 2d 66 69 6c 65 3e 20 61 73 20 61 6e 20 69 6e 70 -file> as an inp
3f90: 75 74 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 ut. (if (file
3fa0: 2d 65 78 69 73 74 73 3f 20 75 70 73 74 72 65 61 -exists? upstrea
3fb0: 6d 2d 66 69 6c 65 29 0a 09 28 69 66 20 28 6f 72 m-file)..(if (or
3fc0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3fd0: 74 73 3f 20 70 61 63 6b 61 67 65 2d 63 6f 6e 66 ts? package-conf
3fe0: 69 67 29 29 20 3b 3b 20 69 66 20 6e 6f 74 20 63 ig)) ;; if not c
3ff0: 72 65 61 74 65 64 20 63 61 6c 6c 20 74 68 65 20 reated call the
4000: 75 70 64 61 74 65 72 2c 20 6f 74 68 65 72 77 69 updater, otherwi
4010: 73 65 20 63 61 6c 6c 20 6f 6e 6c 79 20 69 66 20 se call only if
4020: 75 70 73 74 72 65 61 6d 20 6e 65 77 65 72 0a 09 upstream newer..
4030: 09 28 3e 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 .(> (file-modifi
4040: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 75 70 73 74 cation-time upst
4050: 72 65 61 6d 2d 66 69 6c 65 29 28 66 69 6c 65 2d ream-file)(file-
4060: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
4070: 65 20 70 61 63 6b 61 67 65 2d 63 6f 6e 66 69 67 e package-config
4080: 29 29 29 0a 09 20 20 20 20 28 68 61 6e 64 6c 65 ))).. (handle
4090: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 -exceptions..
40a0: 20 20 65 78 6e 0a 09 20 20 20 20 20 28 64 65 62 exn.. (deb
40b0: 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 45 ug:print 0 #f "E
40c0: 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 RROR: failed to
40d0: 72 75 6e 20 73 63 72 69 70 74 20 22 20 63 6f 6e run script " con
40e0: 76 65 72 73 69 6f 6e 2d 73 63 72 69 70 74 20 22 version-script "
40f0: 20 77 69 74 68 20 70 61 72 61 6d 73 20 22 20 75 with params " u
4100: 70 73 74 72 65 61 6d 2d 66 69 6c 65 20 22 20 22 pstream-file " "
4110: 20 70 61 63 6b 61 67 65 2d 63 6f 6e 66 69 67 29 package-config)
4120: 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 70 69 .. (let ((pi
4130: 64 20 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 d (process-run c
4140: 6f 6e 76 65 72 73 69 6f 6e 2d 73 63 72 69 70 74 onversion-script
4150: 20 28 6c 69 73 74 20 75 70 73 74 72 65 61 6d 2d (list upstream-
4160: 66 69 6c 65 20 70 61 63 6b 61 67 65 2d 63 6f 6e file package-con
4170: 66 69 67 29 29 29 29 0a 09 20 20 20 20 20 20 20 fig))))..
4180: 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 (process-wait pi
4190: 64 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 d))).. (debug
41a0: 3a 70 72 69 6e 74 20 30 20 23 66 20 22 53 6b 69 :print 0 #f "Ski
41b0: 70 70 69 6e 67 20 75 70 64 61 74 65 20 6f 66 20 pping update of
41c0: 22 20 70 61 63 6b 61 67 65 2d 63 6f 6e 66 69 67 " package-config
41d0: 20 22 20 66 72 6f 6d 20 22 20 75 70 73 74 72 65 " from " upstre
41e0: 61 6d 2d 66 69 6c 65 29 29 0a 09 28 64 65 62 75 am-file))..(debu
41f0: 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 53 6b g:print 0 #f "Sk
4200: 69 70 70 69 6e 67 20 75 70 64 61 74 65 20 6f 66 ipping update of
4210: 20 22 20 70 61 63 6b 61 67 65 2d 63 6f 6e 66 69 " package-confi
4220: 67 20 22 20 61 73 20 22 20 75 70 73 74 72 65 61 g " as " upstrea
4230: 6d 2d 66 69 6c 65 20 22 20 6e 6f 74 20 66 6f 75 m-file " not fou
4240: 6e 64 22 29 29 0a 20 20 20 20 3b 3b 20 28 69 6e nd")). ;; (in
4250: 69 3a 70 72 6f 70 65 72 74 79 2d 73 65 70 61 72 i:property-separ
4260: 61 74 6f 72 2d 70 61 74 74 20 22 20 2a 20 20 2a ator-patt " * *
4270: 22 29 0a 20 20 20 20 3b 3b 20 28 69 6e 69 3a 70 "). ;; (ini:p
4280: 72 6f 70 65 72 74 79 2d 73 65 70 61 72 61 74 6f roperty-separato
4290: 72 20 23 5c 73 70 61 63 65 29 0a 20 20 20 20 28 r #\space). (
42a0: 6c 65 74 20 28 28 72 65 73 20 28 69 66 20 28 66 let ((res (if (f
42b0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 63 6b ile-exists? pack
42c0: 61 67 65 2d 63 6f 6e 66 69 67 29 0a 09 09 20 20 age-config)...
42d0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
42e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 debug:print 0 #f
42f0: 20 22 52 65 61 64 69 6e 67 20 70 61 63 6b 61 67 "Reading packag
4300: 65 20 63 6f 6e 66 69 67 20 22 20 70 61 63 6b 61 e config " packa
4310: 67 65 2d 63 6f 6e 66 69 67 29 0a 09 09 20 20 20 ge-config)...
4320: 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 70 (read-config p
4330: 61 63 6b 61 67 65 2d 63 6f 6e 66 69 67 20 23 66 ackage-config #f
4340: 20 23 74 29 29 0a 09 09 20 20 20 28 6d 61 6b 65 #t))... (make
4350: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a -hash-table)))).
4360: 20 20 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 (pop-direc
4370: 74 6f 72 79 29 0a 20 20 20 20 20 20 72 65 73 29 tory). res)
4380: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 72 65 ))..(define (sre
4390: 74 72 69 65 76 65 3a 70 72 6f 63 65 73 73 2d 61 trieve:process-a
43a0: 63 74 69 6f 6e 20 63 6f 6e 66 69 67 64 61 74 20 ction configdat
43b0: 61 63 74 69 6f 6e 20 2e 20 61 72 67 73 29 0a 20 action . args).
43c0: 20 28 6c 65 74 2a 20 28 28 62 61 73 65 2d 64 69 (let* ((base-di
43d0: 72 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a r (configf:
43e0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
43f0: 20 22 73 65 74 74 69 6e 67 73 22 20 22 62 61 73 "settings" "bas
4400: 65 2d 64 69 72 22 29 29 0a 09 20 28 75 73 65 72 e-dir")).. (user
4410: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
4420: 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 0a 20 nt-user-name)).
4430: 20 20 20 20 20 20 20 20 28 61 6c 6c 6f 77 65 64 (allowed
4440: 2d 73 75 62 2d 70 61 74 68 73 20 28 63 6f 6e 66 -sub-paths (conf
4450: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
4460: 67 64 61 74 20 22 73 65 74 74 69 6e 67 73 22 20 gdat "settings"
4470: 22 61 6c 6c 6f 77 65 64 2d 73 75 62 2d 70 61 74 "allowed-sub-pat
4480: 68 73 22 29 29 20 0a 09 20 28 61 6c 6c 6f 77 65 hs")) .. (allowe
4490: 64 2d 75 73 65 72 73 20 28 73 74 72 69 6e 67 2d d-users (string-
44a0: 73 70 6c 69 74 0a 09 09 09 20 28 6f 72 20 28 63 split.... (or (c
44b0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
44c0: 6e 66 69 67 64 61 74 20 22 73 65 74 74 69 6e 67 nfigdat "setting
44d0: 73 22 20 22 61 6c 6c 6f 77 65 64 2d 75 73 65 72 s" "allowed-user
44e0: 73 22 29 0a 09 09 09 20 20 20 20 20 22 22 29 29 s").... ""))
44f0: 29 0a 09 20 28 64 65 66 61 75 6c 74 2d 61 72 65 ).. (default-are
4500: 61 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b a (configf:look
4510: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 up configdat "se
4520: 74 74 69 6e 67 73 22 20 22 64 65 66 61 75 6c 74 ttings" "default
4530: 2d 61 72 65 61 22 29 29 29 20 3b 3b 20 6f 74 68 -area"))) ;; oth
4540: 65 72 77 69 73 65 20 6b 6e 6f 77 6e 20 61 73 20 erwise known as
4550: 74 68 65 20 70 61 63 6b 61 67 65 0a 20 20 20 20 the package.
4560: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 62 61 . (if (not ba
4570: 73 65 2d 64 69 72 29 0a 09 28 62 65 67 69 6e 0a se-dir)..(begin.
4580: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
4590: 30 20 23 66 20 22 5b 73 65 74 74 69 6e 67 73 5d 0 #f "[settings]
45a0: 5c 6e 62 61 73 65 2d 64 69 72 20 2f 73 6f 6d 65 \nbase-dir /some
45b0: 2f 70 61 74 68 5c 6e 5c 6e 20 49 73 20 4d 49 53 /path\n\n Is MIS
45c0: 53 49 4e 47 20 66 72 6f 6d 20 74 68 65 20 63 6f SING from the co
45d0: 6e 66 69 67 20 66 69 6c 65 21 22 29 0a 09 20 20 nfig file!")..
45e0: 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 69 66 (exit))). (if
45f0: 20 28 6e 75 6c 6c 3f 20 61 6c 6c 6f 77 65 64 2d (null? allowed-
4600: 75 73 65 72 73 29 0a 09 28 62 65 67 69 6e 0a 09 users)..(begin..
4610: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4620: 20 23 66 20 22 5b 73 65 74 69 6e 67 73 5d 5c 6e #f "[setings]\n
4630: 61 6c 6c 6f 77 65 64 2d 75 73 65 72 73 20 75 73 allowed-users us
4640: 65 72 31 20 75 73 65 72 32 20 2e 2e 2e 5c 6e 5c er1 user2 ...\n\
4650: 6e 20 49 73 20 4d 49 53 53 49 4e 47 20 66 72 6f n Is MISSING fro
4660: 6d 20 74 68 65 20 63 6f 6e 66 69 67 20 66 69 6c m the config fil
4670: 65 21 22 29 0a 09 20 20 28 65 78 69 74 29 29 29 e!").. (exit)))
4680: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d . (if (not (m
4690: 65 6d 62 65 72 20 75 73 65 72 20 61 6c 6c 6f 77 ember user allow
46a0: 65 64 2d 75 73 65 72 73 29 29 0a 09 28 62 65 67 ed-users))..(beg
46b0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
46c0: 6e 74 20 30 20 23 66 20 22 55 73 65 72 20 5c 22 nt 0 #f "User \"
46d0: 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d " (current-user-
46e0: 6e 61 6d 65 29 20 22 5c 22 20 64 6f 65 73 20 6e name) "\" does n
46f0: 6f 74 20 68 61 76 65 20 61 63 63 65 73 73 2e 20 ot have access.
4700: 45 78 69 74 69 6e 67 22 29 0a 09 20 20 28 65 78 Exiting").. (ex
4710: 69 74 20 31 29 29 29 0a 20 20 20 20 28 63 61 73 it 1))). (cas
4720: 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
4730: 6c 20 61 63 74 69 6f 6e 29 0a 20 20 20 20 20 20 l action).
4740: 28 28 67 65 74 29 0a 20 20 20 20 20 20 20 28 69 ((get). (i
4750: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 f (< (length arg
4760: 73 29 20 31 29 0a 09 20 20 20 28 62 65 67 69 6e s) 1).. (begin
4770: 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
4780: 72 69 6e 74 20 30 20 23 66 20 22 45 52 52 4f 52 rint 0 #f "ERROR
4790: 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 : Missing argume
47a0: 6e 74 73 3b 20 22 20 28 73 74 72 69 6e 67 2d 69 nts; " (string-i
47b0: 6e 74 65 72 73 70 65 72 73 65 20 61 72 67 73 20 ntersperse args
47c0: 22 2c 20 22 29 29 0a 09 20 20 20 20 20 28 65 78 ", ")).. (ex
47d0: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 28 it 1))). (
47e0: 6c 65 74 2a 20 28 28 72 65 6d 61 72 67 73 20 20 let* ((remargs
47f0: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
4800: 73 20 61 72 67 73 20 27 28 22 2d 6d 22 20 22 2d s args '("-m" "-
4810: 69 22 20 22 2d 70 61 63 6b 61 67 65 22 29 20 27 i" "-package") '
4820: 28 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 () args:arg-hash
4830: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
4840: 20 20 20 28 76 65 72 73 69 6f 6e 20 20 20 20 20 (version
4850: 28 63 61 72 20 61 72 67 73 29 29 0a 09 20 20 20 (car args))..
4860: 20 20 20 28 6d 73 67 20 20 20 20 20 20 20 20 20 (msg
4870: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
4880: 67 20 22 2d 6d 22 29 20 22 22 29 29 0a 09 20 20 g "-m") ""))..
4890: 20 20 20 20 28 70 61 63 6b 61 67 65 2d 74 79 70 (package-typ
48a0: 65 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d e (or (args:get-
48b0: 61 72 67 20 22 2d 70 61 63 6b 61 67 65 22 29 0a arg "-package").
48c0: 09 09 09 09 64 65 66 61 75 6c 74 2d 61 72 65 61 ....default-area
48d0: 29 29 0a 09 20 20 20 20 20 20 28 65 78 65 2d 64 )).. (exe-d
48e0: 69 72 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a ir (configf:
48f0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
4900: 20 22 65 78 65 2d 69 6e 66 6f 22 20 22 65 78 65 "exe-info" "exe
4910: 2d 64 69 72 22 29 29 29 0a 3b 3b 09 20 20 20 20 -dir"))).;;.
4920: 20 20 28 72 65 6c 63 6f 6e 66 69 67 20 20 20 28 (relconfig (
4930: 73 72 65 74 72 69 65 76 65 3a 6c 6f 61 64 2d 70 sretrieve:load-p
4940: 61 63 6b 61 67 65 73 20 63 6f 6e 66 69 67 64 61 ackages configda
4950: 74 20 65 78 65 2d 64 69 72 20 70 61 63 6b 61 67 t exe-dir packag
4960: 65 2d 74 79 70 65 29 29 29 0a 0a 09 20 28 64 65 e-type)))... (de
4970: 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 bug:print 0 #f "
4980: 72 65 74 72 69 65 76 69 6e 67 20 22 20 76 65 72 retrieving " ver
4990: 73 69 6f 6e 20 22 20 6f 66 20 22 20 70 61 63 6b sion " of " pack
49a0: 61 67 65 2d 74 79 70 65 20 22 20 61 73 20 74 61 age-type " as ta
49b0: 72 20 64 61 74 61 20 6f 6e 20 73 74 64 6f 75 74 r data on stdout
49c0: 22 29 0a 09 20 28 73 72 65 74 72 69 65 76 65 3a ").. (sretrieve:
49d0: 67 65 74 20 63 6f 6e 66 69 67 64 61 74 20 75 73 get configdat us
49e0: 65 72 20 76 65 72 73 69 6f 6e 20 6d 73 67 29 29 er version msg))
49f0: 29 0a 20 20 20 20 20 20 20 20 20 28 28 63 70 29 ). ((cp)
4a00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
4a10: 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 73 (< (length args
4a20: 29 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) 1).
4a30: 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 (begin ..
4a40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 (debug:print 0 #
4a50: 66 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e f "ERROR: Missin
4a60: 67 20 61 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 g arguments; " (
4a70: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
4a80: 73 65 20 61 72 67 73 20 22 2c 20 22 29 29 0a 09 se args ", "))..
4a90: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
4aa0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
4ab0: 28 28 72 65 6d 61 72 67 73 20 20 20 20 20 28 61 ((remargs (a
4ac0: 72 67 73 3a 67 65 74 2d 61 72 67 73 20 61 72 67 rgs:get-args arg
4ad0: 73 20 27 28 22 2d 6d 22 20 22 2d 69 22 20 22 2d s '("-m" "-i" "-
4ae0: 70 61 63 6b 61 67 65 22 29 20 27 28 29 20 61 72 package") '() ar
4af0: 67 73 3a 61 72 67 2d 68 61 73 68 20 30 29 29 0a gs:arg-hash 0)).
4b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
4b10: 69 6c 65 20 20 20 20 20 28 63 61 72 20 61 72 67 ile (car arg
4b20: 73 29 29 0a 09 20 20 20 20 20 20 28 6d 73 67 20 s)).. (msg
4b30: 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 (or (arg
4b40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 s:get-arg "-m")
4b50: 22 22 29 29 20 29 0a 0a 09 20 28 64 65 62 75 67 "")) )... (debug
4b60: 3a 70 72 69 6e 74 20 30 20 23 66 20 22 63 6f 70 :print 0 #f "cop
4b70: 69 6e 67 69 6e 67 20 22 20 66 69 6c 65 20 22 20 inging " file "
4b80: 74 6f 20 63 75 72 72 65 6e 74 20 64 69 72 65 63 to current direc
4b90: 74 6f 72 79 20 22 20 29 0a 09 20 28 73 72 65 74 tory " ).. (sret
4ba0: 72 69 65 76 65 3a 63 70 20 63 6f 6e 66 69 67 64 rieve:cp configd
4bb0: 61 74 20 75 73 65 72 20 66 69 6c 65 20 6d 73 67 at user file msg
4bc0: 29 29 29 0a 20 20 20 20 20 20 28 28 6c 73 29 0a ))). ((ls).
4bd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
4be0: 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 (< (length args)
4bf0: 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1).
4c00: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 28 (begin .. (
4c10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 23 66 debug:print 0 #f
4c20: 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 "ERROR: Missing
4c30: 20 61 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 arguments; " (s
4c40: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
4c50: 65 20 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 e args ", "))..
4c60: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 (exit 1))).
4c70: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
4c80: 28 72 65 6d 61 72 67 73 20 20 20 20 20 28 61 72 (remargs (ar
4c90: 67 73 3a 67 65 74 2d 61 72 67 73 20 61 72 67 73 gs:get-args args
4ca0: 20 27 28 22 2d 6d 22 20 22 2d 69 22 20 22 2d 70 '("-m" "-i" "-p
4cb0: 61 63 6b 61 67 65 22 29 20 27 28 29 20 61 72 67 ackage") '() arg
4cc0: 73 3a 61 72 67 2d 68 61 73 68 20 30 29 29 0a 20 s:arg-hash 0)).
4cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 (di
4ce0: 72 20 20 20 20 20 28 63 61 72 20 61 72 67 73 29 r (car args)
4cf0: 29 0a 09 20 20 20 20 20 20 28 6d 73 67 20 20 20 ).. (msg
4d00: 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a (or (args:
4d10: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 22 22 get-arg "-m") ""
4d20: 29 29 20 29 0a 0a 09 20 28 64 65 62 75 67 3a 70 )) )... (debug:p
4d30: 72 69 6e 74 20 30 20 23 66 20 22 4c 69 73 74 69 rint 0 #f "Listi
4d40: 6e 67 20 66 69 6c 65 73 20 69 6e 20 22 20 29 0a ng files in " ).
4d50: 09 20 28 73 72 65 74 72 69 65 76 65 3a 6c 73 20 . (sretrieve:ls
4d60: 63 6f 6e 66 69 67 64 61 74 20 75 73 65 72 20 64 configdat user d
4d70: 69 72 20 6d 73 67 29 29 29 0a 20 0a 20 20 20 20 ir msg))). .
4d80: 20 20 28 65 6c 73 65 20 28 64 65 62 75 67 3a 70 (else (debug:p
4d90: 72 69 6e 74 20 30 20 23 66 20 22 55 6e 72 65 63 rint 0 #f "Unrec
4da0: 6f 67 6e 69 73 65 64 20 63 6f 6d 6d 61 6e 64 20 ognised command
4db0: 22 20 61 63 74 69 6f 6e 29 29 29 29 29 0a 20 20 " action))))).
4dc0: 0a 3b 3b 20 65 61 73 65 20 64 65 62 75 67 67 69 .;; ease debuggi
4dd0: 6e 67 20 62 79 20 6c 6f 61 64 69 6e 67 20 7e 2f ng by loading ~/
4de0: 2e 64 61 73 68 62 6f 61 72 64 72 63 20 2d 20 52 .dashboardrc - R
4df0: 45 4d 4f 56 45 20 46 52 4f 4d 20 50 52 4f 44 55 EMOVE FROM PRODU
4e00: 43 54 49 4f 4e 21 0a 3b 3b 20 28 6c 65 74 20 28 CTION!.;; (let (
4e10: 28 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 20 28 (debugcontrolf (
4e20: 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f conc (get-enviro
4e30: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
4e40: 48 4f 4d 45 22 29 20 22 2f 2e 73 72 65 74 72 69 HOME") "/.sretri
4e50: 65 76 65 72 63 22 29 29 29 0a 3b 3b 20 20 20 28 everc"))).;; (
4e60: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
4e70: 20 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 29 0a debugcontrolf).
4e80: 3b 3b 20 20 20 20 20 20 20 28 6c 6f 61 64 20 64 ;; (load d
4e90: 65 62 75 67 63 6f 6e 74 72 6f 6c 66 29 29 29 0a ebugcontrolf))).
4ea0: 0a 28 64 65 66 69 6e 65 20 28 6d 61 69 6e 29 0a .(define (main).
4eb0: 20 20 28 6c 65 74 2a 20 28 28 61 72 67 73 20 20 (let* ((args
4ec0: 20 20 20 20 28 61 72 67 76 29 29 0a 09 20 28 70 (argv)).. (p
4ed0: 72 6f 67 20 20 20 20 20 20 28 63 61 72 20 61 72 rog (car ar
4ee0: 67 73 29 29 0a 09 20 28 72 65 6d 61 20 20 20 20 gs)).. (rema
4ef0: 20 20 28 63 64 72 20 61 72 67 73 29 29 0a 09 20 (cdr args))..
4f00: 28 65 78 65 2d 6e 61 6d 65 20 20 28 70 61 74 68 (exe-name (path
4f10: 6e 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 name-file (car (
4f20: 61 72 67 76 29 29 29 29 0a 09 20 28 65 78 65 2d argv)))).. (exe-
4f30: 64 69 72 20 20 20 28 6f 72 20 28 70 61 74 68 6e dir (or (pathn
4f40: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 70 72 ame-directory pr
4f50: 6f 67 29 0a 09 09 09 28 73 72 65 74 72 69 65 76 og)....(sretriev
4f60: 65 3a 66 69 6e 64 20 65 78 65 2d 6e 61 6d 65 20 e:find exe-name
4f70: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 67 (string-split (g
4f80: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
4f90: 61 72 69 61 62 6c 65 20 22 50 41 54 48 22 29 20 ariable "PATH")
4fa0: 22 3a 22 29 29 29 29 0a 09 20 28 63 6f 6e 66 69 ":")))).. (confi
4fb0: 67 64 61 74 20 28 73 72 65 74 72 69 65 76 65 3a gdat (sretrieve:
4fc0: 6c 6f 61 64 2d 63 6f 6e 66 69 67 20 65 78 65 2d load-config exe-
4fd0: 64 69 72 20 65 78 65 2d 6e 61 6d 65 29 29 29 0a dir exe-name))).
4fe0: 20 20 20 20 3b 3b 20 70 72 65 73 65 72 76 65 20 ;; preserve
4ff0: 74 68 65 20 65 78 65 20 64 61 74 61 20 69 6e 20 the exe data in
5000: 74 68 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 0a the config file.
5010: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
5020: 73 65 74 21 20 63 6f 6e 66 69 67 64 61 74 20 22 set! configdat "
5030: 65 78 65 2d 69 6e 66 6f 22 20 28 6c 69 73 74 20 exe-info" (list
5040: 28 6c 69 73 74 20 22 65 78 65 2d 6e 61 6d 65 22 (list "exe-name"
5050: 20 65 78 65 2d 6e 61 6d 65 29 0a 09 09 09 09 09 exe-name)......
5060: 09 28 6c 69 73 74 20 22 65 78 65 2d 64 69 72 22 .(list "exe-dir"
5070: 20 20 65 78 65 2d 64 69 72 29 29 29 0a 20 20 20 exe-dir))).
5080: 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 20 6f (cond. ;; o
5090: 6e 65 2d 77 6f 72 64 20 63 6f 6d 6d 61 6e 64 73 ne-word commands
50a0: 0a 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e . ((eq? (len
50b0: 67 74 68 20 72 65 6d 61 29 20 31 29 0a 20 20 20 gth rema) 1).
50c0: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
50d0: 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 72 20 72 65 ->symbol (car re
50e0: 6d 61 29 29 0a 09 28 28 68 65 6c 70 20 2d 68 20 ma))..((help -h
50f0: 2d 68 65 6c 70 20 2d 2d 68 20 2d 2d 68 65 6c 70 -help --h --help
5100: 29 0a 09 20 28 70 72 69 6e 74 20 73 72 65 74 72 ).. (print sretr
5110: 69 65 76 65 3a 68 65 6c 70 29 29 0a 09 28 28 6c ieve:help))..((l
5120: 69 73 74 2d 76 61 72 73 29 20 3b 3b 20 70 72 69 ist-vars) ;; pri
5130: 6e 74 20 6f 75 74 20 74 68 65 20 69 6e 69 20 66 nt out the ini f
5140: 69 6c 65 0a 09 20 28 6d 61 70 20 70 72 69 6e 74 ile.. (map print
5150: 20 28 73 72 65 74 72 69 65 76 65 3a 67 65 74 2d (sretrieve:get-
5160: 61 72 65 61 73 20 63 6f 6e 66 69 67 64 61 74 29 areas configdat)
5170: 29 29 0a 09 28 28 6c 73 29 0a 09 20 28 6c 65 74 ))..((ls).. (let
5180: 2a 20 28 28 62 61 73 65 2d 64 69 72 20 28 63 6f * ((base-dir (co
5190: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
51a0: 66 69 67 64 61 74 20 22 73 65 74 74 69 6e 67 73 figdat "settings
51b0: 22 20 22 62 61 73 65 2d 64 69 72 22 29 29 29 0a " "base-dir"))).
51c0: 09 20 20 20 28 69 66 20 62 61 73 65 2d 64 69 72 . (if base-dir
51d0: 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
51e0: 09 09 20 28 70 72 69 6e 74 20 22 46 69 6c 65 73 .. (print "Files
51f0: 20 69 6e 20 22 20 62 61 73 65 2d 64 69 72 29 0a in " base-dir).
5200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5210: 20 28 73 72 65 74 72 69 65 76 65 3a 64 6f 2d 61 (sretrieve:do-a
5220: 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 s-calling-user.
5230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5240: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
5250: 20 28 70 72 6f 63 65 73 73 2d 65 78 65 63 75 74 (process-execut
5260: 65 20 22 2f 62 69 6e 2f 6c 73 22 20 28 6c 69 73 e "/bin/ls" (lis
5270: 74 20 22 2d 6c 72 74 22 20 62 61 73 65 2d 64 69 t "-lrt" base-di
5280: 72 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 r))))).. (
5290: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 4e 6f print "ERROR: No
52a0: 20 62 61 73 65 20 64 69 72 20 73 70 65 63 69 66 base dir specif
52b0: 69 65 64 21 22 29 29 29 29 0a 09 28 28 6c 6f 67 ied!"))))..((log
52c0: 29 0a 09 20 28 73 72 65 74 72 69 65 76 65 3a 64 ).. (sretrieve:d
52d0: 62 2d 64 6f 20 63 6f 6e 66 69 67 64 61 74 20 28 b-do configdat (
52e0: 6c 61 6d 62 64 61 20 28 64 62 29 0a 09 09 09 09 lambda (db).....
52f0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 4c 6f 67 (print "Log
5300: 73 20 3a 20 22 29 0a 09 09 09 09 20 20 20 20 20 s : ").....
5310: 28 71 75 65 72 79 20 28 66 6f 72 2d 65 61 63 68 (query (for-each
5320: 2d 72 6f 77 0a 09 09 09 09 09 20 20 20 20 20 28 -row...... (
5330: 6c 61 6d 62 64 61 20 28 72 6f 77 29 0a 09 09 09 lambda (row)....
5340: 09 09 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 .. (apply
5350: 70 72 69 6e 74 20 28 69 6e 74 65 72 73 70 65 72 print (intersper
5360: 73 65 20 72 6f 77 20 22 20 7c 20 22 29 29 29 29 se row " | "))))
5370: 0a 09 09 09 09 09 20 20 20 20 28 73 71 6c 20 64 ...... (sql d
5380: 62 20 22 53 45 4c 45 43 54 20 2a 20 46 52 4f 4d b "SELECT * FROM
5390: 20 61 63 74 69 6f 6e 73 22 29 29 29 29 29 0a 09 actions")))))..
53a0: 28 28 73 68 65 6c 6c 29 0a 09 20 28 73 72 65 74 ((shell).. (sret
53b0: 72 69 65 76 65 3a 73 68 65 6c 6c 29 29 0a 09 28 rieve:shell))..(
53c0: 65 6c 73 65 0a 09 20 28 70 72 69 6e 74 20 22 45 else.. (print "E
53d0: 52 52 4f 52 3a 20 55 6e 72 65 63 6f 67 6e 69 73 RROR: Unrecognis
53e0: 65 64 20 63 6f 6d 6d 61 6e 64 2e 20 54 72 79 20 ed command. Try
53f0: 5c 22 73 72 65 74 72 69 65 76 65 20 68 65 6c 70 \"sretrieve help
5400: 5c 22 22 29 29 29 29 0a 20 20 20 20 20 3b 3b 20 \"")))). ;;
5410: 6d 75 6c 74 69 2d 77 6f 72 64 20 63 6f 6d 6d 61 multi-word comma
5420: 6e 64 73 0a 20 20 20 20 20 28 28 6e 75 6c 6c 3f nds. ((null?
5430: 20 72 65 6d 61 29 28 70 72 69 6e 74 20 73 72 65 rema)(print sre
5440: 74 72 69 65 76 65 3a 68 65 6c 70 29 29 0a 20 20 trieve:help)).
5450: 20 20 20 28 28 3e 3d 20 28 6c 65 6e 67 74 68 20 ((>= (length
5460: 72 65 6d 61 29 20 32 29 0a 20 20 20 20 20 20 28 rema) 2). (
5470: 61 70 70 6c 79 20 73 72 65 74 72 69 65 76 65 3a apply sretrieve:
5480: 70 72 6f 63 65 73 73 2d 61 63 74 69 6f 6e 20 63 process-action c
5490: 6f 6e 66 69 67 64 61 74 20 28 63 61 72 20 72 65 onfigdat (car re
54a0: 6d 61 29 28 63 64 72 20 72 65 6d 61 29 29 29 0a ma)(cdr rema))).
54b0: 20 20 20 20 20 28 65 6c 73 65 20 28 64 65 62 75 (else (debu
54c0: 67 3a 70 72 69 6e 74 20 30 20 23 66 20 22 45 52 g:print 0 #f "ER
54d0: 52 4f 52 3a 20 55 6e 72 65 63 6f 67 6e 69 73 65 ROR: Unrecognise
54e0: 64 20 63 6f 6d 6d 61 6e 64 2e 20 54 72 79 20 5c d command. Try \
54f0: 22 73 72 65 74 72 69 65 76 65 20 68 65 6c 70 5c "sretrieve help\
5500: 22 22 29 29 29 29 29 0a 0a 28 6d 61 69 6e 29 0a "")))))..(main).