Artifact
8dcb81c313ea12a436ac7fe7fdb275e7fc96e6a9:
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 28 75 73 65 20 defstruct).(use
0160: 73 63 73 68 2d 70 72 6f 63 65 73 73 29 0a 0a 28 scsh-process)..(
0170: 75 73 65 20 72 65 66 64 62 29 0a 0a 0a 3b 3b 20 use refdb)...;;
0180: 28 75 73 65 20 73 73 61 78 29 0a 3b 3b 20 28 75 (use ssax).;; (u
0190: 73 65 20 73 78 6d 6c 2d 73 65 72 69 61 6c 69 7a se sxml-serializ
01a0: 65 72 29 0a 3b 3b 20 28 75 73 65 20 73 78 6d 6c er).;; (use sxml
01b0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 73 29 0a -modifications).
01c0: 3b 3b 20 28 75 73 65 20 72 65 67 65 78 29 0a 3b ;; (use regex).;
01d0: 3b 20 28 75 73 65 20 73 72 66 69 2d 36 39 29 0a ; (use srfi-69).
01e0: 3b 3b 20 28 75 73 65 20 72 65 67 65 78 2d 63 61 ;; (use regex-ca
01f0: 73 65 29 0a 3b 3b 20 28 75 73 65 20 70 6f 73 69 se).;; (use posi
0200: 78 29 0a 3b 3b 20 28 75 73 65 20 6a 73 6f 6e 29 x).;; (use json)
0210: 0a 3b 3b 20 28 75 73 65 20 63 73 76 29 0a 28 75 .;; (use csv).(u
0220: 73 65 20 73 72 66 69 2d 31 38 29 0a 28 75 73 65 se srfi-18).(use
0230: 20 73 72 66 69 2d 31 39 29 0a 0a 28 75 73 65 20 srfi-19)..(use
0240: 66 6f 72 6d 61 74 29 0a 0a 3b 3b 20 28 72 65 71 format)..;; (req
0250: 75 69 72 65 2d 6c 69 62 72 61 72 79 20 69 6e 69 uire-library ini
0260: 2d 66 69 6c 65 29 0a 3b 3b 20 28 69 6d 70 6f 72 -file).;; (impor
0270: 74 20 28 70 72 65 66 69 78 20 69 6e 69 2d 66 69 t (prefix ini-fi
0280: 6c 65 20 69 6e 69 3a 29 29 0a 0a 28 75 73 65 20 le ini:))..(use
0290: 73 71 6c 2d 64 65 2d 6c 69 74 65 20 73 72 66 69 sql-de-lite srfi
02a0: 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 72 -1 posix regex r
02b0: 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d 36 egex-case srfi-6
02c0: 39 29 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 28 70 9).;; (import (p
02d0: 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 refix sqlite3 sq
02e0: 6c 69 74 65 33 3a 29 29 0a 3b 3b 20 0a 28 64 65 lite3:)).;; .(de
02f0: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 clare (uses conf
0300: 69 67 66 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 igf)).;; (declar
0310: 65 20 28 75 73 65 73 20 74 72 65 65 29 29 0a 28 e (uses tree)).(
0320: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 61 declare (uses ma
0330: 72 67 73 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 rgs)).;; (declar
0340: 65 20 28 75 73 65 73 20 64 63 6f 6d 6d 6f 6e 29 e (uses dcommon)
0350: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0360: 73 65 73 20 6c 61 75 6e 63 68 29 29 0a 3b 3b 20 ses launch)).;;
0370: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 67 (declare (uses g
0380: 75 74 69 6c 73 29 29 0a 3b 3b 20 28 64 65 63 6c utils)).;; (decl
0390: 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 3b are (uses db)).;
03a0: 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ; (declare (uses
03b0: 20 73 79 6e 63 68 61 73 68 29 29 0a 3b 3b 20 28 synchash)).;; (
03c0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 declare (uses se
03d0: 72 76 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 rver)).(declare
03e0: 28 75 73 65 73 20 6d 65 67 61 74 65 73 74 2d 76 (uses megatest-v
03f0: 65 72 73 69 6f 6e 29 29 0a 3b 3b 20 28 64 65 63 ersion)).;; (dec
0400: 6c 61 72 65 20 28 75 73 65 73 20 74 62 64 29 29 lare (uses tbd))
0410: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 6d 65 67 61 ..(include "mega
0420: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
0430: 2e 73 63 6d 22 29 0a 3b 3b 3b 20 70 6c 65 61 73 .scm").;;; pleas
0440: 65 20 63 72 65 61 74 65 20 74 68 69 73 20 66 69 e create this fi
0450: 6c 65 20 62 65 66 6f 72 65 20 75 73 69 6e 67 20 le before using
0460: 73 61 75 74 68 65 72 69 73 65 2e 20 46 6f 72 20 sautherise. For
0470: 73 61 6d 70 6c 65 20 66 69 6c 65 20 69 73 20 61 sample file is a
0480: 76 61 6c 69 61 62 6c 65 20 73 61 6d 70 6c 65 2d valiable sample-
0490: 73 61 75 74 68 2d 70 61 74 68 73 2e 73 63 6d 2e sauth-paths.scm.
04a0: 20 0a 28 69 6e 63 6c 75 64 65 20 22 73 61 75 74 .(include "saut
04b0: 68 2d 70 61 74 68 73 2e 73 63 6d 22 29 0a 28 69 h-paths.scm").(i
04c0: 6e 63 6c 75 64 65 20 22 73 61 75 74 68 2d 63 6f nclude "sauth-co
04d0: 6d 6d 6f 6e 2e 73 63 6d 22 29 0a 0a 0a 3b 3b 0a mmon.scm")...;;.
04e0: 3b 3b 20 47 4c 4f 42 41 4c 53 0a 3b 3b 0a 28 64 ;; GLOBALS.;;.(d
04f0: 65 66 69 6e 65 20 2a 73 70 75 62 6c 69 73 68 3a efine *spublish:
0500: 63 75 72 72 65 6e 74 2d 74 61 62 2d 6e 75 6d 62 current-tab-numb
0510: 65 72 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a er* 0).(define *
0520: 61 72 67 73 2d 68 61 73 68 2a 20 28 6d 61 6b 65 args-hash* (make
0530: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
0540: 65 66 69 6e 65 20 73 70 75 62 6c 69 73 68 3a 68 efine spublish:h
0550: 65 6c 70 20 28 63 6f 6e 63 20 22 55 73 61 67 65 elp (conc "Usage
0560: 3a 20 73 70 75 62 6c 69 73 68 20 5b 61 63 74 69 : spublish [acti
0570: 6f 6e 20 5b 70 61 72 61 6d 73 20 2e 2e 2e 5d 5d on [params ...]]
0580: 0a 0a 20 20 6c 73 20 20 20 20 20 20 20 20 20 20 .. ls
0590: 20 20 20 20 20 20 20 20 20 20 20 3a 20 6c 69 73 : lis
05a0: 74 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 74 61 t contents of ta
05b0: 72 67 65 74 20 61 72 65 61 0a 20 20 63 70 7c 70 rget area. cp|p
05c0: 75 62 6c 69 73 68 20 3c 73 72 63 20 66 69 6c 65 ublish <src file
05d0: 3e 20 3c 64 65 73 74 69 6e 61 74 69 6f 6e 3e 20 > <destination>
05e0: 20 20 20 20 20 3a 20 63 6f 70 79 20 66 69 6c 65 : copy file
05f0: 20 74 6f 20 74 61 72 67 65 74 20 61 72 65 61 0a to target area.
0600: 20 20 6d 6b 64 69 72 20 3c 64 69 72 20 6e 61 6d mkdir <dir nam
0610: 65 3e 20 20 20 20 20 20 20 3a 20 6d 61 6b 73 20 e> : maks
0620: 64 69 72 65 63 74 6f 72 79 20 69 6e 20 74 61 72 directory in tar
0630: 67 65 74 20 61 72 65 61 20 20 0a 20 20 72 6d 20 get area . rm
0640: 3c 66 69 6c 65 3e 20 20 20 20 20 20 20 20 20 20 <file>
0650: 20 20 20 20 3a 20 72 65 6d 6f 76 65 20 66 69 6c : remove fil
0660: 65 20 3c 66 69 6c 65 3e 20 66 72 6f 6d 20 74 61 e <file> from ta
0670: 72 67 65 74 20 61 72 65 61 0a 20 20 6c 6e 20 3c rget area. ln <
0680: 74 61 72 67 65 74 3e 20 3c 6c 69 6e 6b 20 6e 61 target> <link na
0690: 6d 65 3e 20 3a 20 63 72 65 61 74 65 73 20 61 20 me> : creates a
06a0: 73 79 6d 6c 69 6e 6b 0a 20 20 6c 6f 67 20 20 20 symlink. log
06b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06c0: 20 3a 0a 0a 20 20 6f 70 74 69 6f 6e 73 3a 0a 0a :.. options:..
06d0: 20 20 20 20 2d 6d 20 5c 22 6d 65 73 73 61 67 65 -m \"message
06e0: 5c 22 20 20 20 20 20 20 20 20 3a 20 64 65 73 63 \" : desc
06f0: 72 69 62 65 20 77 68 61 74 20 77 61 73 20 64 6f ribe what was do
0700: 6e 65 0a 4e 6f 74 65 3a 20 41 6c 6c 20 74 68 65 ne.Note: All the
0710: 20 74 61 72 67 65 74 20 6c 6f 63 61 74 69 6f 6e target location
0720: 73 20 72 65 6c 61 74 69 76 65 20 74 6f 20 62 61 s relative to ba
0730: 73 65 20 70 61 74 68 20 0a 50 61 72 74 20 6f 66 se path .Part of
0740: 20 74 68 65 20 4d 65 67 61 74 65 73 74 20 74 6f the Megatest to
0750: 6f 6c 20 73 75 69 74 65 2e 0a 4c 65 61 72 6e 20 ol suite..Learn
0760: 6d 6f 72 65 20 61 74 20 68 74 74 70 3a 2f 2f 77 more at http://w
0770: 77 77 2e 6b 69 61 74 6f 61 2e 63 6f 6d 2f 66 6f ww.kiatoa.com/fo
0780: 73 73 69 6c 73 2f 6d 65 67 61 74 65 73 74 0a 0a ssils/megatest..
0790: 56 65 72 73 69 6f 6e 3a 20 22 20 6d 65 67 61 74 Version: " megat
07a0: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 est-fossil-hash)
07b0: 29 20 3b 3b 20 22 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 0a 3b 3b 20 52 45 43 4f 52 44 53 0a 3b 3b 3d 3d .;; RECORDS.;;==
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ====..;;========
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
08a0: 3b 20 44 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ; DB.;;=========
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
08f0: 64 65 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 2d define *default-
0900: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 log-port* (curre
0910: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
0920: 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 (define *verbosi
0930: 74 79 2a 20 20 20 20 20 20 20 20 20 31 29 0a 0a ty* 1)..
0940: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
0950: 68 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 64 62 20 h:initialize-db
0960: 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 0a db). (for-each.
0970: 20 20 20 28 6c 61 6d 62 64 61 20 28 71 72 79 29 (lambda (qry)
0980: 0a 20 20 20 20 20 28 65 78 65 63 20 28 73 71 6c . (exec (sql
0990: 20 64 62 20 71 72 79 29 29 29 0a 20 20 20 28 6c db qry))). (l
09a0: 69 73 74 20 0a 20 20 20 20 22 43 52 45 41 54 45 ist . "CREATE
09b0: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
09c0: 49 53 54 53 20 61 63 74 69 6f 6e 73 0a 20 20 20 ISTS actions.
09d0: 20 20 20 20 20 20 28 69 64 20 20 20 20 20 20 20 (id
09e0: 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 49 4d INTEGER PRIM
09f0: 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 ARY KEY,.
0a00: 20 20 20 61 63 74 69 6f 6e 20 20 20 20 20 20 20 action
0a10: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 TEXT NOT NULL,.
0a20: 20 20 20 20 20 20 20 20 20 73 75 62 6d 69 74 74 submitt
0a30: 65 72 20 20 20 20 54 45 58 54 20 4e 4f 54 20 4e er TEXT NOT N
0a40: 55 4c 4c 2c 0a 20 20 20 20 20 20 20 20 20 20 64 ULL,. d
0a50: 61 74 65 74 69 6d 65 20 20 20 20 20 54 49 4d 45 atetime TIME
0a60: 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 28 73 STAMP DEFAULT (s
0a70: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
0a80: 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 20 w')),.
0a90: 73 72 63 70 61 74 68 20 20 20 20 20 20 54 45 58 srcpath TEX
0aa0: 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 20 T NOT NULL,.
0ab0: 20 20 20 20 20 20 63 6f 6d 6d 65 6e 74 20 20 20 comment
0ac0: 20 20 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 TEXT DEFAULT
0ad0: 27 27 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 20 20 20 '' NOT NULL,.
0ae0: 20 20 20 20 20 20 20 73 74 61 74 65 20 20 20 20 state
0af0: 20 20 20 20 54 45 58 54 20 44 45 46 41 55 4c 54 TEXT DEFAULT
0b00: 20 27 6e 65 77 27 29 3b 22 0a 20 20 20 20 29 29 'new');". ))
0b10: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 )..(define (spub
0b20: 6c 69 73 68 3a 72 65 67 69 73 74 65 72 2d 61 63 lish:register-ac
0b30: 74 69 6f 6e 20 64 62 20 61 63 74 69 6f 6e 20 73 tion db action s
0b40: 75 62 6d 69 74 74 65 72 20 73 6f 75 72 63 65 2d ubmitter source-
0b50: 70 61 74 68 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 path comment).
0b60: 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 (exec (sql db "I
0b70: 4e 53 45 52 54 20 49 4e 54 4f 20 61 63 74 69 6f NSERT INTO actio
0b80: 6e 73 20 28 61 63 74 69 6f 6e 2c 73 75 62 6d 69 ns (action,submi
0b90: 74 74 65 72 2c 73 72 63 70 61 74 68 2c 63 6f 6d tter,srcpath,com
0ba0: 6d 65 6e 74 29 0a 20 20 20 20 20 20 20 20 20 20 ment).
0bb0: 20 20 20 20 20 20 20 56 41 4c 55 45 53 28 3f 2c VALUES(?,
0bc0: 3f 2c 3f 2c 3f 29 22 29 0a 09 61 63 74 69 6f 6e ?,?,?)")..action
0bd0: 0a 09 73 75 62 6d 69 74 74 65 72 0a 09 73 6f 75 ..submitter..sou
0be0: 72 63 65 2d 70 61 74 68 0a 09 63 6f 6d 6d 65 6e rce-path..commen
0bf0: 74 29 29 0a 0a 3b 3b 20 28 63 61 6c 6c 2d 77 69 t))..;; (call-wi
0c00: 74 68 2d 64 61 74 61 62 61 73 65 0a 3b 3b 20 20 th-database.;;
0c10: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 3b 3b 20 (lambda (db).;;
0c20: 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 (set-busy-hand
0c30: 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 69 ler! db (busy-ti
0c40: 6d 65 6f 75 74 20 31 30 30 30 30 29 29 20 3b 20 meout 10000)) ;
0c50: 31 30 20 73 65 63 6f 6e 64 20 74 69 6d 65 6f 75 10 second timeou
0c60: 74 0a 3b 3b 20 20 20 2e 2e 2e 29 29 0a 0a 3b 3b t.;; ...))..;;
0c70: 20 43 72 65 61 74 65 20 74 68 65 20 73 71 6c 69 Create the sqli
0c80: 74 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 73 te db.(define (s
0c90: 70 75 62 6c 69 73 68 3a 64 62 2d 64 6f 20 63 6f publish:db-do co
0ca0: 6e 66 69 67 64 61 74 20 70 72 6f 63 29 20 0a 20 nfigdat proc) .
0cb0: 20 28 6c 65 74 20 28 28 70 61 74 68 20 28 63 6f (let ((path (co
0cc0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
0cd0: 66 69 67 64 61 74 20 22 64 61 74 61 62 61 73 65 figdat "database
0ce0: 22 20 22 6c 6f 63 61 74 69 6f 6e 22 29 29 29 0a " "location"))).
0cf0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 61 74 (if (not pat
0d00: 68 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 h)..(begin.. (p
0d10: 72 69 6e 74 20 22 5b 64 61 74 61 62 61 73 65 5d rint "[database]
0d20: 5c 6e 6c 6f 63 61 74 69 6f 6e 20 2f 73 6f 6d 65 \nlocation /some
0d30: 2f 70 61 74 68 5c 6e 5c 6e 20 49 73 20 6d 69 73 /path\n\n Is mis
0d40: 73 69 6e 67 20 66 72 6f 6d 20 74 68 65 20 63 6f sing from the co
0d50: 6e 66 69 67 20 66 69 6c 65 21 22 29 0a 09 20 20 nfig file!")..
0d60: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 28 (exit 1))). (
0d70: 69 66 20 28 61 6e 64 20 70 61 74 68 0a 09 20 20 if (and path..
0d80: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 (directory? p
0d90: 61 74 68 29 0a 09 20 20 20 20 20 28 66 69 6c 65 ath).. (file
0da0: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 70 61 -read-access? pa
0db0: 74 68 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 th))..(let* ((db
0dc0: 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 70 61 path (conc pa
0dd0: 74 68 20 22 2f 73 70 75 62 6c 69 73 68 2e 64 62 th "/spublish.db
0de0: 22 29 29 0a 09 20 20 20 20 20 20 20 28 77 72 69 ")).. (wri
0df0: 74 65 61 62 6c 65 20 28 66 69 6c 65 2d 77 72 69 teable (file-wri
0e00: 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 te-access? dbpat
0e10: 68 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 65 h)).. (dbe
0e20: 78 69 73 74 73 20 20 28 66 69 6c 65 2d 65 78 69 xists (file-exi
0e30: 73 74 73 3f 20 64 62 70 61 74 68 29 29 29 0a 09 sts? dbpath)))..
0e40: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
0e50: 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
0e60: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 64 (begin.. (d
0e70: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 ebug:print 2 *de
0e80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0e90: 22 45 52 52 4f 52 3a 20 70 72 6f 62 6c 65 6d 20 "ERROR: problem
0ea0: 61 63 63 65 73 73 69 6e 67 20 64 62 20 22 20 64 accessing db " d
0eb0: 62 70 61 74 68 0a 09 09 09 20 20 28 28 63 6f 6e bpath.... ((con
0ec0: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
0ed0: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
0ee0: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 essage) exn))..
0ef0: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
0f00: 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 64 61 74 (call-with-dat
0f10: 61 62 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 abase.
0f20: 20 20 64 62 70 61 74 68 0a 09 20 20 20 20 28 6c dbpath.. (l
0f30: 61 6d 62 64 61 20 28 64 62 29 0a 09 20 20 20 20 ambda (db)..
0f40: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 63 61 6c ;; (print "cal
0f50: 6c 69 6e 67 20 70 72 6f 63 20 22 20 70 72 6f 63 ling proc " proc
0f60: 20 22 20 6f 6e 20 64 62 20 22 20 64 62 29 0a 09 " on db " db)..
0f70: 20 20 20 20 20 20 28 73 65 74 2d 62 75 73 79 2d (set-busy-
0f80: 68 61 6e 64 6c 65 72 21 20 64 62 20 28 62 75 73 handler! db (bus
0f90: 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 y-timeout 10000)
0fa0: 29 20 3b 3b 20 31 30 20 73 65 63 20 74 69 6d 65 ) ;; 10 sec time
0fb0: 6f 75 74 0a 09 20 20 20 20 20 20 28 69 66 20 28 out.. (if (
0fc0: 6e 6f 74 20 64 62 65 78 69 73 74 73 29 28 73 70 not dbexists)(sp
0fd0: 75 62 6c 69 73 68 3a 69 6e 69 74 69 61 6c 69 7a ublish:initializ
0fe0: 65 2d 64 62 20 64 62 29 29 0a 09 20 20 20 20 20 e-db db))..
0ff0: 20 28 70 72 6f 63 20 64 62 29 29 29 29 29 0a 09 (proc db)))))..
1000: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 69 (print "ERROR: i
1010: 6e 76 61 6c 69 64 20 70 61 74 68 20 66 6f 72 20 nvalid path for
1020: 73 74 6f 72 69 6e 67 20 64 61 74 61 62 61 73 65 storing database
1030: 3a 20 22 20 70 61 74 68 29 29 29 29 0a 0a 3b 3b : " path))))..;;
1040: 20 63 6f 70 79 20 69 6e 20 66 69 6c 65 20 74 6f copy in file to
1050: 20 64 65 73 74 2c 20 76 61 6c 69 64 61 74 69 6f dest, validatio
1060: 6e 20 69 73 20 64 6f 6e 65 20 42 45 46 4f 52 45 n is done BEFORE
1070: 20 63 61 6c 6c 69 6e 67 20 74 68 69 73 0a 3b 3b calling this.;;
1080: 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 .(define (spubli
1090: 73 68 3a 63 70 20 63 6f 6e 66 69 67 64 61 74 20 sh:cp configdat
10a0: 73 75 62 6d 69 74 74 65 72 20 73 6f 75 72 63 65 submitter source
10b0: 2d 70 61 74 68 20 74 61 72 67 65 74 2d 64 69 72 -path target-dir
10c0: 20 74 61 72 67 2d 66 69 6c 65 20 64 65 73 74 2d targ-file dest-
10d0: 64 69 72 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 dir comment). (
10e0: 6c 65 74 20 28 28 64 65 73 74 2d 64 69 72 2d 70 let ((dest-dir-p
10f0: 61 74 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 ath (conc target
1100: 2d 64 69 72 20 22 2f 22 20 64 65 73 74 2d 64 69 -dir "/" dest-di
1110: 72 29 29 0a 20 20 20 20 20 20 20 20 28 74 61 72 r)). (tar
1120: 67 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 72 g-path (conc tar
1130: 67 65 74 2d 64 69 72 20 22 2f 22 20 64 65 73 74 get-dir "/" dest
1140: 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d 66 69 -dir "/" targ-fi
1150: 6c 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 le))). (if (f
1160: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
1170: 2d 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 -path)..(begin..
1180: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
1190: 20 74 61 72 67 65 74 20 66 69 6c 65 20 61 6c 72 target file alr
11a0: 65 61 64 79 20 65 78 69 73 74 73 2c 20 72 65 6d eady exists, rem
11b0: 6f 76 65 20 69 74 20 62 65 66 6f 72 65 20 72 65 ove it before re
11c0: 2d 70 75 62 6c 69 73 68 69 6e 67 22 29 0a 09 20 -publishing")..
11d0: 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 (exit 1))).
11e0: 20 20 20 28 69 66 20 28 6e 6f 74 28 66 69 6c 65 (if (not(file
11f0: 2d 65 78 69 73 74 73 3f 20 64 65 73 74 2d 64 69 -exists? dest-di
1200: 72 2d 70 61 74 68 29 29 0a 09 28 62 65 67 69 6e r-path))..(begin
1210: 0a 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f .. (print "ERRO
1220: 52 3a 20 74 61 72 67 65 74 20 64 69 72 65 63 74 R: target direct
1230: 6f 72 79 20 22 20 64 65 73 74 2d 64 69 72 2d 70 ory " dest-dir-p
1240: 61 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 ath " does not e
1250: 78 69 73 74 73 2e 22 20 29 0a 09 20 20 28 65 78 xists." ).. (ex
1260: 69 74 20 31 29 29 29 0a 0a 20 20 20 20 28 73 70 it 1))).. (sp
1270: 75 62 6c 69 73 68 3a 64 62 2d 64 6f 0a 20 20 20 ublish:db-do.
1280: 20 20 63 6f 6e 66 69 67 64 61 74 0a 20 20 20 20 configdat.
1290: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
12a0: 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a 72 (spublish:r
12b0: 65 67 69 73 74 65 72 2d 61 63 74 69 6f 6e 20 64 egister-action d
12c0: 62 20 22 63 70 22 20 73 75 62 6d 69 74 74 65 72 b "cp" submitter
12d0: 20 73 6f 75 72 63 65 2d 70 61 74 68 20 63 6f 6d source-path com
12e0: 6d 65 6e 74 29 29 29 0a 20 20 20 20 28 6c 65 74 ment))). (let
12f0: 2a 20 28 3b 3b 20 28 74 61 72 67 65 74 2d 70 61 * (;; (target-pa
1300: 74 68 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b th (configf:look
1310: 75 70 20 22 73 65 74 74 69 6e 67 73 22 20 22 74 up "settings" "t
1320: 61 72 67 65 74 2d 70 61 74 68 22 29 29 0a 09 20 arget-path"))..
1330: 20 20 28 74 68 31 20 20 20 20 20 20 20 20 20 28 (th1 (
1340: 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 make-thread....
1350: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
1360: 20 28 66 69 6c 65 2d 63 6f 70 79 20 73 6f 75 72 (file-copy sour
1370: 63 65 2d 70 61 74 68 20 74 61 72 67 2d 70 61 74 ce-path targ-pat
1380: 68 20 23 74 29 29 0a 20 20 20 20 20 20 20 20 20 h #t)).
1390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13a0: 20 20 20 28 70 72 69 6e 74 20 22 20 2e 2e 2e 20 (print " ...
13b0: 66 69 6c 65 20 22 20 74 61 72 67 2d 70 61 74 68 file " targ-path
13c0: 20 22 20 63 6f 70 69 65 64 20 74 6f 20 22 20 74 " copied to " t
13d0: 61 72 67 2d 70 61 74 68 29 0a 09 09 09 20 3b 3b arg-path).... ;;
13e0: 20 28 6c 65 74 20 28 28 70 69 64 20 28 70 72 6f (let ((pid (pro
13f0: 63 65 73 73 2d 72 75 6e 20 22 63 70 22 20 28 6c cess-run "cp" (l
1400: 69 73 74 20 73 6f 75 72 63 65 2d 70 61 74 68 20 ist source-path
1410: 74 61 72 67 65 74 2d 64 69 72 29 29 29 29 0a 09 target-dir))))..
1420: 09 09 20 3b 3b 20 20 20 28 70 72 6f 63 65 73 73 .. ;; (process
1430: 2d 77 61 69 74 20 70 69 64 29 29 29 0a 09 09 09 -wait pid)))....
1440: 20 22 63 6f 70 79 20 74 68 72 65 61 64 22 29 29 "copy thread"))
1450: 0a 09 20 20 20 28 74 68 32 20 20 20 20 20 20 20 .. (th2
1460: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 (make-thread..
1470: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
1480: 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 . (let loop ()
1490: 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
14a0: 2d 73 6c 65 65 70 21 20 31 35 29 0a 09 09 09 20 -sleep! 15)....
14b0: 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 2e 22 (display "."
14c0: 29 0a 09 09 09 20 20 20 20 20 28 66 6c 75 73 68 ).... (flush
14d0: 2d 6f 75 74 70 75 74 29 0a 09 09 09 20 20 20 20 -output)....
14e0: 20 28 6c 6f 6f 70 29 29 29 0a 09 09 09 20 22 61 (loop))).... "a
14f0: 63 74 69 6f 6e 20 69 73 20 68 61 70 70 65 6e 69 ction is happeni
1500: 6e 67 20 74 68 72 65 61 64 22 29 29 29 0a 20 20 ng thread"))).
1510: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
1520: 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 t! th1). (t
1530: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
1540: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
1550: 6a 6f 69 6e 21 20 74 68 31 29 29 0a 20 20 20 20 join! th1)).
1560: 28 63 6f 6e 73 20 23 74 20 22 53 75 63 63 65 73 (cons #t "Succes
1570: 73 66 75 6c 6c 79 20 73 61 76 65 64 20 64 61 74 sfully saved dat
1580: 61 22 29 29 29 0a 0a 3b 3b 20 63 6f 70 79 20 64 a")))..;; copy d
1590: 69 72 65 63 74 6f 72 79 20 74 6f 20 64 65 73 74 irectory to dest
15a0: 2c 20 76 61 6c 69 64 61 74 69 6f 6e 20 69 73 20 , validation is
15b0: 64 6f 6e 65 20 42 45 46 4f 52 45 20 63 61 6c 6c done BEFORE call
15c0: 69 6e 67 20 74 68 69 73 0a 3b 3b 0a 0a 28 64 65 ing this.;;..(de
15d0: 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 74 fine (spublish:t
15e0: 61 72 20 63 6f 6e 66 69 67 64 61 74 20 73 75 62 ar configdat sub
15f0: 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d 64 69 mitter target-di
1600: 72 20 64 65 73 74 2d 64 69 72 20 63 6f 6d 6d 65 r dest-dir comme
1610: 6e 74 29 0a 20 20 28 6c 65 74 20 28 28 64 65 73 nt). (let ((des
1620: 74 2d 64 69 72 2d 70 61 74 68 20 28 63 6f 6e 63 t-dir-path (conc
1630: 20 74 61 72 67 65 74 2d 64 69 72 20 22 2f 22 20 target-dir "/"
1640: 64 65 73 74 2d 64 69 72 29 29 29 0a 20 20 20 20 dest-dir))).
1650: 20 20 20 28 69 66 20 28 6e 6f 74 28 66 69 6c 65 (if (not(file
1660: 2d 65 78 69 73 74 73 3f 20 64 65 73 74 2d 64 69 -exists? dest-di
1670: 72 2d 70 61 74 68 29 29 0a 09 28 62 65 67 69 6e r-path))..(begin
1680: 0a 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f .. (print "ERRO
1690: 52 3a 20 74 61 72 67 65 74 20 64 69 72 65 63 74 R: target direct
16a0: 6f 72 79 20 22 20 64 65 73 74 2d 64 69 72 2d 70 ory " dest-dir-p
16b0: 61 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 ath " does not e
16c0: 78 69 73 74 73 2e 22 20 29 0a 09 20 20 28 65 78 xists." ).. (ex
16d0: 69 74 20 31 29 29 29 0a 20 20 20 20 3b 3b 28 70 it 1))). ;;(p
16e0: 72 69 6e 74 20 64 65 73 74 2d 64 69 72 2d 70 61 rint dest-dir-pa
16f0: 74 68 20 29 0a 20 20 20 20 28 73 70 75 62 6c 69 th ). (spubli
1700: 73 68 3a 64 62 2d 64 6f 0a 20 20 20 20 20 63 6f sh:db-do. co
1710: 6e 66 69 67 64 61 74 0a 20 20 20 20 20 28 6c 61 nfigdat. (la
1720: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 mbda (db).
1730: 20 28 73 70 75 62 6c 69 73 68 3a 72 65 67 69 73 (spublish:regis
1740: 74 65 72 2d 61 63 74 69 6f 6e 20 64 62 20 22 74 ter-action db "t
1750: 61 72 22 20 73 75 62 6d 69 74 74 65 72 20 64 65 ar" submitter de
1760: 73 74 2d 64 69 72 2d 70 61 74 68 20 63 6f 6d 6d st-dir-path comm
1770: 65 6e 74 29 29 29 0a 20 20 20 20 20 20 20 28 63 ent))). (c
1780: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
1790: 64 65 73 74 2d 64 69 72 2d 70 61 74 68 29 0a 20 dest-dir-path).
17a0: 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d 77 (process-w
17b0: 61 69 74 20 28 70 72 6f 63 65 73 73 2d 72 75 6e ait (process-run
17c0: 20 22 2f 62 69 6e 2f 74 61 72 22 20 28 6c 69 73 "/bin/tar" (lis
17d0: 74 20 22 78 66 22 20 22 2d 22 29 29 29 0a 20 20 t "xf" "-"))).
17e0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 (print "Dat
17f0: 61 20 63 6f 70 69 65 64 20 74 6f 20 22 20 64 65 a copied to " de
1800: 73 74 2d 64 69 72 2d 70 61 74 68 29 20 0a 0a 20 st-dir-path) ..
1810: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 23 74 20 (cons #t
1820: 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 73 61 "Successfully sa
1830: 76 65 64 20 64 61 74 61 22 29 29 29 0a 0a 0a 28 ved data")))...(
1840: 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 define (spublish
1850: 3a 76 61 6c 69 64 61 74 65 20 74 61 72 67 65 74 :validate target
1860: 2d 64 69 72 20 74 61 72 67 2d 6d 6b 29 0a 20 20 -dir targ-mk).
1870: 28 6c 65 74 2a 20 28 28 6e 6f 72 6d 61 6c 2d 70 (let* ((normal-p
1880: 61 74 68 20 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 ath (normalize-p
1890: 61 74 68 6e 61 6d 65 20 74 61 72 67 2d 6d 6b 29 athname targ-mk)
18a0: 29 0a 20 20 20 20 20 20 20 20 28 74 61 72 67 2d ). (targ-
18b0: 70 61 74 68 20 28 63 6f 6e 63 20 74 61 72 67 65 path (conc targe
18c0: 74 2d 64 69 72 20 22 2f 22 20 6e 6f 72 6d 61 6c t-dir "/" normal
18d0: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 69 66 -path))). (if
18e0: 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e (string-contain
18f0: 73 20 20 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 s normal-path
1900: 22 2e 2e 22 29 0a 20 20 20 20 28 62 65 67 69 6e ".."). (begin
1910: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 . (print "E
1920: 52 52 4f 52 3a 20 50 61 74 68 20 20 22 20 74 61 RROR: Path " ta
1930: 72 67 2d 6d 6b 20 22 20 72 65 73 6f 6c 76 65 64 rg-mk " resolved
1940: 20 6f 75 74 73 69 64 65 20 74 61 72 67 65 74 20 outside target
1950: 61 72 65 61 20 22 20 20 74 61 72 67 65 74 2d 64 area " target-d
1960: 69 72 20 29 0a 20 20 20 20 20 20 28 65 78 69 74 ir ). (exit
1970: 20 31 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 1))).. (if (
1980: 6e 6f 74 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 not (string-cont
1990: 61 69 6e 73 20 74 61 72 67 2d 70 61 74 68 20 74 ains targ-path t
19a0: 61 72 67 65 74 2d 64 69 72 29 29 0a 20 20 20 20 arget-dir)).
19b0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 (begin. (pr
19c0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 59 6f 75 20 int "ERROR: You
19d0: 63 61 6e 6e 6f 74 20 75 70 64 61 74 65 20 64 61 cannot update da
19e0: 74 61 20 6f 75 74 73 69 64 65 20 22 20 74 61 72 ta outside " tar
19f0: 67 65 74 2d 64 69 72 20 22 2e 22 29 0a 20 20 20 get-dir ".").
1a00: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 (exit 1))).
1a10: 20 20 28 70 72 69 6e 74 20 22 50 61 74 68 20 22 (print "Path "
1a20: 20 74 61 72 67 2d 6d 6b 20 22 20 69 73 20 76 61 targ-mk " is va
1a30: 6c 69 64 2e 22 29 20 20 20 0a 20 29 29 0a 3b 3b lid.") . )).;;
1a40: 20 6d 61 6b 65 20 64 69 72 65 63 74 6f 72 79 20 make directory
1a50: 69 6e 20 64 65 73 74 0a 3b 3b 0a 0a 28 64 65 66 in dest.;;..(def
1a60: 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 6d 6b ine (spublish:mk
1a70: 64 69 72 20 63 6f 6e 66 69 67 64 61 74 20 73 75 dir configdat su
1a80: 62 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d 64 bmitter target-d
1a90: 69 72 20 74 61 72 67 2d 6d 6b 20 63 6f 6d 6d 65 ir targ-mk comme
1aa0: 6e 74 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 nt). (let ((tar
1ab0: 67 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 72 g-path (conc tar
1ac0: 67 65 74 2d 64 69 72 20 22 2f 22 20 74 61 72 67 get-dir "/" targ
1ad0: 2d 6d 6b 29 29 29 0a 20 20 20 20 0a 20 20 20 20 -mk))). .
1ae0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
1af0: 3f 20 74 61 72 67 2d 70 61 74 68 29 0a 09 28 62 ? targ-path)..(b
1b00: 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 egin.. (print "
1b10: 45 52 52 4f 52 3a 20 74 61 72 67 65 74 20 44 69 ERROR: target Di
1b20: 72 65 63 74 6f 72 79 20 22 20 74 61 72 67 2d 70 rectory " targ-p
1b30: 61 74 68 20 22 20 61 6c 72 65 61 64 79 20 65 78 ath " already ex
1b40: 69 73 74 21 21 22 29 0a 09 20 20 28 65 78 69 74 ist!!").. (exit
1b50: 20 31 29 29 29 0a 20 20 20 20 28 73 70 75 62 6c 1))). (spubl
1b60: 69 73 68 3a 64 62 2d 64 6f 0a 20 20 20 20 20 63 ish:db-do. c
1b70: 6f 6e 66 69 67 64 61 74 0a 20 20 20 20 20 28 6c onfigdat. (l
1b80: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
1b90: 20 20 28 73 70 75 62 6c 69 73 68 3a 72 65 67 69 (spublish:regi
1ba0: 73 74 65 72 2d 61 63 74 69 6f 6e 20 64 62 20 22 ster-action db "
1bb0: 6d 6b 64 69 72 22 20 73 75 62 6d 69 74 74 65 72 mkdir" submitter
1bc0: 20 74 61 72 67 2d 6d 6b 20 63 6f 6d 6d 65 6e 74 targ-mk comment
1bd0: 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ))). (let* ((
1be0: 74 68 31 20 20 20 20 20 20 20 20 20 28 6d 61 6b th1 (mak
1bf0: 65 2d 74 68 72 65 61 64 0a 09 09 09 20 28 6c 61 e-thread.... (la
1c00: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 28 63 mbda ().... (c
1c10: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
1c20: 74 61 72 67 2d 70 61 74 68 20 23 74 29 0a 09 09 targ-path #t)...
1c30: 09 20 20 20 28 70 72 69 6e 74 20 22 20 2e 2e 2e . (print " ...
1c40: 20 64 69 72 20 22 20 74 61 72 67 2d 70 61 74 68 dir " targ-path
1c50: 20 22 20 63 72 65 61 74 65 64 22 29 29 0a 09 09 " created"))...
1c60: 09 20 22 6d 6b 64 69 72 20 74 68 72 65 61 64 22 . "mkdir thread"
1c70: 29 29 0a 09 20 20 20 28 74 68 32 20 20 20 20 20 )).. (th2
1c80: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
1c90: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
1ca0: 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
1cb0: 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 ().... (thre
1cc0: 61 64 2d 73 6c 65 65 70 21 20 31 35 29 0a 09 09 ad-sleep! 15)...
1cd0: 09 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 . (display "
1ce0: 2e 22 29 0a 09 09 09 20 20 20 20 20 28 66 6c 75 .").... (flu
1cf0: 73 68 2d 6f 75 74 70 75 74 29 0a 09 09 09 20 20 sh-output)....
1d00: 20 20 20 28 6c 6f 6f 70 29 29 29 0a 09 09 09 20 (loop)))....
1d10: 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 70 65 "action is happe
1d20: 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 29 0a ning thread"))).
1d30: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
1d40: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 art! th1).
1d50: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
1d60: 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h2). (threa
1d70: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 20 20 d-join! th1)).
1d80: 20 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 63 (cons #t "Succ
1d90: 65 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 64 essfully saved d
1da0: 61 74 61 22 29 29 29 0a 0a 3b 3b 20 63 72 65 61 ata")))..;; crea
1db0: 74 65 20 61 20 73 79 6d 6c 69 6e 6b 20 69 6e 20 te a symlink in
1dc0: 64 65 73 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dest.;;.(define
1dd0: 28 73 70 75 62 6c 69 73 68 3a 6c 6e 20 63 6f 6e (spublish:ln con
1de0: 66 69 67 64 61 74 20 73 75 62 6d 69 74 74 65 72 figdat submitter
1df0: 20 74 61 72 67 65 74 2d 64 69 72 20 74 61 72 67 target-dir targ
1e00: 2d 6c 69 6e 6b 20 6c 69 6e 6b 2d 6e 61 6d 65 20 -link link-name
1e10: 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 6c 65 74 20 comment). (let
1e20: 28 28 74 61 72 67 2d 70 61 74 68 20 28 63 6f 6e ((targ-path (con
1e30: 63 20 74 61 72 67 65 74 2d 64 69 72 20 22 2f 22 c target-dir "/"
1e40: 20 6c 69 6e 6b 2d 6e 61 6d 65 29 29 29 0a 20 20 link-name))).
1e50: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
1e60: 74 73 3f 20 74 61 72 67 2d 70 61 74 68 29 0a 09 ts? targ-path)..
1e70: 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 (begin.. (print
1e80: 20 22 45 52 52 4f 52 3a 20 74 61 72 67 65 74 20 "ERROR: target
1e90: 66 69 6c 65 20 22 20 74 61 72 67 2d 70 61 74 68 file " targ-path
1ea0: 20 22 20 61 6c 72 65 61 64 79 20 65 78 69 73 74 " already exist
1eb0: 21 21 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 !!").. (exit 1)
1ec0: 29 29 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 )). (if (not
1ed0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
1ee0: 61 72 67 2d 6c 69 6e 6b 20 29 29 0a 09 28 62 65 arg-link ))..(be
1ef0: 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 45 gin.. (print "E
1f00: 52 52 4f 52 3a 20 74 61 72 67 65 74 20 66 69 6c RROR: target fil
1f10: 65 20 22 20 74 61 72 67 2d 6c 69 6e 6b 20 22 20 e " targ-link "
1f20: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 21 21 does not exist!!
1f30: 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 ").. (exit 1)))
1f40: 0a 20 0a 20 20 20 20 28 73 70 75 62 6c 69 73 68 . . (spublish
1f50: 3a 64 62 2d 64 6f 0a 20 20 20 20 20 63 6f 6e 66 :db-do. conf
1f60: 69 67 64 61 74 0a 20 20 20 20 20 28 6c 61 6d 62 igdat. (lamb
1f70: 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 28 da (db). (
1f80: 73 70 75 62 6c 69 73 68 3a 72 65 67 69 73 74 65 spublish:registe
1f90: 72 2d 61 63 74 69 6f 6e 20 64 62 20 22 6c 6e 22 r-action db "ln"
1fa0: 20 73 75 62 6d 69 74 74 65 72 20 6c 69 6e 6b 2d submitter link-
1fb0: 6e 61 6d 65 20 63 6f 6d 6d 65 6e 74 29 29 29 0a name comment))).
1fc0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 31 20 (let* ((th1
1fd0: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 (make-th
1fe0: 72 65 61 64 0a 09 09 09 20 28 6c 61 6d 62 64 61 read.... (lambda
1ff0: 20 28 29 0a 09 09 09 20 20 20 28 63 72 65 61 74 ().... (creat
2000: 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 e-symbolic-link
2010: 74 61 72 67 2d 6c 69 6e 6b 20 74 61 72 67 2d 70 targ-link targ-p
2020: 61 74 68 20 20 29 0a 09 09 09 20 20 20 28 70 72 ath ).... (pr
2030: 69 6e 74 20 22 20 2e 2e 2e 20 6c 69 6e 6b 20 22 int " ... link "
2040: 20 74 61 72 67 2d 70 61 74 68 20 22 20 63 72 65 targ-path " cre
2050: 61 74 65 64 22 29 29 0a 09 09 09 20 22 73 79 6d ated")).... "sym
2060: 6c 69 6e 6b 20 74 68 72 65 61 64 22 29 29 0a 09 link thread"))..
2070: 20 20 20 28 74 68 32 20 20 20 20 20 20 20 20 20 (th2
2080: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 (make-thread....
2090: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
20a0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 (let loop ()..
20b0: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
20c0: 6c 65 65 70 21 20 31 35 29 0a 09 09 09 20 20 20 leep! 15)....
20d0: 20 20 28 64 69 73 70 6c 61 79 20 22 2e 22 29 0a (display ".").
20e0: 09 09 09 20 20 20 20 20 28 66 6c 75 73 68 2d 6f ... (flush-o
20f0: 75 74 70 75 74 29 0a 09 09 09 20 20 20 20 20 28 utput).... (
2100: 6c 6f 6f 70 29 29 29 0a 09 09 09 20 22 61 63 74 loop))).... "act
2110: 69 6f 6e 20 69 73 20 68 61 70 70 65 6e 69 6e 67 ion is happening
2120: 20 74 68 72 65 61 64 22 29 29 29 0a 20 20 20 20 thread"))).
2130: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
2140: 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 68 72 th1). (thr
2150: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
2160: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f (thread-jo
2170: 69 6e 21 20 74 68 31 29 29 0a 20 20 20 20 28 63 in! th1)). (c
2180: 6f 6e 73 20 23 74 20 22 53 75 63 63 65 73 73 66 ons #t "Successf
2190: 75 6c 6c 79 20 73 61 76 65 64 20 64 61 74 61 22 ully saved data"
21a0: 29 29 29 0a 0a 0a 3b 3b 20 72 65 6d 6f 76 65 20 )))...;; remove
21b0: 63 6f 70 79 20 6f 66 20 66 69 6c 65 20 69 6e 20 copy of file in
21c0: 64 65 73 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dest.;;.(define
21d0: 28 73 70 75 62 6c 69 73 68 3a 72 6d 20 63 6f 6e (spublish:rm con
21e0: 66 69 67 64 61 74 20 73 75 62 6d 69 74 74 65 72 figdat submitter
21f0: 20 74 61 72 67 65 74 2d 64 69 72 20 74 61 72 67 target-dir targ
2200: 2d 66 69 6c 65 20 63 6f 6d 6d 65 6e 74 29 0a 20 -file comment).
2210: 20 28 6c 65 74 20 28 28 74 61 72 67 2d 70 61 74 (let ((targ-pat
2220: 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d 64 h (conc target-d
2230: 69 72 20 22 2f 22 20 74 61 72 67 2d 66 69 6c 65 ir "/" targ-file
2240: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
2250: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
2260: 61 72 67 2d 70 61 74 68 29 29 0a 09 28 62 65 67 arg-path))..(beg
2270: 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 45 52 in.. (print "ER
2280: 52 4f 52 3a 20 74 61 72 67 65 74 20 66 69 6c 65 ROR: target file
2290: 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 20 6e " targ-path " n
22a0: 6f 74 20 66 6f 75 6e 64 2c 20 6e 6f 74 68 69 6e ot found, nothin
22b0: 67 20 74 6f 20 72 65 6d 6f 76 65 2e 22 29 0a 09 g to remove.")..
22c0: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
22d0: 20 28 73 70 75 62 6c 69 73 68 3a 64 62 2d 64 6f (spublish:db-do
22e0: 0a 20 20 20 20 20 63 6f 6e 66 69 67 64 61 74 0a . configdat.
22f0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 (lambda (db
2300: 29 0a 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 ). (spubli
2310: 73 68 3a 72 65 67 69 73 74 65 72 2d 61 63 74 69 sh:register-acti
2320: 6f 6e 20 64 62 20 22 72 6d 22 20 73 75 62 6d 69 on db "rm" submi
2330: 74 74 65 72 20 74 61 72 67 2d 66 69 6c 65 20 63 tter targ-file c
2340: 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 28 6c omment))). (l
2350: 65 74 2a 20 28 28 74 68 31 20 20 20 20 20 20 20 et* ((th1
2360: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 (make-thread..
2370: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
2380: 09 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 . (delete-file
2390: 20 74 61 72 67 2d 70 61 74 68 29 0a 09 09 09 20 targ-path)....
23a0: 20 20 28 70 72 69 6e 74 20 22 20 2e 2e 2e 20 66 (print " ... f
23b0: 69 6c 65 20 22 20 74 61 72 67 2d 70 61 74 68 20 ile " targ-path
23c0: 22 20 72 65 6d 6f 76 65 64 22 29 29 0a 09 09 09 " removed"))....
23d0: 20 22 72 6d 20 74 68 72 65 61 64 22 29 29 0a 09 "rm thread"))..
23e0: 20 20 20 28 74 68 32 20 20 20 20 20 20 20 20 20 (th2
23f0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 (make-thread....
2400: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
2410: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 (let loop ()..
2420: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
2430: 6c 65 65 70 21 20 31 35 29 0a 09 09 09 20 20 20 leep! 15)....
2440: 20 20 28 64 69 73 70 6c 61 79 20 22 2e 22 29 0a (display ".").
2450: 09 09 09 20 20 20 20 20 28 66 6c 75 73 68 2d 6f ... (flush-o
2460: 75 74 70 75 74 29 0a 09 09 09 20 20 20 20 20 28 utput).... (
2470: 6c 6f 6f 70 29 29 29 0a 09 09 09 20 22 61 63 74 loop))).... "act
2480: 69 6f 6e 20 69 73 20 68 61 70 70 65 6e 69 6e 67 ion is happening
2490: 20 74 68 72 65 61 64 22 29 29 29 0a 20 20 20 20 thread"))).
24a0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
24b0: 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 68 72 th1). (thr
24c0: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
24d0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f (thread-jo
24e0: 69 6e 21 20 74 68 31 29 29 0a 20 20 20 20 28 63 in! th1)). (c
24f0: 6f 6e 73 20 23 74 20 22 53 75 63 63 65 73 73 66 ons #t "Successf
2500: 75 6c 6c 79 20 73 61 76 65 64 20 64 61 74 61 22 ully saved data"
2510: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 )))..(define (sp
2520: 75 62 6c 69 73 68 3a 62 61 63 6b 75 70 2d 6d 6f ublish:backup-mo
2530: 76 65 20 70 61 74 68 29 0a 20 20 28 6c 65 74 2a ve path). (let*
2540: 20 28 28 74 72 61 73 68 64 69 72 20 20 28 63 6f ((trashdir (co
2550: 6e 63 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 nc (pathname-dir
2560: 65 63 74 6f 72 79 20 70 61 74 68 29 20 22 2f 2e ectory path) "/.
2570: 74 72 61 73 68 22 29 29 0a 09 20 28 74 72 61 73 trash")).. (tras
2580: 68 66 69 6c 65 20 28 63 6f 6e 63 20 74 72 61 73 hfile (conc tras
2590: 68 64 69 72 20 22 2f 22 20 28 63 75 72 72 65 6e hdir "/" (curren
25a0: 74 2d 73 65 63 6f 6e 64 73 29 20 22 2d 22 20 28 t-seconds) "-" (
25b0: 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 70 61 pathname-file pa
25c0: 74 68 29 29 29 29 0a 20 20 20 20 28 63 72 65 61 th)))). (crea
25d0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 74 72 61 te-directory tra
25e0: 73 68 64 69 72 20 23 74 29 0a 20 20 20 20 28 69 shdir #t). (i
25f0: 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 f (directory? pa
2600: 74 68 29 0a 09 28 73 79 73 74 65 6d 20 28 63 6f th)..(system (co
2610: 6e 63 20 22 6d 76 20 22 20 70 61 74 68 20 22 20 nc "mv " path "
2620: 22 20 74 72 61 73 68 66 69 6c 65 29 29 0a 09 28 " trashfile))..(
2630: 66 69 6c 65 2d 6d 6f 76 65 20 70 61 74 68 20 74 file-move path t
2640: 72 61 73 68 2d 66 69 6c 65 29 29 29 29 0a 0a 0a rash-file))))...
2650: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
2660: 68 3a 6c 73 74 2d 3e 70 61 74 68 20 70 61 74 68 h:lst->path path
2670: 6c 73 74 29 0a 20 20 28 63 6f 6e 63 20 22 2f 22 lst). (conc "/"
2680: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2690: 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 70 erse (map conc p
26a0: 61 74 68 6c 73 74 29 20 22 2f 22 29 29 29 0a 0a athlst) "/")))..
26b0: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
26c0: 68 3a 70 61 74 68 2d 3e 6c 73 74 20 70 61 74 68 h:path->lst path
26d0: 29 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ). (string-spli
26e0: 74 20 70 61 74 68 20 22 2f 22 29 29 0a 0a 28 64 t path "/"))..(d
26f0: 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a efine (spublish:
2700: 70 61 74 68 64 61 74 2d 61 70 70 6c 79 2d 68 65 pathdat-apply-he
2710: 75 72 69 73 74 69 63 73 20 63 6f 6e 66 69 67 64 uristics configd
2720: 61 74 20 70 61 74 68 29 0a 20 20 28 63 6f 6e 64 at path). (cond
2730: 0a 20 20 20 28 28 66 69 6c 65 2d 65 78 69 73 74 . ((file-exist
2740: 73 3f 20 70 61 74 68 29 20 22 66 6f 75 6e 64 22 s? path) "found"
2750: 29 0a 20 20 20 28 65 6c 73 65 20 28 63 6f 6e 63 ). (else (conc
2760: 20 70 61 74 68 20 22 20 6e 6f 74 20 69 6e 73 74 path " not inst
2770: 61 6c 6c 65 64 22 29 29 29 29 0a 0a 3b 3b 3d 3d alled"))))..;;==
2780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27c0: 3d 3d 3d 3d 0a 3b 3b 20 4d 49 53 43 0a 3b 3b 3d ====.;; MISC.;;=
27d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2810: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
2820: 73 70 75 62 6c 69 73 68 3a 64 6f 2d 61 73 2d 63 spublish:do-as-c
2830: 61 6c 6c 69 6e 67 2d 75 73 65 72 20 70 72 6f 63 alling-user proc
2840: 29 0a 20 20 28 6c 65 74 20 28 28 65 69 64 20 28 ). (let ((eid (
2850: 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 current-effectiv
2860: 65 2d 75 73 65 72 2d 69 64 29 29 0a 20 20 20 20 e-user-id)).
2870: 20 20 20 20 28 63 69 64 20 28 63 75 72 72 65 6e (cid (curren
2880: 74 2d 75 73 65 72 2d 69 64 29 29 29 0a 20 20 20 t-user-id))).
2890: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 (if (not (eq? e
28a0: 69 64 20 63 69 64 29 29 20 3b 3b 20 72 75 6e 6e id cid)) ;; runn
28b0: 69 6e 67 20 73 75 69 64 0a 20 20 20 20 20 20 20 ing suid.
28c0: 20 20 20 20 20 28 73 65 74 21 20 28 63 75 72 72 (set! (curr
28d0: 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 ent-effective-us
28e0: 65 72 2d 69 64 29 20 63 69 64 29 29 0a 20 20 20 er-id) cid)).
28f0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 6e ;; (print "runn
2900: 69 6e 67 20 61 73 20 22 20 28 63 75 72 72 65 6e ing as " (curren
2910: 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 72 t-effective-user
2920: 2d 69 64 29 29 0a 20 20 20 20 28 70 72 6f 63 29 -id)). (proc)
2930: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
2940: 71 3f 20 65 69 64 20 63 69 64 29 29 0a 20 20 20 q? eid cid)).
2950: 20 20 20 20 20 28 73 65 74 21 20 28 63 75 72 72 (set! (curr
2960: 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 ent-effective-us
2970: 65 72 2d 69 64 29 20 65 69 64 29 29 29 29 0a 0a er-id) eid))))..
2980: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
2990: 68 3a 66 69 6e 64 20 6e 61 6d 65 20 70 61 74 68 h:find name path
29a0: 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s). (if (null?
29b0: 70 61 74 68 73 29 0a 20 20 20 20 20 20 23 66 0a paths). #f.
29c0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
29d0: 28 28 68 65 64 20 28 63 61 72 20 70 61 74 68 73 ((hed (car paths
29e0: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
29f0: 70 61 74 68 73 29 29 29 0a 09 28 69 66 20 28 66 paths)))..(if (f
2a00: 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e ile-exists? (con
2a10: 63 20 68 65 64 20 22 2f 22 20 6e 61 6d 65 29 29 c hed "/" name))
2a20: 0a 09 20 20 20 20 68 65 64 0a 09 20 20 20 20 28 .. hed.. (
2a30: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
2a40: 09 23 66 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 .#f...(loop (car
2a50: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
2a60: 29 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))).;;=========
2a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
2ab0: 3b 3b 53 68 65 6c 6c 20 0a 3b 3b 3d 3d 3d 3d 3d ;;Shell .;;=====
2ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b00: 3d 3d 3d 0a 28 64 65 66 69 6e 65 20 28 73 70 75 ===.(define (spu
2b10: 62 6c 69 73 68 3a 67 65 74 2d 61 63 63 65 73 73 blish:get-access
2b20: 61 62 6c 65 2d 70 72 6f 6a 65 63 74 73 20 20 61 able-projects a
2b30: 72 65 61 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 rea). (let* ((
2b40: 70 72 6f 6a 65 63 74 73 20 60 28 29 29 29 0a 20 projects `())).
2b50: 20 20 20 20 3b 20 20 28 70 72 69 6e 74 20 22 69 ; (print "i
2b60: 6e 20 73 70 75 62 6c 69 73 68 3a 67 65 74 2d 61 n spublish:get-a
2b70: 63 63 65 73 73 61 62 6c 65 2d 70 72 6f 6a 65 63 ccessable-projec
2b80: 74 73 22 29 20 0a 20 20 20 20 20 20 20 20 3b 28 ts") . ;(
2b90: 70 72 69 6e 74 20 28 73 70 75 62 6c 69 73 68 3a print (spublish:
2ba0: 68 61 73 2d 70 65 72 6d 69 73 73 69 6f 6e 20 61 has-permission a
2bb0: 72 65 61 29 29 0a 20 20 20 20 20 20 20 20 28 69 rea)). (i
2bc0: 66 20 28 73 70 75 62 6c 69 73 68 3a 68 61 73 2d f (spublish:has-
2bd0: 70 65 72 6d 69 73 73 69 6f 6e 20 61 72 65 61 29 permission area)
2be0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2bf0: 28 73 65 74 21 20 70 72 6f 6a 65 63 74 73 20 28 (set! projects (
2c00: 63 6f 6e 73 20 61 72 65 61 20 70 72 6f 6a 65 63 cons area projec
2c10: 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ts)).
2c20: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
2c30: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
2c40: 6e 74 20 22 55 73 65 72 20 63 61 6e 6e 6f 74 20 nt "User cannot
2c50: 61 63 63 65 73 73 20 61 72 65 61 20 22 20 61 72 access area " ar
2c60: 65 61 20 22 21 21 22 29 20 20 0a 20 20 20 20 20 ea "!!") .
2c70: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
2c80: 20 31 29 29 29 20 0a 20 20 20 20 20 20 20 3b 20 1))) . ;
2c90: 20 28 70 72 69 6e 74 20 22 65 78 69 74 69 6e 67 (print "exiting
2ca0: 20 73 70 75 62 6c 69 73 68 3a 67 65 74 2d 61 63 spublish:get-ac
2cb0: 63 65 73 73 61 62 6c 65 2d 70 72 6f 6a 65 63 74 cessable-project
2cc0: 73 22 29 0a 20 20 20 20 70 72 6f 6a 65 63 74 73 s"). projects
2cd0: 29 29 0a 0a 3b 3b 20 66 75 6e 63 74 69 6f 6e 20 ))..;; function
2ce0: 74 6f 20 66 69 6e 64 20 73 68 65 65 74 73 20 74 to find sheets t
2cf0: 6f 20 77 68 69 63 68 20 75 73 65 20 68 61 73 20 o which use has
2d00: 61 63 63 65 73 73 20 0a 28 64 65 66 69 6e 65 20 access .(define
2d10: 28 73 70 75 62 6c 69 73 68 3a 68 61 73 2d 70 65 (spublish:has-pe
2d20: 72 6d 69 73 73 69 6f 6e 20 20 61 72 65 61 29 0a rmission area).
2d30: 20 20 3b 28 70 72 69 6e 74 20 22 69 6e 20 73 70 ;(print "in sp
2d40: 75 62 6c 69 73 68 3a 68 61 73 2d 70 65 72 6d 69 ublish:has-permi
2d50: 73 73 69 6f 6e 22 29 0a 20 20 28 6c 65 74 2a 20 ssion"). (let*
2d60: 28 28 75 73 65 72 6e 61 6d 65 20 20 20 20 20 28 ((username (
2d70: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
2d80: 65 29 29 0a 20 20 20 20 20 20 20 20 28 72 65 74 e)). (ret
2d90: 2d 76 61 6c 20 23 66 29 29 0a 20 20 28 63 6f 6e -val #f)). (con
2da0: 64 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 28 69 d. ((equal? (i
2db0: 73 2d 61 64 6d 69 6e 20 75 73 65 72 6e 61 6d 65 s-admin username
2dc0: 29 20 23 74 29 0a 20 20 20 20 20 28 73 65 74 21 ) #t). (set!
2dd0: 20 72 65 74 2d 76 61 6c 20 23 74 29 29 0a 20 20 ret-val #t)).
2de0: 20 20 28 28 65 71 75 61 6c 3f 20 28 69 73 2d 75 ((equal? (is-u
2df0: 73 65 72 20 22 70 75 62 6c 69 73 68 22 20 75 73 ser "publish" us
2e00: 65 72 6e 61 6d 65 20 61 72 65 61 29 20 23 74 29 ername area) #t)
2e10: 0a 20 20 20 20 20 28 73 65 74 21 20 72 65 74 2d . (set! ret-
2e20: 76 61 6c 20 23 74 29 29 0a 20 20 20 28 28 65 71 val #t)). ((eq
2e30: 75 61 6c 3f 20 28 69 73 2d 75 73 65 72 20 22 77 ual? (is-user "w
2e40: 72 69 74 65 72 2d 61 64 6d 69 6e 22 20 75 73 65 riter-admin" use
2e50: 72 6e 61 6d 65 20 61 72 65 61 29 20 23 74 29 20 rname area) #t)
2e60: 0a 20 20 20 20 20 28 73 65 74 21 20 72 65 74 2d . (set! ret-
2e70: 76 61 6c 20 23 74 29 29 0a 0a 20 20 20 28 28 65 val #t)).. ((e
2e80: 71 75 61 6c 3f 20 28 69 73 2d 75 73 65 72 20 22 qual? (is-user "
2e90: 61 72 65 61 2d 61 64 6d 69 6e 22 20 75 73 65 72 area-admin" user
2ea0: 6e 61 6d 65 20 61 72 65 61 29 20 23 74 29 20 0a name area) #t) .
2eb0: 20 20 20 20 20 28 73 65 74 21 20 72 65 74 2d 76 (set! ret-v
2ec0: 61 6c 20 23 74 29 29 0a 20 20 20 28 65 6c 73 65 al #t)). (else
2ed0: 20 20 0a 20 20 20 20 28 73 65 74 21 20 72 65 74 . (set! ret
2ee0: 2d 76 61 6c 20 23 66 29 29 29 0a 20 20 3b 20 20 -val #f))). ;
2ef0: 28 70 72 69 6e 74 20 72 65 74 2d 76 61 6c 29 0a (print ret-val).
2f00: 20 20 20 20 20 72 65 74 2d 76 61 6c 29 29 0a 0a ret-val))..
2f10: 28 64 65 66 69 6e 65 20 28 69 73 5f 64 69 72 65 (define (is_dire
2f20: 63 74 6f 72 79 20 74 61 72 67 65 74 2d 70 61 74 ctory target-pat
2f30: 68 29 20 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 h) . (let* ((re
2f40: 74 76 61 6c 20 23 66 29 29 0a 20 20 28 73 61 75 tval #f)). (sau
2f50: 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 thorize:do-as-ca
2f60: 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 09 lling-user. .
2f70: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
2f80: 20 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 75 ;(print (cu
2f90: 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d rrent-effective-
2fa0: 75 73 65 72 2d 69 64 29 20 29 20 0a 20 20 20 20 user-id) ) .
2fb0: 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 (if (direc
2fc0: 74 6f 72 79 3f 20 74 61 72 67 65 74 2d 70 61 74 tory? target-pat
2fd0: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
2fe0: 20 20 28 73 65 74 21 20 72 65 74 76 61 6c 20 20 (set! retval
2ff0: 23 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 #t)))).
3000: 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 75 72 ;(print (cur
3010: 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 rent-effective-u
3020: 73 65 72 2d 69 64 29 29 0a 20 20 20 20 20 72 65 ser-id)). re
3030: 74 76 61 6c 29 29 20 0a 0a 0a 28 64 65 66 69 6e tval)) ...(defin
3040: 65 20 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c e (spublish:shel
3050: 6c 2d 63 70 20 73 72 63 2d 70 61 74 68 20 74 61 l-cp src-path ta
3060: 72 67 65 74 2d 70 61 74 68 29 20 20 0a 20 20 28 rget-path) . (
3070: 63 6f 6e 64 0a 20 20 20 28 28 6e 6f 74 20 28 66 cond. ((not (f
3080: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
3090: 65 74 2d 70 61 74 68 29 29 0a 09 28 70 72 69 6e et-path))..(prin
30a0: 74 20 22 45 52 52 4f 52 3a 20 74 61 72 67 65 74 t "ERROR: target
30b0: 20 44 69 72 65 63 74 6f 72 79 20 22 20 74 61 72 Directory " tar
30c0: 67 65 74 2d 70 61 74 68 20 22 20 64 6f 65 73 20 get-path " does
30d0: 6e 6f 74 20 65 78 69 73 74 21 21 22 29 29 0a 20 not exist!!")).
30e0: 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 ((not (file-ex
30f0: 69 73 74 73 3f 20 73 72 63 2d 70 61 74 68 29 29 ists? src-path))
3100: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 . (print "Err
3110: 6f 72 3a 20 53 6f 75 72 63 65 20 70 61 74 68 20 or: Source path
3120: 22 20 73 72 63 2d 70 61 74 68 20 22 20 64 6f 65 " src-path " doe
3130: 73 20 6e 6f 74 20 65 78 69 73 74 21 21 22 20 29 s not exist!!" )
3140: 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 ). (else.
3150: 28 69 66 20 28 69 73 5f 64 69 72 65 63 74 6f 72 (if (is_director
3160: 79 20 73 72 63 2d 70 61 74 68 29 20 0a 20 20 20 y src-path) .
3170: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
3180: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
3190: 70 61 72 65 6e 74 2d 64 69 72 20 73 72 63 2d 70 parent-dir src-p
31a0: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
31b0: 20 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 64 (start-d
31c0: 69 72 20 74 61 72 67 65 74 2d 70 61 74 68 29 29 ir target-path))
31d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
31e0: 20 20 3b 28 70 72 69 6e 74 20 22 70 61 72 65 6e ;(print "paren
31f0: 74 2d 64 69 72 20 22 20 70 61 72 65 6e 74 2d 64 t-dir " parent-d
3200: 69 72 20 22 20 73 74 61 72 74 2d 64 69 72 20 22 ir " start-dir "
3210: 20 73 74 61 72 74 2d 64 69 72 29 20 20 20 0a 20 start-dir) .
3220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3230: 28 72 75 6e 20 28 70 69 70 65 0a 20 20 20 20 20 (run (pipe.
3240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
3250: 65 67 69 6e 20 28 73 79 73 74 65 6d 20 28 63 6f egin (system (co
3260: 6e 63 20 22 63 64 20 22 20 70 61 72 65 6e 74 2d nc "cd " parent-
3270: 64 69 72 20 22 20 3b 74 61 72 20 63 68 66 20 2d dir " ;tar chf -
3280: 20 2e 22 20 29 29 29 0a 20 20 20 20 20 20 20 20 ." ))).
3290: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
32a0: 6e 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 n (change-direct
32b0: 6f 72 79 20 73 74 61 72 74 2d 64 69 72 29 0a 20 ory start-dir).
32c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32d0: 20 20 20 20 20 20 20 20 20 3b 28 70 72 69 6e 74 ;(print
32e0: 20 22 31 32 33 22 29 0a 20 20 20 20 20 20 20 20 "123").
32f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3300: 20 20 28 72 75 6e 2d 63 6d 64 20 22 74 61 72 22 (run-cmd "tar"
3310: 20 28 6c 69 73 74 20 22 78 66 22 20 22 2d 22 29 (list "xf" "-")
3320: 29 29 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 )))))) .
3330: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
3340: 20 20 28 6c 65 74 2a 28 28 70 61 72 65 6e 74 2d (let*((parent-
3350: 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 dir (pathname-di
3360: 72 65 63 74 6f 72 79 20 73 72 63 2d 70 61 74 68 rectory src-path
3370: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3380: 20 20 20 20 20 28 73 74 61 72 74 2d 64 69 72 20 (start-dir
3390: 74 61 72 67 65 74 2d 70 61 74 68 29 0a 20 20 20 target-path).
33a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
33b0: 6c 65 6e 61 6d 65 20 28 69 66 20 20 28 70 61 74 lename (if (pat
33c0: 68 6e 61 6d 65 2d 65 78 74 65 6e 73 69 6f 6e 20 hname-extension
33d0: 73 72 63 2d 70 61 74 68 29 20 20 0a 20 20 20 20 src-path) .
33e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3400: 20 20 28 63 6f 6e 63 28 70 61 74 68 6e 61 6d 65 (conc(pathname
3410: 2d 66 69 6c 65 20 73 72 63 2d 70 61 74 68 29 20 -file src-path)
3420: 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 65 78 "." (pathname-ex
3430: 74 65 6e 73 69 6f 6e 20 73 72 63 2d 70 61 74 68 tension src-path
3440: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3460: 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 (pathna
3470: 6d 65 2d 66 69 6c 65 20 73 72 63 2d 70 61 74 68 me-file src-path
3480: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
3490: 20 20 20 20 20 3b 28 70 72 69 6e 74 20 22 70 61 ;(print "pa
34a0: 72 65 6e 74 2d 64 69 72 20 22 20 70 61 72 65 6e rent-dir " paren
34b0: 74 2d 64 69 72 20 22 20 73 74 61 72 74 2d 64 69 t-dir " start-di
34c0: 72 20 22 20 73 74 61 72 74 2d 64 69 72 29 20 20 r " start-dir)
34d0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
34e0: 20 20 20 28 72 75 6e 20 28 70 69 70 65 0a 20 20 (run (pipe.
34f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3500: 20 28 62 65 67 69 6e 20 28 73 79 73 74 65 6d 20 (begin (system
3510: 28 63 6f 6e 63 20 22 63 64 20 22 20 70 61 72 65 (conc "cd " pare
3520: 6e 74 2d 64 69 72 20 22 3b 74 61 72 20 63 68 66 nt-dir ";tar chf
3530: 20 2d 20 22 20 66 69 6c 65 6e 61 6d 65 20 29 29 - " filename ))
3540: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3550: 20 20 20 20 20 28 62 65 67 69 6e 20 28 63 68 61 (begin (cha
3560: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 73 74 nge-directory st
3570: 61 72 74 2d 64 69 72 29 0a 20 20 20 20 20 20 20 art-dir).
3580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3590: 20 20 20 28 72 75 6e 2d 63 6d 64 20 22 74 61 72 (run-cmd "tar
35a0: 22 20 28 6c 69 73 74 20 22 78 66 22 20 22 2d 22 " (list "xf" "-"
35b0: 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ))) .
35c0: 20 20 20 20 20 20 20 29 29 29 29 29 29 29 29 0a )))))))).
35d0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c ..(define (spubl
35e0: 69 73 68 3a 73 68 65 6c 6c 2d 6d 6b 64 69 72 20 ish:shell-mkdir
35f0: 74 61 72 67 2d 70 61 74 68 29 0a 20 20 20 20 28 targ-path). (
3600: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
3610: 20 74 61 72 67 2d 70 61 74 68 29 0a 09 28 62 65 targ-path)..(be
3620: 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 45 gin.. (print "E
3630: 52 52 4f 52 3a 20 74 61 72 67 65 74 20 44 69 72 RROR: target Dir
3640: 65 63 74 6f 72 79 20 22 20 74 61 72 67 2d 70 61 ectory " targ-pa
3650: 74 68 20 22 20 61 6c 72 65 61 64 79 20 65 78 69 th " already exi
3660: 73 74 21 21 22 29 29 0a 20 20 20 20 20 20 20 20 st!!")).
3670: 28 6c 65 74 2a 20 28 28 74 68 31 20 20 20 20 20 (let* ((th1
3680: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
3690: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
36a0: 09 09 09 20 20 20 28 63 72 65 61 74 65 2d 64 69 ... (create-di
36b0: 72 65 63 74 6f 72 79 20 74 61 72 67 2d 70 61 74 rectory targ-pat
36c0: 68 20 23 74 29 0a 09 09 09 20 20 20 28 70 72 69 h #t).... (pri
36d0: 6e 74 20 22 20 2e 2e 2e 20 64 69 72 20 22 20 74 nt " ... dir " t
36e0: 61 72 67 2d 70 61 74 68 20 22 20 63 72 65 61 74 arg-path " creat
36f0: 65 64 22 29 29 0a 09 09 09 20 22 6d 6b 64 69 72 ed")).... "mkdir
3700: 20 74 68 72 65 61 64 22 29 29 0a 09 20 20 20 28 thread")).. (
3710: 74 68 32 20 20 20 20 20 20 20 20 20 28 6d 61 6b th2 (mak
3720: 65 2d 74 68 72 65 61 64 0a 09 09 09 20 28 6c 61 e-thread.... (la
3730: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 28 6c mbda ().... (l
3740: 65 74 20 6c 6f 6f 70 20 28 29 0a 09 09 09 20 20 et loop ()....
3750: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
3760: 21 20 31 35 29 0a 09 09 09 20 20 20 20 20 28 64 ! 15).... (d
3770: 69 73 70 6c 61 79 20 22 2e 22 29 0a 09 09 09 20 isplay ".")....
3780: 20 20 20 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 (flush-outpu
3790: 74 29 0a 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 t).... (loop
37a0: 29 29 29 0a 09 09 09 20 22 61 63 74 69 6f 6e 20 ))).... "action
37b0: 69 73 20 68 61 70 70 65 6e 69 6e 67 20 74 68 72 is happening thr
37c0: 65 61 64 22 29 29 29 0a 20 20 20 20 20 20 28 74 ead"))). (t
37d0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 hread-start! th1
37e0: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
37f0: 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 start! th2).
3800: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
3810: 74 68 31 29 0a 20 20 20 20 28 63 6f 6e 73 20 23 th1). (cons #
3820: 74 20 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 t "Successfully
3830: 73 61 76 65 64 20 64 61 74 61 22 29 29 29 29 0a saved data")))).
3840: 20 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 ..(define (spub
3850: 6c 69 73 68 3a 73 68 65 6c 6c 2d 72 6d 20 74 61 lish:shell-rm ta
3860: 72 67 2d 70 61 74 68 29 0a 20 20 20 20 28 69 66 rg-path). (if
3870: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3880: 74 73 3f 20 74 61 72 67 2d 70 61 74 68 29 29 0a ts? targ-path)).
3890: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e .(begin.. (prin
38a0: 74 20 22 45 52 52 4f 52 3a 20 74 61 72 67 65 74 t "ERROR: target
38b0: 20 70 61 74 68 20 22 20 74 61 72 67 2d 70 61 74 path " targ-pat
38c0: 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 h " does not exi
38d0: 73 74 21 21 22 29 29 0a 20 20 20 20 20 20 20 20 st!!")).
38e0: 28 6c 65 74 2a 20 28 28 74 68 31 20 20 20 20 20 (let* ((th1
38f0: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
3900: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
3910: 09 09 09 20 20 20 28 64 65 6c 65 74 65 2d 66 69 ... (delete-fi
3920: 6c 65 20 20 74 61 72 67 2d 70 61 74 68 20 29 0a le targ-path ).
3930: 09 09 09 20 20 20 28 70 72 69 6e 74 20 22 20 2e ... (print " .
3940: 2e 2e 20 70 61 74 68 20 22 20 74 61 72 67 2d 70 .. path " targ-p
3950: 61 74 68 20 22 20 64 65 6c 65 74 65 64 22 29 29 ath " deleted"))
3960: 0a 09 09 09 20 22 72 6d 20 74 68 72 65 61 64 22 .... "rm thread"
3970: 29 29 0a 09 20 20 20 28 74 68 32 20 20 20 20 20 )).. (th2
3980: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
3990: 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
39a0: 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
39b0: 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 ().... (thre
39c0: 61 64 2d 73 6c 65 65 70 21 20 31 35 29 0a 09 09 ad-sleep! 15)...
39d0: 09 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 . (display "
39e0: 2e 22 29 0a 09 09 09 20 20 20 20 20 28 66 6c 75 .").... (flu
39f0: 73 68 2d 6f 75 74 70 75 74 29 0a 09 09 09 20 20 sh-output)....
3a00: 20 20 20 28 6c 6f 6f 70 29 29 29 0a 09 09 09 20 (loop)))....
3a10: 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 70 65 "action is happe
3a20: 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 29 0a ning thread"))).
3a30: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
3a40: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 art! th1).
3a50: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
3a60: 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h2). (threa
3a70: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 d-join! th1).
3a80: 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 63 65 (cons #t "Succe
3a90: 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 64 61 ssfully saved da
3aa0: 74 61 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ta"))))..(define
3ab0: 20 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c 6c (spublish:shell
3ac0: 2d 6c 6e 20 73 72 63 2d 70 61 74 68 20 74 61 72 -ln src-path tar
3ad0: 67 65 74 2d 70 61 74 68 20 73 75 62 2d 70 61 74 get-path sub-pat
3ae0: 68 29 0a 20 20 20 28 69 66 20 28 6e 6f 74 20 28 h). (if (not (
3af0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 75 62 file-exists? sub
3b00: 2d 70 61 74 68 29 29 0a 09 20 28 70 72 69 6e 74 -path)).. (print
3b10: 20 22 45 52 52 4f 52 3a 20 50 61 74 68 20 22 20 "ERROR: Path "
3b20: 73 75 62 2d 70 61 74 68 20 22 20 64 6f 65 73 20 sub-path " does
3b30: 6e 6f 74 20 65 78 69 73 74 21 21 20 63 61 6e 6e not exist!! cann
3b40: 6f 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 ot proceed with
3b50: 6c 69 6e 6b 20 63 72 65 61 74 69 6f 6e 21 21 22 link creation!!"
3b60: 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ). (begin
3b70: 20 20 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
3b80: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3b90: 74 73 3f 20 73 72 63 2d 70 61 74 68 29 29 0a 20 ts? src-path)).
3ba0: 20 09 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
3bb0: 52 4f 52 3a 20 50 61 74 68 20 22 20 73 72 63 2d ROR: Path " src-
3bc0: 70 61 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 path " does not
3bd0: 65 78 69 73 74 21 21 20 63 61 6e 6e 6f 74 20 70 exist!! cannot p
3be0: 72 6f 63 65 65 64 20 77 69 74 68 20 6c 69 6e 6b roceed with link
3bf0: 20 63 72 65 61 74 69 6f 6e 21 21 22 29 0a 20 20 creation!!").
3c00: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
3c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3c20: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
3c30: 73 3f 20 74 61 72 67 65 74 2d 70 61 74 68 29 0a s? target-path).
3c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c50: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
3c60: 3a 20 50 61 74 68 20 22 20 74 61 72 67 65 74 2d : Path " target-
3c70: 70 61 74 68 20 22 61 6c 72 65 61 64 79 20 65 78 path "already ex
3c80: 69 73 74 21 21 20 63 61 6e 6e 6f 74 20 70 72 6f ist!! cannot pro
3c90: 63 65 65 64 20 77 69 74 68 20 6c 69 6e 6b 20 63 ceed with link c
3ca0: 72 65 61 74 69 6f 6e 21 21 22 29 0a 20 20 20 20 reation!!").
3cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3cc0: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 72 (cr
3ce0: 65 61 74 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 eate-symbolic-li
3cf0: 6e 6b 20 73 72 63 2d 70 61 74 68 20 74 61 72 67 nk src-path targ
3d00: 65 74 2d 70 61 74 68 20 20 29 0a 09 09 09 20 20 et-path )....
3d10: 20 28 70 72 69 6e 74 20 22 20 2e 2e 2e 20 6c 69 (print " ... li
3d20: 6e 6b 20 22 20 74 61 72 67 65 74 2d 70 61 74 68 nk " target-path
3d30: 20 22 20 63 72 65 61 74 65 64 22 29 29 29 29 29 " created")))))
3d40: 29 29 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 73 ))). .(define (s
3d50: 70 75 62 6c 69 73 68 3a 73 68 65 6c 6c 2d 68 65 publish:shell-he
3d60: 6c 70 29 0a 28 63 6f 6e 63 20 22 55 73 61 67 65 lp).(conc "Usage
3d70: 3a 20 5b 61 63 74 69 6f 6e 20 5b 70 61 72 61 6d : [action [param
3d80: 73 20 2e 2e 2e 5d 5d 0a 0a 20 20 6c 73 20 20 20 s ...]].. ls
3d90: 20 5b 74 61 72 67 65 74 20 70 61 74 68 5d 20 20 [target path]
3da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 09 20 20 .
3db0: 3a 20 6c 69 73 74 20 63 6f 6e 74 65 6e 74 73 20 : list contents
3dc0: 6f 66 20 74 61 72 67 65 74 20 61 72 65 61 2e 0a of target area..
3dd0: 20 20 63 64 20 20 20 20 3c 74 61 72 67 65 74 20 cd <target
3de0: 70 61 74 68 3e 20 09 20 20 20 20 20 09 20 20 20 path> . .
3df0: 20 20 20 20 20 20 20 3a 20 54 6f 20 63 68 61 6e : To chan
3e00: 67 65 20 74 68 65 20 63 75 72 72 65 6e 74 20 64 ge the current d
3e10: 69 72 65 63 74 6f 72 79 20 77 69 74 68 69 6e 20 irectory within
3e20: 74 68 65 20 73 72 65 74 72 69 76 65 20 73 68 65 the sretrive she
3e30: 6c 6c 2e 20 0a 20 20 70 77 64 09 09 09 09 20 20 ll. . pwd....
3e40: 20 20 20 09 20 20 3a 20 50 72 69 6e 74 73 20 74 . : Prints t
3e50: 68 65 20 66 75 6c 6c 20 70 61 74 68 6e 61 6d 65 he full pathname
3e60: 20 6f 66 20 74 68 65 20 63 75 72 72 65 6e 74 20 of the current
3e70: 64 69 72 65 63 74 6f 72 79 20 77 69 74 68 69 6e directory within
3e80: 20 74 68 65 20 73 72 65 74 72 69 76 65 20 73 68 the sretrive sh
3e90: 65 6c 6c 2e 0a 20 20 6d 6b 64 69 72 20 3c 70 61 ell.. mkdir <pa
3ea0: 74 68 3e 20 20 20 20 20 20 20 20 20 20 20 20 20 th>
3eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a :
3ec0: 20 63 72 65 61 74 65 73 20 64 69 72 65 63 74 6f creates directo
3ed0: 72 79 2e 20 4e 6f 74 65 20 69 74 20 64 6f 65 73 ry. Note it does
3ee0: 20 6e 6f 74 20 63 72 65 61 74 65 27 73 20 61 20 not create's a
3ef0: 70 61 74 68 20 72 65 63 75 72 73 69 76 65 20 6d path recursive m
3f00: 61 6e 6e 65 72 2e 0a 20 20 72 6d 20 3c 74 61 72 anner.. rm <tar
3f10: 67 65 74 20 70 61 74 68 3e 20 20 20 20 20 20 20 get path>
3f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f30: 20 3a 20 72 65 6d 6f 76 65 73 20 66 69 6c 65 73 : removes files
3f40: 20 61 6e 64 20 65 6d 6f 74 79 20 64 69 72 65 63 and emoty direc
3f50: 74 6f 72 69 65 73 20 20 20 0a 20 20 63 70 20 3c tories . cp <
3f60: 73 72 63 3e 20 3c 74 61 72 67 65 74 20 70 61 74 src> <target pat
3f70: 68 3e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h>
3f80: 20 20 20 20 3a 20 63 6f 70 79 20 61 20 66 69 6c : copy a fil
3f90: 65 2f 64 69 72 20 74 6f 20 74 61 72 67 65 74 20 e/dir to target
3fa0: 70 61 74 68 2e 20 69 66 20 73 72 63 20 69 73 20 path. if src is
3fb0: 61 20 64 69 72 20 69 74 20 61 75 74 6f 6d 61 74 a dir it automat
3fc0: 69 63 61 6c 6c 79 20 6d 61 6b 65 73 20 61 20 72 ically makes a r
3fd0: 65 63 75 72 73 69 76 65 20 63 6f 70 79 2e 0a 20 ecursive copy..
3fe0: 20 6c 6e 20 54 41 52 47 45 54 20 4c 49 4e 4b 5f ln TARGET LINK_
3ff0: 4e 41 4d 45 20 20 20 20 20 20 20 20 20 20 20 20 NAME
4000: 20 20 20 20 20 20 20 20 20 3a 20 63 72 65 61 74 : creat
4010: 65 73 20 61 20 73 79 6d 6c 69 6e 6b 20 20 20 20 es a symlink
4020: 20 20 0a 50 61 72 74 20 6f 66 20 74 68 65 20 4d .Part of the M
4030: 65 67 61 74 65 73 74 20 74 6f 6f 6c 20 73 75 69 egatest tool sui
4040: 74 65 2e 0a 4c 65 61 72 6e 20 6d 6f 72 65 20 61 te..Learn more a
4050: 74 20 68 74 74 70 3a 2f 2f 77 77 77 2e 6b 69 61 t http://www.kia
4060: 74 6f 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f toa.com/fossils/
4070: 6d 65 67 61 74 65 73 74 0a 0a 56 65 72 73 69 6f megatest..Versio
4080: 6e 3a 20 22 20 6d 65 67 61 74 65 73 74 2d 66 6f n: " megatest-fo
4090: 73 73 69 6c 2d 68 61 73 68 29 0a 29 09 0a 0a 28 ssil-hash).)...(
40a0: 64 65 66 69 6e 65 20 28 74 6f 70 6c 65 76 65 6c define (toplevel
40b0: 2d 63 6f 6d 6d 61 6e 64 20 2e 20 61 72 67 73 29 -command . args)
40c0: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 #f)..(define (s
40d0: 70 75 62 6c 69 73 68 3a 73 68 65 6c 6c 20 61 72 publish:shell ar
40e0: 65 61 29 0a 20 3b 20 28 70 72 69 6e 74 20 61 72 ea). ; (print ar
40f0: 65 61 29 0a 20 20 28 75 73 65 20 72 65 61 64 6c ea). (use readl
4100: 69 6e 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 ine). (let* ((p
4110: 61 74 68 20 20 20 20 20 20 27 28 29 29 0a 09 20 ath '())..
4120: 28 70 72 6f 6d 70 74 20 20 20 20 22 73 70 75 62 (prompt "spub
4130: 6c 69 73 68 3e 20 22 29 0a 09 20 28 61 72 67 73 lish> ").. (args
4140: 20 20 20 20 20 20 28 61 72 67 76 29 29 0a 20 20 (argv)).
4150: 20 20 20 20 20 20 20 28 75 73 72 20 28 63 75 72 (usr (cur
4160: 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
4170: 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 28 74 ) . (t
4180: 6f 70 2d 61 72 65 61 73 20 28 73 70 75 62 6c 69 op-areas (spubli
4190: 73 68 3a 67 65 74 2d 61 63 63 65 73 73 61 62 6c sh:get-accessabl
41a0: 65 2d 70 72 6f 6a 65 63 74 73 20 61 72 65 61 29 e-projects area)
41b0: 29 0a 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 ). (clos
41c0: 65 2d 70 6f 72 74 20 20 20 20 20 23 66 29 0a 20 e-port #f).
41d0: 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 6f 62 (area-ob
41e0: 6a 20 20 28 67 65 74 2d 6f 62 6a 2d 62 79 2d 63 j (get-obj-by-c
41f0: 6f 64 65 20 61 72 65 61 29 29 0a 20 20 20 20 20 ode area)).
4200: 20 20 20 20 28 75 73 65 72 2d 6f 62 6a 20 28 67 (user-obj (g
4210: 65 74 2d 75 73 65 72 20 75 73 72 29 29 20 0a 20 et-user usr)) .
4220: 20 20 20 20 20 20 20 20 28 62 61 73 65 2d 70 61 (base-pa
4230: 74 68 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 th (if (null? ar
4240: 65 61 2d 6f 62 6a 29 20 0a 20 20 20 20 20 20 20 ea-obj) .
4250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4260: 20 20 22 22 20 0a 20 20 20 20 20 20 20 20 20 20 "" .
4270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
4280: 61 64 64 72 20 28 63 64 72 20 61 72 65 61 2d 6f addr (cdr area-o
4290: 62 6a 29 29 29 29 20 20 20 20 20 20 0a 09 20 28 bj)))) .. (
42a0: 69 70 6f 72 74 20 20 20 20 20 28 6d 61 6b 65 2d iport (make-
42b0: 72 65 61 64 6c 69 6e 65 2d 70 6f 72 74 20 70 72 readline-port pr
42c0: 6f 6d 70 74 29 29 29 0a 20 20 20 20 20 20 20 20 ompt))).
42d0: 3b 28 70 72 69 6e 74 20 62 61 73 65 2d 70 61 74 ;(print base-pat
42e0: 68 29 20 0a 20 20 20 20 20 20 20 20 28 69 66 20 h) . (if
42f0: 28 6e 75 6c 6c 3f 20 61 72 65 61 2d 6f 62 6a 29 (null? area-obj)
4300: 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 . (begi
4310: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
4320: 28 70 72 69 6e 74 20 22 41 72 65 61 20 22 20 61 (print "Area " a
4330: 72 65 61 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 rea " does not e
4340: 78 69 73 74 22 29 0a 20 20 20 20 20 20 20 20 20 xist").
4350: 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 (exit 1))).
4360: 20 20 20 20 3b 20 28 70 72 69 6e 74 20 22 68 65 ; (print "he
4370: 72 65 22 29 20 20 20 20 0a 09 28 6c 65 74 20 6c re") ..(let l
4380: 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d oop ((inl (read-
4390: 6c 69 6e 65 20 69 70 6f 72 74 29 29 29 0a 09 20 line iport)))..
43a0: 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 28 6f (if (not (or (o
43b0: 72 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 r (eof-object? i
43c0: 6e 6c 29 0a 09 09 20 20 20 20 20 20 20 28 65 71 nl)... (eq
43d0: 75 61 6c 3f 20 69 6e 6c 20 22 65 78 69 74 22 29 ual? inl "exit")
43e0: 29 20 28 70 6f 72 74 2d 63 6c 6f 73 65 64 3f 20 ) (port-closed?
43f0: 69 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 iport)))..
4400: 28 6c 65 74 2a 20 28 28 70 61 72 74 73 20 28 73 (let* ((parts (s
4410: 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e 6c 29 tring-split inl)
4420: 29 0a 09 09 20 20 20 20 20 28 63 6d 64 20 20 20 )... (cmd
4430: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 74 73 (if (null? parts
4440: 29 20 23 66 20 28 63 61 72 20 70 61 72 74 73 29 ) #f (car parts)
4450: 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 28 )))...(if (and (
4460: 6e 6f 74 20 63 6d 64 29 20 28 6e 6f 74 20 28 70 not cmd) (not (p
4470: 6f 72 74 2d 63 6c 6f 73 65 64 3f 20 69 70 6f 72 ort-closed? ipor
4480: 74 29 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 t)))... (loop
4490: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 (read-line))...
44a0: 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e (case (strin
44b0: 67 2d 3e 73 79 6d 62 6f 6c 20 63 6d 64 29 0a 09 g->symbol cmd)..
44c0: 09 20 20 20 20 20 20 28 28 63 64 29 0a 09 09 20 . ((cd)...
44d0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 (if (> (le
44e0: 6e 67 74 68 20 70 61 72 74 73 29 20 31 29 20 3b ngth parts) 1) ;
44f0: 3b 20 68 61 76 65 20 61 20 70 61 72 61 6d 65 74 ; have a paramet
4500: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
4510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
4520: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
4530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4540: 20 20 28 6c 65 74 2a 28 28 61 72 67 20 28 63 61 (let*((arg (ca
4550: 64 72 20 70 61 72 74 73 29 29 0a 20 20 20 20 20 dr parts)).
4560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
4580: 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 61 esolved-path (sa
4590: 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c uth-common:resol
45a0: 76 65 2d 70 61 74 68 20 20 61 72 67 20 70 61 74 ve-path arg pat
45b0: 68 20 74 6f 70 2d 61 72 65 61 73 29 29 0a 20 20 h top-areas)).
45c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
45d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
45e0: 20 28 74 61 72 67 65 74 2d 70 61 74 68 20 28 73 (target-path (s
45f0: 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d auth-common:get-
4600: 74 61 72 67 65 74 2d 70 61 74 68 20 70 61 74 68 target-path path
4610: 20 20 61 72 67 20 74 6f 70 2d 61 72 65 61 73 20 arg top-areas
4620: 62 61 73 65 2d 70 61 74 68 29 29 29 0a 20 20 20 base-path))).
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
4650: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 74 f (not (equal? t
4660: 61 72 67 65 74 2d 70 61 74 68 20 23 66 29 29 0a arget-path #f)).
4670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4690: 20 28 69 66 20 28 6f 72 20 28 65 71 75 61 6c 3f (if (or (equal?
46a0: 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 23 resolved-path #
46b0: 66 29 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 f) (not (file-ex
46c0: 69 73 74 73 3f 20 74 61 72 67 65 74 2d 70 61 74 ists? target-pat
46d0: 68 29 29 29 20 20 20 20 0a 20 20 20 20 20 20 20 h))) .
46e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46f0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
4700: 20 22 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 "Invalid argume
4710: 6e 74 20 22 20 61 72 67 20 22 2e 2e 20 22 29 0a nt " arg ".. ").
4720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4740: 20 20 28 62 65 67 69 6e 20 20 20 20 20 20 0a 09 (begin ..
4750: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 28 73 .. (s
4760: 65 74 21 20 70 61 74 68 20 72 65 73 6f 6c 76 65 et! path resolve
4770: 64 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 d-path).
4780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4790: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 (sa
47a0: 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 uthorize:do-as-c
47b0: 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 alling-user.
47c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47d0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
47e0: 61 20 28 29 0a 09 09 09 20 20 20 20 28 72 75 6e a ().... (run
47f0: 2d 63 6d 64 20 28 63 6f 6e 63 20 2a 73 61 75 74 -cmd (conc *saut
4800: 68 2d 70 61 74 68 2a 20 22 2f 73 61 75 74 68 6f h-path* "/sautho
4810: 72 69 7a 65 22 29 20 28 6c 69 73 74 20 22 72 65 rize") (list "re
4820: 67 69 73 74 65 72 2d 6c 6f 67 22 20 28 63 6f 6e gister-log" (con
4830: 63 20 22 5c 22 22 20 69 6e 6c 20 22 5c 22 22 29 c "\"" inl "\"")
4840: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
4850: 20 28 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 29 (car user-obj))
4860: 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e (number->strin
4870: 67 20 28 63 61 64 64 72 20 61 72 65 61 2d 6f 62 g (caddr area-ob
4880: 6a 29 29 20 20 22 63 64 22 29 29 29 29 0a 20 20 j)) "cd")))).
4890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48b0: 29 29 29 29 29 20 20 0a 20 20 20 09 09 09 20 20 ))))) . ...
48c0: 20 28 73 65 74 21 20 70 61 74 68 20 27 28 29 29 (set! path '())
48d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
48e0: 20 20 20 20 20 20 20 20 20 28 28 70 77 64 29 0a ((pwd).
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4900: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
4910: 6c 6c 3f 20 70 61 74 68 29 0a 20 20 20 20 20 20 ll? path).
4920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4930: 20 20 20 20 20 28 70 72 69 6e 74 20 22 2f 22 29 (print "/")
4940: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
4960: 72 69 6e 74 20 22 2f 22 20 28 73 74 72 69 6e 67 rint "/" (string
4970: 2d 6a 6f 69 6e 20 70 61 74 68 20 22 2f 22 29 29 -join path "/"))
4980: 29 29 20 0a 09 09 20 20 20 20 20 20 28 28 6c 73 )) ... ((ls
4990: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a )... (let*
49a0: 20 28 28 74 68 65 70 61 74 68 20 28 69 66 20 28 ((thepath (if (
49b0: 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 > (length parts)
49c0: 20 31 29 20 3b 3b 20 68 61 76 65 20 61 20 70 61 1) ;; have a pa
49d0: 72 61 6d 65 74 65 72 0a 09 09 09 09 09 20 20 20 rameter......
49e0: 28 63 64 72 20 70 61 72 74 73 29 0a 09 09 09 09 (cdr parts).....
49f0: 09 20 20 20 60 28 29 29 29 0a 09 09 09 20 20 20 . `()))....
4a00: 20 20 20 28 70 6c 65 6e 20 20 20 20 28 6c 65 6e (plen (len
4a10: 67 74 68 20 74 68 65 70 61 74 68 29 29 29 0a 20 gth thepath))).
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a30: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 (cond...
4a40: 09 20 20 28 28 6e 75 6c 6c 3f 20 74 68 65 70 61 . ((null? thepa
4a50: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4a70: 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 sauth-common:she
4a80: 6c 6c 2d 6c 73 2d 63 6d 64 20 70 61 74 68 20 22 ll-ls-cmd path "
4a90: 22 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 " top-areas base
4aa0: 2d 70 61 74 68 20 20 27 28 29 29 0a 20 20 20 20 -path '()).
4ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ac0: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
4ad0: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
4ae0: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 g-user.
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b00: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
4b10: 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 ... (run-cmd
4b20: 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 (conc *sauth-pat
4b30: 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 h* "/sauthorize"
4b40: 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 ) (list "registe
4b50: 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 r-log" (conc "\"
4b60: 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d " inl "\"") (num
4b70: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 ber->string (car
4b80: 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 user-obj)) (nu
4b90: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 mber->string (ca
4ba0: 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 ddr area-obj))
4bb0: 22 6c 73 22 29 29 29 29 20 20 20 29 0a 09 09 09 "ls")))) )....
4bc0: 20 20 28 28 3c 20 70 6c 65 6e 20 32 29 0a 20 20 ((< plen 2).
4bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4be0: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
4bf0: 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c 73 -common:shell-ls
4c00: 2d 63 6d 64 20 70 61 74 68 20 20 28 63 61 72 20 -cmd path (car
4c10: 74 68 65 70 61 74 68 29 20 74 6f 70 2d 61 72 65 thepath) top-are
4c20: 61 73 20 62 61 73 65 2d 70 61 74 68 20 27 28 29 as base-path '()
4c30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c50: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 (sauthorize:do-a
4c60: 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 s-calling-user.
4c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
4c90: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 28 mbda ().... (
4ca0: 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 2a 73 run-cmd (conc *s
4cb0: 61 75 74 68 2d 70 61 74 68 2a 20 22 2f 73 61 75 auth-path* "/sau
4cc0: 74 68 6f 72 69 7a 65 22 29 20 28 6c 69 73 74 20 thorize") (list
4cd0: 22 72 65 67 69 73 74 65 72 2d 6c 6f 67 22 20 28 "register-log" (
4ce0: 63 6f 6e 63 20 22 5c 22 22 20 69 6e 6c 20 22 5c conc "\"" inl "\
4cf0: 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 "") (number->str
4d00: 69 6e 67 20 28 63 61 72 20 75 73 65 72 2d 6f 62 ing (car user-ob
4d10: 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 j)) (number->st
4d20: 72 69 6e 67 20 28 63 61 64 64 72 20 61 72 65 61 ring (caddr area
4d30: 2d 6f 62 6a 29 29 20 20 22 6c 73 22 29 29 29 29 -obj)) "ls"))))
4d40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4d50: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
4d60: 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e .
4d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4d80: 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 20 if (equal? (car
4d90: 74 68 65 70 61 74 68 29 20 22 7c 22 29 0a 20 20 thepath) "|").
4da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4db0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 (sau
4dc0: 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c 2d th-common:shell-
4dd0: 6c 73 2d 63 6d 64 20 70 61 74 68 20 22 22 20 74 ls-cmd path "" t
4de0: 6f 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 op-areas base-pa
4df0: 74 68 20 74 68 65 70 61 74 68 29 0a 20 20 20 20 th thepath).
4e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e10: 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 (sauth
4e20: 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c 73 -common:shell-ls
4e30: 2d 63 6d 64 20 70 61 74 68 20 20 28 63 61 72 20 -cmd path (car
4e40: 74 68 65 70 61 74 68 29 20 74 6f 70 2d 61 72 65 thepath) top-are
4e50: 61 73 20 62 61 73 65 2d 70 61 74 68 20 28 63 64 as base-path (cd
4e60: 72 20 74 68 65 70 61 74 68 29 29 29 0a 20 20 20 r thepath))).
4e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e80: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
4e90: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
4ea0: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 g-user.
4eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ec0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
4ed0: 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 ... (run-cmd
4ee0: 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 (conc *sauth-pat
4ef0: 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 h* "/sauthorize"
4f00: 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 ) (list "registe
4f10: 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 r-log" (conc "\"
4f20: 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d " inl "\"") (num
4f30: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 ber->string (car
4f40: 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 user-obj)) (nu
4f50: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 mber->string (ca
4f60: 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 ddr area-obj))
4f70: 22 6c 73 22 29 29 29 29 29 29 29 29 0a 20 20 20 "ls")))))))).
4f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f90: 20 20 20 20 28 28 6d 6b 64 69 72 29 0a 20 20 20 ((mkdir).
4fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fb0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 (let* ((th
4fc0: 65 70 61 74 68 20 28 69 66 20 28 3e 20 28 6c 65 epath (if (> (le
4fd0: 6e 67 74 68 20 70 61 72 74 73 29 20 31 29 20 3b ngth parts) 1) ;
4fe0: 3b 20 68 61 76 65 20 61 20 70 61 72 61 6d 65 74 ; have a paramet
4ff0: 65 72 0a 09 09 09 09 20 20 20 28 63 64 72 20 70 er..... (cdr p
5000: 61 72 74 73 29 0a 09 09 09 09 20 20 20 60 28 29 arts)..... `()
5010: 29 29 0a 09 09 09 20 20 20 20 20 20 28 70 6c 65 )).... (ple
5020: 6e 20 20 20 20 28 6c 65 6e 67 74 68 20 74 68 65 n (length the
5030: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
5040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5050: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
5060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5070: 20 28 28 6e 75 6c 6c 3f 20 74 68 65 70 61 74 68 ((null? thepath
5080: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
50a0: 72 69 6e 74 20 22 6d 6b 64 69 72 20 74 61 6b 65 rint "mkdir take
50b0: 73 20 6f 6e 65 20 61 72 67 75 6d 65 6e 74 22 29 s one argument")
50c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
50d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 ((<
50e0: 70 6c 65 6e 20 32 29 20 0a 20 20 20 20 20 20 20 plen 2) .
50f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5100: 20 20 20 20 20 28 6c 65 74 2a 28 28 6d 6b 2d 70 (let*((mk-p
5110: 61 74 68 20 28 63 61 64 72 20 70 61 72 74 73 29 ath (cadr parts)
5120: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5140: 20 20 20 20 28 72 65 73 6f 6c 76 65 64 2d 70 61 (resolved-pa
5150: 74 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e th (sauth-common
5160: 3a 72 65 73 6f 6c 76 65 2d 70 61 74 68 20 20 6d :resolve-path m
5170: 6b 2d 70 61 74 68 20 70 61 74 68 20 74 6f 70 2d k-path path top-
5180: 61 72 65 61 73 29 29 0a 20 20 20 20 20 20 20 20 areas)).
5190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51a0: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
51b0: 74 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f t-path (sauth-co
51c0: 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 65 74 2d mmon:get-target-
51d0: 70 61 74 68 20 70 61 74 68 20 20 6d 6b 2d 70 61 path path mk-pa
51e0: 74 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 th top-areas bas
51f0: 65 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 e-path))).
5200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5210: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
5220: 20 28 65 71 75 61 6c 3f 20 74 61 72 67 65 74 2d (equal? target-
5230: 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 20 20 path #f)).
5240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5250: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
5260: 65 71 75 61 6c 3f 20 72 65 73 6f 6c 76 65 64 2d equal? resolved-
5270: 70 61 74 68 20 23 66 29 20 20 20 20 20 0a 20 20 path #f) .
5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
52a0: 70 72 69 6e 74 20 22 49 6e 76 61 6c 69 64 20 61 print "Invalid a
52b0: 72 67 75 6d 65 6e 74 20 22 20 6d 6b 2d 70 61 74 rgument " mk-pat
52c0: 68 20 22 2e 2e 20 22 29 0a 20 20 20 20 20 20 20 h ".. ").
52d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52e0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
52f0: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
5300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5310: 20 20 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 (spubli
5320: 73 68 3a 73 68 65 6c 6c 2d 6d 6b 64 69 72 20 74 sh:shell-mkdir t
5330: 61 72 67 65 74 2d 70 61 74 68 29 20 20 20 0a 20 arget-path) .
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5360: 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 (sauthorize
5370: 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 :do-as-calling-u
5380: 73 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 ser.
5390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53a0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ()....
53b0: 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f (run-cmd (co
53c0: 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 nc *sauth-path*
53d0: 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 "/sauthorize") (
53e0: 6c 69 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c list "register-l
53f0: 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 22 20 69 og" (conc "\"" i
5400: 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d 62 65 72 nl "\"") (number
5410: 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 75 73 ->string (car us
5420: 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 6d 62 65 er-obj)) (numbe
5430: 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 64 64 72 r->string (caddr
5440: 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 22 6d 6b area-obj)) "mk
5450: 64 69 72 22 29 29 29 29 29 29 29 0a 09 09 20 20 dir")))))))...
5460: 20 20 20 20 20 29 29 29 29 29 0a 20 20 20 20 20 ))))).
5470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5480: 20 20 28 28 72 6d 29 0a 20 20 20 20 20 20 20 20 ((rm).
5490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54a0: 20 20 28 6c 65 74 2a 20 28 28 74 68 65 70 61 74 (let* ((thepat
54b0: 68 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 h (if (> (length
54c0: 20 70 61 72 74 73 29 20 31 29 20 3b 3b 20 68 61 parts) 1) ;; ha
54d0: 76 65 20 61 20 70 61 72 61 6d 65 74 65 72 0a 09 ve a parameter..
54e0: 09 09 09 20 20 20 28 63 64 72 20 70 61 72 74 73 ... (cdr parts
54f0: 29 0a 09 09 09 09 20 20 20 60 28 29 29 29 0a 09 )..... `()))..
5500: 09 09 20 20 20 20 20 20 28 70 6c 65 6e 20 20 20 .. (plen
5510: 20 28 6c 65 6e 67 74 68 20 74 68 65 70 61 74 68 (length thepath
5520: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
5530: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5540: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
5550: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e ((n
5560: 75 6c 6c 3f 20 74 68 65 70 61 74 68 29 0a 20 20 ull? thepath).
5570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5580: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
5590: 20 22 72 6d 20 74 61 6b 65 73 20 6f 6e 65 20 61 "rm takes one a
55a0: 72 67 75 6d 65 6e 74 22 29 29 0a 20 20 20 20 20 rgument")).
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55c0: 20 20 20 20 20 28 28 3c 20 70 6c 65 6e 20 32 29 ((< plen 2)
55d0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
55e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
55f0: 65 74 2a 28 28 72 6d 2d 70 61 74 68 20 28 63 61 et*((rm-path (ca
5600: 64 72 20 70 61 72 74 73 29 29 0a 20 20 20 20 20 dr parts)).
5610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5620: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
5630: 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 61 75 solved-path (sau
5640: 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 th-common:resolv
5650: 65 2d 70 61 74 68 20 20 72 6d 2d 70 61 74 68 20 e-path rm-path
5660: 70 61 74 68 20 74 6f 70 2d 61 72 65 61 73 29 29 path top-areas))
5670: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5690: 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 68 20 (target-path
56a0: 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 (sauth-common:ge
56b0: 74 2d 74 61 72 67 65 74 2d 70 61 74 68 20 70 61 t-target-path pa
56c0: 74 68 20 20 72 6d 2d 70 61 74 68 20 74 6f 70 2d th rm-path top-
56d0: 61 72 65 61 73 20 62 61 73 65 2d 70 61 74 68 29 areas base-path)
56e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
56f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5700: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
5710: 3f 20 74 61 72 67 65 74 2d 70 61 74 68 20 23 66 ? target-path #f
5720: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5740: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
5750: 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 23 66 resolved-path #f
5760: 29 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 ) .
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5780: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
5790: 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 Invalid argument
57a0: 20 22 20 72 6d 2d 70 61 74 68 20 22 2e 2e 20 22 " rm-path ".. "
57b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
57c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57d0: 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 (begin .
57e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5800: 20 20 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c (spublish:shel
5810: 6c 2d 72 6d 20 74 61 72 67 65 74 2d 70 61 74 68 l-rm target-path
5820: 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 ) .
5830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5840: 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 (saut
5850: 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c horize:do-as-cal
5860: 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 20 ling-user.
5870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5880: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
5890: 28 29 0a 09 09 09 20 20 20 20 28 72 75 6e 2d 63 ().... (run-c
58a0: 6d 64 20 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d md (conc *sauth-
58b0: 70 61 74 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 path* "/sauthori
58c0: 7a 65 22 29 20 28 6c 69 73 74 20 22 72 65 67 69 ze") (list "regi
58d0: 73 74 65 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 ster-log" (conc
58e0: 22 5c 22 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 "\"" inl "\"") (
58f0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 number->string (
5900: 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 car user-obj))
5910: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
5920: 28 63 61 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 (caddr area-obj)
5930: 29 20 20 22 72 6d 22 29 29 29 29 29 29 29 0a 09 ) "rm")))))))..
5940: 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 0a 20 . )))))..
5950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5960: 20 20 20 20 20 28 28 63 70 20 70 75 62 6c 69 73 ((cp publis
5970: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
5980: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
5990: 74 2a 20 28 28 74 68 65 70 61 74 68 20 28 69 66 t* ((thepath (if
59a0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 (> (length part
59b0: 73 29 20 31 29 20 3b 3b 20 68 61 76 65 20 61 20 s) 1) ;; have a
59c0: 70 61 72 61 6d 65 74 65 72 0a 09 09 09 09 20 20 parameter.....
59d0: 20 28 63 64 72 20 70 61 72 74 73 29 0a 09 09 09 (cdr parts)....
59e0: 09 20 20 20 60 28 29 29 29 0a 09 09 09 20 20 20 . `()))....
59f0: 20 20 20 28 70 6c 65 6e 20 20 20 20 28 6c 65 6e (plen (len
5a00: 67 74 68 20 74 68 65 70 61 74 68 29 29 29 0a 20 gth thepath))).
5a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a20: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
5a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a40: 20 20 20 20 20 20 20 20 28 28 6f 72 20 28 6e 75 ((or (nu
5a50: 6c 6c 3f 20 74 68 65 70 61 74 68 29 20 28 3c 20 ll? thepath) (<
5a60: 70 6c 65 6e 20 32 29 29 20 0a 20 20 20 20 20 20 plen 2)) .
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a80: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 63 70 (print "cp
5a90: 20 74 61 6b 65 73 20 74 77 6f 20 61 72 67 75 6d takes two argum
5aa0: 65 6e 74 22 29 29 0a 20 20 20 20 20 20 20 20 20 ent")).
5ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ac0: 20 28 28 3c 20 70 6c 65 6e 20 33 29 20 0a 20 20 ((< plen 3) .
5ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ae0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 28 (let*(
5af0: 28 73 72 63 2d 70 61 74 68 20 28 63 61 72 20 74 (src-path (car t
5b00: 68 65 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 hepath)).
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b20: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 73 74 (dest
5b30: 2d 70 61 74 68 20 28 63 61 64 72 20 74 68 65 70 -path (cadr thep
5b40: 61 74 68 29 29 20 20 20 0a 20 20 20 20 20 20 20 ath)) .
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b60: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 6f (reso
5b70: 6c 76 65 64 2d 70 61 74 68 20 28 73 61 75 74 68 lved-path (sauth
5b80: 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d -common:resolve-
5b90: 70 61 74 68 20 20 64 65 73 74 2d 70 61 74 68 20 path dest-path
5ba0: 70 61 74 68 20 74 6f 70 2d 61 72 65 61 73 29 29 path top-areas))
5bb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bd0: 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 68 20 (target-path
5be0: 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 (sauth-common:ge
5bf0: 74 2d 74 61 72 67 65 74 2d 70 61 74 68 20 70 61 t-target-path pa
5c00: 74 68 20 20 64 65 73 74 2d 70 61 74 68 20 74 6f th dest-path to
5c10: 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 74 p-areas base-pat
5c20: 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h))).
5c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c40: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
5c50: 61 6c 3f 20 74 61 72 67 65 74 2d 70 61 74 68 20 al? target-path
5c60: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f)).
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c80: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
5c90: 3f 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 ? resolved-path
5ca0: 23 66 29 20 20 20 20 20 0a 20 20 20 20 20 20 20 #f) .
5cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cc0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
5cd0: 20 22 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 "Invalid argume
5ce0: 6e 74 20 22 20 64 65 73 74 2d 70 61 74 68 20 22 nt " dest-path "
5cf0: 2e 2e 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 .. ").
5d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d10: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a (begin .
5d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d40: 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a (spublish:
5d50: 73 68 65 6c 6c 2d 63 70 20 73 72 63 2d 70 61 74 shell-cp src-pat
5d60: 68 20 74 61 72 67 65 74 2d 70 61 74 68 29 20 20 h target-path)
5d70: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d90: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
5da0: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
5db0: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 g-user.
5dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5dd0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
5de0: 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 ... (run-cmd
5df0: 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 (conc *sauth-pat
5e00: 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 h* "/sauthorize"
5e10: 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 ) (list "registe
5e20: 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 r-log" (conc "\"
5e30: 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d " inl "\"") (num
5e40: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 ber->string (car
5e50: 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 user-obj)) (nu
5e60: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 mber->string (ca
5e70: 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 ddr area-obj))
5e80: 22 63 70 22 29 29 29 29 29 29 29 0a 09 09 20 20 "cp")))))))...
5e90: 20 20 20 20 20 29 29 29 29 29 0a 20 20 20 20 20 ))))).
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 28 28 6c 6e 29 0a 20 20 20 20 20 20 20 20 20 ((ln).
5ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ed0: 20 20 28 6c 65 74 2a 20 28 28 74 68 65 70 61 74 (let* ((thepat
5ee0: 68 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 h (if (> (length
5ef0: 20 70 61 72 74 73 29 20 31 29 20 3b 3b 20 68 61 parts) 1) ;; ha
5f00: 76 65 20 61 20 70 61 72 61 6d 65 74 65 72 0a 09 ve a parameter..
5f10: 09 09 09 20 20 20 28 63 64 72 20 70 61 72 74 73 ... (cdr parts
5f20: 29 0a 09 09 09 09 20 20 20 60 28 29 29 29 0a 09 )..... `()))..
5f30: 09 09 20 20 20 20 20 20 28 70 6c 65 6e 20 20 20 .. (plen
5f40: 20 28 6c 65 6e 67 74 68 20 74 68 65 70 61 74 68 (length thepath
5f50: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5f70: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6f ((o
5f90: 72 20 28 6e 75 6c 6c 3f 20 74 68 65 70 61 74 68 r (null? thepath
5fa0: 29 20 28 3c 20 70 6c 65 6e 20 32 29 29 20 0a 20 ) (< plen 2)) .
5fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fc0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
5fd0: 74 20 22 6c 6e 20 74 61 6b 65 73 20 74 77 6f 20 t "ln takes two
5fe0: 61 72 67 75 6d 65 6e 74 22 29 29 0a 20 20 20 20 argument")).
5ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6000: 20 20 20 20 20 20 28 28 3c 20 70 6c 65 6e 20 33 ((< plen 3
6010: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
6020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6030: 6c 65 74 2a 28 28 73 72 63 2d 70 61 74 68 20 28 let*((src-path (
6040: 63 61 72 20 74 68 65 70 61 74 68 29 29 0a 20 20 car thepath)).
6050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6070: 28 64 65 73 74 2d 70 61 74 68 20 28 63 61 64 72 (dest-path (cadr
6080: 20 74 68 65 70 61 74 68 29 29 20 20 20 0a 20 20 thepath)) .
6090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60b0: 28 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 (resolved-path (
60c0: 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 sauth-common:res
60d0: 6f 6c 76 65 2d 70 61 74 68 20 20 64 65 73 74 2d olve-path dest-
60e0: 70 61 74 68 20 70 61 74 68 20 74 6f 70 2d 61 72 path path top-ar
60f0: 65 61 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 eas)).
6100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6110: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 2d (target-
6120: 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d path (sauth-comm
6130: 6f 6e 3a 67 65 74 2d 74 61 72 67 65 74 2d 70 61 on:get-target-pa
6140: 74 68 20 70 61 74 68 20 20 64 65 73 74 2d 70 61 th path dest-pa
6150: 74 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 th top-areas bas
6160: 65 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 e-path)).
6170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6180: 20 20 20 20 20 20 20 20 20 20 20 28 73 75 62 2d (sub-
6190: 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 path (conc "/" (
61a0: 73 74 72 69 6e 67 2d 72 65 76 65 72 73 65 20 28 string-reverse (
61b0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 63 64 72 string-join (cdr
61c0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
61d0: 73 74 72 69 6e 67 2d 72 65 76 65 72 73 65 20 20 string-reverse
61e0: 74 61 72 67 65 74 2d 70 61 74 68 29 20 22 2f 22 target-path) "/"
61f0: 29 29 20 22 2f 22 29 29 29 29 29 0a 20 20 20 20 )) "/"))))).
6200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6210: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
6220: 6f 74 20 28 65 71 75 61 6c 3f 20 74 61 72 67 65 ot (equal? targe
6230: 74 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 t-path #f)).
6240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6250: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6260: 20 28 65 71 75 61 6c 3f 20 72 65 73 6f 6c 76 65 (equal? resolve
6270: 64 2d 70 61 74 68 20 23 66 29 20 20 20 20 20 0a d-path #f) .
6280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62a0: 20 28 70 72 69 6e 74 20 22 49 6e 76 61 6c 69 64 (print "Invalid
62b0: 20 61 72 67 75 6d 65 6e 74 20 22 20 64 65 73 74 argument " dest
62c0: 2d 70 61 74 68 20 22 2e 2e 20 22 29 0a 20 20 20 -path ".. ").
62d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
62f0: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
6300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6310: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 (sp
6320: 75 62 6c 69 73 68 3a 73 68 65 6c 6c 2d 6c 6e 20 ublish:shell-ln
6330: 73 72 63 2d 70 61 74 68 20 74 61 72 67 65 74 2d src-path target-
6340: 70 61 74 68 20 73 75 62 2d 70 61 74 68 29 20 20 path sub-path)
6350: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6370: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
6380: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
6390: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 g-user.
63a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63b0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
63c0: 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 ... (run-cmd
63d0: 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 (conc *sauth-pat
63e0: 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 h* "/sauthorize"
63f0: 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 ) (list "registe
6400: 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 r-log" (conc "\"
6410: 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d " inl "\"") (num
6420: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 ber->string (car
6430: 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 user-obj)) (nu
6440: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 mber->string (ca
6450: 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 ddr area-obj))
6460: 22 6c 6e 22 29 29 29 29 29 29 29 0a 09 09 20 20 "ln")))))))...
6470: 20 20 20 20 20 29 29 29 29 29 20 20 0a 20 20 20 ))))) .
6480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6490: 20 20 20 28 28 65 78 69 74 29 0a 20 20 20 20 20 ((exit).
64a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64b0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 67 6f 74 (print "got
64c0: 20 65 78 69 74 22 29 29 20 20 0a 20 20 20 20 20 exit")) .
64d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64e0: 20 28 28 68 65 6c 70 29 0a 20 20 20 20 20 20 20 ((help).
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 20 20 20 28 70 72 69 6e 74 20 28 73 70 75 62 6c (print (spubl
6510: 69 73 68 3a 73 68 65 6c 6c 2d 68 65 6c 70 29 29 ish:shell-help))
6520: 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 )... (else
6530: 0a 09 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 ... (print
6540: 20 22 47 6f 74 20 63 6f 6d 6d 61 6e 64 3a 20 22 "Got command: "
6550: 20 69 6e 6c 29 29 29 29 0a 20 20 20 20 20 20 20 inl)))).
6560: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
6570: 28 72 65 61 64 2d 6c 69 6e 65 20 69 70 6f 72 74 (read-line iport
6580: 29 29 29 29 29 29 29 0a 0a 0a 3b 3b 3d 3d 3d 3d )))))))...;;====
6590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65d0: 3d 3d 0a 3b 3b 20 4d 41 49 4e 0a 3b 3b 3d 3d 3d ==.;; MAIN.;;===
65e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6620: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 ===..(define (sp
6630: 75 62 6c 69 73 68 3a 6c 6f 61 64 2d 63 6f 6e 66 ublish:load-conf
6640: 69 67 20 65 78 65 2d 64 69 72 20 65 78 65 2d 6e ig exe-dir exe-n
6650: 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 ame). (let* ((f
6660: 6e 61 6d 65 20 20 20 28 63 6f 6e 63 20 65 78 65 name (conc exe
6670: 2d 64 69 72 20 22 2f 2e 22 20 65 78 65 2d 6e 61 -dir "/." exe-na
6680: 6d 65 20 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a me ".config"))).
6690: 20 20 20 20 3b 3b 20 28 69 6e 69 3a 70 72 6f 70 ;; (ini:prop
66a0: 65 72 74 79 2d 73 65 70 61 72 61 74 6f 72 2d 70 erty-separator-p
66b0: 61 74 74 20 22 20 2a 20 20 2a 22 29 0a 20 20 20 att " * *").
66c0: 20 3b 3b 20 28 69 6e 69 3a 70 72 6f 70 65 72 74 ;; (ini:propert
66d0: 79 2d 73 65 70 61 72 61 74 6f 72 20 23 5c 73 70 y-separator #\sp
66e0: 61 63 65 29 0a 20 20 20 20 28 69 66 20 28 66 69 ace). (if (fi
66f0: 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 le-exists? fname
6700: 29 0a 09 3b 3b 20 28 69 6e 69 3a 72 65 61 64 2d )..;; (ini:read-
6710: 69 6e 69 20 66 6e 61 6d 65 29 0a 09 28 72 65 61 ini fname)..(rea
6720: 64 2d 63 6f 6e 66 69 67 20 66 6e 61 6d 65 20 23 d-config fname #
6730: 66 20 23 74 29 0a 09 28 6d 61 6b 65 2d 68 61 73 f #t)..(make-has
6740: 68 2d 74 61 62 6c 65 29 29 29 29 0a 0a 28 64 65 h-table))))..(de
6750: 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 70 fine (spublish:p
6760: 72 6f 63 65 73 73 2d 61 63 74 69 6f 6e 20 61 63 rocess-action ac
6770: 74 69 6f 6e 20 2e 20 61 72 67 73 29 0a 20 20 28 tion . args). (
6780: 6c 65 74 2a 20 28 0a 20 20 20 20 20 20 20 20 20 let* (.
6790: 3b 3b 20 28 74 61 72 67 65 74 2d 64 69 72 20 20 ;; (target-dir
67a0: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
67b0: 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 74 p configdat "set
67c0: 74 69 6e 67 73 22 20 22 74 61 72 67 65 74 2d 64 tings" "target-d
67d0: 69 72 22 29 29 0a 09 20 28 75 73 65 72 20 20 20 ir")).. (user
67e0: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
67f0: 75 73 65 72 2d 6e 61 6d 65 29 29 0a 09 20 3b 3b user-name)).. ;;
6800: 28 61 6c 6c 6f 77 65 64 2d 75 73 65 72 73 20 28 (allowed-users (
6810: 73 74 72 69 6e 67 2d 73 70 6c 69 74 0a 09 3b 3b string-split..;;
6820: 09 09 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a .. (or (configf:
6830: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
6840: 20 22 73 65 74 74 69 6e 67 73 22 20 22 61 6c 6c "settings" "all
6850: 6f 77 65 64 2d 75 73 65 72 73 22 29 0a 09 3b 3b owed-users")..;;
6860: 09 09 20 20 20 20 20 22 22 29 29 29 0a 29 0a 20 .. ""))).).
6870: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
6880: 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 6f 6e 29 ->symbol action)
6890: 0a 20 20 20 20 20 20 28 28 63 70 20 70 75 62 6c . ((cp publ
68a0: 69 73 68 29 0a 20 20 20 20 20 20 20 28 69 66 20 ish). (if
68b0: 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 (< (length args)
68c0: 20 32 29 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 2).. (begin .
68d0: 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
68e0: 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 ROR: Missing arg
68f0: 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 72 69 6e uments; " (strin
6900: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 61 72 g-intersperse ar
6910: 67 73 20 22 2c 20 22 29 29 0a 09 20 20 20 20 20 gs ", "))..
6920: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 20 (exit 1))).
6930: 20 20 28 6c 65 74 2a 20 28 28 72 65 6d 61 72 67 (let* ((remarg
6940: 73 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d s (args:get-
6950: 61 72 67 73 20 61 72 67 73 20 27 28 22 2d 6d 22 args args '("-m"
6960: 29 20 27 28 29 20 61 72 67 73 3a 61 72 67 2d 68 ) '() args:arg-h
6970: 61 73 68 20 30 29 29 0a 20 20 20 20 20 20 20 20 ash 0)).
6980: 20 20 20 20 20 20 28 64 65 73 74 2d 64 69 72 20 (dest-dir
6990: 28 63 61 64 72 20 61 72 67 73 29 29 0a 20 20 20 (cadr args)).
69a0: 20 20 20 20 20 20 20 20 20 20 20 28 73 72 63 2d (src-
69b0: 70 61 74 68 2d 69 6e 20 28 63 61 72 20 61 72 67 path-in (car arg
69c0: 73 29 29 0a 09 20 20 20 20 20 20 28 73 72 63 2d s)).. (src-
69d0: 70 61 74 68 20 20 20 20 28 77 69 74 68 2d 69 6e path (with-in
69e0: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 09 put-from-pipe...
69f0: 09 20 20 20 20 28 63 6f 6e 63 20 22 72 65 61 64 . (conc "read
6a00: 6c 69 6e 6b 20 2d 66 20 22 20 73 72 63 2d 70 61 link -f " src-pa
6a10: 74 68 2d 69 6e 29 0a 09 09 09 20 20 20 20 28 6c th-in).... (l
6a20: 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 ambda ()....
6a30: 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 (read-line))))
6a40: 0a 09 20 20 20 20 20 20 28 6d 73 67 20 20 20 20 .. (msg
6a50: 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 (or (args:g
6a60: 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 22 22 29 et-arg "-m") "")
6a70: 29 0a 09 20 20 20 20 20 20 28 74 61 72 67 2d 66 ).. (targ-f
6a80: 69 6c 65 20 20 20 28 70 61 74 68 6e 61 6d 65 2d ile (pathname-
6a90: 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 strip-directory
6aa0: 73 72 63 2d 70 61 74 68 29 29 29 0a 09 20 28 69 src-path))).. (i
6ab0: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 f (not (file-rea
6ac0: 64 2d 61 63 63 65 73 73 3f 20 73 72 63 2d 70 61 d-access? src-pa
6ad0: 74 68 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 th)).. (begi
6ae0: 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 n.. (print
6af0: 20 22 45 52 52 4f 52 3a 20 73 6f 75 72 63 65 20 "ERROR: source
6b00: 66 69 6c 65 20 6e 6f 74 20 72 65 61 64 61 62 6c file not readabl
6b10: 65 3a 20 22 20 73 72 63 2d 70 61 74 68 29 0a 09 e: " src-path)..
6b20: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
6b30: 29 0a 09 20 28 69 66 20 28 64 69 72 65 63 74 6f ).. (if (directo
6b40: 72 79 3f 20 73 72 63 2d 70 61 74 68 29 0a 09 20 ry? src-path)..
6b50: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
6b60: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
6b70: 22 45 52 52 4f 52 3a 20 73 6f 75 72 63 65 20 66 "ERROR: source f
6b80: 69 6c 65 20 69 73 20 61 20 64 69 72 65 63 74 6f ile is a directo
6b90: 72 79 2c 20 74 68 69 73 20 69 73 20 6e 6f 74 20 ry, this is not
6ba0: 73 75 70 70 6f 72 74 65 64 20 79 65 74 2e 22 29 supported yet.")
6bb0: 0a 09 20 20 20 20 20 20 20 28 65 78 69 74 20 31 .. (exit 1
6bc0: 29 29 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 ))).. (print
6bd0: 20 22 70 75 62 6c 69 73 68 69 6e 67 20 22 20 73 "publishing " s
6be0: 72 63 2d 70 61 74 68 2d 69 6e 20 22 20 74 6f 20 rc-path-in " to
6bf0: 22 20 74 61 72 67 65 74 2d 64 69 72 29 0a 20 20 " target-dir).
6c00: 20 20 20 20 20 20 20 20 20 20 20 28 73 70 75 62 (spub
6c10: 6c 69 73 68 3a 76 61 6c 69 64 61 74 65 20 20 20 lish:validate
6c20: 20 20 74 61 72 67 65 74 2d 64 69 72 20 64 65 73 target-dir des
6c30: 74 2d 64 69 72 29 0a 09 20 20 20 20 20 28 73 70 t-dir).. (sp
6c40: 75 62 6c 69 73 68 3a 63 70 20 63 6f 6e 66 69 67 ublish:cp config
6c50: 64 61 74 20 75 73 65 72 20 73 72 63 2d 70 61 74 dat user src-pat
6c60: 68 20 74 61 72 67 65 74 2d 64 69 72 20 74 61 72 h target-dir tar
6c70: 67 2d 66 69 6c 65 20 64 65 73 74 2d 64 69 72 20 g-file dest-dir
6c80: 6d 73 67 29 29 29 0a 20 20 20 20 20 20 28 28 74 msg))). ((t
6c90: 61 72 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ar). (if
6ca0: 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 (< (length args)
6cb0: 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 1). (b
6cc0: 65 67 69 6e 20 0a 09 20 20 20 20 20 28 70 72 69 egin .. (pri
6cd0: 6e 74 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 nt "ERROR: Missi
6ce0: 6e 67 20 61 72 67 75 6d 65 6e 74 73 3b 20 22 20 ng arguments; "
6cf0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6d00: 72 73 65 20 61 72 67 73 20 22 2c 20 22 29 29 0a rse args ", ")).
6d10: 09 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 . (exit 1)))
6d20: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
6d30: 28 64 73 74 2d 64 69 72 20 28 63 61 72 20 61 72 (dst-dir (car ar
6d40: 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 gs)).
6d50: 20 20 20 20 28 6d 73 67 20 20 20 20 20 20 20 20 (msg
6d60: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
6d70: 72 67 20 22 2d 6d 22 29 20 22 22 29 29 29 0a 20 rg "-m") ""))).
6d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
6d90: 70 75 62 6c 69 73 68 3a 76 61 6c 69 64 61 74 65 publish:validate
6da0: 20 20 20 20 20 74 61 72 67 65 74 2d 64 69 72 20 target-dir
6db0: 20 64 73 74 2d 64 69 72 29 0a 20 20 20 20 20 20 dst-dir).
6dc0: 20 20 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 (spubli
6dd0: 73 68 3a 74 61 72 20 63 6f 6e 66 69 67 64 61 74 sh:tar configdat
6de0: 20 75 73 65 72 20 74 61 72 67 65 74 2d 64 69 72 user target-dir
6df0: 20 64 73 74 2d 64 69 72 20 6d 73 67 29 29 29 0a dst-dir msg))).
6e00: 20 0a 20 20 20 20 20 20 28 28 6d 6b 64 69 72 29 . ((mkdir)
6e10: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 . (if (<
6e20: 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 31 29 (length args) 1)
6e30: 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 . (begi
6e40: 6e 20 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 n .. (print
6e50: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
6e60: 61 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 arguments; " (st
6e70: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
6e80: 20 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 20 args ", "))..
6e90: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 (exit 1))).
6ea0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 (let* ((ta
6eb0: 72 67 2d 6d 6b 20 28 63 61 72 20 61 72 67 73 29 rg-mk (car args)
6ec0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6ed0: 20 28 6d 73 67 20 20 20 20 20 20 20 20 20 28 6f (msg (o
6ee0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
6ef0: 22 2d 6d 22 29 20 22 22 29 29 29 20 0a 20 20 20 "-m") ""))) .
6f00: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
6f10: 6e 74 20 22 61 74 74 65 6d 70 74 69 6e 67 20 74 nt "attempting t
6f20: 6f 20 63 72 65 61 74 65 20 64 69 72 65 63 74 6f o create directo
6f30: 72 79 20 22 20 74 61 72 67 2d 6d 6b 20 22 20 69 ry " targ-mk " i
6f40: 6e 20 22 20 74 61 72 67 65 74 2d 64 69 72 29 0a n " target-dir).
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6f60: 73 70 75 62 6c 69 73 68 3a 76 61 6c 69 64 61 74 spublish:validat
6f70: 65 20 20 20 20 20 74 61 72 67 65 74 2d 64 69 72 e target-dir
6f80: 20 74 61 72 67 2d 6d 6b 29 0a 20 20 20 20 20 20 targ-mk).
6f90: 20 20 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 (spubli
6fa0: 73 68 3a 6d 6b 64 69 72 20 63 6f 6e 66 69 67 64 sh:mkdir configd
6fb0: 61 74 20 75 73 65 72 20 74 61 72 67 65 74 2d 64 at user target-d
6fc0: 69 72 20 74 61 72 67 2d 6d 6b 20 6d 73 67 29 29 ir targ-mk msg))
6fd0: 29 0a 0a 20 20 20 20 20 20 28 28 6c 6e 29 20 0a ).. ((ln) .
6fe0: 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 28 (if (< (
6ff0: 6c 65 6e 67 74 68 20 61 72 67 73 29 20 32 29 0a length args) 2).
7000: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
7010: 20 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 .. (print "
7020: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 61 ERROR: Missing a
7030: 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 72 rguments; " (str
7040: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
7050: 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 20 20 args ", "))..
7060: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
7070: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 (let* ((tar
7080: 67 2d 6c 69 6e 6b 20 28 63 61 72 20 61 72 67 73 g-link (car args
7090: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
70a0: 20 20 28 6c 69 6e 6b 2d 6e 61 6d 65 20 28 63 61 (link-name (ca
70b0: 64 72 20 61 72 67 73 29 29 20 20 0a 20 20 20 20 dr args)) .
70c0: 20 20 20 20 20 20 20 20 20 20 20 28 73 75 62 2d (sub-
70d0: 70 61 74 68 20 28 73 74 72 69 6e 67 2d 72 65 76 path (string-rev
70e0: 65 72 73 65 20 28 73 74 72 69 6e 67 2d 6a 6f 69 erse (string-joi
70f0: 6e 20 28 63 64 72 20 28 73 74 72 69 6e 67 2d 73 n (cdr (string-s
7100: 70 6c 69 74 20 28 73 74 72 69 6e 67 2d 72 65 76 plit (string-rev
7110: 65 72 73 65 20 6c 69 6e 6b 2d 6e 61 6d 65 29 20 erse link-name)
7120: 22 2f 22 29 29 20 22 2f 22 29 29 29 20 0a 20 20 "/")) "/"))) .
7130: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 73 (ms
7140: 67 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 g (or (a
7150: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 rgs:get-arg "-m"
7160: 29 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 ) ""))).
7170: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 (if (> (s
7180: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 28 73 74 72 tring-length(str
7190: 69 6e 67 2d 74 72 69 6d 20 73 75 62 2d 70 61 74 ing-trim sub-pat
71a0: 68 29 29 20 30 29 0a 20 20 20 20 20 20 20 20 20 h)) 0).
71b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
71c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71d0: 20 28 70 72 69 6e 74 20 22 61 74 74 65 6d 70 74 (print "attempt
71e0: 69 6e 67 20 74 6f 20 63 72 65 61 74 65 20 64 69 ing to create di
71f0: 72 65 63 74 6f 72 79 20 22 20 73 75 62 2d 70 61 rectory " sub-pa
7200: 74 68 20 22 20 69 6e 20 22 20 74 61 72 67 65 74 th " in " target
7210: 2d 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 -dir).
7220: 20 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 (spublis
7230: 68 3a 76 61 6c 69 64 61 74 65 20 20 20 20 20 74 h:validate t
7240: 61 72 67 65 74 2d 64 69 72 20 73 75 62 2d 70 61 arget-dir sub-pa
7250: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
7260: 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 63 6f (print (co
7270: 6e 63 20 74 61 72 67 65 74 2d 64 69 72 20 22 2f nc target-dir "/
7280: 22 20 73 75 62 2d 70 61 74 68 20 29 20 29 0a 20 " sub-path ) ).
7290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72a0: 20 28 70 72 69 6e 74 20 28 64 69 72 65 63 74 6f (print (directo
72b0: 72 79 2d 65 78 69 73 74 73 3f 28 63 6f 6e 63 20 ry-exists?(conc
72c0: 74 61 72 67 65 74 2d 64 69 72 20 22 2f 22 20 73 target-dir "/" s
72d0: 75 62 2d 70 61 74 68 20 29 29 29 0a 20 20 20 20 ub-path ))).
72e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
72f0: 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 f (directory-exi
7300: 73 74 73 3f 28 63 6f 6e 63 20 74 61 72 67 65 74 sts?(conc target
7310: 2d 64 69 72 20 22 2f 22 20 73 75 62 2d 70 61 74 -dir "/" sub-pat
7320: 68 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h )).
7330: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
7340: 54 61 72 67 65 74 20 44 69 72 65 63 74 6f 72 79 Target Directory
7350: 20 22 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d " (conc target-
7360: 64 69 72 20 73 75 62 2d 70 61 74 68 20 29 20 22 dir sub-path ) "
7370: 20 65 78 69 73 74 21 21 22 29 0a 20 20 20 20 20 exist!!").
7380: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 (sp
7390: 75 62 6c 69 73 68 3a 6d 6b 64 69 72 20 63 6f 6e ublish:mkdir con
73a0: 66 69 67 64 61 74 20 75 73 65 72 20 74 61 72 67 figdat user targ
73b0: 65 74 2d 64 69 72 20 73 75 62 2d 70 61 74 68 20 et-dir sub-path
73c0: 6d 73 67 29 29 29 29 0a 0a 20 20 20 20 20 20 20 msg))))..
73d0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
73e0: 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 72 attempting to cr
73f0: 65 61 74 65 20 6c 69 6e 6b 20 22 20 6c 69 6e 6b eate link " link
7400: 2d 6e 61 6d 65 20 22 20 69 6e 20 22 20 74 61 72 -name " in " tar
7410: 67 65 74 2d 64 69 72 29 0a 20 20 20 20 20 20 20 get-dir).
7420: 20 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 (spublis
7430: 68 3a 6c 6e 20 63 6f 6e 66 69 67 64 61 74 20 75 h:ln configdat u
7440: 73 65 72 20 74 61 72 67 65 74 2d 64 69 72 20 74 ser target-dir t
7450: 61 72 67 2d 6c 69 6e 6b 20 6c 69 6e 6b 2d 6e 61 arg-link link-na
7460: 6d 65 20 6d 73 67 29 29 29 0a 0a 20 20 20 20 20 me msg)))..
7470: 20 28 28 72 6d 29 0a 20 20 20 20 20 20 20 28 69 ((rm). (i
7480: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 67 f (< (length arg
7490: 73 29 20 31 29 0a 09 20 20 20 28 62 65 67 69 6e s) 1).. (begin
74a0: 20 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 .. (print "
74b0: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 61 ERROR: Missing a
74c0: 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 72 rguments; " (str
74d0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
74e0: 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 20 20 args ", "))..
74f0: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
7500: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 (let* ((targ
7510: 2d 66 69 6c 65 20 28 63 61 72 20 61 72 67 73 29 -file (car args)
7520: 29 0a 09 20 20 20 20 20 20 28 6d 73 67 20 20 20 ).. (msg
7530: 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a (or (args:
7540: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 22 22 get-arg "-m") ""
7550: 29 29 29 0a 09 20 28 70 72 69 6e 74 20 22 61 74 ))).. (print "at
7560: 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f tempting to remo
7570: 76 65 20 22 20 74 61 72 67 2d 66 69 6c 65 20 22 ve " targ-file "
7580: 20 66 72 6f 6d 20 22 20 74 61 72 67 65 74 2d 64 from " target-d
7590: 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ir). (
75a0: 73 70 75 62 6c 69 73 68 3a 76 61 6c 69 64 61 74 spublish:validat
75b0: 65 20 20 20 20 20 74 61 72 67 65 74 2d 64 69 72 e target-dir
75c0: 20 74 61 72 67 2d 66 69 6c 65 29 0a 0a 09 20 28 targ-file)... (
75d0: 73 70 75 62 6c 69 73 68 3a 72 6d 20 63 6f 6e 66 spublish:rm conf
75e0: 69 67 64 61 74 20 75 73 65 72 20 74 61 72 67 65 igdat user targe
75f0: 74 2d 64 69 72 20 74 61 72 67 2d 66 69 6c 65 20 t-dir targ-file
7600: 6d 73 67 29 29 29 0a 20 20 20 20 20 20 28 28 70 msg))). ((p
7610: 75 62 6c 69 73 68 29 0a 20 20 20 20 20 20 20 28 ublish). (
7620: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 72 if (< (length ar
7630: 67 73 29 20 33 29 0a 09 20 20 20 28 62 65 67 69 gs) 3).. (begi
7640: 6e 20 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 n .. (print
7650: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
7660: 61 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 arguments; " (st
7670: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7680: 20 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 20 args ", "))..
7690: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 (exit 1))..
76a0: 20 28 6c 65 74 2a 20 28 28 73 72 63 70 61 74 68 (let* ((srcpath
76b0: 20 20 28 6c 69 73 74 2d 72 65 66 20 61 72 67 73 (list-ref args
76c0: 20 30 29 29 0a 09 09 20 20 28 61 72 65 61 6e 61 0))... (areana
76d0: 6d 65 20 28 6c 69 73 74 2d 72 65 66 20 61 72 67 me (list-ref arg
76e0: 73 20 31 29 29 0a 09 09 20 20 28 76 65 72 73 69 s 1))... (versi
76f0: 6f 6e 20 20 28 6c 69 73 74 2d 72 65 66 20 61 72 on (list-ref ar
7700: 67 73 20 32 29 29 0a 09 09 20 20 28 72 65 6d 61 gs 2))... (rema
7710: 72 67 73 20 20 28 61 72 67 73 3a 67 65 74 2d 61 rgs (args:get-a
7720: 72 67 73 20 28 64 72 6f 70 20 61 72 67 73 20 32 rgs (drop args 2
7730: 29 0a 09 09 09 09 09 20 20 20 27 28 22 2d 74 79 )...... '("-ty
7740: 70 65 22 20 3b 3b 20 6c 69 6e 6b 20 6f 72 20 63 pe" ;; link or c
7750: 6f 70 79 20 28 64 65 66 61 75 6c 74 20 69 73 20 opy (default is
7760: 63 6f 70 79 29 0a 09 09 09 09 09 20 20 20 20 20 copy)......
7770: 22 2d 6d 22 29 0a 09 09 09 09 09 20 20 20 27 28 "-m")...... '(
7780: 29 0a 09 09 09 09 09 20 20 20 61 72 67 73 3a 61 )...... args:a
7790: 72 67 2d 68 61 73 68 0a 09 09 09 09 09 20 20 20 rg-hash......
77a0: 30 29 29 0a 09 09 20 20 28 70 75 62 6c 69 73 68 0))... (publish
77b0: 2d 74 79 70 65 20 28 69 66 20 28 65 71 75 61 6c -type (if (equal
77c0: 3f 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ? (args:get-arg
77d0: 22 2d 74 79 70 65 22 29 20 22 6c 69 6e 6b 22 29 "-type") "link")
77e0: 20 27 6c 69 6e 6b 20 27 63 6f 70 79 29 29 0a 09 'link 'copy))..
77f0: 09 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 . (comment
7800: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
7810: 72 67 20 22 2d 6d 22 29 20 22 22 29 29 0a 09 09 rg "-m") ""))...
7820: 20 20 28 73 75 62 6d 69 74 74 65 72 20 20 20 20 (submitter
7830: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
7840: 6d 65 29 29 0a 09 09 20 20 28 71 75 61 6c 69 74 me))... (qualit
7850: 79 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 y (args:get
7860: 2d 61 72 67 20 22 2d 71 75 61 6c 69 74 79 22 29 -arg "-quality")
7870: 29 0a 09 09 20 20 28 70 75 62 6c 69 73 68 2d 72 )... (publish-r
7880: 65 73 20 20 28 73 70 75 62 6c 69 73 68 3a 70 75 es (spublish:pu
7890: 62 6c 69 73 68 20 63 6f 6e 66 69 67 64 61 74 20 blish configdat
78a0: 70 75 62 6c 69 73 68 2d 74 79 70 65 20 61 72 65 publish-type are
78b0: 61 6e 61 6d 65 20 76 65 72 73 69 6f 6e 20 63 6f aname version co
78c0: 6d 6d 65 6e 74 20 73 72 63 70 61 74 68 20 73 75 mment srcpath su
78d0: 62 6d 69 74 74 65 72 20 71 75 61 6c 69 74 79 29 bmitter quality)
78e0: 29 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f )).. (if (no
78f0: 74 20 28 63 61 72 20 70 75 62 6c 69 73 68 2d 72 t (car publish-r
7900: 65 73 29 29 0a 09 09 20 28 62 65 67 69 6e 0a 09 es))... (begin..
7910: 09 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f . (print "ERRO
7920: 52 3a 20 22 20 28 63 64 72 20 70 75 62 6c 69 73 R: " (cdr publis
7930: 68 2d 72 65 73 29 29 0a 09 09 20 20 20 28 65 78 h-res))... (ex
7940: 69 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 20 it 1)))))).
7950: 20 28 28 6c 69 73 74 2d 76 65 72 73 69 6f 6e 73 ((list-versions
7960: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ). (let ((
7970: 61 72 65 61 2d 6e 61 6d 65 20 28 63 61 72 20 61 area-name (car a
7980: 72 67 73 29 29 20 3b 3b 20 20 20 20 20 20 76 65 rgs)) ;; ve
7990: 72 73 69 6f 6e 20 70 61 74 74 20 20 20 66 75 6c rsion patt ful
79a0: 6c 20 70 72 69 6e 74 0a 09 20 20 20 20 20 28 72 l print.. (r
79b0: 65 6d 61 72 67 73 20 20 20 28 61 72 67 73 3a 67 emargs (args:g
79c0: 65 74 2d 61 72 67 73 20 61 72 67 73 20 27 28 22 et-args args '("
79d0: 2d 76 70 61 74 74 22 29 20 27 28 22 2d 66 75 6c -vpatt") '("-ful
79e0: 6c 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 l") args:arg-has
79f0: 68 20 30 29 29 0a 09 20 20 20 20 20 28 64 62 20 h 0)).. (db
7a00: 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 (spublish
7a10: 3a 6f 70 65 6e 2d 64 62 20 63 6f 6e 66 69 67 64 :open-db configd
7a20: 61 74 29 29 0a 09 20 20 20 20 20 28 76 65 72 73 at)).. (vers
7a30: 69 6f 6e 73 20 20 28 73 70 75 62 6c 69 73 68 3a ions (spublish:
7a40: 67 65 74 2d 76 65 72 73 69 6f 6e 73 2d 66 6f 72 get-versions-for
7a50: 2d 61 72 65 61 20 64 62 20 28 63 61 72 20 61 72 -area db (car ar
7a60: 67 73 29 20 76 65 72 73 69 6f 6e 2d 70 61 74 74 gs) version-patt
7a70: 3a 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 : (args:get-arg
7a80: 22 2d 76 70 61 74 74 22 29 29 29 29 0a 09 20 3b "-vpatt")))).. ;
7a90: 3b 20 28 70 72 69 6e 74 20 22 61 72 65 61 2d 6e ; (print "area-n
7aa0: 61 6d 65 3d 22 20 61 72 65 61 2d 6e 61 6d 65 20 ame=" area-name
7ab0: 22 20 61 72 67 73 3d 22 20 61 72 67 73 20 22 20 " args=" args "
7ac0: 2a 61 72 67 73 2d 68 61 73 68 2a 3d 22 20 28 68 *args-hash*=" (h
7ad0: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
7ae0: 20 2a 61 72 67 73 2d 68 61 73 68 2a 29 29 0a 09 *args-hash*))..
7af0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
7b00: 29 0a 09 09 28 69 66 20 28 61 72 67 73 3a 67 65 )...(if (args:ge
7b10: 74 2d 61 72 67 20 22 2d 66 75 6c 6c 22 29 0a 09 t-arg "-full")..
7b20: 09 20 20 20 20 28 66 6f 72 6d 61 74 20 23 74 20 . (format #t
7b30: 0a 09 09 09 20 20 20 20 22 7e 31 30 61 7e 31 30 .... "~10a~10
7b40: 61 7e 34 61 7e 32 37 61 7e 33 30 61 5c 6e 22 0a a~4a~27a~30a\n".
7b50: 09 09 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ... (vector-r
7b60: 65 66 20 78 20 30 29 0a 09 09 09 20 20 20 20 28 ef x 0).... (
7b70: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 31 29 20 vector-ref x 1)
7b80: 0a 09 09 09 20 20 20 20 28 76 65 63 74 6f 72 2d .... (vector-
7b90: 72 65 66 20 78 20 32 29 20 0a 09 09 09 20 20 20 ref x 2) ....
7ba0: 20 28 63 6f 6e 63 20 22 5c 22 22 20 28 74 69 6d (conc "\"" (tim
7bb0: 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e e->string (secon
7bc0: 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 28 ds->local-time (
7bd0: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 33 29 29 vector-ref x 3))
7be0: 29 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 28 ) "\"").... (
7bf0: 63 6f 6e 63 20 22 5c 22 22 20 28 76 65 63 74 6f conc "\"" (vecto
7c00: 72 2d 72 65 66 20 78 20 34 29 20 22 5c 22 22 29 r-ref x 4) "\"")
7c10: 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 28 )... (print (
7c20: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 29 vector-ref x 0))
7c30: 29 29 0a 09 20 20 20 20 20 20 76 65 72 73 69 6f )).. versio
7c40: 6e 73 29 29 29 0a 20 20 20 20 20 20 20 28 28 73 ns))). ((s
7c50: 68 65 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 20 hell).
7c60: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 (if (< (length a
7c70: 72 67 73 29 20 31 29 0a 20 20 20 20 20 20 20 20 rgs) 1).
7c80: 20 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 (begin ..
7c90: 20 20 20 28 70 72 69 6e 74 20 20 22 45 52 52 4f (print "ERRO
7ca0: 52 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d R: Missing argum
7cb0: 65 6e 74 73 20 61 72 65 61 21 21 22 20 29 0a 09 ents area!!" )..
7cc0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 75 (spu
7ce0: 62 6c 69 73 68 3a 73 68 65 6c 6c 20 28 63 61 72 blish:shell (car
7cf0: 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 20 args))).
7d00: 29 20 0a 20 20 20 0a 20 20 20 20 20 20 28 65 6c ) . . (el
7d10: 73 65 20 28 70 72 69 6e 74 20 22 55 6e 72 65 63 se (print "Unrec
7d20: 6f 67 6e 69 73 65 64 20 63 6f 6d 6d 61 6e 64 20 ognised command
7d30: 22 20 61 63 74 69 6f 6e 29 29 29 29 29 0a 20 20 " action))))).
7d40: 0a 3b 3b 20 65 61 73 65 20 64 65 62 75 67 67 69 .;; ease debuggi
7d50: 6e 67 20 62 79 20 6c 6f 61 64 69 6e 67 20 7e 2f ng by loading ~/
7d60: 2e 64 61 73 68 62 6f 61 72 64 72 63 20 2d 20 52 .dashboardrc - R
7d70: 45 4d 4f 56 45 20 46 52 4f 4d 20 50 52 4f 44 55 EMOVE FROM PRODU
7d80: 43 54 49 4f 4e 21 0a 3b 3b 20 28 6c 65 74 20 28 CTION!.;; (let (
7d90: 28 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 20 28 (debugcontrolf (
7da0: 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f conc (get-enviro
7db0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
7dc0: 48 4f 4d 45 22 29 20 22 2f 2e 73 70 75 62 6c 69 HOME") "/.spubli
7dd0: 73 68 72 63 22 29 29 29 0a 3b 3b 20 20 20 28 69 shrc"))).;; (i
7de0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
7df0: 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 29 0a 3b debugcontrolf).;
7e00: 3b 20 20 20 20 20 20 20 28 6c 6f 61 64 20 64 65 ; (load de
7e10: 62 75 67 63 6f 6e 74 72 6f 6c 66 29 29 29 0a 0a bugcontrolf)))..
7e20: 28 64 65 66 69 6e 65 20 28 6d 61 69 6e 29 0a 20 (define (main).
7e30: 20 28 6c 65 74 2a 20 28 28 61 72 67 73 20 20 20 (let* ((args
7e40: 20 20 20 28 61 72 67 76 29 29 0a 09 20 28 70 72 (argv)).. (pr
7e50: 6f 67 20 20 20 20 20 20 28 63 61 72 20 61 72 67 og (car arg
7e60: 73 29 29 0a 09 20 28 72 65 6d 61 20 20 20 20 20 s)).. (rema
7e70: 20 28 63 64 72 20 61 72 67 73 29 29 0a 09 20 28 (cdr args)).. (
7e80: 65 78 65 2d 6e 61 6d 65 20 20 28 70 61 74 68 6e exe-name (pathn
7e90: 61 6d 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 ame-file (car (a
7ea0: 72 67 76 29 29 29 29 29 0a 20 20 20 20 28 63 6f rgv))))). (co
7eb0: 6e 64 0a 20 20 20 20 20 3b 3b 20 6f 6e 65 2d 77 nd. ;; one-w
7ec0: 6f 72 64 20 63 6f 6d 6d 61 6e 64 73 0a 20 20 20 ord commands.
7ed0: 20 20 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 ((eq? (length
7ee0: 72 65 6d 61 29 20 31 29 0a 20 20 20 20 20 20 28 rema) 1). (
7ef0: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
7f00: 6d 62 6f 6c 20 28 63 61 72 20 72 65 6d 61 29 29 mbol (car rema))
7f10: 0a 09 28 28 68 65 6c 70 20 2d 68 20 2d 68 65 6c ..((help -h -hel
7f20: 70 20 2d 2d 68 20 2d 2d 68 65 6c 70 29 0a 09 20 p --h --help)..
7f30: 28 70 72 69 6e 74 20 73 70 75 62 6c 69 73 68 3a (print spublish:
7f40: 68 65 6c 70 29 29 0a 09 28 65 6c 73 65 0a 09 20 help))..(else..
7f50: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 55 (print "ERROR: U
7f60: 6e 72 65 63 6f 67 6e 69 73 65 64 20 63 6f 6d 6d nrecognised comm
7f70: 61 6e 64 2e 20 54 72 79 20 5c 22 73 70 75 62 6c and. Try \"spubl
7f80: 69 73 68 20 68 65 6c 70 5c 22 22 29 29 29 29 0a ish help\"")))).
7f90: 20 20 20 20 20 3b 3b 20 6d 75 6c 74 69 2d 77 6f ;; multi-wo
7fa0: 72 64 20 63 6f 6d 6d 61 6e 64 73 0a 20 20 20 20 rd commands.
7fb0: 20 28 28 6e 75 6c 6c 3f 20 72 65 6d 61 29 28 70 ((null? rema)(p
7fc0: 72 69 6e 74 20 73 70 75 62 6c 69 73 68 3a 68 65 rint spublish:he
7fd0: 6c 70 29 29 0a 20 20 20 20 20 28 28 3e 3d 20 28 lp)). ((>= (
7fe0: 6c 65 6e 67 74 68 20 72 65 6d 61 29 20 32 29 0a length rema) 2).
7ff0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 73 70 75 (apply spu
8000: 62 6c 69 73 68 3a 70 72 6f 63 65 73 73 2d 61 63 blish:process-ac
8010: 74 69 6f 6e 20 28 63 61 72 20 72 65 6d 61 29 28 tion (car rema)(
8020: 63 64 72 20 72 65 6d 61 29 29 29 0a 20 20 20 20 cdr rema))).
8030: 20 28 65 6c 73 65 20 28 70 72 69 6e 74 20 22 45 (else (print "E
8040: 52 52 4f 52 3a 20 55 6e 72 65 63 6f 67 6e 69 73 RROR: Unrecognis
8050: 65 64 20 63 6f 6d 6d 61 6e 64 32 2e 20 54 72 79 ed command2. Try
8060: 20 5c 22 73 70 75 62 6c 69 73 68 20 68 65 6c 70 \"spublish help
8070: 5c 22 22 29 29 29 29 29 0a 0a 28 6d 61 69 6e 29 \"")))))..(main)
8080: 0a .