Artifact
ec4585c6208400e950a8c16ebf1c1bbc6eb14cf9:
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 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 0a 28 75 73 65 20 64 65 nses/>...(use de
0300: 66 73 74 72 75 63 74 29 0a 28 75 73 65 20 73 63 fstruct).(use sc
0310: 73 68 2d 70 72 6f 63 65 73 73 29 0a 28 75 73 65 sh-process).(use
0320: 20 72 65 66 64 62 29 0a 28 75 73 65 20 73 72 66 refdb).(use srf
0330: 69 2d 31 38 29 0a 28 75 73 65 20 73 72 66 69 2d i-18).(use srfi-
0340: 31 39 29 0a 28 75 73 65 20 66 6f 72 6d 61 74 29 19).(use format)
0350: 0a 28 75 73 65 20 73 71 6c 2d 64 65 2d 6c 69 74 .(use sql-de-lit
0360: 65 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 e srfi-1 posix r
0370: 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 egex regex-case
0380: 73 72 66 69 2d 36 39 29 0a 0a 3b 28 64 65 63 6c srfi-69)..;(decl
0390: 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 67 are (uses config
03a0: 66 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 f)).;; (declare
03b0: 28 75 73 65 73 20 74 72 65 65 29 29 0a 28 64 65 (uses tree)).(de
03c0: 63 6c 61 72 65 20 28 75 73 65 73 20 6d 61 72 67 clare (uses marg
03d0: 73 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 6d s))..(include "m
03e0: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 2e egatest-version.
03f0: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0400: 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d megatest-fossil-
0410: 68 61 73 68 2e 73 63 6d 22 29 0a 3b 3b 3b 20 70 hash.scm").;;; p
0420: 6c 65 61 73 65 20 63 72 65 61 74 65 20 74 68 69 lease create thi
0430: 73 20 66 69 6c 65 20 62 65 66 6f 72 65 20 75 73 s file before us
0440: 69 6e 67 20 73 61 75 74 68 65 72 69 73 65 2e 20 ing sautherise.
0450: 46 6f 72 20 73 61 6d 70 6c 65 20 66 69 6c 65 20 For sample file
0460: 69 73 20 61 76 61 6c 69 61 62 6c 65 20 73 61 6d is avaliable sam
0470: 70 6c 65 2d 73 61 75 74 68 2d 70 61 74 68 73 2e ple-sauth-paths.
0480: 73 63 6d 2e 20 0a 28 69 6e 63 6c 75 64 65 20 22 scm. .(include "
0490: 73 61 75 74 68 2d 70 61 74 68 73 2e 73 63 6d 22 sauth-paths.scm"
04a0: 29 0a 28 69 6e 63 6c 75 64 65 20 22 73 61 75 74 ).(include "saut
04b0: 68 2d 63 6f 6d 6d 6f 6e 2e 73 63 6d 22 29 0a 28 h-common.scm").(
04c0: 64 65 66 69 6e 65 20 28 74 6f 70 6c 65 76 65 6c define (toplevel
04d0: 2d 63 6f 6d 6d 61 6e 64 20 2e 20 61 72 67 73 29 -command . args)
04e0: 20 23 66 29 0a 28 75 73 65 20 72 65 61 64 6c 69 #f).(use readli
04f0: 6e 65 29 0a 0a 3b 3b 0a 3b 3b 20 47 4c 4f 42 41 ne)..;;.;; GLOBA
0500: 4c 53 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 73 LS.;;.(define *s
0510: 70 75 62 6c 69 73 68 3a 63 75 72 72 65 6e 74 2d publish:current-
0520: 74 61 62 2d 6e 75 6d 62 65 72 2a 20 30 29 0a 28 tab-number* 0).(
0530: 64 65 66 69 6e 65 20 2a 61 72 67 73 2d 68 61 73 define *args-has
0540: 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 h* (make-hash-ta
0550: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 73 70 ble)).(define sp
0560: 75 62 6c 69 73 68 3a 68 65 6c 70 20 28 63 6f 6e ublish:help (con
0570: 63 20 22 55 73 61 67 65 3a 20 73 70 75 62 6c 69 c "Usage: spubli
0580: 73 68 20 20 5b 61 63 74 69 6f 6e 20 5b 70 61 72 sh [action [par
0590: 61 6d 73 20 2e 2e 2e 5d 5d 0a 0a 20 20 6c 73 20 ams ...]].. ls
05a0: 20 20 20 20 20 20 3c 61 72 65 61 3e 20 20 20 20 <area>
05b0: 20 20 20 20 20 20 20 20 20 20 3a 20 6c 69 73 74 : list
05c0: 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 74 61 72 contents of tar
05d0: 67 65 74 20 61 72 65 61 0a 20 20 63 70 7c 70 75 get area. cp|pu
05e0: 62 6c 69 73 68 20 3c 61 72 65 61 3e 20 3c 73 72 blish <area> <sr
05f0: 63 20 66 69 6c 65 3e 20 3c 64 65 73 74 69 6e 61 c file> <destina
0600: 74 69 6f 6e 3e 20 20 20 20 20 20 3a 20 63 6f 70 tion> : cop
0610: 79 20 66 69 6c 65 20 74 6f 20 74 61 72 67 65 74 y file to target
0620: 20 61 72 65 61 0a 20 20 6d 6b 64 69 72 20 3c 61 area. mkdir <a
0630: 72 65 61 3e 20 3c 64 69 72 20 6e 61 6d 65 3e 20 rea> <dir name>
0640: 20 20 20 20 20 20 3a 20 6d 61 6b 73 20 64 69 72 : maks dir
0650: 65 63 74 6f 72 79 20 69 6e 20 74 61 72 67 65 74 ectory in target
0660: 20 61 72 65 61 20 20 0a 20 20 72 6d 20 3c 61 72 area . rm <ar
0670: 65 61 3e 20 3c 66 69 6c 65 3e 20 20 20 20 20 20 ea> <file>
0680: 20 20 20 20 20 20 20 20 3a 20 72 65 6d 6f 76 65 : remove
0690: 20 66 69 6c 65 20 3c 66 69 6c 65 3e 20 66 72 6f file <file> fro
06a0: 6d 20 74 61 72 67 65 74 20 61 72 65 61 0a 20 20 m target area.
06b0: 6c 6e 20 3c 61 72 65 61 3e 20 3c 74 61 72 67 65 ln <area> <targe
06c0: 74 3e 20 3c 6c 69 6e 6b 20 6e 61 6d 65 3e 20 3a t> <link name> :
06d0: 20 63 72 65 61 74 65 73 20 61 20 73 79 6d 6c 69 creates a symli
06e0: 6e 6b 0a 20 0a 20 20 6f 70 74 69 6f 6e 73 3a 0a nk. . options:.
06f0: 0a 20 20 20 20 2d 6d 20 5c 22 6d 65 73 73 61 67 . -m \"messag
0700: 65 5c 22 20 20 20 20 20 20 20 20 3a 20 64 65 73 e\" : des
0710: 63 72 69 62 65 20 77 68 61 74 20 77 61 73 20 64 cribe what was d
0720: 6f 6e 65 0a 4e 6f 74 65 3a 20 41 6c 6c 20 74 68 one.Note: All th
0730: 65 20 74 61 72 67 65 74 20 6c 6f 63 61 74 69 6f e target locatio
0740: 6e 73 20 72 65 6c 61 74 69 76 65 20 74 6f 20 62 ns relative to b
0750: 61 73 65 20 70 61 74 68 20 0a 50 61 72 74 20 6f ase path .Part o
0760: 66 20 74 68 65 20 4d 65 67 61 74 65 73 74 20 74 f the Megatest t
0770: 6f 6f 6c 20 73 75 69 74 65 2e 0a 4c 65 61 72 6e ool suite..Learn
0780: 20 6d 6f 72 65 20 61 74 20 68 74 74 70 3a 2f 2f more at http://
0790: 77 77 77 2e 6b 69 61 74 6f 61 2e 63 6f 6d 2f 66 www.kiatoa.com/f
07a0: 6f 73 73 69 6c 73 2f 6d 65 67 61 74 65 73 74 0a ossils/megatest.
07b0: 0a 56 65 72 73 69 6f 6e 3a 20 22 20 6d 65 67 61 .Version: " mega
07c0: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
07d0: 29 29 20 3b 3b 20 22 0a 0a 3b 3b 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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 0a 3b 3b 20 52 45 43 4f 52 44 53 0a 3b 3b 3d =.;; RECORDS.;;=
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 3d 3d 3d 3d 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 0a 0a 3b 3b 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 3d 3d ================
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
08c0: 3b 3b 20 44 42 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ;; DB.;;========
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 3d 3d 3d ================
08f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0910: 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 (define *default
0920: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 -log-port* (curr
0930: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0940: 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 .(define *verbos
0950: 69 74 79 2a 20 20 20 20 20 20 20 20 20 31 29 0a ity* 1).
0960: 0a 3b 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c .;(define (spubl
0970: 69 73 68 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 64 ish:initialize-d
0980: 62 20 64 62 29 0a 3b 20 20 28 66 6f 72 2d 65 61 b db).; (for-ea
0990: 63 68 0a 3b 20 20 20 28 6c 61 6d 62 64 61 20 28 ch.; (lambda (
09a0: 71 72 79 29 0a 3b 20 20 20 20 20 28 65 78 65 63 qry).; (exec
09b0: 20 28 73 71 6c 20 64 62 20 71 72 79 29 29 29 0a (sql db qry))).
09c0: 3b 20 20 20 28 6c 69 73 74 20 0a 3b 20 20 20 20 ; (list .;
09d0: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 "CREATE TABLE IF
09e0: 20 4e 4f 54 20 45 58 49 53 54 53 20 61 63 74 69 NOT EXISTS acti
09f0: 6f 6e 73 0a 3b 20 20 20 20 20 20 20 20 20 28 69 ons.; (i
0a00: 64 20 20 20 20 20 20 20 20 20 20 20 49 4e 54 45 d INTE
0a10: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
0a20: 0a 3b 20 20 20 20 20 20 20 20 20 20 61 63 74 69 .; acti
0a30: 6f 6e 20 20 20 20 20 20 20 54 45 58 54 20 4e 4f on TEXT NO
0a40: 54 20 4e 55 4c 4c 2c 0a 3b 20 20 20 20 20 20 20 T NULL,.;
0a50: 20 20 20 73 75 62 6d 69 74 74 65 72 20 20 20 20 submitter
0a60: 54 45 58 54 20 4e 4f 54 20 4e 55 4c 4c 2c 0a 3b TEXT NOT NULL,.;
0a70: 20 20 20 20 20 20 20 20 20 20 64 61 74 65 74 69 dateti
0a80: 6d 65 20 20 20 20 20 54 49 4d 45 53 54 41 4d 50 me TIMESTAMP
0a90: 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 DEFAULT (strfti
0aa0: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c me('%s','now')),
0ab0: 0a 3b 20 20 20 20 20 20 20 20 20 20 73 72 63 70 .; srcp
0ac0: 61 74 68 20 20 20 20 20 20 54 45 58 54 20 4e 4f ath TEXT NO
0ad0: 54 20 4e 55 4c 4c 2c 0a 3b 20 20 20 20 20 20 20 T NULL,.;
0ae0: 20 20 20 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 comment
0af0: 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 20 TEXT DEFAULT ''
0b00: 4e 4f 54 20 4e 55 4c 4c 2c 0a 3b 20 20 20 20 20 NOT NULL,.;
0b10: 20 20 20 20 20 73 74 61 74 65 20 20 20 20 20 20 state
0b20: 20 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 TEXT DEFAULT '
0b30: 6e 65 77 27 29 3b 22 0a 3b 20 20 20 20 29 29 29 new');".; )))
0b40: 0a 0a 3b 28 64 65 66 69 6e 65 20 28 73 70 75 62 ..;(define (spub
0b50: 6c 69 73 68 3a 72 65 67 69 73 74 65 72 2d 61 63 lish:register-ac
0b60: 74 69 6f 6e 20 64 62 20 61 63 74 69 6f 6e 20 73 tion db action s
0b70: 75 62 6d 69 74 74 65 72 20 73 6f 75 72 63 65 2d ubmitter source-
0b80: 70 61 74 68 20 63 6f 6d 6d 65 6e 74 29 0a 3b 20 path comment).;
0b90: 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 (exec (sql db "
0ba0: 49 4e 53 45 52 54 20 49 4e 54 4f 20 61 63 74 69 INSERT INTO acti
0bb0: 6f 6e 73 20 28 61 63 74 69 6f 6e 2c 73 75 62 6d ons (action,subm
0bc0: 69 74 74 65 72 2c 73 72 63 70 61 74 68 2c 63 6f itter,srcpath,co
0bd0: 6d 6d 65 6e 74 29 0a 3b 20 20 20 20 20 20 20 20 mment).;
0be0: 20 20 20 20 20 20 20 20 20 56 41 4c 55 45 53 28 VALUES(
0bf0: 3f 2c 3f 2c 3f 2c 3f 29 22 29 0a 3b 09 61 63 74 ?,?,?,?)").;.act
0c00: 69 6f 6e 0a 3b 09 73 75 62 6d 69 74 74 65 72 0a ion.;.submitter.
0c10: 3b 09 73 6f 75 72 63 65 2d 70 61 74 68 0a 3b 09 ;.source-path.;.
0c20: 63 6f 6d 6d 65 6e 74 29 29 0a 0a 3b 3b 20 28 63 comment))..;; (c
0c30: 61 6c 6c 2d 77 69 74 68 2d 64 61 74 61 62 61 73 all-with-databas
0c40: 65 0a 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 64 e.;; (lambda (d
0c50: 62 29 0a 3b 3b 20 20 20 28 73 65 74 2d 62 75 73 b).;; (set-bus
0c60: 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 62 y-handler! db (b
0c70: 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 usy-timeout 1000
0c80: 30 29 29 20 3b 20 31 30 20 73 65 63 6f 6e 64 20 0)) ; 10 second
0c90: 74 69 6d 65 6f 75 74 0a 3b 3b 20 20 20 2e 2e 2e timeout.;; ...
0ca0: 29 29 0a 0a 3b 3b 20 43 72 65 61 74 65 20 74 68 ))..;; Create th
0cb0: 65 20 73 71 6c 69 74 65 20 64 62 0a 3b 28 64 65 e sqlite db.;(de
0cc0: 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 64 fine (spublish:d
0cd0: 62 2d 64 6f 20 63 6f 6e 66 69 67 64 61 74 20 70 b-do configdat p
0ce0: 72 6f 63 29 20 0a 3b 20 20 28 6c 65 74 20 28 28 roc) .; (let ((
0cf0: 70 61 74 68 20 28 63 6f 6e 66 69 67 66 3a 6c 6f path (configf:lo
0d00: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
0d10: 64 61 74 61 62 61 73 65 22 20 22 6c 6f 63 61 74 database" "locat
0d20: 69 6f 6e 22 29 29 29 0a 3b 20 20 20 20 28 69 66 ion"))).; (if
0d30: 20 28 6e 6f 74 20 70 61 74 68 29 0a 3b 09 28 62 (not path).;.(b
0d40: 65 67 69 6e 0a 3b 09 20 20 28 70 72 69 6e 74 20 egin.;. (print
0d50: 22 5b 64 61 74 61 62 61 73 65 5d 5c 6e 6c 6f 63 "[database]\nloc
0d60: 61 74 69 6f 6e 20 2f 73 6f 6d 65 2f 70 61 74 68 ation /some/path
0d70: 5c 6e 5c 6e 20 49 73 20 6d 69 73 73 69 6e 67 20 \n\n Is missing
0d80: 66 72 6f 6d 20 74 68 65 20 63 6f 6e 66 69 67 20 from the config
0d90: 66 69 6c 65 21 22 29 0a 3b 09 20 20 28 65 78 69 file!").;. (exi
0da0: 74 20 31 29 29 29 0a 3b 20 20 20 20 28 69 66 20 t 1))).; (if
0db0: 28 61 6e 64 20 70 61 74 68 0a 3b 09 20 20 20 20 (and path.;.
0dc0: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 74 (directory? pat
0dd0: 68 29 0a 3b 09 20 20 20 20 20 28 66 69 6c 65 2d h).;. (file-
0de0: 72 65 61 64 2d 61 63 63 65 73 73 3f 20 70 61 74 read-access? pat
0df0: 68 29 29 0a 3b 09 28 6c 65 74 2a 20 28 28 64 62 h)).;.(let* ((db
0e00: 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 70 61 path (conc pa
0e10: 74 68 20 22 2f 73 70 75 62 6c 69 73 68 2e 64 62 th "/spublish.db
0e20: 22 29 29 0a 3b 09 20 20 20 20 20 20 20 28 77 72 ")).;. (wr
0e30: 69 74 65 61 62 6c 65 20 28 66 69 6c 65 2d 77 72 iteable (file-wr
0e40: 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 ite-access? dbpa
0e50: 74 68 29 29 0a 3b 09 20 20 20 20 20 20 20 28 64 th)).;. (d
0e60: 62 65 78 69 73 74 73 20 20 28 66 69 6c 65 2d 65 bexists (file-e
0e70: 78 69 73 74 73 3f 20 64 62 70 61 74 68 29 29 29 xists? dbpath)))
0e80: 0a 3b 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 .;. (handle-exc
0e90: 65 70 74 69 6f 6e 73 0a 3b 09 20 20 20 65 78 6e eptions.;. exn
0ea0: 0a 3b 09 20 20 20 28 62 65 67 69 6e 0a 3b 09 20 .;. (begin.;.
0eb0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0ec0: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
0ed0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 72 port* "ERROR: pr
0ee0: 6f 62 6c 65 6d 20 61 63 63 65 73 73 69 6e 67 20 oblem accessing
0ef0: 64 62 20 22 20 64 62 70 61 74 68 0a 3b 09 09 09 db " dbpath.;...
0f00: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
0f10: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
0f20: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
0f30: 78 6e 29 29 0a 3b 09 20 20 20 20 20 28 65 78 69 xn)).;. (exi
0f40: 74 20 31 29 29 0a 3b 09 20 20 20 28 63 61 6c 6c t 1)).;. (call
0f50: 2d 77 69 74 68 2d 64 61 74 61 62 61 73 65 0a 3b -with-database.;
0f60: 20 20 20 20 20 20 20 20 20 20 20 20 64 62 70 61 dbpa
0f70: 74 68 0a 3b 09 20 20 20 20 28 6c 61 6d 62 64 61 th.;. (lambda
0f80: 20 28 64 62 29 0a 3b 09 20 20 20 20 20 20 3b 3b (db).;. ;;
0f90: 20 28 70 72 69 6e 74 20 22 63 61 6c 6c 69 6e 67 (print "calling
0fa0: 20 70 72 6f 63 20 22 20 70 72 6f 63 20 22 20 6f proc " proc " o
0fb0: 6e 20 64 62 20 22 20 64 62 29 0a 3b 09 20 20 20 n db " db).;.
0fc0: 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e (set-busy-han
0fd0: 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 dler! db (busy-t
0fe0: 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 20 3b imeout 10000)) ;
0ff0: 3b 20 31 30 20 73 65 63 20 74 69 6d 65 6f 75 74 ; 10 sec timeout
1000: 0a 3b 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f .;. (if (no
1010: 74 20 64 62 65 78 69 73 74 73 29 28 73 70 75 62 t dbexists)(spub
1020: 6c 69 73 68 3a 69 6e 69 74 69 61 6c 69 7a 65 2d lish:initialize-
1030: 64 62 20 64 62 29 29 0a 3b 09 20 20 20 20 20 20 db db)).;.
1040: 28 70 72 6f 63 20 64 62 29 29 29 29 29 0a 3b 09 (proc db))))).;.
1050: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 69 (print "ERROR: i
1060: 6e 76 61 6c 69 64 20 70 61 74 68 20 66 6f 72 20 nvalid path for
1070: 73 74 6f 72 69 6e 67 20 64 61 74 61 62 61 73 65 storing database
1080: 3a 20 22 20 70 61 74 68 29 29 29 29 0a 3b 0a 3b : " path)))).;.;
1090: 3b 3b 20 63 6f 70 79 20 69 6e 20 66 69 6c 65 20 ;; copy in file
10a0: 74 6f 20 64 65 73 74 2c 20 76 61 6c 69 64 61 74 to dest, validat
10b0: 69 6f 6e 20 69 73 20 64 6f 6e 65 20 42 45 46 4f ion is done BEFO
10c0: 52 45 20 63 61 6c 6c 69 6e 67 20 74 68 69 73 0a RE calling this.
10d0: 3b 3b 3b 0a 3b 28 64 65 66 69 6e 65 20 28 73 70 ;;;.;(define (sp
10e0: 75 62 6c 69 73 68 3a 63 70 20 63 6f 6e 66 69 67 ublish:cp config
10f0: 64 61 74 20 73 75 62 6d 69 74 74 65 72 20 73 6f dat submitter so
1100: 75 72 63 65 2d 70 61 74 68 20 74 61 72 67 65 74 urce-path target
1110: 2d 64 69 72 20 74 61 72 67 2d 66 69 6c 65 20 64 -dir targ-file d
1120: 65 73 74 2d 64 69 72 20 63 6f 6d 6d 65 6e 74 29 est-dir comment)
1130: 0a 3b 20 20 28 6c 65 74 20 28 28 64 65 73 74 2d .; (let ((dest-
1140: 64 69 72 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 dir-path (conc t
1150: 61 72 67 65 74 2d 64 69 72 20 22 2f 22 20 64 65 arget-dir "/" de
1160: 73 74 2d 64 69 72 29 29 0a 3b 20 20 20 20 20 20 st-dir)).;
1170: 20 20 28 74 61 72 67 2d 70 61 74 68 20 28 63 6f (targ-path (co
1180: 6e 63 20 74 61 72 67 65 74 2d 64 69 72 20 22 2f nc target-dir "/
1190: 22 20 64 65 73 74 2d 64 69 72 20 22 2f 22 20 74 " dest-dir "/" t
11a0: 61 72 67 2d 66 69 6c 65 29 29 29 0a 3b 20 20 20 arg-file))).;
11b0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
11c0: 73 3f 20 74 61 72 67 2d 70 61 74 68 29 0a 3b 09 s? targ-path).;.
11d0: 28 62 65 67 69 6e 0a 3b 09 20 20 28 70 72 69 6e (begin.;. (prin
11e0: 74 20 22 45 52 52 4f 52 3a 20 74 61 72 67 65 74 t "ERROR: target
11f0: 20 66 69 6c 65 20 61 6c 72 65 61 64 79 20 65 78 file already ex
1200: 69 73 74 73 2c 20 72 65 6d 6f 76 65 20 69 74 20 ists, remove it
1210: 62 65 66 6f 72 65 20 72 65 2d 70 75 62 6c 69 73 before re-publis
1220: 68 69 6e 67 22 29 0a 3b 09 20 20 28 65 78 69 74 hing").;. (exit
1230: 20 31 29 29 29 0a 3b 20 20 20 20 20 20 20 28 69 1))).; (i
1240: 66 20 28 6e 6f 74 28 66 69 6c 65 2d 65 78 69 73 f (not(file-exis
1250: 74 73 3f 20 64 65 73 74 2d 64 69 72 2d 70 61 74 ts? dest-dir-pat
1260: 68 29 29 0a 3b 09 28 62 65 67 69 6e 0a 3b 09 20 h)).;.(begin.;.
1270: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
1280: 74 61 72 67 65 74 20 64 69 72 65 63 74 6f 72 79 target directory
1290: 20 22 20 64 65 73 74 2d 64 69 72 2d 70 61 74 68 " dest-dir-path
12a0: 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 " does not exis
12b0: 74 73 2e 22 20 29 0a 3b 09 20 20 28 65 78 69 74 ts." ).;. (exit
12c0: 20 31 29 29 29 0a 3b 0a 3b 20 20 20 20 28 73 70 1))).;.; (sp
12d0: 75 62 6c 69 73 68 3a 64 62 2d 64 6f 0a 3b 20 20 ublish:db-do.;
12e0: 20 20 20 63 6f 6e 66 69 67 64 61 74 0a 3b 20 20 configdat.;
12f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a (lambda (db).
1300: 3b 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 ; (spublis
1310: 68 3a 72 65 67 69 73 74 65 72 2d 61 63 74 69 6f h:register-actio
1320: 6e 20 64 62 20 22 63 70 22 20 73 75 62 6d 69 74 n db "cp" submit
1330: 74 65 72 20 73 6f 75 72 63 65 2d 70 61 74 68 20 ter source-path
1340: 63 6f 6d 6d 65 6e 74 29 29 29 0a 3b 20 20 20 20 comment))).;
1350: 28 6c 65 74 2a 20 28 3b 3b 20 28 74 61 72 67 65 (let* (;; (targe
1360: 74 2d 70 61 74 68 20 28 63 6f 6e 66 69 67 66 3a t-path (configf:
1370: 6c 6f 6f 6b 75 70 20 22 73 65 74 74 69 6e 67 73 lookup "settings
1380: 22 20 22 74 61 72 67 65 74 2d 70 61 74 68 22 29 " "target-path")
1390: 29 0a 3b 09 20 20 20 28 74 68 31 20 20 20 20 20 ).;. (th1
13a0: 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 (make-thread
13b0: 0a 3b 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 .;... (lambda ()
13c0: 0a 3b 09 09 09 20 20 20 28 66 69 6c 65 2d 63 6f .;... (file-co
13d0: 70 79 20 73 6f 75 72 63 65 2d 70 61 74 68 20 74 py source-path t
13e0: 61 72 67 2d 70 61 74 68 20 23 74 29 29 0a 3b 20 arg-path #t)).;
13f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1400: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
1410: 74 20 22 20 2e 2e 2e 20 66 69 6c 65 20 22 20 74 t " ... file " t
1420: 61 72 67 2d 70 61 74 68 20 22 20 63 6f 70 69 65 arg-path " copie
1430: 64 20 74 6f 20 22 20 74 61 72 67 2d 70 61 74 68 d to " targ-path
1440: 29 0a 3b 09 09 09 20 3b 3b 20 28 6c 65 74 20 28 ).;... ;; (let (
1450: 28 70 69 64 20 28 70 72 6f 63 65 73 73 2d 72 75 (pid (process-ru
1460: 6e 20 22 63 70 22 20 28 6c 69 73 74 20 73 6f 75 n "cp" (list sou
1470: 72 63 65 2d 70 61 74 68 20 74 61 72 67 65 74 2d rce-path target-
1480: 64 69 72 29 29 29 29 0a 3b 09 09 09 20 3b 3b 20 dir)))).;... ;;
1490: 20 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 (process-wait
14a0: 70 69 64 29 29 29 0a 3b 09 09 09 20 22 63 6f 70 pid))).;... "cop
14b0: 79 20 74 68 72 65 61 64 22 29 29 0a 3b 09 20 20 y thread")).;.
14c0: 20 28 74 68 32 20 20 20 20 20 20 20 20 20 28 6d (th2 (m
14d0: 61 6b 65 2d 74 68 72 65 61 64 0a 3b 09 09 09 20 ake-thread.;...
14e0: 28 6c 61 6d 62 64 61 20 28 29 0a 3b 09 09 09 20 (lambda ().;...
14f0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 3b (let loop ().;
1500: 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d ... (thread-
1510: 73 6c 65 65 70 21 20 31 35 29 0a 3b 09 09 09 20 sleep! 15).;...
1520: 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 2e 22 (display "."
1530: 29 0a 3b 09 09 09 20 20 20 20 20 28 66 6c 75 73 ).;... (flus
1540: 68 2d 6f 75 74 70 75 74 29 0a 3b 09 09 09 20 20 h-output).;...
1550: 20 20 20 28 6c 6f 6f 70 29 29 29 0a 3b 09 09 09 (loop))).;...
1560: 20 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 70 "action is happ
1570: 65 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 29 ening thread")))
1580: 0a 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .; (thread-
1590: 73 74 61 72 74 21 20 74 68 31 29 0a 3b 20 20 20 start! th1).;
15a0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
15b0: 21 20 74 68 32 29 0a 3b 20 20 20 20 20 20 28 74 ! th2).; (t
15c0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 hread-join! th1)
15d0: 29 0a 3b 20 20 20 20 28 63 6f 6e 73 20 23 74 20 ).; (cons #t
15e0: 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 73 61 "Successfully sa
15f0: 76 65 64 20 64 61 74 61 22 29 29 29 0a 3b 0a 3b ved data"))).;.;
1600: 3b 3b 20 63 6f 70 79 20 64 69 72 65 63 74 6f 72 ;; copy director
1610: 79 20 74 6f 20 64 65 73 74 2c 20 76 61 6c 69 64 y to dest, valid
1620: 61 74 69 6f 6e 20 69 73 20 64 6f 6e 65 20 42 45 ation is done BE
1630: 46 4f 52 45 20 63 61 6c 6c 69 6e 67 20 74 68 69 FORE calling thi
1640: 73 0a 3b 3b 3b 0a 3b 0a 3b 28 64 65 66 69 6e 65 s.;;;.;.;(define
1650: 20 28 73 70 75 62 6c 69 73 68 3a 74 61 72 20 63 (spublish:tar c
1660: 6f 6e 66 69 67 64 61 74 20 73 75 62 6d 69 74 74 onfigdat submitt
1670: 65 72 20 74 61 72 67 65 74 2d 64 69 72 20 64 65 er target-dir de
1680: 73 74 2d 64 69 72 20 63 6f 6d 6d 65 6e 74 29 0a st-dir comment).
1690: 3b 20 20 28 6c 65 74 20 28 28 64 65 73 74 2d 64 ; (let ((dest-d
16a0: 69 72 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 61 ir-path (conc ta
16b0: 72 67 65 74 2d 64 69 72 20 22 2f 22 20 64 65 73 rget-dir "/" des
16c0: 74 2d 64 69 72 29 29 29 0a 3b 20 20 20 20 20 20 t-dir))).;
16d0: 20 28 69 66 20 28 6e 6f 74 28 66 69 6c 65 2d 65 (if (not(file-e
16e0: 78 69 73 74 73 3f 20 64 65 73 74 2d 64 69 72 2d xists? dest-dir-
16f0: 70 61 74 68 29 29 0a 3b 09 28 62 65 67 69 6e 0a path)).;.(begin.
1700: 3b 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f ;. (print "ERRO
1710: 52 3a 20 74 61 72 67 65 74 20 64 69 72 65 63 74 R: target direct
1720: 6f 72 79 20 22 20 64 65 73 74 2d 64 69 72 2d 70 ory " dest-dir-p
1730: 61 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 ath " does not e
1740: 78 69 73 74 73 2e 22 20 29 0a 3b 09 20 20 28 65 xists." ).;. (e
1750: 78 69 74 20 31 29 29 29 0a 3b 20 20 20 20 3b 3b xit 1))).; ;;
1760: 28 70 72 69 6e 74 20 64 65 73 74 2d 64 69 72 2d (print dest-dir-
1770: 70 61 74 68 20 29 0a 3b 20 20 20 20 28 73 70 75 path ).; (spu
1780: 62 6c 69 73 68 3a 64 62 2d 64 6f 0a 3b 20 20 20 blish:db-do.;
1790: 20 20 63 6f 6e 66 69 67 64 61 74 0a 3b 20 20 20 configdat.;
17a0: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 3b (lambda (db).;
17b0: 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 (spublish
17c0: 3a 72 65 67 69 73 74 65 72 2d 61 63 74 69 6f 6e :register-action
17d0: 20 64 62 20 22 74 61 72 22 20 73 75 62 6d 69 74 db "tar" submit
17e0: 74 65 72 20 64 65 73 74 2d 64 69 72 2d 70 61 74 ter dest-dir-pat
17f0: 68 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 3b 20 20 h comment))).;
1800: 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 (change-dir
1810: 65 63 74 6f 72 79 20 64 65 73 74 2d 64 69 72 2d ectory dest-dir-
1820: 70 61 74 68 29 0a 3b 20 20 20 20 20 20 20 28 70 path).; (p
1830: 72 6f 63 65 73 73 2d 77 61 69 74 20 28 70 72 6f rocess-wait (pro
1840: 63 65 73 73 2d 72 75 6e 20 22 2f 62 69 6e 2f 74 cess-run "/bin/t
1850: 61 72 22 20 28 6c 69 73 74 20 22 78 66 22 20 22 ar" (list "xf" "
1860: 2d 22 29 29 29 0a 3b 20 20 20 20 20 20 20 28 70 -"))).; (p
1870: 72 69 6e 74 20 22 44 61 74 61 20 63 6f 70 69 65 rint "Data copie
1880: 64 20 74 6f 20 22 20 64 65 73 74 2d 64 69 72 2d d to " dest-dir-
1890: 70 61 74 68 29 20 0a 3b 0a 3b 20 20 20 20 20 20 path) .;.;
18a0: 20 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 63 (cons #t "Succ
18b0: 65 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 64 essfully saved d
18c0: 61 74 61 22 29 29 29 0a 0a 0a 3b 28 64 65 66 69 ata")))...;(defi
18d0: 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 76 61 6c ne (spublish:val
18e0: 69 64 61 74 65 20 74 61 72 67 65 74 2d 64 69 72 idate target-dir
18f0: 20 74 61 72 67 2d 6d 6b 29 0a 3b 20 20 28 6c 65 targ-mk).; (le
1900: 74 2a 20 28 28 6e 6f 72 6d 61 6c 2d 70 61 74 68 t* ((normal-path
1910: 20 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 (normalize-path
1920: 6e 61 6d 65 20 74 61 72 67 2d 6d 6b 29 29 0a 3b name targ-mk)).;
1930: 20 20 20 20 20 20 20 20 28 74 61 72 67 2d 70 61 (targ-pa
1940: 74 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d th (conc target-
1950: 64 69 72 20 22 2f 22 20 6e 6f 72 6d 61 6c 2d 70 dir "/" normal-p
1960: 61 74 68 29 29 29 0a 3b 20 20 20 20 28 69 66 20 ath))).; (if
1970: 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 (string-contains
1980: 20 20 20 6e 6f 72 6d 61 6c 2d 70 61 74 68 20 22 normal-path "
1990: 2e 2e 22 29 0a 3b 20 20 20 20 28 62 65 67 69 6e ..").; (begin
19a0: 0a 3b 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 .; (print "
19b0: 45 52 52 4f 52 3a 20 50 61 74 68 20 20 22 20 74 ERROR: Path " t
19c0: 61 72 67 2d 6d 6b 20 22 20 72 65 73 6f 6c 76 65 arg-mk " resolve
19d0: 64 20 6f 75 74 73 69 64 65 20 74 61 72 67 65 74 d outside target
19e0: 20 61 72 65 61 20 22 20 20 74 61 72 67 65 74 2d area " target-
19f0: 64 69 72 20 29 0a 3b 20 20 20 20 20 20 28 65 78 dir ).; (ex
1a00: 69 74 20 31 29 29 29 0a 3b 0a 3b 20 20 20 20 28 it 1))).;.; (
1a10: 69 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d if (not (string-
1a20: 63 6f 6e 74 61 69 6e 73 20 74 61 72 67 2d 70 61 contains targ-pa
1a30: 74 68 20 74 61 72 67 65 74 2d 64 69 72 29 29 0a th target-dir)).
1a40: 3b 20 20 20 20 28 62 65 67 69 6e 0a 3b 20 20 20 ; (begin.;
1a50: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
1a60: 3a 20 59 6f 75 20 63 61 6e 6e 6f 74 20 75 70 64 : You cannot upd
1a70: 61 74 65 20 64 61 74 61 20 6f 75 74 73 69 64 65 ate data outside
1a80: 20 22 20 74 61 72 67 65 74 2d 64 69 72 20 22 2e " target-dir ".
1a90: 22 29 0a 3b 20 20 20 20 20 20 28 65 78 69 74 20 ").; (exit
1aa0: 31 29 29 29 0a 3b 20 20 20 20 28 70 72 69 6e 74 1))).; (print
1ab0: 20 22 50 61 74 68 20 22 20 74 61 72 67 2d 6d 6b "Path " targ-mk
1ac0: 20 22 20 69 73 20 76 61 6c 69 64 2e 22 29 20 20 " is valid.")
1ad0: 20 0a 3b 20 29 29 0a 3b 3b 20 6d 61 6b 65 20 64 .; )).;; make d
1ae0: 69 72 65 63 74 6f 72 79 20 69 6e 20 64 65 73 74 irectory in dest
1af0: 0a 3b 3b 0a 0a 3b 28 64 65 66 69 6e 65 20 28 73 .;;..;(define (s
1b00: 70 75 62 6c 69 73 68 3a 6d 6b 64 69 72 20 63 6f publish:mkdir co
1b10: 6e 66 69 67 64 61 74 20 73 75 62 6d 69 74 74 65 nfigdat submitte
1b20: 72 20 74 61 72 67 65 74 2d 64 69 72 20 74 61 72 r target-dir tar
1b30: 67 2d 6d 6b 20 63 6f 6d 6d 65 6e 74 29 0a 3b 20 g-mk comment).;
1b40: 20 28 6c 65 74 20 28 28 74 61 72 67 2d 70 61 74 (let ((targ-pat
1b50: 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d 64 h (conc target-d
1b60: 69 72 20 22 2f 22 20 74 61 72 67 2d 6d 6b 29 29 ir "/" targ-mk))
1b70: 29 0a 3b 20 20 20 20 0a 3b 20 20 20 20 28 69 66 ).; .; (if
1b80: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
1b90: 61 72 67 2d 70 61 74 68 29 0a 3b 09 28 62 65 67 arg-path).;.(beg
1ba0: 69 6e 0a 3b 09 20 20 28 70 72 69 6e 74 20 22 45 in.;. (print "E
1bb0: 52 52 4f 52 3a 20 74 61 72 67 65 74 20 44 69 72 RROR: target Dir
1bc0: 65 63 74 6f 72 79 20 22 20 74 61 72 67 2d 70 61 ectory " targ-pa
1bd0: 74 68 20 22 20 61 6c 72 65 61 64 79 20 65 78 69 th " already exi
1be0: 73 74 21 21 22 29 0a 3b 09 20 20 28 65 78 69 74 st!!").;. (exit
1bf0: 20 31 29 29 29 0a 3b 20 20 20 20 28 73 70 75 62 1))).; (spub
1c00: 6c 69 73 68 3a 64 62 2d 64 6f 0a 3b 20 20 20 20 lish:db-do.;
1c10: 20 63 6f 6e 66 69 67 64 61 74 0a 3b 20 20 20 20 configdat.;
1c20: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 3b 20 (lambda (db).;
1c30: 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a (spublish:
1c40: 72 65 67 69 73 74 65 72 2d 61 63 74 69 6f 6e 20 register-action
1c50: 64 62 20 22 6d 6b 64 69 72 22 20 73 75 62 6d 69 db "mkdir" submi
1c60: 74 74 65 72 20 74 61 72 67 2d 6d 6b 20 63 6f 6d tter targ-mk com
1c70: 6d 65 6e 74 29 29 29 0a 3b 20 20 20 20 28 6c 65 ment))).; (le
1c80: 74 2a 20 28 28 74 68 31 20 20 20 20 20 20 20 20 t* ((th1
1c90: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b 09 (make-thread.;.
1ca0: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 09 .. (lambda ().;.
1cb0: 09 09 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 .. (create-dir
1cc0: 65 63 74 6f 72 79 20 74 61 72 67 2d 70 61 74 68 ectory targ-path
1cd0: 20 23 74 29 0a 3b 09 09 09 20 20 20 28 70 72 69 #t).;... (pri
1ce0: 6e 74 20 22 20 2e 2e 2e 20 64 69 72 20 22 20 74 nt " ... dir " t
1cf0: 61 72 67 2d 70 61 74 68 20 22 20 63 72 65 61 74 arg-path " creat
1d00: 65 64 22 29 29 0a 3b 09 09 09 20 22 6d 6b 64 69 ed")).;... "mkdi
1d10: 72 20 74 68 72 65 61 64 22 29 29 0a 3b 09 20 20 r thread")).;.
1d20: 20 28 74 68 32 20 20 20 20 20 20 20 20 20 28 6d (th2 (m
1d30: 61 6b 65 2d 74 68 72 65 61 64 0a 3b 09 09 09 20 ake-thread.;...
1d40: 28 6c 61 6d 62 64 61 20 28 29 0a 3b 09 09 09 20 (lambda ().;...
1d50: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 3b (let loop ().;
1d60: 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d ... (thread-
1d70: 73 6c 65 65 70 21 20 31 35 29 0a 3b 09 09 09 20 sleep! 15).;...
1d80: 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 2e 22 (display "."
1d90: 29 0a 3b 09 09 09 20 20 20 20 20 28 66 6c 75 73 ).;... (flus
1da0: 68 2d 6f 75 74 70 75 74 29 0a 3b 09 09 09 20 20 h-output).;...
1db0: 20 20 20 28 6c 6f 6f 70 29 29 29 0a 3b 09 09 09 (loop))).;...
1dc0: 20 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 70 "action is happ
1dd0: 65 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 29 ening thread")))
1de0: 0a 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .; (thread-
1df0: 73 74 61 72 74 21 20 74 68 31 29 0a 3b 20 20 20 start! th1).;
1e00: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
1e10: 21 20 74 68 32 29 0a 3b 20 20 20 20 20 20 28 74 ! th2).; (t
1e20: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 hread-join! th1)
1e30: 29 0a 3b 20 20 20 20 28 63 6f 6e 73 20 23 74 20 ).; (cons #t
1e40: 22 53 75 63 63 65 73 73 66 75 6c 6c 79 20 73 61 "Successfully sa
1e50: 76 65 64 20 64 61 74 61 22 29 29 29 0a 0a 3b 3b ved data")))..;;
1e60: 20 63 72 65 61 74 65 20 61 20 73 79 6d 6c 69 6e create a symlin
1e70: 6b 20 69 6e 20 64 65 73 74 0a 3b 3b 0a 3b 28 64 k in dest.;;.;(d
1e80: 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a efine (spublish:
1e90: 6c 6e 20 63 6f 6e 66 69 67 64 61 74 20 73 75 62 ln configdat sub
1ea0: 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d 64 69 mitter target-di
1eb0: 72 20 74 61 72 67 2d 6c 69 6e 6b 20 6c 69 6e 6b r targ-link link
1ec0: 2d 6e 61 6d 65 20 63 6f 6d 6d 65 6e 74 29 0a 3b -name comment).;
1ed0: 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 70 61 (let ((targ-pa
1ee0: 74 68 20 28 63 6f 6e 63 20 74 61 72 67 65 74 2d th (conc target-
1ef0: 64 69 72 20 22 2f 22 20 6c 69 6e 6b 2d 6e 61 6d dir "/" link-nam
1f00: 65 29 29 29 0a 3b 20 20 20 20 28 69 66 20 28 66 e))).; (if (f
1f10: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
1f20: 2d 70 61 74 68 29 0a 3b 09 28 62 65 67 69 6e 0a -path).;.(begin.
1f30: 3b 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f ;. (print "ERRO
1f40: 52 3a 20 74 61 72 67 65 74 20 66 69 6c 65 20 22 R: target file "
1f50: 20 74 61 72 67 2d 70 61 74 68 20 22 20 61 6c 72 targ-path " alr
1f60: 65 61 64 79 20 65 78 69 73 74 21 21 22 29 0a 3b eady exist!!").;
1f70: 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 3b 20 . (exit 1))).;
1f80: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
1f90: 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 2d le-exists? targ-
1fa0: 6c 69 6e 6b 20 29 29 0a 3b 09 28 62 65 67 69 6e link )).;.(begin
1fb0: 0a 3b 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 .;. (print "ERR
1fc0: 4f 52 3a 20 74 61 72 67 65 74 20 66 69 6c 65 20 OR: target file
1fd0: 22 20 74 61 72 67 2d 6c 69 6e 6b 20 22 20 64 6f " targ-link " do
1fe0: 65 73 20 6e 6f 74 20 65 78 69 73 74 21 21 22 29 es not exist!!")
1ff0: 0a 3b 09 20 20 28 65 78 69 74 20 31 29 29 29 0a .;. (exit 1))).
2000: 3b 20 0a 3b 20 20 20 20 28 73 70 75 62 6c 69 73 ; .; (spublis
2010: 68 3a 64 62 2d 64 6f 0a 3b 20 20 20 20 20 63 6f h:db-do.; co
2020: 6e 66 69 67 64 61 74 0a 3b 20 20 20 20 20 28 6c nfigdat.; (l
2030: 61 6d 62 64 61 20 28 64 62 29 0a 3b 20 20 20 20 ambda (db).;
2040: 20 20 20 28 73 70 75 62 6c 69 73 68 3a 72 65 67 (spublish:reg
2050: 69 73 74 65 72 2d 61 63 74 69 6f 6e 20 64 62 20 ister-action db
2060: 22 6c 6e 22 20 73 75 62 6d 69 74 74 65 72 20 6c "ln" submitter l
2070: 69 6e 6b 2d 6e 61 6d 65 20 63 6f 6d 6d 65 6e 74 ink-name comment
2080: 29 29 29 0a 3b 20 20 20 20 28 6c 65 74 2a 20 28 ))).; (let* (
2090: 28 74 68 31 20 20 20 20 20 20 20 20 20 28 6d 61 (th1 (ma
20a0: 6b 65 2d 74 68 72 65 61 64 0a 3b 09 09 09 20 28 ke-thread.;... (
20b0: 6c 61 6d 62 64 61 20 28 29 0a 3b 09 09 09 20 20 lambda ().;...
20c0: 20 28 63 72 65 61 74 65 2d 73 79 6d 62 6f 6c 69 (create-symboli
20d0: 63 2d 6c 69 6e 6b 20 74 61 72 67 2d 6c 69 6e 6b c-link targ-link
20e0: 20 74 61 72 67 2d 70 61 74 68 20 20 29 0a 3b 09 targ-path ).;.
20f0: 09 09 20 20 20 28 70 72 69 6e 74 20 22 20 2e 2e .. (print " ..
2100: 2e 20 6c 69 6e 6b 20 22 20 74 61 72 67 2d 70 61 . link " targ-pa
2110: 74 68 20 22 20 63 72 65 61 74 65 64 22 29 29 0a th " created")).
2120: 3b 09 09 09 20 22 73 79 6d 6c 69 6e 6b 20 74 68 ;... "symlink th
2130: 72 65 61 64 22 29 29 0a 3b 09 20 20 20 28 74 68 read")).;. (th
2140: 32 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 2 (make-
2150: 74 68 72 65 61 64 0a 3b 09 09 09 20 28 6c 61 6d thread.;... (lam
2160: 62 64 61 20 28 29 0a 3b 09 09 09 20 20 20 28 6c bda ().;... (l
2170: 65 74 20 6c 6f 6f 70 20 28 29 0a 3b 09 09 09 20 et loop ().;...
2180: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
2190: 70 21 20 31 35 29 0a 3b 09 09 09 20 20 20 20 20 p! 15).;...
21a0: 28 64 69 73 70 6c 61 79 20 22 2e 22 29 0a 3b 09 (display ".").;.
21b0: 09 09 20 20 20 20 20 28 66 6c 75 73 68 2d 6f 75 .. (flush-ou
21c0: 74 70 75 74 29 0a 3b 09 09 09 20 20 20 20 20 28 tput).;... (
21d0: 6c 6f 6f 70 29 29 29 0a 3b 09 09 09 20 22 61 63 loop))).;... "ac
21e0: 74 69 6f 6e 20 69 73 20 68 61 70 70 65 6e 69 6e tion is happenin
21f0: 67 20 74 68 72 65 61 64 22 29 29 29 0a 3b 20 20 g thread"))).;
2200: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
2210: 74 21 20 74 68 31 29 0a 3b 20 20 20 20 20 20 28 t! th1).; (
2220: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
2230: 32 29 0a 3b 20 20 20 20 20 20 28 74 68 72 65 61 2).; (threa
2240: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 3b 20 d-join! th1)).;
2250: 20 20 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 (cons #t "Suc
2260: 63 65 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 cessfully saved
2270: 64 61 74 61 22 29 29 29 0a 0a 0a 3b 3b 20 72 65 data")))...;; re
2280: 6d 6f 76 65 20 63 6f 70 79 20 6f 66 20 66 69 6c move copy of fil
2290: 65 20 69 6e 20 64 65 73 74 0a 3b 3b 0a 3b 28 64 e in dest.;;.;(d
22a0: 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a efine (spublish:
22b0: 72 6d 20 63 6f 6e 66 69 67 64 61 74 20 73 75 62 rm configdat sub
22c0: 6d 69 74 74 65 72 20 74 61 72 67 65 74 2d 64 69 mitter target-di
22d0: 72 20 74 61 72 67 2d 66 69 6c 65 20 63 6f 6d 6d r targ-file comm
22e0: 65 6e 74 29 0a 3b 20 20 28 6c 65 74 20 28 28 74 ent).; (let ((t
22f0: 61 72 67 2d 70 61 74 68 20 28 63 6f 6e 63 20 74 arg-path (conc t
2300: 61 72 67 65 74 2d 64 69 72 20 22 2f 22 20 74 61 arget-dir "/" ta
2310: 72 67 2d 66 69 6c 65 29 29 29 0a 3b 20 20 20 20 rg-file))).;
2320: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 (if (not (file-e
2330: 78 69 73 74 73 3f 20 74 61 72 67 2d 70 61 74 68 xists? targ-path
2340: 29 29 0a 3b 09 28 62 65 67 69 6e 0a 3b 09 20 20 )).;.(begin.;.
2350: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 (print "ERROR: t
2360: 61 72 67 65 74 20 66 69 6c 65 20 22 20 74 61 72 arget file " tar
2370: 67 2d 70 61 74 68 20 22 20 6e 6f 74 20 66 6f 75 g-path " not fou
2380: 6e 64 2c 20 6e 6f 74 68 69 6e 67 20 74 6f 20 72 nd, nothing to r
2390: 65 6d 6f 76 65 2e 22 29 0a 3b 09 20 20 28 65 78 emove.").;. (ex
23a0: 69 74 20 31 29 29 29 0a 3b 20 20 20 20 28 73 70 it 1))).; (sp
23b0: 75 62 6c 69 73 68 3a 64 62 2d 64 6f 0a 3b 20 20 ublish:db-do.;
23c0: 20 20 20 63 6f 6e 66 69 67 64 61 74 0a 3b 20 20 configdat.;
23d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a (lambda (db).
23e0: 3b 20 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 ; (spublis
23f0: 68 3a 72 65 67 69 73 74 65 72 2d 61 63 74 69 6f h:register-actio
2400: 6e 20 64 62 20 22 72 6d 22 20 73 75 62 6d 69 74 n db "rm" submit
2410: 74 65 72 20 74 61 72 67 2d 66 69 6c 65 20 63 6f ter targ-file co
2420: 6d 6d 65 6e 74 29 29 29 0a 3b 20 20 20 20 28 6c mment))).; (l
2430: 65 74 2a 20 28 28 74 68 31 20 20 20 20 20 20 20 et* ((th1
2440: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 3b (make-thread.;
2450: 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b ... (lambda ().;
2460: 09 09 09 20 20 20 28 64 65 6c 65 74 65 2d 66 69 ... (delete-fi
2470: 6c 65 20 74 61 72 67 2d 70 61 74 68 29 0a 3b 09 le targ-path).;.
2480: 09 09 20 20 20 28 70 72 69 6e 74 20 22 20 2e 2e .. (print " ..
2490: 2e 20 66 69 6c 65 20 22 20 74 61 72 67 2d 70 61 . file " targ-pa
24a0: 74 68 20 22 20 72 65 6d 6f 76 65 64 22 29 29 0a th " removed")).
24b0: 3b 09 09 09 20 22 72 6d 20 74 68 72 65 61 64 22 ;... "rm thread"
24c0: 29 29 0a 3b 09 20 20 20 28 74 68 32 20 20 20 20 )).;. (th2
24d0: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
24e0: 64 0a 3b 09 09 09 20 28 6c 61 6d 62 64 61 20 28 d.;... (lambda (
24f0: 29 0a 3b 09 09 09 20 20 20 28 6c 65 74 20 6c 6f ).;... (let lo
2500: 6f 70 20 28 29 0a 3b 09 09 09 20 20 20 20 20 28 op ().;... (
2510: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 35 thread-sleep! 15
2520: 29 0a 3b 09 09 09 20 20 20 20 20 28 64 69 73 70 ).;... (disp
2530: 6c 61 79 20 22 2e 22 29 0a 3b 09 09 09 20 20 20 lay ".").;...
2540: 20 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 74 29 (flush-output)
2550: 0a 3b 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 29 .;... (loop)
2560: 29 29 0a 3b 09 09 09 20 22 61 63 74 69 6f 6e 20 )).;... "action
2570: 69 73 20 68 61 70 70 65 6e 69 6e 67 20 74 68 72 is happening thr
2580: 65 61 64 22 29 29 29 0a 3b 20 20 20 20 20 20 28 ead"))).; (
2590: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
25a0: 31 29 0a 3b 20 20 20 20 20 20 28 74 68 72 65 61 1).; (threa
25b0: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 3b 20 d-start! th2).;
25c0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 (thread-joi
25d0: 6e 21 20 74 68 31 29 29 0a 3b 20 20 20 20 28 63 n! th1)).; (c
25e0: 6f 6e 73 20 23 74 20 22 53 75 63 63 65 73 73 66 ons #t "Successf
25f0: 75 6c 6c 79 20 73 61 76 65 64 20 64 61 74 61 22 ully saved data"
2600: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 )))..(define (sp
2610: 75 62 6c 69 73 68 3a 62 61 63 6b 75 70 2d 6d 6f ublish:backup-mo
2620: 76 65 20 70 61 74 68 29 0a 20 20 28 6c 65 74 2a ve path). (let*
2630: 20 28 28 74 72 61 73 68 64 69 72 20 20 28 63 6f ((trashdir (co
2640: 6e 63 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 nc (pathname-dir
2650: 65 63 74 6f 72 79 20 70 61 74 68 29 20 22 2f 2e ectory path) "/.
2660: 74 72 61 73 68 22 29 29 0a 09 20 28 74 72 61 73 trash")).. (tras
2670: 68 66 69 6c 65 20 28 63 6f 6e 63 20 74 72 61 73 hfile (conc tras
2680: 68 64 69 72 20 22 2f 22 20 28 63 75 72 72 65 6e hdir "/" (curren
2690: 74 2d 73 65 63 6f 6e 64 73 29 20 22 2d 22 20 28 t-seconds) "-" (
26a0: 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 70 61 pathname-file pa
26b0: 74 68 29 29 29 29 0a 20 20 20 20 28 63 72 65 61 th)))). (crea
26c0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 74 72 61 te-directory tra
26d0: 73 68 64 69 72 20 23 74 29 0a 20 20 20 20 28 69 shdir #t). (i
26e0: 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 f (directory? pa
26f0: 74 68 29 0a 09 28 73 79 73 74 65 6d 20 28 63 6f th)..(system (co
2700: 6e 63 20 22 6d 76 20 22 20 70 61 74 68 20 22 20 nc "mv " path "
2710: 22 20 74 72 61 73 68 66 69 6c 65 29 29 0a 09 28 " trashfile))..(
2720: 66 69 6c 65 2d 6d 6f 76 65 20 70 61 74 68 20 74 file-move path t
2730: 72 61 73 68 2d 66 69 6c 65 29 29 29 29 0a 0a 0a rash-file))))...
2740: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
2750: 68 3a 6c 73 74 2d 3e 70 61 74 68 20 70 61 74 68 h:lst->path path
2760: 6c 73 74 29 0a 20 20 28 63 6f 6e 63 20 22 2f 22 lst). (conc "/"
2770: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2780: 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 70 erse (map conc p
2790: 61 74 68 6c 73 74 29 20 22 2f 22 29 29 29 0a 0a athlst) "/")))..
27a0: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
27b0: 68 3a 70 61 74 68 2d 3e 6c 73 74 20 70 61 74 68 h:path->lst path
27c0: 29 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ). (string-spli
27d0: 74 20 70 61 74 68 20 22 2f 22 29 29 0a 0a 28 64 t path "/"))..(d
27e0: 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a efine (spublish:
27f0: 70 61 74 68 64 61 74 2d 61 70 70 6c 79 2d 68 65 pathdat-apply-he
2800: 75 72 69 73 74 69 63 73 20 63 6f 6e 66 69 67 64 uristics configd
2810: 61 74 20 70 61 74 68 29 0a 20 20 28 63 6f 6e 64 at path). (cond
2820: 0a 20 20 20 28 28 66 69 6c 65 2d 65 78 69 73 74 . ((file-exist
2830: 73 3f 20 70 61 74 68 29 20 22 66 6f 75 6e 64 22 s? path) "found"
2840: 29 0a 20 20 20 28 65 6c 73 65 20 28 63 6f 6e 63 ). (else (conc
2850: 20 70 61 74 68 20 22 20 6e 6f 74 20 69 6e 73 74 path " not inst
2860: 61 6c 6c 65 64 22 29 29 29 29 0a 0a 3b 3b 3d 3d alled"))))..;;==
2870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28b0: 3d 3d 3d 3d 0a 3b 3b 20 4d 49 53 43 0a 3b 3b 3d ====.;; MISC.;;=
28c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2900: 3d 3d 3d 3d 3d 0a 0a 3b 28 64 65 66 69 6e 65 20 =====..;(define
2910: 28 73 70 75 62 6c 69 73 68 3a 64 6f 2d 61 73 2d (spublish:do-as-
2920: 63 61 6c 6c 69 6e 67 2d 75 73 65 72 20 70 72 6f calling-user pro
2930: 63 29 0a 3b 20 20 28 6c 65 74 20 28 28 65 69 64 c).; (let ((eid
2940: 20 28 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 (current-effect
2950: 69 76 65 2d 75 73 65 72 2d 69 64 29 29 0a 3b 20 ive-user-id)).;
2960: 20 20 20 20 20 20 20 28 63 69 64 20 28 63 75 72 (cid (cur
2970: 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 29 0a rent-user-id))).
2980: 3b 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 ; (if (not (e
2990: 71 3f 20 65 69 64 20 63 69 64 29 29 20 3b 3b 20 q? eid cid)) ;;
29a0: 72 75 6e 6e 69 6e 67 20 73 75 69 64 0a 3b 20 20 running suid.;
29b0: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
29c0: 28 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 (current-effecti
29d0: 76 65 2d 75 73 65 72 2d 69 64 29 20 63 69 64 29 ve-user-id) cid)
29e0: 29 0a 3b 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ).; ;; (print
29f0: 20 22 72 75 6e 6e 69 6e 67 20 61 73 20 22 20 28 "running as " (
2a00: 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 current-effectiv
2a10: 65 2d 75 73 65 72 2d 69 64 29 29 0a 3b 20 20 20 e-user-id)).;
2a20: 20 28 70 72 6f 63 29 0a 3b 20 20 20 20 28 69 66 (proc).; (if
2a30: 20 28 6e 6f 74 20 28 65 71 3f 20 65 69 64 20 63 (not (eq? eid c
2a40: 69 64 29 29 0a 3b 20 20 20 20 20 20 20 20 28 73 id)).; (s
2a50: 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 66 66 et! (current-eff
2a60: 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 29 20 ective-user-id)
2a70: 65 69 64 29 29 29 29 0a 0a 3b 28 64 65 66 69 6e eid))))..;(defin
2a80: 65 20 28 73 70 75 62 6c 69 73 68 3a 66 69 6e 64 e (spublish:find
2a90: 20 6e 61 6d 65 20 70 61 74 68 73 29 0a 3b 20 20 name paths).;
2aa0: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 68 73 (if (null? paths
2ab0: 29 0a 3b 20 20 20 20 20 20 23 66 0a 3b 20 20 20 ).; #f.;
2ac0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
2ad0: 65 64 20 28 63 61 72 20 70 61 74 68 73 29 29 0a ed (car paths)).
2ae0: 3b 09 09 20 28 74 61 6c 20 28 63 64 72 20 70 61 ;.. (tal (cdr pa
2af0: 74 68 73 29 29 29 0a 3b 09 28 69 66 20 28 66 69 ths))).;.(if (fi
2b00: 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 le-exists? (conc
2b10: 20 68 65 64 20 22 2f 22 20 6e 61 6d 65 29 29 0a hed "/" name)).
2b20: 3b 09 20 20 20 20 68 65 64 0a 3b 09 20 20 20 20 ;. hed.;.
2b30: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
2b40: 3b 09 09 23 66 0a 3b 09 09 28 6c 6f 6f 70 20 28 ;..#f.;..(loop (
2b50: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
2b60: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
2b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bb0: 3d 3d 3d 0a 3b 3b 53 68 65 6c 6c 20 0a 3b 3b 3d ===.;;Shell .;;=
2bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c00: 3d 3d 3d 3d 3d 3d 3d 0a 28 64 65 66 69 6e 65 20 =======.(define
2c10: 28 73 70 75 62 6c 69 73 68 3a 67 65 74 2d 61 63 (spublish:get-ac
2c20: 63 65 73 73 61 62 6c 65 2d 70 72 6f 6a 65 63 74 cessable-project
2c30: 73 20 20 61 72 65 61 29 0a 20 20 20 28 6c 65 74 s area). (let
2c40: 2a 20 28 28 70 72 6f 6a 65 63 74 73 20 60 28 29 * ((projects `()
2c50: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
2c60: 69 66 20 28 73 70 75 62 6c 69 73 68 3a 68 61 73 if (spublish:has
2c70: 2d 70 65 72 6d 69 73 73 69 6f 6e 20 61 72 65 61 -permission area
2c80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2c90: 20 28 73 65 74 21 20 70 72 6f 6a 65 63 74 73 20 (set! projects
2ca0: 28 63 6f 6e 73 20 61 72 65 61 20 70 72 6f 6a 65 (cons area proje
2cb0: 63 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 cts)).
2cc0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
2ce0: 69 6e 74 20 22 55 73 65 72 20 63 61 6e 6e 6f 74 int "User cannot
2cf0: 20 61 63 63 65 73 73 20 61 72 65 61 20 22 20 61 access area " a
2d00: 72 65 61 20 22 21 21 22 29 20 20 0a 20 20 20 20 rea "!!") .
2d10: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
2d20: 74 20 31 29 29 29 20 0a 20 20 20 20 70 72 6f 6a t 1))) . proj
2d30: 65 63 74 73 29 29 0a 0a 3b 3b 20 66 75 6e 63 74 ects))..;; funct
2d40: 69 6f 6e 20 74 6f 20 66 69 6e 64 20 73 68 65 65 ion to find shee
2d50: 74 73 20 74 6f 20 77 68 69 63 68 20 75 73 65 20 ts to which use
2d60: 68 61 73 20 61 63 63 65 73 73 20 0a 28 64 65 66 has access .(def
2d70: 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 68 61 ine (spublish:ha
2d80: 73 2d 70 65 72 6d 69 73 73 69 6f 6e 20 20 61 72 s-permission ar
2d90: 65 61 29 0a 20 20 3b 28 70 72 69 6e 74 20 22 69 ea). ;(print "i
2da0: 6e 20 73 70 75 62 6c 69 73 68 3a 68 61 73 2d 70 n spublish:has-p
2db0: 65 72 6d 69 73 73 69 6f 6e 22 29 0a 20 20 28 6c ermission"). (l
2dc0: 65 74 2a 20 28 28 75 73 65 72 6e 61 6d 65 20 20 et* ((username
2dd0: 20 20 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 (current-user
2de0: 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -name)).
2df0: 28 72 65 74 2d 76 61 6c 20 23 66 29 29 0a 20 20 (ret-val #f)).
2e00: 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 75 61 6c (cond. ((equal
2e10: 3f 20 28 69 73 2d 61 64 6d 69 6e 20 75 73 65 72 ? (is-admin user
2e20: 6e 61 6d 65 29 20 23 74 29 0a 20 20 20 20 20 28 name) #t). (
2e30: 73 65 74 21 20 72 65 74 2d 76 61 6c 20 23 74 29 set! ret-val #t)
2e40: 29 0a 20 20 20 20 28 28 65 71 75 61 6c 3f 20 28 ). ((equal? (
2e50: 69 73 2d 75 73 65 72 20 22 70 75 62 6c 69 73 68 is-user "publish
2e60: 22 20 75 73 65 72 6e 61 6d 65 20 61 72 65 61 29 " username area)
2e70: 20 23 74 29 0a 20 20 20 20 20 28 73 65 74 21 20 #t). (set!
2e80: 72 65 74 2d 76 61 6c 20 23 74 29 29 0a 20 20 20 ret-val #t)).
2e90: 28 28 65 71 75 61 6c 3f 20 28 69 73 2d 75 73 65 ((equal? (is-use
2ea0: 72 20 22 77 72 69 74 65 72 2d 61 64 6d 69 6e 22 r "writer-admin"
2eb0: 20 75 73 65 72 6e 61 6d 65 20 61 72 65 61 29 20 username area)
2ec0: 23 74 29 20 0a 20 20 20 20 20 28 73 65 74 21 20 #t) . (set!
2ed0: 72 65 74 2d 76 61 6c 20 23 74 29 29 0a 0a 20 20 ret-val #t))..
2ee0: 20 28 28 65 71 75 61 6c 3f 20 28 69 73 2d 75 73 ((equal? (is-us
2ef0: 65 72 20 22 61 72 65 61 2d 61 64 6d 69 6e 22 20 er "area-admin"
2f00: 75 73 65 72 6e 61 6d 65 20 61 72 65 61 29 20 23 username area) #
2f10: 74 29 20 0a 20 20 20 20 20 28 73 65 74 21 20 72 t) . (set! r
2f20: 65 74 2d 76 61 6c 20 23 74 29 29 0a 20 20 20 28 et-val #t)). (
2f30: 65 6c 73 65 20 20 0a 20 20 20 20 28 73 65 74 21 else . (set!
2f40: 20 72 65 74 2d 76 61 6c 20 23 66 29 29 29 0a 20 ret-val #f))).
2f50: 20 20 20 20 20 20 72 65 74 2d 76 61 6c 29 29 0a ret-val)).
2f60: 0a 28 64 65 66 69 6e 65 20 28 69 73 5f 64 69 72 .(define (is_dir
2f70: 65 63 74 6f 72 79 20 74 61 72 67 65 74 2d 70 61 ectory target-pa
2f80: 74 68 29 20 0a 20 20 28 6c 65 74 2a 20 28 28 72 th) . (let* ((r
2f90: 65 74 76 61 6c 20 23 66 29 29 0a 20 20 28 73 61 etval #f)). (sa
2fa0: 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 uthorize:do-as-c
2fb0: 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 alling-user.
2fc0: 09 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 .(lambda ().
2fd0: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 ;(print (c
2fe0: 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 urrent-effective
2ff0: 2d 75 73 65 72 2d 69 64 29 20 29 20 0a 20 20 20 -user-id) ) .
3000: 20 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 (if (dire
3010: 63 74 6f 72 79 3f 20 74 61 72 67 65 74 2d 70 61 ctory? target-pa
3020: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
3030: 20 20 20 28 73 65 74 21 20 72 65 74 76 61 6c 20 (set! retval
3040: 20 23 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 #t)))).
3050: 20 20 20 20 20 3b 28 70 72 69 6e 74 20 28 63 75 ;(print (cu
3060: 72 72 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d rrent-effective-
3070: 75 73 65 72 2d 69 64 29 29 0a 20 20 20 20 20 72 user-id)). r
3080: 65 74 76 61 6c 29 29 20 0a 0a 3b 3b 3b 3b 3b 3b etval)) ..;;;;;;
3090: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
30a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
30b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
30c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b ;;;;;;;;;;;;;;.;
30d0: 3b 20 73 68 65 6c 6c 20 66 75 6e 63 74 69 6f 6e ; shell function
30e0: 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b s.;;;;;;;;;;;;;;
30f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3100: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3110: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3120: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 28 64 65 66 69 6e ;;;;;;;;;.(defin
3130: 65 20 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c e (spublish:shel
3140: 6c 2d 63 70 20 73 72 63 2d 70 61 74 68 20 74 61 l-cp src-path ta
3150: 72 67 65 74 2d 70 61 74 68 29 20 20 0a 20 20 28 rget-path) . (
3160: 63 6f 6e 64 0a 20 20 20 28 28 6e 6f 74 20 28 66 cond. ((not (f
3170: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
3180: 65 74 2d 70 61 74 68 29 29 0a 09 28 73 61 75 74 et-path))..(saut
3190: 68 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 28 63 h:print-error (c
31a0: 6f 6e 63 20 22 20 74 61 72 67 65 74 20 44 69 72 onc " target Dir
31b0: 65 63 74 6f 72 79 20 22 20 74 61 72 67 65 74 2d ectory " target-
31c0: 70 61 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 path " does not
31d0: 65 78 69 73 74 21 21 22 29 29 29 0a 20 20 20 28 exist!!"))). (
31e0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
31f0: 73 3f 20 73 72 63 2d 70 61 74 68 29 29 0a 20 20 s? src-path)).
3200: 20 20 28 73 61 75 74 68 3a 70 72 69 6e 74 2d 65 (sauth:print-e
3210: 72 72 6f 72 20 28 63 6f 6e 63 20 22 53 6f 75 72 rror (conc "Sour
3220: 63 65 20 70 61 74 68 20 22 20 73 72 63 2d 70 61 ce path " src-pa
3230: 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 th " does not ex
3240: 69 73 74 21 21 22 20 29 29 29 0a 20 20 20 28 65 ist!!" ))). (e
3250: 6c 73 65 0a 20 20 20 20 20 28 69 66 20 28 3c 20 lse. (if (<
3260: 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 70 (sauth-common:sp
3270: 61 63 65 2d 6c 65 66 74 2d 61 74 2d 64 65 73 74 ace-left-at-dest
3280: 20 74 61 72 67 65 74 2d 70 61 74 68 29 20 28 73 target-path) (s
3290: 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 73 72 63 2d auth-common:src-
32a0: 73 69 7a 65 20 73 72 63 2d 70 61 74 68 29 29 0a size src-path)).
32b0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
32c0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
32d0: 73 61 75 74 68 3a 70 72 69 6e 74 2d 65 72 72 6f sauth:print-erro
32e0: 72 20 22 44 65 73 74 69 6e 61 74 69 6f 6e 20 64 r "Destination d
32f0: 6f 65 73 20 6e 6f 74 20 68 61 76 65 20 65 6e 6f oes not have eno
3300: 75 67 68 20 64 69 73 6b 20 73 70 61 63 65 2e 22 ugh disk space."
3310: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
3320: 65 78 69 74 20 31 29 29 29 20 20 20 20 0a 20 20 exit 1))) .
3330: 20 20 20 28 69 66 20 28 69 73 5f 64 69 72 65 63 (if (is_direc
3340: 74 6f 72 79 20 73 72 63 2d 70 61 74 68 29 20 0a tory src-path) .
3350: 09 20 28 62 65 67 69 6e 0a 09 20 20 20 28 6c 65 . (begin.. (le
3360: 74 2a 20 28 28 70 61 72 65 6e 74 2d 64 69 72 20 t* ((parent-dir
3370: 73 72 63 2d 70 61 74 68 29 0a 09 09 20 20 28 73 src-path)... (s
3380: 74 61 72 74 2d 64 69 72 20 74 61 72 67 65 74 2d tart-dir target-
3390: 70 61 74 68 29 29 0a 09 20 20 20 20 20 28 72 75 path)).. (ru
33a0: 6e 20 28 70 69 70 65 0a 09 09 20 20 20 28 62 65 n (pipe... (be
33b0: 67 69 6e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e gin (system (con
33c0: 63 20 22 63 64 20 22 20 70 61 72 65 6e 74 2d 64 c "cd " parent-d
33d0: 69 72 20 22 20 3b 74 61 72 20 63 68 66 20 2d 20 ir " ;tar chf -
33e0: 2e 22 20 29 29 29 0a 09 09 20 20 20 28 62 65 67 ." )))... (beg
33f0: 69 6e 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 in (change-direc
3400: 74 6f 72 79 20 73 74 61 72 74 2d 64 69 72 29 0a tory start-dir).
3410: 09 09 09 09 09 3b 28 70 72 69 6e 74 20 22 31 32 .....;(print "12
3420: 33 22 29 0a 09 09 09 20 20 28 72 75 6e 2d 63 6d 3").... (run-cm
3430: 64 20 22 74 61 72 22 20 28 6c 69 73 74 20 22 78 d "tar" (list "x
3440: 66 22 20 22 2d 22 29 29 29 29 29 0a 09 20 20 20 f" "-")))))..
3450: 20 20 28 70 72 69 6e 74 20 22 43 6f 70 69 65 64 (print "Copied
3460: 20 64 61 74 61 20 74 6f 20 22 20 73 74 61 72 74 data to " start
3470: 2d 64 69 72 29 29 29 20 0a 20 20 20 20 20 20 20 -dir))) .
3480: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
3490: 20 20 20 28 6c 65 74 2a 28 28 70 61 72 65 6e 74 (let*((parent
34a0: 2d 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 -dir (pathname-d
34b0: 69 72 65 63 74 6f 72 79 20 73 72 63 2d 70 61 74 irectory src-pat
34c0: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
34d0: 20 20 20 20 20 20 28 73 74 61 72 74 2d 64 69 72 (start-dir
34e0: 20 74 61 72 67 65 74 2d 70 61 74 68 29 0a 20 20 target-path).
34f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
3500: 69 6c 65 6e 61 6d 65 20 28 69 66 20 20 28 70 61 ilename (if (pa
3510: 74 68 6e 61 6d 65 2d 65 78 74 65 6e 73 69 6f 6e thname-extension
3520: 20 73 72 63 2d 70 61 74 68 29 20 20 0a 20 20 20 src-path) .
3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3550: 20 20 20 28 63 6f 6e 63 28 70 61 74 68 6e 61 6d (conc(pathnam
3560: 65 2d 66 69 6c 65 20 73 72 63 2d 70 61 74 68 29 e-file src-path)
3570: 20 22 2e 22 20 28 70 61 74 68 6e 61 6d 65 2d 65 "." (pathname-e
3580: 78 74 65 6e 73 69 6f 6e 20 73 72 63 2d 70 61 74 xtension src-pat
3590: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
35a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35b0: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e (pathn
35c0: 61 6d 65 2d 66 69 6c 65 20 73 72 63 2d 70 61 74 ame-file src-pat
35d0: 68 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 h)))).
35e0: 20 20 20 20 20 20 3b 28 70 72 69 6e 74 20 22 70 ;(print "p
35f0: 61 72 65 6e 74 2d 64 69 72 20 22 20 70 61 72 65 arent-dir " pare
3600: 6e 74 2d 64 69 72 20 22 20 73 74 61 72 74 2d 64 nt-dir " start-d
3610: 69 72 20 22 20 73 74 61 72 74 2d 64 69 72 29 20 ir " start-dir)
3620: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3630: 20 20 20 20 28 72 75 6e 20 28 70 69 70 65 0a 20 (run (pipe.
3640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3650: 20 20 28 62 65 67 69 6e 20 28 73 79 73 74 65 6d (begin (system
3660: 20 28 63 6f 6e 63 20 22 63 64 20 22 20 70 61 72 (conc "cd " par
3670: 65 6e 74 2d 64 69 72 20 22 3b 74 61 72 20 63 68 ent-dir ";tar ch
3680: 66 20 2d 20 22 20 66 69 6c 65 6e 61 6d 65 20 29 f - " filename )
3690: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
36a0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 63 68 (begin (ch
36b0: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 73 ange-directory s
36c0: 74 61 72 74 2d 64 69 72 29 0a 20 20 20 20 20 20 tart-dir).
36d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36e0: 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 22 74 61 (run-cmd "ta
36f0: 72 22 20 28 6c 69 73 74 20 22 78 66 22 20 22 2d r" (list "xf" "-
3700: 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 "))))).
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3720: 20 28 70 72 69 6e 74 20 22 43 6f 70 69 65 64 20 (print "Copied
3730: 64 61 74 61 20 74 6f 20 22 20 73 74 61 72 74 2d data to " start-
3740: 64 69 72 29 29 29 29 29 29 29 0a 0a 0a 28 64 65 dir)))))))...(de
3750: 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 73 fine (spublish:s
3760: 68 65 6c 6c 2d 6d 6b 64 69 72 20 74 61 72 67 2d hell-mkdir targ-
3770: 70 61 74 68 29 0a 20 20 20 20 28 69 66 20 28 66 path). (if (f
3780: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 61 72 67 ile-exists? targ
3790: 2d 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 -path)..(begin..
37a0: 20 20 28 70 72 69 6e 74 20 22 49 6e 66 6f 3a 20 (print "Info:
37b0: 54 61 72 67 65 74 20 44 69 72 65 63 74 6f 72 79 Target Directory
37c0: 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 20 61 " targ-path " a
37d0: 6c 72 65 61 64 79 20 65 78 69 73 74 21 21 22 29 lready exist!!")
37e0: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ). (let*
37f0: 28 28 74 68 31 20 20 20 20 20 20 20 20 20 28 6d ((th1 (m
3800: 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 28 ake-thread.... (
3810: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
3820: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
3830: 79 20 74 61 72 67 2d 70 61 74 68 20 23 74 29 0a y targ-path #t).
3840: 09 09 09 20 20 20 28 70 72 69 6e 74 20 22 20 2e ... (print " .
3850: 2e 2e 20 64 69 72 20 22 20 74 61 72 67 2d 70 61 .. dir " targ-pa
3860: 74 68 20 22 20 63 72 65 61 74 65 64 22 29 29 0a th " created")).
3870: 09 09 09 20 22 6d 6b 64 69 72 20 74 68 72 65 61 ... "mkdir threa
3880: 64 22 29 29 0a 09 20 20 20 28 74 68 32 20 20 20 d")).. (th2
3890: 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 (make-thre
38a0: 61 64 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ad.... (lambda (
38b0: 29 0a 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f ).... (let loo
38c0: 70 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 p ().... (th
38d0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 35 29 0a read-sleep! 15).
38e0: 09 09 09 20 20 20 20 20 28 64 69 73 70 6c 61 79 ... (display
38f0: 20 22 2e 22 29 0a 09 09 09 20 20 20 20 20 28 66 ".").... (f
3900: 6c 75 73 68 2d 6f 75 74 70 75 74 29 0a 09 09 09 lush-output)....
3910: 20 20 20 20 20 28 6c 6f 6f 70 29 29 29 0a 09 09 (loop)))...
3920: 09 20 22 61 63 74 69 6f 6e 20 69 73 20 68 61 70 . "action is hap
3930: 70 65 6e 69 6e 67 20 74 68 72 65 61 64 22 29 29 pening thread"))
3940: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
3950: 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 start! th1).
3960: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
3970: 20 74 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 th2). (thr
3980: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 ead-join! th1).
3990: 20 20 20 28 63 6f 6e 73 20 23 74 20 22 53 75 63 (cons #t "Suc
39a0: 63 65 73 73 66 75 6c 6c 79 20 73 61 76 65 64 20 cessfully saved
39b0: 64 61 74 61 22 29 29 29 29 0a 20 0a 0a 28 64 65 data")))). ..(de
39c0: 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 73 fine (spublish:s
39d0: 68 65 6c 6c 2d 72 6d 20 74 61 72 67 2d 70 61 74 hell-rm targ-pat
39e0: 68 20 69 70 6f 72 74 29 0a 20 20 20 20 28 69 66 h iport). (if
39f0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3a00: 74 73 3f 20 74 61 72 67 2d 70 61 74 68 29 29 0a ts? targ-path)).
3a10: 09 28 62 65 67 69 6e 0a 09 20 20 28 73 61 75 74 .(begin.. (saut
3a20: 68 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 28 63 h:print-error (c
3a30: 6f 6e 63 20 22 74 61 72 67 65 74 20 70 61 74 68 onc "target path
3a40: 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 20 64 " targ-path " d
3a50: 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 21 21 22 oes not exist!!"
3a60: 29 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 ))). (beg
3a70: 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 in . (
3a80: 70 72 69 6e 74 20 22 41 72 65 20 79 6f 75 20 73 print "Are you s
3a90: 75 72 65 20 79 6f 75 20 77 61 6e 74 20 74 6f 20 ure you want to
3aa0: 64 65 6c 65 74 65 20 22 20 74 61 72 67 2d 70 61 delete " targ-pa
3ab0: 74 68 20 22 3f 5b 79 2f 6e 5d 22 29 20 0a 20 20 th "?[y/n]") .
3ac0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
3ad0: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
3ae0: 20 69 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 iport))).
3af0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 (if (e
3b00: 71 75 61 6c 3f 20 69 6e 6c 20 22 79 22 29 0a 09 qual? inl "y")..
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
3b20: 74 2a 20 28 28 74 68 31 20 20 20 20 20 20 20 20 t* ((th1
3b30: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 (make-thread...
3b40: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 . (lambda ()
3b50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b70: 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c (if (symbolic-l
3b80: 69 6e 6b 3f 20 74 61 72 67 2d 70 61 74 68 29 0a ink? targ-path).
3b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bb0: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 20 (delete-file
3bc0: 74 61 72 67 2d 70 61 74 68 20 29 20 20 0a 20 20 targ-path ) .
3bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bf0: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
3c00: 74 61 72 67 2d 70 61 74 68 29 0a 20 20 20 20 20 targ-path).
3c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3c30: 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 delete-directory
3c40: 20 74 61 72 67 2d 70 61 74 68 20 23 74 29 20 20 targ-path #t)
3c50: 20 20 20 0a 09 09 09 20 20 20 20 20 20 20 20 20 ....
3c60: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 (delete-file
3c70: 20 74 61 72 67 2d 70 61 74 68 20 29 29 29 0a 09 targ-path )))..
3c80: 09 09 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 .. (print
3c90: 20 22 20 2e 2e 2e 20 70 61 74 68 20 22 20 74 61 " ... path " ta
3ca0: 72 67 2d 70 61 74 68 20 22 20 64 65 6c 65 74 65 rg-path " delete
3cb0: 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 20 d"))....
3cc0: 22 72 6d 20 74 68 72 65 61 64 22 29 29 0a 09 20 "rm thread"))..
3cd0: 20 20 09 09 20 20 20 20 28 74 68 32 20 20 20 20 .. (th2
3ce0: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
3cf0: 64 0a 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 d.... (lamb
3d00: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 20 da ()....
3d10: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 (let loop ()..
3d20: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 28 74 .. (t
3d30: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 35 29 hread-sleep! 15)
3d40: 0a 09 09 09 20 20 20 20 20 20 20 20 20 20 20 20 ....
3d50: 28 64 69 73 70 6c 61 79 20 22 2e 22 29 0a 09 09 (display ".")...
3d60: 09 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6c . (fl
3d70: 75 73 68 2d 6f 75 74 70 75 74 29 0a 09 09 09 20 ush-output)....
3d80: 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop
3d90: 29 29 29 0a 09 09 09 20 22 61 63 74 69 6f 6e 20 ))).... "action
3da0: 69 73 20 68 61 70 70 65 6e 69 6e 67 20 74 68 72 is happening thr
3db0: 65 61 64 22 29 29 29 0a 20 20 20 20 20 20 09 09 ead"))). ..
3dc0: 09 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 .(thread-start!
3dd0: 74 68 31 29 0a 20 20 20 20 20 20 09 09 09 28 74 th1). ...(t
3de0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
3df0: 29 0a 20 20 20 20 20 20 09 09 09 28 74 68 72 65 ). ...(thre
3e00: 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 ad-join! th1).
3e10: 20 20 09 09 09 28 63 6f 6e 73 20 23 74 20 22 53 ...(cons #t "S
3e20: 75 63 63 65 73 73 66 75 6c 6c 79 20 73 61 76 65 uccessfully save
3e30: 64 20 64 61 74 61 22 29 29 29 29 29 29 29 0a 0a d data")))))))..
3e40: 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 (define (spublis
3e50: 68 3a 73 68 65 6c 6c 2d 6c 6e 20 73 72 63 2d 70 h:shell-ln src-p
3e60: 61 74 68 20 74 61 72 67 65 74 2d 70 61 74 68 20 ath target-path
3e70: 73 75 62 2d 70 61 74 68 29 0a 20 20 20 28 69 66 sub-path). (if
3e80: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
3e90: 74 73 3f 20 73 75 62 2d 70 61 74 68 29 29 0a 09 ts? sub-path))..
3ea0: 20 28 73 61 75 74 68 3a 70 72 69 6e 74 2d 65 72 (sauth:print-er
3eb0: 72 6f 72 20 28 63 6f 6e 63 20 22 50 61 74 68 20 ror (conc "Path
3ec0: 22 20 73 75 62 2d 70 61 74 68 20 22 20 64 6f 65 " sub-path " doe
3ed0: 73 20 6e 6f 74 20 65 78 69 73 74 21 21 20 63 61 s not exist!! ca
3ee0: 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 77 69 74 nnot proceed wit
3ef0: 68 20 6c 69 6e 6b 20 63 72 65 61 74 69 6f 6e 21 h link creation!
3f00: 21 22 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 !")). (be
3f10: 67 69 6e 20 20 0a 20 20 20 20 20 20 20 20 20 20 gin .
3f20: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 (if (not (file-e
3f30: 78 69 73 74 73 3f 20 73 72 63 2d 70 61 74 68 29 xists? src-path)
3f40: 29 0a 20 20 09 20 20 20 20 28 73 61 75 74 68 3a ). . (sauth:
3f50: 70 72 69 6e 74 2d 65 72 72 6f 72 20 28 63 6f 6e print-error (con
3f60: 63 20 22 50 61 74 68 20 22 20 73 72 63 2d 70 61 c "Path " src-pa
3f70: 74 68 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 th " does not ex
3f80: 69 73 74 21 21 20 63 61 6e 6e 6f 74 20 70 72 6f ist!! cannot pro
3f90: 63 65 65 64 20 77 69 74 68 20 6c 69 6e 6b 20 63 ceed with link c
3fa0: 72 65 61 74 69 6f 6e 21 21 22 29 29 0a 20 20 20 reation!!")).
3fb0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
3fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fd0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
3fe0: 3f 20 74 61 72 67 65 74 2d 70 61 74 68 29 0a 20 ? target-path).
3ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4000: 20 20 28 73 61 75 74 68 3a 70 72 69 6e 74 2d 65 (sauth:print-e
4010: 72 72 6f 72 20 28 63 6f 6e 63 20 22 50 61 74 68 rror (conc "Path
4020: 20 22 20 74 61 72 67 65 74 2d 70 61 74 68 20 22 " target-path "
4030: 61 6c 72 65 61 64 79 20 65 78 69 73 74 21 21 20 already exist!!
4040: 63 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 77 cannot proceed w
4050: 69 74 68 20 6c 69 6e 6b 20 63 72 65 61 74 69 6f ith link creatio
4060: 6e 21 21 22 29 29 0a 20 20 20 20 20 20 20 20 20 n!!")).
4070: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
4080: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4090: 20 20 20 20 20 20 20 20 28 63 72 65 61 74 65 2d (create-
40a0: 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 73 72 symbolic-link sr
40b0: 63 2d 70 61 74 68 20 74 61 72 67 65 74 2d 70 61 c-path target-pa
40c0: 74 68 20 20 29 0a 09 09 09 20 20 20 28 70 72 69 th ).... (pri
40d0: 6e 74 20 22 20 2e 2e 2e 20 6c 69 6e 6b 20 22 20 nt " ... link "
40e0: 74 61 72 67 65 74 2d 70 61 74 68 20 22 20 63 72 target-path " cr
40f0: 65 61 74 65 64 22 29 29 29 29 29 29 29 29 0a 20 eated")))))))).
4100: 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 .(define (spubli
4110: 73 68 3a 73 68 65 6c 6c 2d 68 65 6c 70 29 0a 28 sh:shell-help).(
4120: 63 6f 6e 63 20 22 55 73 61 67 65 3a 20 5b 61 63 conc "Usage: [ac
4130: 74 69 6f 6e 20 5b 70 61 72 61 6d 73 20 2e 2e 2e tion [params ...
4140: 5d 5d 0a 0a 20 20 6c 73 20 20 20 20 5b 74 61 72 ]].. ls [tar
4150: 67 65 74 20 70 61 74 68 5d 20 20 20 20 20 20 20 get path]
4160: 20 20 20 20 20 20 20 20 09 20 20 3a 20 6c 69 73 . : lis
4170: 74 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 74 61 t contents of ta
4180: 72 67 65 74 20 61 72 65 61 2e 0a 20 20 63 64 20 rget area.. cd
4190: 20 20 20 3c 74 61 72 67 65 74 20 70 61 74 68 3e <target path>
41a0: 20 09 20 20 20 20 20 09 20 20 20 20 20 20 20 20 . .
41b0: 20 20 3a 20 54 6f 20 63 68 61 6e 67 65 20 74 68 : To change th
41c0: 65 20 63 75 72 72 65 6e 74 20 64 69 72 65 63 74 e current direct
41d0: 6f 72 79 20 77 69 74 68 69 6e 20 74 68 65 20 73 ory within the s
41e0: 72 65 74 72 69 76 65 20 73 68 65 6c 6c 2e 20 0a retrive shell. .
41f0: 20 20 70 77 64 09 09 09 09 20 20 20 20 20 09 20 pwd.... .
4200: 20 3a 20 50 72 69 6e 74 73 20 74 68 65 20 66 75 : Prints the fu
4210: 6c 6c 20 70 61 74 68 6e 61 6d 65 20 6f 66 20 74 ll pathname of t
4220: 68 65 20 63 75 72 72 65 6e 74 20 64 69 72 65 63 he current direc
4230: 74 6f 72 79 20 77 69 74 68 69 6e 20 74 68 65 20 tory within the
4240: 73 72 65 74 72 69 76 65 20 73 68 65 6c 6c 2e 0a sretrive shell..
4250: 20 20 6d 6b 64 69 72 20 3c 70 61 74 68 3e 20 20 mkdir <path>
4260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4270: 20 20 20 20 20 20 20 20 20 20 3a 20 63 72 65 61 : crea
4280: 74 65 73 20 64 69 72 65 63 74 6f 72 79 2e 20 4e tes directory. N
4290: 6f 74 65 20 69 74 20 64 6f 65 73 20 6e 6f 74 20 ote it does not
42a0: 63 72 65 61 74 65 27 73 20 61 20 70 61 74 68 20 create's a path
42b0: 72 65 63 75 72 73 69 76 65 20 6d 61 6e 6e 65 72 recursive manner
42c0: 2e 0a 20 20 72 6d 20 3c 74 61 72 67 65 74 20 70 .. rm <target p
42d0: 61 74 68 3e 20 20 20 20 20 20 20 20 20 20 20 20 ath>
42e0: 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 72 65 : re
42f0: 6d 6f 76 65 73 20 66 69 6c 65 73 20 61 6e 64 20 moves files and
4300: 65 6d 6f 74 79 20 64 69 72 65 63 74 6f 72 69 65 emoty directorie
4310: 73 20 20 20 0a 20 20 63 70 20 3c 73 72 63 3e 20 s . cp <src>
4320: 3c 74 61 72 67 65 74 20 70 61 74 68 3e 20 20 20 <target path>
4330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a :
4340: 20 63 6f 70 79 20 61 20 66 69 6c 65 2f 64 69 72 copy a file/dir
4350: 20 74 6f 20 74 61 72 67 65 74 20 70 61 74 68 2e to target path.
4360: 20 69 66 20 73 72 63 20 69 73 20 61 20 64 69 72 if src is a dir
4370: 20 69 74 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c it automaticall
4380: 79 20 6d 61 6b 65 73 20 61 20 72 65 63 75 72 73 y makes a recurs
4390: 69 76 65 20 63 6f 70 79 2e 0a 20 20 6c 6e 20 54 ive copy.. ln T
43a0: 41 52 47 45 54 20 4c 49 4e 4b 5f 4e 41 4d 45 20 ARGET LINK_NAME
43b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43c0: 20 20 20 20 3a 20 63 72 65 61 74 65 73 20 61 20 : creates a
43d0: 73 79 6d 6c 69 6e 6b 20 20 20 20 20 20 0a 50 61 symlink .Pa
43e0: 72 74 20 6f 66 20 74 68 65 20 4d 65 67 61 74 65 rt of the Megate
43f0: 73 74 20 74 6f 6f 6c 20 73 75 69 74 65 2e 0a 4c st tool suite..L
4400: 65 61 72 6e 20 6d 6f 72 65 20 61 74 20 68 74 74 earn more at htt
4410: 70 3a 2f 2f 77 77 77 2e 6b 69 61 74 6f 61 2e 63 p://www.kiatoa.c
4420: 6f 6d 2f 66 6f 73 73 69 6c 73 2f 6d 65 67 61 74 om/fossils/megat
4430: 65 73 74 0a 0a 56 65 72 73 69 6f 6e 3a 20 22 20 est..Version: "
4440: 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d megatest-fossil-
4450: 68 61 73 68 29 0a 29 09 0a 0a 28 64 65 66 69 6e hash).)...(defin
4460: 65 20 28 74 6f 70 6c 65 76 65 6c 2d 63 6f 6d 6d e (toplevel-comm
4470: 61 6e 64 20 2e 20 61 72 67 73 29 20 23 66 29 0a and . args) #f).
4480: 0a 28 64 65 66 69 6e 65 20 28 73 70 75 62 6c 69 .(define (spubli
4490: 73 68 3a 73 68 65 6c 6c 20 61 72 65 61 29 0a 20 sh:shell area).
44a0: 3b 20 28 70 72 69 6e 74 20 61 72 65 61 29 0a 20 ; (print area).
44b0: 20 28 75 73 65 20 72 65 61 64 6c 69 6e 65 29 0a (use readline).
44c0: 0a 20 20 28 6c 65 74 2a 20 28 28 70 61 74 68 20 . (let* ((path
44d0: 20 20 20 20 20 27 28 29 29 0a 09 20 28 70 72 6f '()).. (pro
44e0: 6d 70 74 20 20 20 20 22 73 70 75 62 6c 69 73 68 mpt "spublish
44f0: 3e 20 22 29 0a 09 20 28 61 72 67 73 20 20 20 20 > ").. (args
4500: 20 20 28 61 72 67 76 29 29 0a 20 20 20 20 20 20 (argv)).
4510: 20 20 20 28 75 73 72 20 28 63 75 72 72 65 6e 74 (usr (current
4520: 2d 75 73 65 72 2d 6e 61 6d 65 29 20 29 20 20 20 -user-name) )
4530: 0a 20 20 20 20 20 20 20 20 20 28 74 6f 70 2d 61 . (top-a
4540: 72 65 61 73 20 28 73 70 75 62 6c 69 73 68 3a 67 reas (spublish:g
4550: 65 74 2d 61 63 63 65 73 73 61 62 6c 65 2d 70 72 et-accessable-pr
4560: 6f 6a 65 63 74 73 20 61 72 65 61 29 29 0a 20 20 ojects area)).
4570: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 70 6f (close-po
4580: 72 74 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 rt #f).
4590: 20 20 20 20 28 61 72 65 61 2d 6f 62 6a 20 20 28 (area-obj (
45a0: 67 65 74 2d 6f 62 6a 2d 62 79 2d 63 6f 64 65 20 get-obj-by-code
45b0: 61 72 65 61 29 29 0a 20 20 20 20 20 20 20 20 20 area)).
45c0: 28 75 73 65 72 2d 6f 62 6a 20 28 67 65 74 2d 75 (user-obj (get-u
45d0: 73 65 72 20 75 73 72 29 29 20 0a 20 20 20 20 20 ser usr)) .
45e0: 20 20 20 20 28 62 61 73 65 2d 70 61 74 68 20 28 (base-path (
45f0: 69 66 20 28 6e 75 6c 6c 3f 20 61 72 65 61 2d 6f if (null? area-o
4600: 62 6a 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 bj) .
4610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 22 ""
4620: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4630: 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 72 (caddr
4640: 20 28 63 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 (cdr area-obj))
4650: 29 29 20 20 20 20 20 20 0a 09 20 28 69 70 6f 72 )) .. (ipor
4660: 74 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 61 64 t (make-read
4670: 6c 69 6e 65 2d 70 6f 72 74 20 70 72 6f 6d 70 74 line-port prompt
4680: 29 29 29 0a 20 20 20 20 20 20 20 20 3b 28 70 72 ))). ;(pr
4690: 69 6e 74 20 62 61 73 65 2d 70 61 74 68 29 20 0a int base-path) .
46a0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c (if (nul
46b0: 6c 3f 20 61 72 65 61 2d 6f 62 6a 29 0a 20 20 20 l? area-obj).
46c0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
46d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
46e0: 6e 74 20 22 41 72 65 61 20 22 20 61 72 65 61 20 nt "Area " area
46f0: 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 " does not exist
4700: 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 78 "). (ex
4710: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 it 1))).
4720: 3b 20 28 70 72 69 6e 74 20 22 68 65 72 65 22 29 ; (print "here")
4730: 20 20 20 20 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 ..(let loop
4740: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
4750: 20 69 70 6f 72 74 29 29 29 0a 09 20 20 28 69 66 iport))).. (if
4760: 20 28 6e 6f 74 20 28 6f 72 20 28 6f 72 20 28 65 (not (or (or (e
4770: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
4780: 09 09 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f .. (equal?
4790: 20 69 6e 6c 20 22 65 78 69 74 22 29 29 20 28 70 inl "exit")) (p
47a0: 6f 72 74 2d 63 6c 6f 73 65 64 3f 20 69 70 6f 72 ort-closed? ipor
47b0: 74 29 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 t))).. (let
47c0: 2a 20 28 28 70 61 72 74 73 20 28 73 74 72 69 6e * ((parts (strin
47d0: 67 2d 73 70 6c 69 74 20 69 6e 6c 29 29 0a 09 09 g-split inl))...
47e0: 20 20 20 20 20 28 63 6d 64 20 20 20 28 69 66 20 (cmd (if
47f0: 28 6e 75 6c 6c 3f 20 70 61 72 74 73 29 20 23 66 (null? parts) #f
4800: 20 28 63 61 72 20 70 61 72 74 73 29 29 29 29 0a (car parts)))).
4810: 09 09 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 ..(if (and (not
4820: 63 6d 64 29 20 28 6e 6f 74 20 28 70 6f 72 74 2d cmd) (not (port-
4830: 63 6c 6f 73 65 64 3f 20 69 70 6f 72 74 29 29 29 closed? iport)))
4840: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 ... (loop (re
4850: 61 64 2d 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 ad-line))...
4860: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
4870: 79 6d 62 6f 6c 20 63 6d 64 29 0a 09 09 20 20 20 ymbol cmd)...
4880: 20 20 20 28 28 63 64 29 0a 09 09 20 20 20 20 20 ((cd)...
4890: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
48a0: 20 70 61 72 74 73 29 20 31 29 20 3b 3b 20 68 61 parts) 1) ;; ha
48b0: 76 65 20 61 20 70 61 72 61 6d 65 74 65 72 0a 20 ve a parameter.
48c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48d0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
48e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
4900: 65 74 2a 28 28 61 72 67 20 28 63 61 64 72 20 70 et*((arg (cadr p
4910: 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 arts)).
4920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4930: 20 20 20 20 20 20 20 20 20 20 28 72 65 73 6f 6c (resol
4940: 76 65 64 2d 70 61 74 68 20 28 73 61 75 74 68 2d ved-path (sauth-
4950: 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d 70 common:resolve-p
4960: 61 74 68 20 20 61 72 67 20 70 61 74 68 20 74 6f ath arg path to
4970: 70 2d 61 72 65 61 73 29 29 0a 20 20 20 20 20 20 p-areas)).
4980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4990: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
49a0: 72 67 65 74 2d 70 61 74 68 20 28 73 61 75 74 68 rget-path (sauth
49b0: 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 -common:get-targ
49c0: 65 74 2d 70 61 74 68 20 70 61 74 68 20 20 61 72 et-path path ar
49d0: 67 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 g top-areas base
49e0: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 -path))).
49f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a00: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
4a10: 6f 74 20 28 65 71 75 61 6c 3f 20 74 61 72 67 65 ot (equal? targe
4a20: 74 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 t-path #f)).
4a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
4a50: 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 72 65 73 (or (equal? res
4a60: 6f 6c 76 65 64 2d 70 61 74 68 20 23 66 29 20 28 olved-path #f) (
4a70: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
4a80: 3f 20 74 61 72 67 65 74 2d 70 61 74 68 29 29 29 ? target-path)))
4a90: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ab0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 6e (print "In
4ac0: 76 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 20 22 valid argument "
4ad0: 20 61 72 67 20 22 2e 2e 20 22 29 0a 20 20 20 20 arg ".. ").
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
4b00: 65 67 69 6e 20 20 20 20 20 20 0a 09 09 09 20 20 egin ....
4b10: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
4b20: 70 61 74 68 20 72 65 73 6f 6c 76 65 64 2d 70 61 path resolved-pa
4b30: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b50: 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f (sautho
4b60: 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 rize:do-as-calli
4b70: 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 ng-user.
4b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b90: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
4ba0: 0a 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 .... (run-cmd
4bb0: 20 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 (conc *sauth-pa
4bc0: 74 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 th* "/sauthorize
4bd0: 22 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 ") (list "regist
4be0: 65 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c er-log" (conc "\
4bf0: 22 22 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 "" inl "\"") (nu
4c00: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 mber->string (ca
4c10: 72 20 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e r user-obj)) (n
4c20: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 umber->string (c
4c30: 61 64 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 addr area-obj))
4c40: 20 22 63 64 22 29 29 29 29 0a 20 20 20 20 20 20 "cd")))).
4c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c60: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 29 ))))
4c70: 29 20 20 0a 20 20 20 09 09 09 20 20 20 28 73 65 ) . ... (se
4c80: 74 21 20 70 61 74 68 20 27 28 29 29 29 29 0a 20 t! path '()))).
4c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ca0: 20 20 20 20 20 28 28 70 77 64 29 0a 20 20 20 20 ((pwd).
4cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cc0: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
4cd0: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
4ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cf0: 20 28 70 72 69 6e 74 20 22 2f 22 29 20 20 0a 20 (print "/") .
4d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d10: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
4d20: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 6a 6f 69 "/" (string-joi
4d30: 6e 20 70 61 74 68 20 22 2f 22 29 29 29 29 20 0a n path "/")))) .
4d40: 09 09 20 20 20 20 20 20 28 28 6c 73 29 0a 09 09 .. ((ls)...
4d50: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
4d60: 68 65 70 61 74 68 20 28 69 66 20 28 3e 20 28 6c hepath (if (> (l
4d70: 65 6e 67 74 68 20 70 61 72 74 73 29 20 31 29 20 ength parts) 1)
4d80: 3b 3b 20 68 61 76 65 20 61 20 70 61 72 61 6d 65 ;; have a parame
4d90: 74 65 72 0a 09 09 09 09 09 20 20 20 28 63 64 72 ter...... (cdr
4da0: 20 70 61 72 74 73 29 0a 09 09 09 09 09 20 20 20 parts)......
4db0: 60 28 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 `())).... (
4dc0: 70 6c 65 6e 20 20 20 20 28 6c 65 6e 67 74 68 20 plen (length
4dd0: 74 68 65 70 61 74 68 29 29 29 0a 20 20 20 20 20 thepath))).
4de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4df0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 20 28 (cond.... (
4e00: 28 6e 75 6c 6c 3f 20 74 68 65 70 61 74 68 29 0a (null? thepath).
4e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e20: 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 (saut
4e30: 68 2d 63 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c h-common:shell-l
4e40: 73 2d 63 6d 64 20 70 61 74 68 20 22 22 20 74 6f s-cmd path "" to
4e50: 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 74 p-areas base-pat
4e60: 68 20 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 h '()).
4e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e80: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
4e90: 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 do-as-calling-us
4ea0: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
4eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ec0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
4ed0: 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e (run-cmd (con
4ee0: 63 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 22 c *sauth-path* "
4ef0: 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 6c /sauthorize") (l
4f00: 69 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c 6f ist "register-lo
4f10: 67 22 20 28 63 6f 6e 63 20 22 5c 22 22 20 69 6e g" (conc "\"" in
4f20: 6c 20 22 5c 22 22 29 20 28 6e 75 6d 62 65 72 2d l "\"") (number-
4f30: 3e 73 74 72 69 6e 67 20 28 63 61 72 20 75 73 65 >string (car use
4f40: 72 2d 6f 62 6a 29 29 20 20 28 6e 75 6d 62 65 72 r-obj)) (number
4f50: 2d 3e 73 74 72 69 6e 67 20 28 63 61 64 64 72 20 ->string (caddr
4f60: 61 72 65 61 2d 6f 62 6a 29 29 20 20 22 6c 73 22 area-obj)) "ls"
4f70: 29 29 29 29 20 20 20 29 0a 09 09 09 20 20 28 28 )))) ).... ((
4f80: 3c 20 70 6c 65 6e 20 32 29 0a 20 20 20 20 20 20 < plen 2).
4f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fa0: 20 20 20 20 20 20 28 73 61 75 74 68 2d 63 6f 6d (sauth-com
4fb0: 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c 73 2d 63 6d 64 mon:shell-ls-cmd
4fc0: 20 70 61 74 68 20 20 28 63 61 72 20 74 68 65 70 path (car thep
4fd0: 61 74 68 29 20 74 6f 70 2d 61 72 65 61 73 20 62 ath) top-areas b
4fe0: 61 73 65 2d 70 61 74 68 20 27 28 29 29 0a 20 20 ase-path '()).
4ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5000: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 (sau
5010: 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 thorize:do-as-ca
5020: 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 lling-user.
5030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5040: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
5050: 20 28 29 0a 09 09 09 20 20 20 20 28 72 75 6e 2d ().... (run-
5060: 63 6d 64 20 28 63 6f 6e 63 20 2a 73 61 75 74 68 cmd (conc *sauth
5070: 2d 70 61 74 68 2a 20 22 2f 73 61 75 74 68 6f 72 -path* "/sauthor
5080: 69 7a 65 22 29 20 28 6c 69 73 74 20 22 72 65 67 ize") (list "reg
5090: 69 73 74 65 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 ister-log" (conc
50a0: 20 22 5c 22 22 20 69 6e 6c 20 22 5c 22 22 29 20 "\"" inl "\"")
50b0: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
50c0: 28 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 29 20 (car user-obj))
50d0: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
50e0: 20 28 63 61 64 64 72 20 61 72 65 61 2d 6f 62 6a (caddr area-obj
50f0: 29 29 20 20 22 6c 73 22 29 29 29 29 29 0a 20 20 )) "ls"))))).
5100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5110: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a 20 (else .
5120: 20 20 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 28 69 66 20 28 (if (
5140: 65 71 75 61 6c 3f 20 28 63 61 72 20 74 68 65 70 equal? (car thep
5150: 61 74 68 29 20 22 7c 22 29 0a 20 20 20 20 20 20 ath) "|").
5160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5170: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 2d 63 (sauth-c
5180: 6f 6d 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c 73 2d 63 ommon:shell-ls-c
5190: 6d 64 20 70 61 74 68 20 22 22 20 74 6f 70 2d 61 md path "" top-a
51a0: 72 65 61 73 20 62 61 73 65 2d 70 61 74 68 20 74 reas base-path t
51b0: 68 65 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 hepath).
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51d0: 20 20 20 20 20 20 28 73 61 75 74 68 2d 63 6f 6d (sauth-com
51e0: 6d 6f 6e 3a 73 68 65 6c 6c 2d 6c 73 2d 63 6d 64 mon:shell-ls-cmd
51f0: 20 70 61 74 68 20 20 28 63 61 72 20 74 68 65 70 path (car thep
5200: 61 74 68 29 20 74 6f 70 2d 61 72 65 61 73 20 62 ath) top-areas b
5210: 61 73 65 2d 70 61 74 68 20 28 63 64 72 20 74 68 ase-path (cdr th
5220: 65 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 epath))).
5230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5240: 20 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a (sauthorize:
5250: 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 do-as-calling-us
5260: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
5270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5280: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
5290: 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e (run-cmd (con
52a0: 63 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 22 c *sauth-path* "
52b0: 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 6c /sauthorize") (l
52c0: 69 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c 6f ist "register-lo
52d0: 67 22 20 28 63 6f 6e 63 20 22 5c 22 22 20 69 6e g" (conc "\"" in
52e0: 6c 20 22 5c 22 22 29 20 28 6e 75 6d 62 65 72 2d l "\"") (number-
52f0: 3e 73 74 72 69 6e 67 20 28 63 61 72 20 75 73 65 >string (car use
5300: 72 2d 6f 62 6a 29 29 20 20 28 6e 75 6d 62 65 72 r-obj)) (number
5310: 2d 3e 73 74 72 69 6e 67 20 28 63 61 64 64 72 20 ->string (caddr
5320: 61 72 65 61 2d 6f 62 6a 29 29 20 20 22 6c 73 22 area-obj)) "ls"
5330: 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 )))))))).
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 28 28 6d 6b 64 69 72 29 0a 20 20 20 20 20 20 20 ((mkdir).
5360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5370: 20 20 28 6c 65 74 2a 20 28 28 74 68 65 70 61 74 (let* ((thepat
5380: 68 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 h (if (> (length
5390: 20 70 61 72 74 73 29 20 31 29 20 3b 3b 20 68 61 parts) 1) ;; ha
53a0: 76 65 20 61 20 70 61 72 61 6d 65 74 65 72 0a 09 ve a parameter..
53b0: 09 09 09 20 20 20 28 63 64 72 20 70 61 72 74 73 ... (cdr parts
53c0: 29 0a 09 09 09 09 20 20 20 60 28 29 29 29 0a 09 )..... `()))..
53d0: 09 09 20 20 20 20 20 20 28 70 6c 65 6e 20 20 20 .. (plen
53e0: 20 28 6c 65 6e 67 74 68 20 74 68 65 70 61 74 68 (length thepath
53f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
5400: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5410: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
5420: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e ((n
5430: 75 6c 6c 3f 20 74 68 65 70 61 74 68 29 0a 20 20 ull? thepath).
5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5450: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
5460: 20 22 6d 6b 64 69 72 20 74 61 6b 65 73 20 6f 6e "mkdir takes on
5470: 65 20 61 72 67 75 6d 65 6e 74 22 29 29 0a 20 20 e argument")).
5480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5490: 20 20 20 20 20 20 20 20 28 28 3c 20 70 6c 65 6e ((< plen
54a0: 20 32 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 2) .
54b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54c0: 20 28 6c 65 74 2a 28 28 6d 6b 2d 70 61 74 68 20 (let*((mk-path
54d0: 28 63 61 64 72 20 70 61 72 74 73 29 29 0a 20 20 (cadr parts)).
54e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5500: 28 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 (resolved-path (
5510: 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 sauth-common:res
5520: 6f 6c 76 65 2d 70 61 74 68 20 20 6d 6b 2d 70 61 olve-path mk-pa
5530: 74 68 20 70 61 74 68 20 74 6f 70 2d 61 72 65 61 th path top-area
5540: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
5550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5560: 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 (target-pa
5570: 74 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e th (sauth-common
5580: 3a 67 65 74 2d 74 61 72 67 65 74 2d 70 61 74 68 :get-target-path
5590: 20 70 61 74 68 20 20 6d 6b 2d 70 61 74 68 20 74 path mk-path t
55a0: 6f 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 op-areas base-pa
55b0: 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 th))).
55c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55d0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
55e0: 75 61 6c 3f 20 74 61 72 67 65 74 2d 70 61 74 68 ual? target-path
55f0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
5600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5610: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
5620: 6c 3f 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 l? resolved-path
5630: 20 23 66 29 20 20 20 20 20 0a 20 20 20 20 20 20 #f) .
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
5660: 74 20 22 49 6e 76 61 6c 69 64 20 61 72 67 75 6d t "Invalid argum
5670: 65 6e 74 20 22 20 6d 6b 2d 70 61 74 68 20 22 2e ent " mk-path ".
5680: 2e 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 . ").
5690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56a0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56d0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 68 65 (print "he
56e0: 72 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 re").
56f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5700: 20 20 20 20 20 20 20 20 20 20 20 28 73 70 75 62 (spub
5710: 6c 69 73 68 3a 73 68 65 6c 6c 2d 6d 6b 64 69 72 lish:shell-mkdir
5720: 20 74 61 72 67 65 74 2d 70 61 74 68 29 20 20 20 target-path)
5730: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5750: 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 69 (sauthori
5760: 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 ze:do-as-calling
5770: 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 20 -user.
5780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5790: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
57a0: 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 .. (run-cmd (
57b0: 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 68 conc *sauth-path
57c0: 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 * "/sauthorize")
57d0: 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 72 (list "register
57e0: 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 22 -log" (conc "\""
57f0: 20 69 6e 6c 20 22 5c 22 22 29 20 28 6e 75 6d 62 inl "\"") (numb
5800: 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 20 er->string (car
5810: 75 73 65 72 2d 6f 62 6a 29 29 20 20 28 6e 75 6d user-obj)) (num
5820: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 61 64 ber->string (cad
5830: 64 72 20 61 72 65 61 2d 6f 62 6a 29 29 20 20 22 dr area-obj)) "
5840: 6d 6b 64 69 72 22 29 29 29 29 29 29 29 0a 09 09 mkdir")))))))...
5850: 20 20 20 20 20 20 20 29 29 29 29 29 0a 20 20 20 ))))).
5860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5870: 20 20 20 20 28 28 72 6d 29 0a 20 20 20 20 20 20 ((rm).
5880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5890: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 65 70 (let* ((thep
58a0: 61 74 68 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 ath (if (> (leng
58b0: 74 68 20 70 61 72 74 73 29 20 31 29 20 3b 3b 20 th parts) 1) ;;
58c0: 68 61 76 65 20 61 20 70 61 72 61 6d 65 74 65 72 have a parameter
58d0: 0a 09 09 09 09 20 20 20 28 63 64 72 20 70 61 72 ..... (cdr par
58e0: 74 73 29 0a 09 09 09 09 20 20 20 60 28 29 29 29 ts)..... `()))
58f0: 0a 09 09 09 20 20 20 20 20 20 28 70 6c 65 6e 20 .... (plen
5900: 20 20 20 28 6c 65 6e 67 74 68 20 74 68 65 70 61 (length thepa
5910: 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 th))).
5920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5930: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
5940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5950: 28 6e 75 6c 6c 3f 20 74 68 65 70 61 74 68 29 0a (null? thepath).
5960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5970: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
5980: 6e 74 20 22 72 6d 20 74 61 6b 65 73 20 6f 6e 65 nt "rm takes one
5990: 20 61 72 67 75 6d 65 6e 74 22 29 29 0a 20 20 20 argument")).
59a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59b0: 20 20 20 20 20 20 20 28 28 3c 20 70 6c 65 6e 20 ((< plen
59c0: 32 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 2) .
59d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59e0: 28 6c 65 74 2a 28 28 72 6d 2d 70 61 74 68 20 28 (let*((rm-path (
59f0: 63 61 64 72 20 70 61 72 74 73 29 29 0a 20 20 20 cadr parts)).
5a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5a20: 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 resolved-path (s
5a30: 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f auth-common:reso
5a40: 6c 76 65 2d 70 61 74 68 20 20 72 6d 2d 70 61 74 lve-path rm-pat
5a50: 68 20 70 61 74 68 20 74 6f 70 2d 61 72 65 61 73 h path top-areas
5a60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a80: 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 (target-pat
5a90: 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a h (sauth-common:
5aa0: 67 65 74 2d 74 61 72 67 65 74 2d 70 61 74 68 20 get-target-path
5ab0: 70 61 74 68 20 20 72 6d 2d 70 61 74 68 20 74 6f path rm-path to
5ac0: 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 61 74 p-areas base-pat
5ad0: 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h))).
5ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5af0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
5b00: 61 6c 3f 20 74 61 72 67 65 74 2d 70 61 74 68 20 al? target-path
5b10: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f)).
5b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b30: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
5b40: 3f 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 ? resolved-path
5b50: 23 66 29 20 20 20 20 20 0a 20 20 20 20 20 20 20 #f) .
5b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b70: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
5b80: 20 22 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 "Invalid argume
5b90: 6e 74 20 22 20 72 6d 2d 70 61 74 68 20 22 2e 2e nt " rm-path "..
5ba0: 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ").
5bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bc0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
5bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bf0: 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a 73 68 (spublish:sh
5c00: 65 6c 6c 2d 72 6d 20 74 61 72 67 65 74 2d 70 61 ell-rm target-pa
5c10: 74 68 20 69 70 6f 72 74 29 20 20 20 0a 20 20 20 th iport) .
5c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c40: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
5c50: 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 o-as-calling-use
5c60: 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r.
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c80: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
5c90: 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 (run-cmd (conc
5ca0: 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 22 2f *sauth-path* "/
5cb0: 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 6c 69 sauthorize") (li
5cc0: 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c 6f 67 st "register-log
5cd0: 22 20 28 63 6f 6e 63 20 22 5c 22 22 20 69 6e 6c " (conc "\"" inl
5ce0: 20 22 5c 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e "\"") (number->
5cf0: 73 74 72 69 6e 67 20 28 63 61 72 20 75 73 65 72 string (car user
5d00: 2d 6f 62 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d -obj)) (number-
5d10: 3e 73 74 72 69 6e 67 20 28 63 61 64 64 72 20 61 >string (caddr a
5d20: 72 65 61 2d 6f 62 6a 29 29 20 20 22 72 6d 22 29 rea-obj)) "rm")
5d30: 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 ))))))...
5d40: 29 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 20 )))))..
5d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
5d60: 70 20 70 75 62 6c 69 73 68 29 0a 20 20 20 20 20 p publish).
5d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d80: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 68 65 (let* ((the
5d90: 70 61 74 68 20 28 69 66 20 28 3e 20 28 6c 65 6e path (if (> (len
5da0: 67 74 68 20 70 61 72 74 73 29 20 31 29 20 3b 3b gth parts) 1) ;;
5db0: 20 68 61 76 65 20 61 20 70 61 72 61 6d 65 74 65 have a paramete
5dc0: 72 0a 09 09 09 09 20 20 20 28 63 64 72 20 70 61 r..... (cdr pa
5dd0: 72 74 73 29 0a 09 09 09 09 20 20 20 60 28 29 29 rts)..... `())
5de0: 29 0a 09 09 09 20 20 20 20 20 20 28 70 6c 65 6e ).... (plen
5df0: 20 20 20 20 28 6c 65 6e 67 74 68 20 74 68 65 70 (length thep
5e00: 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 ath))).
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e20: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond.
5e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e40: 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 74 68 65 70 ((or (null? thep
5e50: 61 74 68 29 20 28 3c 20 70 6c 65 6e 20 32 29 29 ath) (< plen 2))
5e60: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
5e80: 72 69 6e 74 20 22 63 70 20 74 61 6b 65 73 20 74 rint "cp takes t
5e90: 77 6f 20 61 72 67 75 6d 65 6e 74 22 29 29 0a 20 wo argument")).
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 20 20 20 20 20 20 20 20 28 28 3c 20 70 6c 65 ((< ple
5ec0: 6e 20 33 29 20 0a 20 20 20 20 20 20 20 20 20 20 n 3) .
5ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ee0: 20 20 28 6c 65 74 2a 28 28 73 72 63 2d 70 61 74 (let*((src-pat
5ef0: 68 20 28 63 61 72 20 74 68 65 70 61 74 68 29 29 h (car thepath))
5f00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f20: 20 20 20 28 64 65 73 74 2d 70 61 74 68 20 28 63 (dest-path (c
5f30: 61 64 72 20 74 68 65 70 61 74 68 29 29 20 20 20 adr thepath))
5f40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f60: 20 20 20 28 72 65 73 6f 6c 76 65 64 2d 70 61 74 (resolved-pat
5f70: 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a h (sauth-common:
5f80: 72 65 73 6f 6c 76 65 2d 70 61 74 68 20 20 64 65 resolve-path de
5f90: 73 74 2d 70 61 74 68 20 70 61 74 68 20 74 6f 70 st-path path top
5fa0: 2d 61 72 65 61 73 29 29 0a 20 20 20 20 20 20 20 -areas)).
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 74 61 72 67 (targ
5fd0: 65 74 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 et-path (sauth-c
5fe0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 65 74 ommon:get-target
5ff0: 2d 70 61 74 68 20 70 61 74 68 20 20 64 65 73 74 -path path dest
6000: 2d 70 61 74 68 20 74 6f 70 2d 61 72 65 61 73 20 -path top-areas
6010: 62 61 73 65 2d 70 61 74 68 29 29 29 0a 20 20 20 base-path))).
6020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6030: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
6040: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 74 61 72 67 not (equal? targ
6050: 65 74 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 et-path #f)).
6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
6080: 66 20 28 65 71 75 61 6c 3f 20 72 65 73 6f 6c 76 f (equal? resolv
6090: 65 64 2d 70 61 74 68 20 23 66 29 20 20 20 20 20 ed-path #f)
60a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
60b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
60c0: 20 20 28 70 72 69 6e 74 20 22 49 6e 76 61 6c 69 (print "Invali
60d0: 64 20 61 72 67 75 6d 65 6e 74 20 22 20 64 65 73 d argument " des
60e0: 74 2d 70 61 74 68 20 22 2e 2e 20 22 29 0a 20 20 t-path ".. ").
60f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6110: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
6120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
6140: 70 75 62 6c 69 73 68 3a 73 68 65 6c 6c 2d 63 70 publish:shell-cp
6150: 20 73 72 63 2d 70 61 74 68 20 74 61 72 67 65 74 src-path target
6160: 2d 70 61 74 68 29 20 20 20 0a 20 20 20 20 20 20 -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 20 20 20 20 20
6190: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 (sauthorize:do-a
61a0: 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 s-calling-user.
61b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
61d0: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 28 mbda ().... (
61e0: 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 2a 73 run-cmd (conc *s
61f0: 61 75 74 68 2d 70 61 74 68 2a 20 22 2f 73 61 75 auth-path* "/sau
6200: 74 68 6f 72 69 7a 65 22 29 20 28 6c 69 73 74 20 thorize") (list
6210: 22 72 65 67 69 73 74 65 72 2d 6c 6f 67 22 20 28 "register-log" (
6220: 63 6f 6e 63 20 22 5c 22 22 20 69 6e 6c 20 22 5c conc "\"" inl "\
6230: 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 "") (number->str
6240: 69 6e 67 20 28 63 61 72 20 75 73 65 72 2d 6f 62 ing (car user-ob
6250: 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 j)) (number->st
6260: 72 69 6e 67 20 28 63 61 64 64 72 20 61 72 65 61 ring (caddr area
6270: 2d 6f 62 6a 29 29 20 20 22 63 70 22 29 29 29 29 -obj)) "cp"))))
6280: 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
6290: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
62a0: 20 20 20 20 20 20 20 20 20 28 28 6c 6e 29 0a 20 ((ln).
62b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62c0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
62d0: 28 28 74 68 65 70 61 74 68 20 28 69 66 20 28 3e ((thepath (if (>
62e0: 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 20 (length parts)
62f0: 31 29 20 3b 3b 20 68 61 76 65 20 61 20 70 61 72 1) ;; have a par
6300: 61 6d 65 74 65 72 0a 09 09 09 09 20 20 20 28 63 ameter..... (c
6310: 64 72 20 70 61 72 74 73 29 0a 09 09 09 09 20 20 dr parts).....
6320: 20 60 28 29 29 29 0a 09 09 09 20 20 20 20 20 20 `()))....
6330: 28 70 6c 65 6e 20 20 20 20 28 6c 65 6e 67 74 68 (plen (length
6340: 20 74 68 65 70 61 74 68 29 29 29 0a 20 20 20 20 thepath))).
6350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6360: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
6370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6380: 20 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f ((or (null?
6390: 20 74 68 65 70 61 74 68 29 20 28 3c 20 70 6c 65 thepath) (< ple
63a0: 6e 20 32 29 29 20 0a 20 20 20 20 20 20 20 20 20 n 2)) .
63b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63c0: 20 20 20 28 70 72 69 6e 74 20 22 6c 6e 20 74 61 (print "ln ta
63d0: 6b 65 73 20 74 77 6f 20 61 72 67 75 6d 65 6e 74 kes two argument
63e0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
63f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
6400: 3c 20 70 6c 65 6e 20 33 29 20 0a 20 20 20 20 20 < plen 3) .
6410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6420: 20 20 20 20 20 20 20 28 6c 65 74 2a 28 28 73 72 (let*((sr
6430: 63 2d 70 61 74 68 20 28 63 61 72 20 74 68 65 70 c-path (car thep
6440: 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 ath)).
6450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6460: 20 20 20 20 20 20 20 20 28 64 65 73 74 2d 70 61 (dest-pa
6470: 74 68 20 28 63 61 64 72 20 74 68 65 70 61 74 68 th (cadr thepath
6480: 29 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 )) .
6490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64a0: 20 20 20 20 20 20 20 20 28 72 65 73 6f 6c 76 65 (resolve
64b0: 64 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f d-path (sauth-co
64c0: 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d 70 61 74 mmon:resolve-pat
64d0: 68 20 20 64 65 73 74 2d 70 61 74 68 20 70 61 74 h dest-path pat
64e0: 68 20 74 6f 70 2d 61 72 65 61 73 29 29 0a 20 20 h top-areas)).
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6510: 28 74 61 72 67 65 74 2d 70 61 74 68 20 28 73 61 (target-path (sa
6520: 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 uth-common:get-t
6530: 61 72 67 65 74 2d 70 61 74 68 20 70 61 74 68 20 arget-path path
6540: 20 64 65 73 74 2d 70 61 74 68 20 74 6f 70 2d 61 dest-path top-a
6550: 72 65 61 73 20 62 61 73 65 2d 70 61 74 68 29 29 reas base-path))
6560: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6580: 20 20 20 28 73 75 62 2d 70 61 74 68 20 28 63 6f (sub-path (co
6590: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 72 nc "/" (string-r
65a0: 65 76 65 72 73 65 20 28 73 74 72 69 6e 67 2d 6a everse (string-j
65b0: 6f 69 6e 20 28 63 64 72 20 28 73 74 72 69 6e 67 oin (cdr (string
65c0: 2d 73 70 6c 69 74 20 28 73 74 72 69 6e 67 2d 72 -split (string-r
65d0: 65 76 65 72 73 65 20 20 74 61 72 67 65 74 2d 70 everse target-p
65e0: 61 74 68 29 20 22 2f 22 29 29 20 22 2f 22 29 29 ath) "/")) "/"))
65f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
6600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6610: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
6620: 6c 3f 20 74 61 72 67 65 74 2d 70 61 74 68 20 23 l? target-path #
6630: 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 f)).
6640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6650: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
6660: 20 72 65 73 6f 6c 76 65 64 2d 70 61 74 68 20 23 resolved-path #
6670: 66 29 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 f) .
6680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6690: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
66a0: 22 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 6e "Invalid argumen
66b0: 74 20 22 20 64 65 73 74 2d 70 61 74 68 20 22 2e t " dest-path ".
66c0: 2e 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 . ").
66d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66e0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
66f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6710: 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a 73 (spublish:s
6720: 68 65 6c 6c 2d 6c 6e 20 73 72 63 2d 70 61 74 68 hell-ln src-path
6730: 20 74 61 72 67 65 74 2d 70 61 74 68 20 73 75 62 target-path sub
6740: 2d 70 61 74 68 29 20 20 20 0a 20 20 20 20 20 20 -path) .
6750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6770: 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 6f 2d 61 (sauthorize:do-a
6780: 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 72 0a 20 s-calling-user.
6790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
67b0: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 28 mbda ().... (
67c0: 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 2a 73 run-cmd (conc *s
67d0: 61 75 74 68 2d 70 61 74 68 2a 20 22 2f 73 61 75 auth-path* "/sau
67e0: 74 68 6f 72 69 7a 65 22 29 20 28 6c 69 73 74 20 thorize") (list
67f0: 22 72 65 67 69 73 74 65 72 2d 6c 6f 67 22 20 28 "register-log" (
6800: 63 6f 6e 63 20 22 5c 22 22 20 69 6e 6c 20 22 5c conc "\"" inl "\
6810: 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 "") (number->str
6820: 69 6e 67 20 28 63 61 72 20 75 73 65 72 2d 6f 62 ing (car user-ob
6830: 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 j)) (number->st
6840: 72 69 6e 67 20 28 63 61 64 64 72 20 61 72 65 61 ring (caddr area
6850: 2d 6f 62 6a 29 29 20 20 22 6c 6e 22 29 29 29 29 -obj)) "ln"))))
6860: 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
6870: 29 29 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 )) .
6880: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 78 69 ((exi
6890: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
68a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
68b0: 69 6e 74 20 22 67 6f 74 20 65 78 69 74 22 29 29 int "got exit"))
68c0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
68d0: 20 20 20 20 20 20 20 20 20 28 28 68 65 6c 70 29 ((help)
68e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
68f0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
6900: 74 20 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c t (spublish:shel
6910: 6c 2d 68 65 6c 70 29 29 29 0a 09 09 20 20 20 20 l-help)))...
6920: 20 20 28 65 6c 73 65 20 0a 09 09 20 20 20 20 20 (else ...
6930: 20 20 28 70 72 69 6e 74 20 22 47 6f 74 20 63 6f (print "Got co
6940: 6d 6d 61 6e 64 3a 20 22 20 69 6e 6c 29 29 29 29 mmand: " inl))))
6950: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6960: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
6970: 6e 65 20 69 70 6f 72 74 29 29 29 29 29 29 29 0a ne iport))))))).
6980: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 41 ==========.;; MA
69d0: 49 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d IN.;;===========
69e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 28 64 ===========..;(d
6a20: 65 66 69 6e 65 20 28 73 70 75 62 6c 69 73 68 3a efine (spublish:
6a30: 6c 6f 61 64 2d 63 6f 6e 66 69 67 20 65 78 65 2d load-config exe-
6a40: 64 69 72 20 65 78 65 2d 6e 61 6d 65 29 0a 3b 20 dir exe-name).;
6a50: 20 28 6c 65 74 2a 20 28 28 66 6e 61 6d 65 20 20 (let* ((fname
6a60: 20 28 63 6f 6e 63 20 65 78 65 2d 64 69 72 20 22 (conc exe-dir "
6a70: 2f 2e 22 20 65 78 65 2d 6e 61 6d 65 20 22 2e 63 /." exe-name ".c
6a80: 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 3b 3b onfig"))). ;;
6a90: 20 28 69 6e 69 3a 70 72 6f 70 65 72 74 79 2d 73 (ini:property-s
6aa0: 65 70 61 72 61 74 6f 72 2d 70 61 74 74 20 22 20 eparator-patt "
6ab0: 2a 20 20 2a 22 29 0a 20 20 20 20 3b 3b 20 28 69 * *"). ;; (i
6ac0: 6e 69 3a 70 72 6f 70 65 72 74 79 2d 73 65 70 61 ni:property-sepa
6ad0: 72 61 74 6f 72 20 23 5c 73 70 61 63 65 29 0a 3b rator #\space).;
6ae0: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
6af0: 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 3b 09 3b ists? fname).;.;
6b00: 3b 20 28 69 6e 69 3a 72 65 61 64 2d 69 6e 69 20 ; (ini:read-ini
6b10: 66 6e 61 6d 65 29 0a 3b 09 28 72 65 61 64 2d 63 fname).;.(read-c
6b20: 6f 6e 66 69 67 20 66 6e 61 6d 65 20 23 66 20 23 onfig fname #f #
6b30: 74 29 0a 3b 09 28 6d 61 6b 65 2d 68 61 73 68 2d t).;.(make-hash-
6b40: 74 61 62 6c 65 29 29 29 29 0a 0a 28 64 65 66 69 table))))..(defi
6b50: 6e 65 20 28 73 70 75 62 6c 69 73 68 3a 70 72 6f ne (spublish:pro
6b60: 63 65 73 73 2d 61 63 74 69 6f 6e 20 61 63 74 69 cess-action acti
6b70: 6f 6e 20 2e 20 61 72 67 73 29 0a 20 20 3b 28 70 on . args). ;(p
6b80: 72 69 6e 74 20 61 72 67 73 29 0a 20 20 28 6c 65 rint args). (le
6b90: 74 2a 20 28 28 75 73 72 20 20 20 20 20 20 20 20 t* ((usr
6ba0: 20 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d (current-user-
6bb0: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
6bc0: 28 75 73 65 72 2d 6f 62 6a 20 28 67 65 74 2d 75 (user-obj (get-u
6bd0: 73 65 72 20 75 73 72 29 29 20 0a 20 20 20 20 20 ser usr)) .
6be0: 20 20 20 20 28 61 72 65 61 20 20 20 28 63 61 72 (area (car
6bf0: 20 61 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 args)).
6c00: 20 28 61 72 65 61 2d 6f 62 6a 20 20 28 67 65 74 (area-obj (get
6c10: 2d 6f 62 6a 2d 62 79 2d 63 6f 64 65 20 61 72 65 -obj-by-code are
6c20: 61 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6f a)). (to
6c30: 70 2d 61 72 65 61 73 20 28 73 70 75 62 6c 69 73 p-areas (spublis
6c40: 68 3a 67 65 74 2d 61 63 63 65 73 73 61 62 6c 65 h:get-accessable
6c50: 2d 70 72 6f 6a 65 63 74 73 20 61 72 65 61 29 29 -projects area))
6c60: 20 20 0a 20 20 20 20 20 20 20 20 20 28 62 61 73 . (bas
6c70: 65 2d 70 61 74 68 20 28 69 66 20 28 6e 75 6c 6c e-path (if (null
6c80: 3f 20 61 72 65 61 2d 6f 62 6a 29 20 0a 20 20 20 ? area-obj) .
6c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ca0: 20 20 20 20 20 20 22 22 20 0a 20 20 20 20 20 20 "" .
6cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cc0: 20 20 28 63 61 64 64 72 20 28 63 64 72 20 61 72 (caddr (cdr ar
6cd0: 65 61 2d 6f 62 6a 29 29 29 29 20 20 20 0a 20 20 ea-obj)))) .
6ce0: 20 20 20 20 20 20 20 28 72 65 6d 61 72 67 73 20 (remargs
6cf0: 28 63 64 72 20 61 72 67 73 29 29 29 0a 20 20 20 (cdr args))).
6d00: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 65 (if (null? are
6d10: 61 2d 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 a-obj).
6d20: 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 (begin .
6d30: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 41 72 (print "Ar
6d40: 65 61 20 22 20 61 72 65 61 20 22 20 64 6f 65 73 ea " area " does
6d50: 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 20 20 20 not exist").
6d60: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
6d70: 29 0a 20 20 20 20 28 63 61 73 65 20 28 73 74 72 ). (case (str
6d80: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 ing->symbol acti
6d90: 6f 6e 29 0a 20 20 20 20 20 20 28 28 63 70 20 70 on). ((cp p
6da0: 75 62 6c 69 73 68 29 0a 20 20 20 20 20 20 20 28 ublish). (
6db0: 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 72 65 if (< (length re
6dc0: 6d 61 72 67 73 29 20 32 29 0a 09 20 20 20 28 62 margs) 2).. (b
6dd0: 65 67 69 6e 20 0a 09 20 20 20 20 20 28 70 72 69 egin .. (pri
6de0: 6e 74 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 nt "ERROR: Missi
6df0: 6e 67 20 61 72 67 75 6d 65 6e 74 73 3b 20 73 70 ng arguments; sp
6e00: 75 62 6c 69 73 68 20 3c 61 72 65 61 3e 20 3c 73 ublish <area> <s
6e10: 72 63 20 66 69 6c 65 3e 20 3c 64 65 73 74 69 6e rc file> <destin
6e20: 61 74 69 6f 6e 3e 22 20 29 0a 09 20 20 20 20 20 ation>" )..
6e30: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 20 (exit 1))).
6e40: 20 20 28 6c 65 74 2a 20 28 28 66 69 6c 74 65 72 (let* ((filter
6e50: 2d 61 72 67 73 20 20 20 20 20 28 61 72 67 73 3a -args (args:
6e60: 67 65 74 2d 61 72 67 73 20 61 72 67 73 20 27 28 get-args args '(
6e70: 22 2d 6d 22 29 20 27 28 29 20 61 72 67 73 3a 61 "-m") '() args:a
6e80: 72 67 2d 68 61 73 68 20 30 29 29 0a 20 20 20 20 rg-hash 0)).
6e90: 20 20 20 20 20 20 20 20 20 20 28 73 72 63 2d 70 (src-p
6ea0: 61 74 68 2d 69 6e 20 28 63 61 72 20 66 69 6c 74 ath-in (car filt
6eb0: 65 72 2d 61 72 67 73 29 29 0a 20 20 20 20 20 20 er-args)).
6ec0: 20 20 20 20 20 20 20 20 28 64 65 73 74 2d 70 61 (dest-pa
6ed0: 74 68 20 28 63 61 64 72 20 66 69 6c 74 65 72 2d th (cadr filter-
6ee0: 61 72 67 73 29 29 0a 09 20 20 20 20 20 20 28 73 args)).. (s
6ef0: 72 63 2d 70 61 74 68 20 20 20 20 28 77 69 74 68 rc-path (with
6f00: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
6f10: 0a 09 09 09 20 20 20 20 28 63 6f 6e 63 20 22 72 .... (conc "r
6f20: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 73 72 63 eadlink -f " src
6f30: 2d 70 61 74 68 2d 69 6e 29 0a 09 09 09 20 20 20 -path-in)....
6f40: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
6f50: 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 (read-line)
6f60: 29 29 29 0a 09 20 20 20 20 20 20 28 6d 73 67 20 ))).. (msg
6f70: 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 (or (arg
6f80: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 s:get-arg "-m")
6f90: 22 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 "")).
6fa0: 20 20 20 28 72 65 73 6f 6c 76 65 64 2d 70 61 74 (resolved-pat
6fb0: 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a h (sauth-common:
6fc0: 72 65 73 6f 6c 76 65 2d 70 61 74 68 20 20 28 63 resolve-path (c
6fd0: 6f 6e 63 20 61 72 65 61 20 22 2f 22 20 64 65 73 onc area "/" des
6fe0: 74 2d 70 61 74 68 29 20 60 28 29 20 74 6f 70 2d t-path) `() top-
6ff0: 61 72 65 61 73 29 29 0a 20 20 20 20 20 20 20 20 areas)).
7000: 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 (target-pa
7010: 74 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e th (sauth-common
7020: 3a 67 65 74 2d 74 61 72 67 65 74 2d 70 61 74 68 :get-target-path
7030: 20 60 28 29 20 20 28 63 6f 6e 63 20 61 72 65 61 `() (conc area
7040: 20 22 2f 22 20 64 65 73 74 2d 70 61 74 68 29 20 "/" dest-path)
7050: 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 2d 70 top-areas base-p
7060: 61 74 68 29 29 29 0a 20 09 20 20 20 20 20 28 69 ath))). . (i
7070: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 74 f (not (equal? t
7080: 61 72 67 65 74 2d 70 61 74 68 20 23 66 29 29 0a arget-path #f)).
7090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70a0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 72 65 73 (if (equal? res
70b0: 6f 6c 76 65 64 2d 70 61 74 68 20 23 66 29 20 20 olved-path #f)
70c0: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
70d0: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
70e0: 49 6e 76 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 Invalid argument
70f0: 20 22 20 64 65 73 74 2d 70 61 74 68 20 22 2e 2e " dest-path "..
7100: 20 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ").
7110: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a (begin .
7120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7130: 20 20 20 20 20 20 28 73 70 75 62 6c 69 73 68 3a (spublish:
7140: 73 68 65 6c 6c 2d 63 70 20 73 72 63 2d 70 61 74 shell-cp src-pat
7150: 68 20 74 61 72 67 65 74 2d 70 61 74 68 29 20 20 h target-path)
7160: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7170: 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f 72 (sauthor
7180: 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e ize:do-as-callin
7190: 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 20 g-user.
71a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
71b0: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
71c0: 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e 63 (run-cmd (conc
71d0: 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 22 2f *sauth-path* "/
71e0: 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 6c 69 sauthorize") (li
71f0: 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c 6f 67 st "register-log
7200: 22 20 28 63 6f 6e 63 20 22 5c 22 20 63 70 20 22 " (conc "\" cp "
7210: 20 73 72 63 2d 70 61 74 68 2d 69 6e 20 22 20 22 src-path-in " "
7220: 20 64 65 73 74 2d 70 61 74 68 20 20 22 5c 22 22 dest-path "\""
7230: 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e ) (number->strin
7240: 67 20 28 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 g (car user-obj)
7250: 29 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 ) (number->stri
7260: 6e 67 20 28 63 61 64 64 72 20 61 72 65 61 2d 6f ng (caddr area-o
7270: 62 6a 29 29 20 20 22 63 70 22 29 29 29 29 29 29 bj)) "cp"))))))
7280: 29 29 29 20 20 20 0a 20 20 20 20 20 20 28 28 6d ))) . ((m
7290: 6b 64 69 72 29 0a 20 20 20 20 20 20 20 20 28 69 kdir). (i
72a0: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 72 65 6d f (< (length rem
72b0: 61 72 67 73 29 20 31 29 0a 20 20 20 20 20 20 20 args) 1).
72c0: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
72d0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
72e0: 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 Missing argument
72f0: 73 3b 20 3c 61 72 65 61 3e 20 3c 70 61 74 68 3e s; <area> <path>
7300: 22 29 0a 09 20 20 20 20 20 28 65 78 69 74 20 31 ").. (exit 1
7310: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 ))). (let
7320: 2a 20 28 28 66 69 6c 74 65 72 2d 61 72 67 73 20 * ((filter-args
7330: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
7340: 67 73 20 61 72 67 73 20 27 28 22 2d 6d 22 29 20 gs args '("-m")
7350: 27 28 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 '() args:arg-has
7360: 68 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 h 0)).
7370: 20 20 20 20 20 28 6d 6b 2d 70 61 74 68 20 28 63 (mk-path (c
7380: 61 72 20 66 69 6c 74 65 72 2d 61 72 67 73 29 29 ar filter-args))
7390: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
73a0: 28 6d 73 67 20 20 20 20 20 20 20 20 20 28 6f 72 (msg (or
73b0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
73c0: 2d 6d 22 29 20 22 22 29 29 0a 20 20 20 20 20 20 -m") "")).
73d0: 20 20 20 20 20 20 20 20 20 28 72 65 73 6f 6c 76 (resolv
73e0: 65 64 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 ed-path (sauth-c
73f0: 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 2d 70 61 ommon:resolve-pa
7400: 74 68 20 20 6d 6b 2d 70 61 74 68 20 28 6c 69 73 th mk-path (lis
7410: 74 20 61 72 65 61 29 20 74 6f 70 2d 61 72 65 61 t area) top-area
7420: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
7430: 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 68 20 (target-path
7440: 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 (sauth-common:ge
7450: 74 2d 74 61 72 67 65 74 2d 70 61 74 68 20 28 6c t-target-path (l
7460: 69 73 74 20 61 72 65 61 29 20 20 6d 6b 2d 70 61 ist area) mk-pa
7470: 74 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 th top-areas bas
7480: 65 2d 70 61 74 68 29 29 29 20 0a 20 20 20 20 20 e-path))) .
7490: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
74a0: 20 22 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "attempting to
74b0: 63 72 65 61 74 65 20 64 69 72 65 63 74 6f 72 79 create directory
74c0: 20 22 20 6d 6b 2d 70 61 74 68 20 20 29 0a 20 20 " mk-path ).
74d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
74e0: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 74 61 (not (equal? ta
74f0: 72 67 65 74 2d 70 61 74 68 20 23 66 29 29 0a 20 rget-path #f)).
7500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7510: 28 69 66 20 28 65 71 75 61 6c 3f 20 72 65 73 6f (if (equal? reso
7520: 6c 76 65 64 2d 70 61 74 68 20 23 66 29 20 20 20 lved-path #f)
7530: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7540: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 49 6e (print "In
7550: 76 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 20 22 valid argument "
7560: 20 6d 6b 2d 70 61 74 68 20 22 2e 2e 20 22 29 0a mk-path ".. ").
7570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7580: 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 (begin .
7590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75a0: 28 73 70 75 62 6c 69 73 68 3a 73 68 65 6c 6c 2d (spublish:shell-
75b0: 6d 6b 64 69 72 20 74 61 72 67 65 74 2d 70 61 74 mkdir target-pat
75c0: 68 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 h) .
75d0: 20 20 20 20 20 20 20 20 20 20 20 28 73 61 75 74 (saut
75e0: 68 6f 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c horize:do-as-cal
75f0: 6c 69 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 20 ling-user.
7600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7610: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
7620: 20 20 20 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 (run-cmd (
7630: 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 74 68 conc *sauth-path
7640: 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 * "/sauthorize")
7650: 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 65 72 (list "register
7660: 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c 22 20 -log" (conc "\"
7670: 6d 6b 64 69 72 20 22 20 6d 6b 2d 70 61 74 68 20 mkdir " mk-path
7680: 20 22 5c 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e "\"") (number->
7690: 73 74 72 69 6e 67 20 28 63 61 72 20 75 73 65 72 string (car user
76a0: 2d 6f 62 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d -obj)) (number-
76b0: 3e 73 74 72 69 6e 67 20 28 63 61 64 64 72 20 61 >string (caddr a
76c0: 72 65 61 2d 6f 62 6a 29 29 20 20 22 6d 6b 64 69 rea-obj)) "mkdi
76d0: 72 22 29 29 29 29 29 29 29 29 29 20 20 0a 20 20 r"))))))))) .
76e0: 20 20 20 20 28 28 6c 6e 29 20 0a 20 20 20 20 20 ((ln) .
76f0: 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 (if (< (lengt
7700: 68 20 72 65 6d 61 72 67 73 29 20 32 29 0a 20 20 h remargs) 2).
7710: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a (begin .
7720: 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
7730: 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 ROR: Missing arg
7740: 75 6d 65 6e 74 73 3b 20 20 3c 61 72 65 61 3e 20 uments; <area>
7750: 3c 74 61 72 67 65 74 3e 20 3c 6c 69 6e 6b 20 6e <target> <link n
7760: 61 6d 65 3e 22 20 29 0a 09 20 20 20 20 20 28 65 ame>" ).. (e
7770: 78 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 xit 1))).
7780: 20 28 6c 65 74 2a 20 28 28 66 69 6c 74 65 72 2d (let* ((filter-
7790: 61 72 67 73 20 20 20 20 20 28 61 72 67 73 3a 67 args (args:g
77a0: 65 74 2d 61 72 67 73 20 61 72 67 73 20 27 28 22 et-args args '("
77b0: 2d 6d 22 29 20 27 28 29 20 61 72 67 73 3a 61 72 -m") '() args:ar
77c0: 67 2d 68 61 73 68 20 30 29 29 0a 20 20 20 20 20 g-hash 0)).
77d0: 20 20 20 20 20 20 20 20 20 28 73 72 63 2d 70 61 (src-pa
77e0: 74 68 20 28 63 61 72 20 66 69 6c 74 65 72 2d 61 th (car filter-a
77f0: 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 rgs)).
7800: 20 20 20 20 28 64 65 73 74 2d 70 61 74 68 20 28 (dest-path (
7810: 63 61 64 72 20 66 69 6c 74 65 72 2d 61 72 67 73 cadr filter-args
7820: 29 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 )) .
7830: 20 20 20 20 28 72 65 73 6f 6c 76 65 64 2d 70 61 (resolved-pa
7840: 74 68 20 28 73 61 75 74 68 2d 63 6f 6d 6d 6f 6e th (sauth-common
7850: 3a 72 65 73 6f 6c 76 65 2d 70 61 74 68 20 20 64 :resolve-path d
7860: 65 73 74 2d 70 61 74 68 20 28 6c 69 73 74 20 61 est-path (list a
7870: 72 65 61 29 20 74 6f 70 2d 61 72 65 61 73 29 29 rea) top-areas))
7880: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
7890: 74 61 72 67 65 74 2d 70 61 74 68 20 28 73 61 75 target-path (sau
78a0: 74 68 2d 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 61 th-common:get-ta
78b0: 72 67 65 74 2d 70 61 74 68 20 20 28 6c 69 73 74 rget-path (list
78c0: 20 61 72 65 61 29 20 20 64 65 73 74 2d 70 61 74 area) dest-pat
78d0: 68 20 74 6f 70 2d 61 72 65 61 73 20 62 61 73 65 h top-areas base
78e0: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
78f0: 20 20 20 20 20 20 28 73 75 62 2d 70 61 74 68 20 (sub-path
7900: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
7910: 67 2d 72 65 76 65 72 73 65 20 28 73 74 72 69 6e g-reverse (strin
7920: 67 2d 6a 6f 69 6e 20 28 63 64 72 20 28 73 74 72 g-join (cdr (str
7930: 69 6e 67 2d 73 70 6c 69 74 20 28 73 74 72 69 6e ing-split (strin
7940: 67 2d 72 65 76 65 72 73 65 20 20 74 61 72 67 65 g-reverse targe
7950: 74 2d 70 61 74 68 29 20 22 2f 22 29 29 20 22 2f t-path) "/")) "/
7960: 22 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 "))))).
7970: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
7980: 65 71 75 61 6c 3f 20 74 61 72 67 65 74 2d 70 61 equal? target-pa
7990: 74 68 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 th #f)).
79a0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 (if (e
79b0: 71 75 61 6c 3f 20 72 65 73 6f 6c 76 65 64 2d 70 qual? resolved-p
79c0: 61 74 68 20 23 66 29 20 20 20 20 20 0a 20 20 20 ath #f) .
79d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79e0: 20 28 70 72 69 6e 74 20 22 49 6e 76 61 6c 69 64 (print "Invalid
79f0: 20 61 72 67 75 6d 65 6e 74 20 22 20 64 65 73 74 argument " dest
7a00: 2d 70 61 74 68 20 22 2e 2e 20 22 29 0a 20 20 20 -path ".. ").
7a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a20: 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 (begin .
7a30: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 75 (spu
7a40: 62 6c 69 73 68 3a 73 68 65 6c 6c 2d 6c 6e 20 73 blish:shell-ln s
7a50: 72 63 2d 70 61 74 68 20 74 61 72 67 65 74 2d 70 rc-path target-p
7a60: 61 74 68 20 73 75 62 2d 70 61 74 68 29 20 20 20 ath sub-path)
7a70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7a80: 20 20 20 28 73 61 75 74 68 6f 72 69 7a 65 3a 64 (sauthorize:d
7a90: 6f 2d 61 73 2d 63 61 6c 6c 69 6e 67 2d 75 73 65 o-as-calling-use
7aa0: 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r.
7ab0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
7ac0: 20 20 20 28 72 75 6e 2d 63 6d 64 20 28 63 6f 6e (run-cmd (con
7ad0: 63 20 2a 73 61 75 74 68 2d 70 61 74 68 2a 20 22 c *sauth-path* "
7ae0: 2f 73 61 75 74 68 6f 72 69 7a 65 22 29 20 28 6c /sauthorize") (l
7af0: 69 73 74 20 22 72 65 67 69 73 74 65 72 2d 6c 6f ist "register-lo
7b00: 67 22 20 28 63 6f 6e 63 20 22 5c 22 20 6c 6e 20 g" (conc "\" ln
7b10: 22 20 73 72 63 2d 70 61 74 68 20 22 20 22 20 64 " src-path " " d
7b20: 65 73 74 2d 70 61 74 68 20 20 22 5c 22 22 29 20 est-path "\"")
7b30: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
7b40: 28 63 61 72 20 75 73 65 72 2d 6f 62 6a 29 29 20 (car user-obj))
7b50: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
7b60: 20 28 63 61 64 64 72 20 61 72 65 61 2d 6f 62 6a (caddr area-obj
7b70: 29 29 20 20 22 6c 6e 22 29 29 29 29 29 29 29 29 )) "ln"))))))))
7b80: 29 0a 20 20 20 20 20 20 28 28 72 6d 29 0a 20 20 ). ((rm).
7b90: 20 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e (if (< (len
7ba0: 67 74 68 20 72 65 6d 61 72 67 73 29 20 31 29 0a gth remargs) 1).
7bb0: 09 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 . (begin ..
7bc0: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
7bd0: 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 6e Missing argumen
7be0: 74 73 3b 20 3c 61 72 65 61 3e 20 3c 70 61 74 68 ts; <area> <path
7bf0: 3e 20 22 29 0a 09 20 20 20 20 20 28 65 78 69 74 > ").. (exit
7c00: 20 31 29 29 29 0a 20 20 20 20 20 20 20 28 6c 65 1))). (le
7c10: 74 2a 20 28 28 66 69 6c 74 65 72 2d 61 72 67 73 t* ((filter-args
7c20: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 73 (args:get-args
7c30: 20 61 72 67 73 20 27 28 22 2d 6d 22 29 20 27 28 args '("-m") '(
7c40: 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 20 ) args:arg-hash
7c50: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
7c60: 20 20 28 72 6d 2d 70 61 74 68 20 28 63 61 72 20 (rm-path (car
7c70: 66 69 6c 74 65 72 2d 61 72 67 73 29 29 0a 20 20 filter-args)).
7c80: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 (res
7c90: 6f 6c 76 65 64 2d 70 61 74 68 20 28 73 61 75 74 olved-path (saut
7ca0: 68 2d 63 6f 6d 6d 6f 6e 3a 72 65 73 6f 6c 76 65 h-common:resolve
7cb0: 2d 70 61 74 68 20 20 72 6d 2d 70 61 74 68 20 28 -path rm-path (
7cc0: 6c 69 73 74 20 61 72 65 61 29 20 74 6f 70 2d 61 list area) top-a
7cd0: 72 65 61 73 29 29 0a 20 20 20 20 20 20 20 20 20 reas)).
7ce0: 20 20 20 20 20 20 28 70 72 6f 6d 70 74 20 20 20 (prompt
7cf0: 20 22 3e 22 29 0a 20 20 20 20 20 20 20 20 20 20 ">").
7d00: 20 20 20 20 28 69 70 6f 72 74 20 20 20 20 20 28 (iport (
7d10: 6d 61 6b 65 2d 72 65 61 64 6c 69 6e 65 2d 70 6f make-readline-po
7d20: 72 74 20 70 72 6f 6d 70 74 29 29 0a 20 20 20 20 rt prompt)).
7d30: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
7d40: 74 2d 70 61 74 68 20 28 73 61 75 74 68 2d 63 6f t-path (sauth-co
7d50: 6d 6d 6f 6e 3a 67 65 74 2d 74 61 72 67 65 74 2d mmon:get-target-
7d60: 70 61 74 68 20 28 6c 69 73 74 20 61 72 65 61 29 path (list area)
7d70: 20 20 72 6d 2d 70 61 74 68 20 74 6f 70 2d 61 72 rm-path top-ar
7d80: 65 61 73 20 62 61 73 65 2d 70 61 74 68 29 29 29 eas base-path)))
7d90: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
7da0: 74 20 28 65 71 75 61 6c 3f 20 74 61 72 67 65 74 t (equal? target
7db0: 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 20 -path #f)).
7dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7dd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
7de0: 28 65 71 75 61 6c 3f 20 72 65 73 6f 6c 76 65 64 (equal? resolved
7df0: 2d 70 61 74 68 20 23 66 29 20 20 20 20 20 0a 20 -path #f) .
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e20: 28 70 72 69 6e 74 20 22 49 6e 76 61 6c 69 64 20 (print "Invalid
7e30: 61 72 67 75 6d 65 6e 74 20 22 20 72 6d 2d 70 61 argument " rm-pa
7e40: 74 68 20 22 2e 2e 20 22 29 0a 20 20 20 20 20 20 th ".. ").
7e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e60: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
7e70: 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 in .
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 20 20 20 20 20 20 20 20 28 73 70 75 62 6c (spubl
7ea0: 69 73 68 3a 73 68 65 6c 6c 2d 72 6d 20 74 61 72 ish:shell-rm tar
7eb0: 67 65 74 2d 70 61 74 68 20 69 70 6f 72 74 29 20 get-path iport)
7ec0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ee0: 20 20 20 20 20 20 20 20 20 28 73 61 75 74 68 6f (sautho
7ef0: 72 69 7a 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 rize:do-as-calli
7f00: 6e 67 2d 75 73 65 72 0a 20 20 20 20 20 20 20 20 ng-user.
7f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f20: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
7f30: 0a 09 09 09 20 20 20 20 28 72 75 6e 2d 63 6d 64 .... (run-cmd
7f40: 20 28 63 6f 6e 63 20 2a 73 61 75 74 68 2d 70 61 (conc *sauth-pa
7f50: 74 68 2a 20 22 2f 73 61 75 74 68 6f 72 69 7a 65 th* "/sauthorize
7f60: 22 29 20 28 6c 69 73 74 20 22 72 65 67 69 73 74 ") (list "regist
7f70: 65 72 2d 6c 6f 67 22 20 28 63 6f 6e 63 20 22 5c er-log" (conc "\
7f80: 22 20 72 6d 20 22 20 72 6d 2d 70 61 74 68 20 22 " rm " rm-path "
7f90: 5c 22 22 29 20 28 6e 75 6d 62 65 72 2d 3e 73 74 \"") (number->st
7fa0: 72 69 6e 67 20 28 63 61 72 20 75 73 65 72 2d 6f ring (car user-o
7fb0: 62 6a 29 29 20 20 28 6e 75 6d 62 65 72 2d 3e 73 bj)) (number->s
7fc0: 74 72 69 6e 67 20 28 63 61 64 64 72 20 61 72 65 tring (caddr are
7fd0: 61 2d 6f 62 6a 29 29 20 20 22 72 6d 22 29 29 29 a-obj)) "rm")))
7fe0: 29 29 29 29 29 29 0a 20 20 20 20 20 20 28 28 73 )))))). ((s
7ff0: 68 65 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 20 hell).
8000: 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 61 (if (< (length a
8010: 72 67 73 29 20 31 29 0a 20 20 20 20 20 20 20 20 rgs) 1).
8020: 20 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 (begin ..
8030: 20 20 20 28 70 72 69 6e 74 20 20 22 45 52 52 4f (print "ERRO
8040: 52 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d R: Missing argum
8050: 65 6e 74 73 20 61 72 65 61 21 21 22 20 29 0a 09 ents area!!" )..
8060: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
8070: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 70 75 (spu
8080: 62 6c 69 73 68 3a 73 68 65 6c 6c 20 61 72 65 61 blish:shell area
8090: 29 29 29 20 0a 20 20 20 20 20 20 28 65 6c 73 65 ))) . (else
80a0: 20 28 70 72 69 6e 74 20 22 55 6e 72 65 63 6f 67 (print "Unrecog
80b0: 6e 69 73 65 64 20 63 6f 6d 6d 61 6e 64 20 22 20 nised command "
80c0: 61 63 74 69 6f 6e 29 29 29 29 29 0a 20 20 0a 3b action))))). .;
80d0: 3b 20 65 61 73 65 20 64 65 62 75 67 67 69 6e 67 ; ease debugging
80e0: 20 62 79 20 6c 6f 61 64 69 6e 67 20 7e 2f 2e 64 by loading ~/.d
80f0: 61 73 68 62 6f 61 72 64 72 63 20 2d 20 52 45 4d ashboardrc - REM
8100: 4f 56 45 20 46 52 4f 4d 20 50 52 4f 44 55 43 54 OVE FROM PRODUCT
8110: 49 4f 4e 21 0a 3b 3b 20 28 6c 65 74 20 28 28 64 ION!.;; (let ((d
8120: 65 62 75 67 63 6f 6e 74 72 6f 6c 66 20 28 63 6f ebugcontrolf (co
8130: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
8140: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f ent-variable "HO
8150: 4d 45 22 29 20 22 2f 2e 73 70 75 62 6c 69 73 68 ME") "/.spublish
8160: 72 63 22 29 29 29 0a 3b 3b 20 20 20 28 69 66 20 rc"))).;; (if
8170: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 65 (file-exists? de
8180: 62 75 67 63 6f 6e 74 72 6f 6c 66 29 0a 3b 3b 20 bugcontrolf).;;
8190: 20 20 20 20 20 20 28 6c 6f 61 64 20 64 65 62 75 (load debu
81a0: 67 63 6f 6e 74 72 6f 6c 66 29 29 29 0a 0a 28 64 gcontrolf)))..(d
81b0: 65 66 69 6e 65 20 28 6d 61 69 6e 29 0a 20 20 28 efine (main). (
81c0: 6c 65 74 2a 20 28 28 61 72 67 73 20 20 20 20 20 let* ((args
81d0: 20 28 61 72 67 76 29 29 0a 09 20 28 70 72 6f 67 (argv)).. (prog
81e0: 20 20 20 20 20 20 28 63 61 72 20 61 72 67 73 29 (car args)
81f0: 29 0a 09 20 28 72 65 6d 61 20 20 20 20 20 20 28 ).. (rema (
8200: 63 64 72 20 61 72 67 73 29 29 0a 09 20 28 65 78 cdr args)).. (ex
8210: 65 2d 6e 61 6d 65 20 20 28 70 61 74 68 6e 61 6d e-name (pathnam
8220: 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 67 e-file (car (arg
8230: 76 29 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 v))))). (cond
8240: 0a 20 20 20 20 20 3b 3b 20 6f 6e 65 2d 77 6f 72 . ;; one-wor
8250: 64 20 63 6f 6d 6d 61 6e 64 73 0a 20 20 20 20 20 d commands.
8260: 28 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 72 65 ((eq? (length re
8270: 6d 61 29 20 31 29 0a 20 20 20 20 20 20 28 63 61 ma) 1). (ca
8280: 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
8290: 6f 6c 20 28 63 61 72 20 72 65 6d 61 29 29 0a 09 ol (car rema))..
82a0: 28 28 68 65 6c 70 20 2d 68 20 2d 68 65 6c 70 20 ((help -h -help
82b0: 2d 2d 68 20 2d 2d 68 65 6c 70 29 0a 09 20 28 70 --h --help).. (p
82c0: 72 69 6e 74 20 73 70 75 62 6c 69 73 68 3a 68 65 rint spublish:he
82d0: 6c 70 29 29 0a 09 28 65 6c 73 65 0a 09 20 28 70 lp))..(else.. (p
82e0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 55 6e 72 rint "ERROR: Unr
82f0: 65 63 6f 67 6e 69 73 65 64 20 63 6f 6d 6d 61 6e ecognised comman
8300: 64 2e 20 54 72 79 20 5c 22 73 70 75 62 6c 69 73 d. Try \"spublis
8310: 68 20 68 65 6c 70 5c 22 22 29 29 29 29 0a 20 20 h help\"")))).
8320: 20 20 20 3b 3b 20 6d 75 6c 74 69 2d 77 6f 72 64 ;; multi-word
8330: 20 63 6f 6d 6d 61 6e 64 73 0a 20 20 20 20 20 28 commands. (
8340: 28 6e 75 6c 6c 3f 20 72 65 6d 61 29 28 70 72 69 (null? rema)(pri
8350: 6e 74 20 73 70 75 62 6c 69 73 68 3a 68 65 6c 70 nt spublish:help
8360: 29 29 0a 20 20 20 20 20 28 28 3e 3d 20 28 6c 65 )). ((>= (le
8370: 6e 67 74 68 20 72 65 6d 61 29 20 32 29 0a 20 20 ngth rema) 2).
8380: 20 20 20 20 28 61 70 70 6c 79 20 73 70 75 62 6c (apply spubl
8390: 69 73 68 3a 70 72 6f 63 65 73 73 2d 61 63 74 69 ish:process-acti
83a0: 6f 6e 20 28 63 61 72 20 72 65 6d 61 29 28 63 64 on (car rema)(cd
83b0: 72 20 72 65 6d 61 29 29 29 0a 20 20 20 20 20 28 r rema))). (
83c0: 65 6c 73 65 20 28 70 72 69 6e 74 20 22 45 52 52 else (print "ERR
83d0: 4f 52 3a 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 OR: Unrecognised
83e0: 20 63 6f 6d 6d 61 6e 64 32 2e 20 54 72 79 20 5c command2. Try \
83f0: 22 73 70 75 62 6c 69 73 68 20 68 65 6c 70 5c 22 "spublish help\"
8400: 22 29 29 29 29 29 0a 0a 28 6d 61 69 6e 29 0a ")))))..(main).