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 73 73 nses/>...(use ss
0300: 61 78 29 0a 28 75 73 65 20 73 78 6d 6c 2d 73 65 ax).(use sxml-se
0310: 72 69 61 6c 69 7a 65 72 29 0a 28 75 73 65 20 73 rializer).(use s
0320: 78 6d 6c 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e xml-modification
0330: 73 29 0a 28 75 73 65 20 72 65 67 65 78 29 0a 28 s).(use regex).(
0340: 75 73 65 20 73 72 66 69 2d 36 39 29 0a 28 75 73 use srfi-69).(us
0350: 65 20 72 65 67 65 78 2d 63 61 73 65 29 0a 28 75 e regex-case).(u
0360: 73 65 20 70 6f 73 69 78 29 0a 28 75 73 65 20 6a se posix).(use j
0370: 73 6f 6e 29 0a 28 75 73 65 20 63 73 76 29 0a 28 son).(use csv).(
0380: 75 73 65 20 73 72 66 69 2d 31 38 29 0a 28 75 73 use srfi-18).(us
0390: 65 20 66 6f 72 6d 61 74 29 0a 0a 28 72 65 71 75 e format)..(requ
03a0: 69 72 65 2d 6c 69 62 72 61 72 79 20 69 75 70 29 ire-library iup)
03b0: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
03c0: 20 69 75 70 20 69 75 70 3a 29 29 0a 28 72 65 71 iup iup:)).(req
03d0: 75 69 72 65 2d 6c 69 62 72 61 72 79 20 69 6e 69 uire-library ini
03e0: 2d 66 69 6c 65 29 0a 28 69 6d 70 6f 72 74 20 28 -file).(import (
03f0: 70 72 65 66 69 78 20 69 6e 69 2d 66 69 6c 65 20 prefix ini-file
0400: 69 6e 69 3a 29 29 0a 0a 28 75 73 65 20 63 61 6e ini:))..(use can
0410: 76 61 73 2d 64 72 61 77 29 0a 28 69 6d 70 6f 72 vas-draw).(impor
0420: 74 20 63 61 6e 76 61 73 2d 64 72 61 77 2d 69 75 t canvas-draw-iu
0430: 70 29 0a 0a 28 75 73 65 20 73 71 6c 69 74 65 33 p)..(use sqlite3
0440: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
0450: 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 gex regex-case s
0460: 72 66 69 2d 36 39 29 0a 28 69 6d 70 6f 72 74 20 rfi-69).(import
0470: 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 (prefix sqlite3
0480: 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 sqlite3:))..(dec
0490: 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 lare (uses confi
04a0: 67 66 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 gf)).(declare (u
04b0: 73 65 73 20 74 72 65 65 29 29 0a 28 64 65 63 6c ses tree)).(decl
04c0: 61 72 65 20 28 75 73 65 73 20 6d 61 72 67 73 29 are (uses margs)
04d0: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
04e0: 73 65 73 20 64 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b ses dcommon)).;;
04f0: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0500: 6c 61 75 6e 63 68 29 29 0a 3b 3b 20 28 64 65 63 launch)).;; (dec
0510: 6c 61 72 65 20 28 75 73 65 73 20 67 75 74 69 6c lare (uses gutil
0520: 73 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 s)).;; (declare
0530: 28 75 73 65 73 20 64 62 29 29 0a 3b 3b 20 28 64 (uses db)).;; (d
0540: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 79 6e eclare (uses syn
0550: 63 68 61 73 68 29 29 0a 3b 3b 20 28 64 65 63 6c chash)).;; (decl
0560: 61 72 65 20 28 75 73 65 73 20 73 65 72 76 65 72 are (uses server
0570: 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 )).;; (declare (
0580: 75 73 65 73 20 6d 65 67 61 74 65 73 74 2d 76 65 uses megatest-ve
0590: 72 73 69 6f 6e 29 29 0a 3b 3b 20 28 64 65 63 6c rsion)).;; (decl
05a0: 61 72 65 20 28 75 73 65 73 20 74 62 64 29 29 0a are (uses tbd)).
05b0: 0a 28 69 6e 63 6c 75 64 65 20 22 6d 65 67 61 74 .(include "megat
05c0: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 2e est-fossil-hash.
05d0: 73 63 6d 22 29 0a 0a 3b 3b 0a 3b 3b 20 47 4c 4f scm")..;;.;; GLO
05e0: 42 41 4c 53 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 BALS.;;.(define
05f0: 2a 64 61 74 61 73 68 61 72 65 3a 63 75 72 72 65 *datashare:curre
0600: 6e 74 2d 74 61 62 2d 6e 75 6d 62 65 72 2a 20 30 nt-tab-number* 0
0610: 29 0a 28 64 65 66 69 6e 65 20 2a 61 72 67 73 2d ).(define *args-
0620: 68 61 73 68 2a 20 28 6d 61 6b 65 2d 68 61 73 68 hash* (make-hash
0630: 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 -table)).(define
0640: 20 64 61 74 61 73 68 61 72 65 3a 68 65 6c 70 20 datashare:help
0650: 28 63 6f 6e 63 20 22 55 73 61 67 65 3a 20 64 61 (conc "Usage: da
0660: 74 61 73 68 61 72 65 20 5b 61 63 74 69 6f 6e 20 tashare [action
0670: 5b 70 61 72 61 6d 73 20 2e 2e 2e 5d 5d 0a 0a 4e [params ...]]..N
0680: 6f 74 65 3a 20 72 75 6e 20 64 61 74 61 73 68 61 ote: run datasha
0690: 72 65 20 77 69 74 68 6f 75 74 20 70 61 72 61 6d re without param
06a0: 65 74 65 72 73 20 74 6f 20 73 74 61 72 74 20 74 eters to start t
06b0: 68 65 20 67 75 69 2e 0a 0a 20 20 6c 69 73 74 2d he gui... list-
06c0: 61 72 65 61 73 20 20 20 20 20 20 20 20 20 20 20 areas
06d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a :
06e0: 20 4c 69 73 74 20 74 68 65 20 61 6c 6c 6f 77 65 List the allowe
06f0: 64 20 61 72 65 61 73 0a 0a 20 20 6c 69 73 74 2d d areas.. list-
0700: 76 65 72 73 69 6f 6e 73 20 3c 61 72 65 61 3e 20 versions <area>
0710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a :
0720: 20 4c 69 73 74 20 76 65 72 73 69 6f 6e 73 20 61 List versions a
0730: 76 61 69 6c 61 62 6c 65 20 69 6e 20 3c 61 72 65 vailable in <are
0740: 61 3e 0a 20 20 20 20 20 20 20 20 20 6f 70 74 69 a>. opti
0750: 6f 6e 73 20 3a 20 2d 66 75 6c 6c 2c 20 2d 76 70 ons : -full, -vp
0760: 61 74 74 20 70 61 74 74 0a 0a 20 20 70 75 62 6c att patt.. publ
0770: 69 73 68 20 3c 70 61 74 68 3e 20 3c 61 72 65 61 ish <path> <area
0780: 3e 20 3c 76 65 72 73 69 6f 6e 3e 20 20 20 20 20 > <version>
0790: 3a 20 50 75 62 6c 69 73 68 20 64 61 74 61 20 66 : Publish data f
07a0: 6f 72 20 61 72 65 61 20 61 6e 64 20 77 69 74 68 or area and with
07b0: 20 76 65 72 73 69 6f 6e 0a 0a 20 20 67 65 74 20 version.. get
07c0: 3c 61 72 65 61 3e 20 3c 76 65 72 73 69 6f 6e 3e <area> <version>
07d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
07e0: 3a 20 47 65 74 20 61 20 6c 69 6e 6b 20 74 6f 20 : Get a link to
07f0: 64 61 74 61 2c 20 70 75 74 20 74 68 65 20 6c 69 data, put the li
0800: 6e 6b 20 69 6e 20 64 65 73 74 70 61 74 68 0a 20 nk in destpath.
0810: 20 20 20 20 20 20 20 20 6f 70 74 69 6f 6e 73 20 options
0820: 3a 20 2d 69 20 69 74 65 72 61 74 69 6f 6e 0a 0a : -i iteration..
0830: 20 20 75 70 64 61 74 65 20 3c 61 72 65 61 3e 20 update <area>
0840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0850: 20 20 20 20 20 20 3a 20 55 70 64 61 74 65 20 74 : Update t
0860: 68 65 20 6c 69 6e 6b 20 74 6f 20 64 61 74 61 20 he link to data
0870: 74 6f 20 74 68 65 20 6c 61 74 65 73 74 20 69 74 to the latest it
0880: 65 72 61 74 69 6f 6e 2e 0a 0a 50 61 72 74 20 6f eration...Part o
0890: 66 20 74 68 65 20 4d 65 67 61 74 65 73 74 20 74 f the Megatest t
08a0: 6f 6f 6c 20 73 75 69 74 65 2e 0a 4c 65 61 72 6e ool suite..Learn
08b0: 20 6d 6f 72 65 20 61 74 20 68 74 74 70 3a 2f 2f more at http://
08c0: 77 77 77 2e 6b 69 61 74 6f 61 2e 63 6f 6d 2f 66 www.kiatoa.com/f
08d0: 6f 73 73 69 6c 73 2f 6d 65 67 61 74 65 73 74 0a ossils/megatest.
08e0: 0a 56 65 72 73 69 6f 6e 3a 20 22 20 6d 65 67 61 .Version: " mega
08f0: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
0900: 29 29 20 3b 3b 20 22 0a 0a 3b 3b 3d 3d 3d 3d 3d )) ;; "..;;=====
0910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0950: 3d 0a 3b 3b 20 52 45 43 4f 52 44 53 0a 3b 3b 3d =.;; RECORDS.;;=
0960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
09a0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 =====..;; make-v
09b0: 65 63 74 6f 72 2d 72 65 63 6f 72 64 20 22 74 65 ector-record "te
09c0: 73 74 69 6e 67 22 20 64 61 74 61 73 74 6f 72 65 sting" datastore
09d0: 20 70 6b 67 20 69 64 20 61 72 65 61 20 76 65 72 pkg id area ver
09e0: 73 69 6f 6e 5f 6e 61 6d 65 20 73 74 6f 72 65 5f sion_name store_
09f0: 74 79 70 65 20 63 6f 70 69 65 64 20 73 6f 75 72 type copied sour
0a00: 63 65 5f 70 61 74 68 20 69 74 65 72 61 74 69 6f ce_path iteratio
0a10: 6e 20 73 75 62 6d 69 74 74 65 72 20 64 61 74 65 n submitter date
0a20: 74 69 6d 65 20 73 74 6f 72 65 67 72 70 20 64 61 time storegrp da
0a30: 74 61 76 6f 6c 20 71 75 61 6c 69 74 79 20 64 69 tavol quality di
0a40: 73 6b 5f 69 64 20 63 6f 6d 6d 65 6e 74 0a 3b 3b sk_id comment.;;
0a50: 20 74 65 73 74 69 6e 67 0a 28 64 65 66 69 6e 65 testing.(define
0a60: 20 28 6d 61 6b 65 2d 64 61 74 61 73 68 61 72 65 (make-datashare
0a70: 3a 70 6b 67 29 28 6d 61 6b 65 2d 76 65 63 74 6f :pkg)(make-vecto
0a80: 72 20 31 35 29 29 0a 28 64 65 66 69 6e 65 2d 69 r 15)).(define-i
0a90: 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 nline (datashare
0aa0: 3a 70 6b 67 2d 67 65 74 2d 69 64 20 20 20 20 20 :pkg-get-id
0ab0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
0ac0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0ad0: 20 30 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 0)).(define-inl
0ae0: 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 ine (datashare:p
0af0: 6b 67 2d 67 65 74 2d 61 72 65 61 20 20 20 20 20 kg-get-area
0b00: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0b10: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
0b20: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0b30: 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 e (datashare:pkg
0b40: 2d 67 65 74 2d 76 65 72 73 69 6f 6e 5f 6e 61 6d -get-version_nam
0b50: 65 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 e vec) (vec
0b60: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 tor-ref vec 2))
0b70: 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 .(define-inline
0b80: 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 (datashare:pkg-g
0b90: 65 74 2d 73 74 6f 72 65 5f 74 79 70 65 20 20 20 et-store_type
0ba0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0bb0: 72 2d 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 r-ref vec 3)).(
0bc0: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 define-inline (d
0bd0: 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 74 atashare:pkg-get
0be0: 2d 63 6f 70 69 65 64 20 20 20 20 20 20 20 20 20 -copied
0bf0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0c00: 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 ref vec 4)).(de
0c10: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 74 fine-inline (dat
0c20: 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 73 ashare:pkg-get-s
0c30: 6f 75 72 63 65 5f 70 61 74 68 20 20 20 20 76 65 ource_path ve
0c40: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
0c50: 66 20 20 76 65 63 20 35 29 29 0a 28 64 65 66 69 f vec 5)).(defi
0c60: 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 ne-inline (datas
0c70: 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 69 74 65 hare:pkg-get-ite
0c80: 72 61 74 69 6f 6e 20 20 20 20 20 20 76 65 63 29 ration vec)
0c90: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0ca0: 20 76 65 63 20 36 29 29 0a 28 64 65 66 69 6e 65 vec 6)).(define
0cb0: 2d 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 61 -inline (datasha
0cc0: 72 65 3a 70 6b 67 2d 67 65 74 2d 73 75 62 6d 69 re:pkg-get-submi
0cd0: 74 74 65 72 20 20 20 20 20 20 76 65 63 29 20 20 tter vec)
0ce0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
0cf0: 65 63 20 37 29 29 0a 28 64 65 66 69 6e 65 2d 69 ec 7)).(define-i
0d00: 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 nline (datashare
0d10: 3a 70 6b 67 2d 67 65 74 2d 64 61 74 65 74 69 6d :pkg-get-datetim
0d20: 65 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 e vec)
0d30: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
0d40: 20 38 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 8)).(define-inl
0d50: 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 ine (datashare:p
0d60: 6b 67 2d 67 65 74 2d 73 74 6f 72 65 67 72 70 20 kg-get-storegrp
0d70: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
0d80: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 39 ector-ref vec 9
0d90: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
0da0: 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 e (datashare:pkg
0db0: 2d 67 65 74 2d 64 61 74 61 76 6f 6c 20 20 20 20 -get-datavol
0dc0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
0dd0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 30 29 tor-ref vec 10)
0de0: 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 ).(define-inline
0df0: 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d (datashare:pkg-
0e00: 67 65 74 2d 71 75 61 6c 69 74 79 20 20 20 20 20 get-quality
0e10: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
0e20: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 31 29 29 or-ref vec 11))
0e30: 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 .(define-inline
0e40: 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 (datashare:pkg-g
0e50: 65 74 2d 64 69 73 6b 5f 69 64 20 20 20 20 20 20 et-disk_id
0e60: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
0e70: 72 2d 72 65 66 20 20 76 65 63 20 31 32 29 29 0a r-ref vec 12)).
0e80: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
0e90: 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 datashare:pkg-ge
0ea0: 74 2d 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 t-comment
0eb0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
0ec0: 2d 72 65 66 20 20 76 65 63 20 31 33 29 29 0a 28 -ref vec 13)).(
0ed0: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 define-inline (d
0ee0: 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 74 atashare:pkg-get
0ef0: 2d 73 74 6f 72 65 64 5f 70 61 74 68 20 20 20 20 -stored_path
0f00: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
0f10: 72 65 66 20 20 76 65 63 20 31 34 29 29 0a 28 64 ref vec 14)).(d
0f20: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 efine-inline (da
0f30: 74 61 73 68 61 72 65 3a 70 6b 67 2d 73 65 74 2d tashare:pkg-set-
0f40: 69 64 21 20 20 20 20 20 20 20 20 20 20 20 20 76 id! v
0f50: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
0f60: 65 74 21 20 76 65 63 20 30 20 76 61 6c 29 29 0a et! vec 0 val)).
0f70: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
0f80: 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 73 65 datashare:pkg-se
0f90: 74 2d 61 72 65 61 21 20 20 20 20 20 20 20 20 20 t-area!
0fa0: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
0fb0: 2d 73 65 74 21 20 76 65 63 20 31 20 76 61 6c 29 -set! vec 1 val)
0fc0: 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 ).(define-inline
0fd0: 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d (datashare:pkg-
0fe0: 73 65 74 2d 76 65 72 73 69 6f 6e 5f 6e 61 6d 65 set-version_name
0ff0: 21 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 ! vec val)(vect
1000: 6f 72 2d 73 65 74 21 20 76 65 63 20 32 20 76 61 or-set! vec 2 va
1010: 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 l)).(define-inli
1020: 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b ne (datashare:pk
1030: 67 2d 73 65 74 2d 73 74 6f 72 65 5f 74 79 70 65 g-set-store_type
1040: 21 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 ! vec val)(ve
1050: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 33 20 ctor-set! vec 3
1060: 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e val)).(define-in
1070: 6c 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a line (datashare:
1080: 70 6b 67 2d 73 65 74 2d 63 6f 70 69 65 64 21 20 pkg-set-copied!
1090: 20 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 vec val)(
10a0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec
10b0: 34 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 4 val)).(define-
10c0: 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 61 72 inline (datashar
10d0: 65 3a 70 6b 67 2d 73 65 74 2d 73 6f 75 72 63 65 e:pkg-set-source
10e0: 5f 70 61 74 68 21 20 20 20 76 65 63 20 76 61 6c _path! vec val
10f0: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1100: 63 20 35 20 76 61 6c 29 29 0a 28 64 65 66 69 6e c 5 val)).(defin
1110: 65 2d 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 e-inline (datash
1120: 61 72 65 3a 70 6b 67 2d 73 65 74 2d 69 74 65 72 are:pkg-set-iter
1130: 61 74 69 6f 6e 21 20 20 20 20 20 76 65 63 20 76 ation! vec v
1140: 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 al)(vector-set!
1150: 76 65 63 20 36 20 76 61 6c 29 29 0a 28 64 65 66 vec 6 val)).(def
1160: 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 74 61 ine-inline (data
1170: 73 68 61 72 65 3a 70 6b 67 2d 73 65 74 2d 73 75 share:pkg-set-su
1180: 62 6d 69 74 74 65 72 21 20 20 20 20 20 76 65 63 bmitter! vec
1190: 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 val)(vector-set
11a0: 21 20 76 65 63 20 37 20 76 61 6c 29 29 0a 28 64 ! vec 7 val)).(d
11b0: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 efine-inline (da
11c0: 74 61 73 68 61 72 65 3a 70 6b 67 2d 73 65 74 2d tashare:pkg-set-
11d0: 64 61 74 65 74 69 6d 65 21 20 20 20 20 20 20 76 datetime! v
11e0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
11f0: 65 74 21 20 76 65 63 20 38 20 76 61 6c 29 29 0a et! vec 8 val)).
1200: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
1210: 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 73 65 datashare:pkg-se
1220: 74 2d 73 74 6f 72 65 67 72 70 21 20 20 20 20 20 t-storegrp!
1230: 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 vec val)(vector
1240: 2d 73 65 74 21 20 76 65 63 20 39 20 76 61 6c 29 -set! vec 9 val)
1250: 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 ).(define-inline
1260: 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d (datashare:pkg-
1270: 73 65 74 2d 64 61 74 61 76 6f 6c 21 20 20 20 20 set-datavol!
1280: 20 20 20 76 65 63 20 76 61 6c 29 28 76 65 63 74 vec val)(vect
1290: 6f 72 2d 73 65 74 21 20 76 65 63 20 31 30 20 76 or-set! vec 10 v
12a0: 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c al)).(define-inl
12b0: 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 70 ine (datashare:p
12c0: 6b 67 2d 73 65 74 2d 71 75 61 6c 69 74 79 21 20 kg-set-quality!
12d0: 20 20 20 20 20 20 76 65 63 20 76 61 6c 29 28 76 vec val)(v
12e0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 31 ector-set! vec 1
12f0: 31 20 76 61 6c 29 29 0a 28 64 65 66 69 6e 65 2d 1 val)).(define-
1300: 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 68 61 72 inline (datashar
1310: 65 3a 70 6b 67 2d 73 65 74 2d 64 69 73 6b 5f 69 e:pkg-set-disk_i
1320: 64 21 20 20 20 20 20 20 20 76 65 63 20 76 61 6c d! vec val
1330: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 )(vector-set! ve
1340: 63 20 31 32 20 76 61 6c 29 29 0a 28 64 65 66 69 c 12 val)).(defi
1350: 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 74 61 73 ne-inline (datas
1360: 68 61 72 65 3a 70 6b 67 2d 73 65 74 2d 63 6f 6d hare:pkg-set-com
1370: 6d 65 6e 74 21 20 20 20 20 20 20 20 76 65 63 20 ment! vec
1380: 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 65 74 21 val)(vector-set!
1390: 20 76 65 63 20 31 33 20 76 61 6c 29 29 0a 28 64 vec 13 val)).(d
13a0: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 61 efine-inline (da
13b0: 74 61 73 68 61 72 65 3a 70 6b 67 2d 73 65 74 2d tashare:pkg-set-
13c0: 73 74 6f 72 65 64 5f 70 61 74 68 21 20 20 20 76 stored_path! v
13d0: 65 63 20 76 61 6c 29 28 76 65 63 74 6f 72 2d 73 ec val)(vector-s
13e0: 65 74 21 20 76 65 63 20 31 34 20 76 61 6c 29 29 et! vec 14 val))
13f0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 42 ==========.;; DB
1440: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1490: 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 69 6e ne (datashare:in
14a0: 69 74 69 61 6c 69 7a 65 2d 64 62 20 64 62 29 0a itialize-db db).
14b0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 28 (for-each. (
14c0: 6c 61 6d 62 64 61 20 28 71 72 79 29 0a 20 20 20 lambda (qry).
14d0: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
14e0: 74 65 20 64 62 20 71 72 79 29 29 0a 20 20 20 28 te db qry)). (
14f0: 6c 69 73 74 20 0a 20 20 20 20 22 43 52 45 41 54 list . "CREAT
1500: 45 20 54 41 42 4c 45 20 70 6b 67 73 20 0a 20 20 E TABLE pkgs .
1510: 20 20 20 20 20 20 20 28 69 64 20 20 20 20 20 20 (id
1520: 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 49 INTEGER PRI
1530: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
1540: 20 20 20 20 61 72 65 61 20 20 20 20 20 20 20 20 area
1550: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
1560: 20 76 65 72 73 69 6f 6e 5f 6e 61 6d 65 20 54 45 version_name TE
1570: 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 73 74 XT,. st
1580: 6f 72 65 5f 74 79 70 65 20 20 20 54 45 58 54 20 ore_type TEXT
1590: 44 45 46 41 55 4c 54 20 27 63 6f 70 79 27 2c 0a DEFAULT 'copy',.
15a0: 20 20 20 20 20 20 20 20 20 20 63 6f 70 69 65 64 copied
15b0: 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 44 INTEGER D
15c0: 45 46 41 55 4c 54 20 30 2c 0a 20 20 20 20 20 20 EFAULT 0,.
15d0: 20 20 20 20 73 6f 75 72 63 65 5f 70 61 74 68 20 source_path
15e0: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
15f0: 20 73 74 6f 72 65 64 5f 70 61 74 68 20 20 54 45 stored_path TE
1600: 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 69 74 XT,. it
1610: 65 72 61 74 69 6f 6e 20 20 20 20 49 4e 54 45 47 eration INTEG
1620: 45 52 20 44 45 46 41 55 4c 54 20 30 2c 0a 20 20 ER DEFAULT 0,.
1630: 20 20 20 20 20 20 20 20 73 75 62 6d 69 74 74 65 submitte
1640: 72 20 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 r TEXT,.
1650: 20 20 20 20 20 64 61 74 65 74 69 6d 65 20 20 20 datetime
1660: 20 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 TIMESTAMP DEFA
1670: 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 ULT (strftime('%
1680: 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 20 20 s','now')),.
1690: 20 20 20 20 20 20 73 74 6f 72 65 67 72 70 20 20 storegrp
16a0: 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 TEXT,.
16b0: 20 20 20 64 61 74 61 76 6f 6c 20 20 20 20 20 20 datavol
16c0: 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
16d0: 20 20 20 71 75 61 6c 69 74 79 20 20 20 20 20 20 quality
16e0: 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 TEXT,.
16f0: 64 69 73 6b 5f 69 64 20 20 20 20 20 20 49 4e 54 disk_id INT
1700: 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 EGER,.
1710: 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 54 45 58 comment TEX
1720: 54 29 3b 22 0a 20 20 20 20 22 43 52 45 41 54 45 T);". "CREATE
1730: 20 54 41 42 4c 45 20 72 65 66 73 0a 20 20 20 20 TABLE refs.
1740: 20 20 20 20 20 28 69 64 20 20 20 20 20 20 20 20 (id
1750: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
1760: 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 70 KEY,. p
1770: 6b 67 5f 69 64 20 20 20 20 49 4e 54 45 47 45 52 kg_id INTEGER
1780: 2c 0a 20 20 20 20 20 20 20 20 20 20 64 65 73 74 ,. dest
1790: 6c 69 6e 6b 20 20 54 45 58 54 29 3b 22 0a 20 20 link TEXT);".
17a0: 20 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 "CREATE TABLE
17b0: 64 69 73 6b 73 0a 20 20 20 20 20 20 20 20 20 28 disks. (
17c0: 69 64 20 20 20 20 20 20 20 20 20 49 4e 54 45 47 id INTEG
17d0: 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a ER PRIMARY KEY,.
17e0: 20 20 20 20 20 20 20 20 20 20 73 74 6f 72 65 67 storeg
17f0: 72 70 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 rp TEXT,.
1800: 20 20 20 20 20 70 61 74 68 20 20 20 20 20 20 20 path
1810: 54 45 58 54 29 3b 22 29 29 29 0a 0a 28 64 65 66 TEXT);")))..(def
1820: 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 72 ine (datashare:r
1830: 65 67 69 73 74 65 72 2d 64 61 74 61 20 64 62 20 egister-data db
1840: 61 72 65 61 20 76 65 72 73 69 6f 6e 2d 6e 61 6d area version-nam
1850: 65 20 73 74 6f 72 65 2d 74 79 70 65 20 73 75 62 e store-type sub
1860: 6d 69 74 74 65 72 20 71 75 61 6c 69 74 79 20 73 mitter quality s
1870: 6f 75 72 63 65 2d 70 61 74 68 20 63 6f 6d 6d 65 ource-path comme
1880: 6e 74 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 nt). (let ((ite
1890: 72 2d 71 72 79 20 20 20 20 20 20 20 28 73 71 6c r-qry (sql
18a0: 69 74 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 ite3:prepare db
18b0: 22 53 45 4c 45 43 54 20 6d 61 78 28 69 74 65 72 "SELECT max(iter
18c0: 61 74 69 6f 6e 29 20 46 52 4f 4d 20 70 6b 67 73 ation) FROM pkgs
18d0: 20 57 48 45 52 45 20 61 72 65 61 3d 3f 20 41 4e WHERE area=? AN
18e0: 44 20 76 65 72 73 69 6f 6e 5f 6e 61 6d 65 3d 3f D version_name=?
18f0: 3b 22 29 29 0a 09 28 6e 65 78 74 2d 69 74 65 72 ;"))..(next-iter
1900: 61 74 69 6f 6e 20 30 29 29 0a 20 20 20 20 28 73 ation 0)). (s
1910: 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e qlite3:with-tran
1920: 73 61 63 74 69 6f 6e 0a 20 20 20 20 20 64 62 0a saction. db.
1930: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
1940: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
1950: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c for-each-row..(l
1960: 61 6d 62 64 61 20 28 69 74 65 72 61 74 69 6f 6e ambda (iteration
1970: 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ).. (if (and (n
1980: 75 6d 62 65 72 3f 20 69 74 65 72 61 74 69 6f 6e umber? iteration
1990: 29 0a 09 09 20 20 20 28 3e 3d 20 69 74 65 72 61 )... (>= itera
19a0: 74 69 6f 6e 20 6e 65 78 74 2d 69 74 65 72 61 74 tion next-iterat
19b0: 69 6f 6e 29 29 0a 09 20 20 20 20 20 20 28 73 65 ion)).. (se
19c0: 74 21 20 6e 65 78 74 2d 69 74 65 72 61 74 69 6f t! next-iteratio
19d0: 6e 20 28 2b 20 69 74 65 72 61 74 69 6f 6e 20 31 n (+ iteration 1
19e0: 29 29 29 29 0a 09 69 74 65 72 2d 71 72 79 20 61 ))))..iter-qry a
19f0: 72 65 61 20 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 rea version-name
1a00: 29 0a 20 20 20 20 20 20 20 3b 3b 20 6e 6f 77 20 ). ;; now
1a10: 73 74 6f 72 65 20 74 68 65 20 64 61 74 61 0a 20 store the data.
1a20: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 (sqlite3:e
1a30: 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 xecute db "INSER
1a40: 54 20 49 4e 54 4f 20 70 6b 67 73 20 28 61 72 65 T INTO pkgs (are
1a50: 61 2c 76 65 72 73 69 6f 6e 5f 6e 61 6d 65 2c 69 a,version_name,i
1a60: 74 65 72 61 74 69 6f 6e 2c 73 74 6f 72 65 5f 74 teration,store_t
1a70: 79 70 65 2c 73 75 62 6d 69 74 74 65 72 2c 73 6f ype,submitter,so
1a80: 75 72 63 65 5f 70 61 74 68 2c 71 75 61 6c 69 74 urce_path,qualit
1a90: 79 2c 63 6f 6d 6d 65 6e 74 29 20 0a 20 20 20 20 y,comment) .
1aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 56 41 4c VAL
1ac0: 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f UES (?,?,?,?,?,?
1ad0: 2c 3f 2c 3f 29 3b 22 0a 09 09 09 61 72 65 61 20 ,?,?);"....area
1ae0: 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 20 6e 65 78 version-name nex
1af0: 74 2d 69 74 65 72 61 74 69 6f 6e 20 28 63 6f 6e t-iteration (con
1b00: 63 20 73 74 6f 72 65 2d 74 79 70 65 29 20 73 75 c store-type) su
1b10: 62 6d 69 74 74 65 72 20 73 6f 75 72 63 65 2d 70 bmitter source-p
1b20: 61 74 68 20 71 75 61 6c 69 74 79 20 63 6f 6d 6d ath quality comm
1b30: 65 6e 74 29 29 29 0a 20 20 20 20 28 73 71 6c 69 ent))). (sqli
1b40: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 69 74 te3:finalize! it
1b50: 65 72 2d 71 72 79 29 0a 20 20 20 20 6e 65 78 74 er-qry). next
1b60: 2d 69 74 65 72 61 74 69 6f 6e 29 29 0a 0a 28 64 -iteration))..(d
1b70: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
1b80: 3a 67 65 74 2d 69 64 20 64 62 20 61 72 65 61 20 :get-id db area
1b90: 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 20 69 74 65 version-name ite
1ba0: 72 61 74 69 6f 6e 29 0a 20 20 28 6c 65 74 20 28 ration). (let (
1bb0: 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 73 (res #f)). (s
1bc0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
1bd0: 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 row. (lambda
1be0: 20 28 69 64 29 0a 20 20 20 20 20 20 20 28 73 65 (id). (se
1bf0: 74 21 20 72 65 73 20 69 64 29 29 0a 20 20 20 20 t! res id)).
1c00: 20 64 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 db. "SELECT
1c10: 20 69 64 20 46 52 4f 4d 20 70 6b 67 73 20 57 48 id FROM pkgs WH
1c20: 45 52 45 20 61 72 65 61 3d 3f 20 41 4e 44 20 76 ERE area=? AND v
1c30: 65 72 73 69 6f 6e 5f 6e 61 6d 65 3d 3f 20 41 4e ersion_name=? AN
1c40: 44 20 69 74 65 72 61 74 69 6f 6e 3d 3f 3b 22 0a D iteration=?;".
1c50: 20 20 20 20 20 61 72 65 61 20 76 65 72 73 69 6f area versio
1c60: 6e 2d 6e 61 6d 65 20 69 74 65 72 61 74 69 6f 6e n-name iteration
1c70: 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 ). res))..(de
1c80: 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a fine (datashare:
1c90: 73 65 74 2d 73 74 6f 72 65 64 2d 70 61 74 68 20 set-stored-path
1ca0: 64 62 20 69 64 20 70 61 74 68 29 0a 20 20 28 73 db id path). (s
1cb0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
1cc0: 62 20 22 55 50 44 41 54 45 20 70 6b 67 73 20 53 b "UPDATE pkgs S
1cd0: 45 54 20 73 74 6f 72 65 64 5f 70 61 74 68 3d 3f ET stored_path=?
1ce0: 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 20 70 61 WHERE id=?;" pa
1cf0: 74 68 20 69 64 29 29 0a 0a 28 64 65 66 69 6e 65 th id))..(define
1d00: 20 28 64 61 74 61 73 68 61 72 65 3a 73 65 74 2d (datashare:set-
1d10: 63 6f 70 69 65 64 20 64 62 20 69 64 20 76 61 6c copied db id val
1d20: 75 65 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 ue). (sqlite3:e
1d30: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
1d40: 45 20 70 6b 67 73 20 53 45 54 20 63 6f 70 69 65 E pkgs SET copie
1d50: 64 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 d=? WHERE id=?;"
1d60: 20 76 61 6c 75 65 20 69 64 29 29 0a 20 20 0a 28 value id)). .(
1d70: 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 define (datashar
1d80: 65 3a 67 65 74 2d 70 6b 67 2d 72 65 63 6f 72 64 e:get-pkg-record
1d90: 20 64 62 20 61 72 65 61 20 76 65 72 73 69 6f 6e db area version
1da0: 2d 6e 61 6d 65 20 69 74 65 72 61 74 69 6f 6e 29 -name iteration)
1db0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
1dc0: 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a )). (sqlite3:
1dd0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 for-each-row.
1de0: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 (lambda (a . b
1df0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
1e00: 65 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 es (apply vector
1e10: 20 61 20 62 29 29 29 0a 20 20 20 20 20 64 62 20 a b))). db
1e20: 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 2a 20 . "SELECT *
1e30: 46 52 4f 4d 20 70 6b 67 73 20 57 48 45 52 45 20 FROM pkgs WHERE
1e40: 61 72 65 61 3d 3f 20 41 4e 44 20 76 65 72 73 69 area=? AND versi
1e50: 6f 6e 5f 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 on_name=? AND it
1e60: 65 72 61 74 69 6f 6e 3d 3f 3b 22 0a 20 20 20 20 eration=?;".
1e70: 20 61 72 65 61 20 0a 20 20 20 20 20 76 65 72 73 area . vers
1e80: 69 6f 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 69 74 ion-name. it
1e90: 65 72 61 74 69 6f 6e 29 0a 20 20 20 20 72 65 73 eration). res
1ea0: 29 29 0a 0a 3b 3b 20 74 61 6b 65 20 76 65 72 73 ))..;; take vers
1eb0: 69 6f 6e 2d 6e 61 6d 65 20 69 74 65 72 61 74 69 ion-name iterati
1ec0: 6f 6e 20 61 6e 64 20 72 65 67 69 73 74 65 72 20 on and register
1ed0: 6f 72 20 75 70 64 61 74 65 20 22 6c 61 73 74 65 or update "laste
1ee0: 73 74 2f 30 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 st/0".;;.(define
1ef0: 20 28 64 61 74 61 73 68 61 72 65 3a 73 65 74 2d (datashare:set-
1f00: 6c 61 74 65 73 74 20 64 62 20 69 64 20 61 72 65 latest db id are
1f10: 61 20 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 20 69 a version-name i
1f20: 74 65 72 61 74 69 6f 6e 29 0a 20 20 28 6c 65 74 teration). (let
1f30: 2a 20 28 28 72 65 63 20 20 20 20 20 20 20 20 20 * ((rec
1f40: 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 2d 70 (datashare:get-p
1f50: 6b 67 2d 72 65 63 6f 72 64 20 64 62 20 61 72 65 kg-record db are
1f60: 61 20 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 20 69 a version-name i
1f70: 74 65 72 61 74 69 6f 6e 29 29 0a 09 20 28 6c 61 teration)).. (la
1f80: 74 65 73 74 2d 69 64 20 20 20 28 64 61 74 61 73 test-id (datas
1f90: 68 61 72 65 3a 67 65 74 2d 69 64 20 64 62 20 61 hare:get-id db a
1fa0: 72 65 61 20 22 6c 61 74 65 73 74 22 20 30 29 29 rea "latest" 0))
1fb0: 0a 09 20 28 73 74 6f 72 65 64 2d 70 61 74 68 20 .. (stored-path
1fc0: 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 (datashare:pkg-g
1fd0: 65 74 2d 73 74 6f 72 65 64 5f 70 61 74 68 20 72 et-stored_path r
1fe0: 65 63 29 29 29 0a 20 20 20 20 28 69 66 20 6c 61 ec))). (if la
1ff0: 74 65 73 74 2d 69 64 20 3b 3b 20 68 61 76 65 20 test-id ;; have
2000: 61 20 72 65 63 6f 72 64 20 2d 20 62 75 6d 70 20 a record - bump
2010: 74 68 65 20 6c 69 6e 6b 20 70 6f 69 6e 74 65 72 the link pointer
2020: 0a 09 28 64 61 74 61 73 68 61 72 65 3a 73 65 74 ..(datashare:set
2030: 2d 73 74 6f 72 65 64 2d 70 61 74 68 20 64 62 20 -stored-path db
2040: 6c 61 74 65 73 74 2d 69 64 20 73 74 6f 72 65 64 latest-id stored
2050: 2d 70 61 74 68 29 0a 09 28 64 61 74 61 73 68 61 -path)..(datasha
2060: 72 65 3a 72 65 67 69 73 74 65 72 2d 64 61 74 61 re:register-data
2070: 20 64 62 20 61 72 65 61 20 22 6c 61 74 65 73 74 db area "latest
2080: 22 20 27 6c 69 6e 6b 20 22 61 75 74 6f 22 20 22 " 'link "auto" "
2090: 6e 61 22 20 73 74 6f 72 65 64 2d 70 61 74 68 20 na" stored-path
20a0: 22 6c 61 74 65 73 74 20 64 61 74 61 22 29 29 29 "latest data")))
20b0: 29 0a 0a 3b 3b 20 73 65 74 20 61 20 70 61 63 6b )..;; set a pack
20c0: 61 67 65 20 72 65 66 2c 20 74 68 69 73 20 69 73 age ref, this is
20d0: 20 74 68 65 20 6c 6f 63 61 74 69 6f 6e 20 77 68 the location wh
20e0: 65 72 65 20 74 68 65 20 6c 69 6e 6b 20 62 61 63 ere the link bac
20f0: 6b 20 74 6f 20 74 68 65 20 73 74 6f 72 65 64 20 k to the stored
2100: 64 61 74 61 20 0a 3b 3b 20 69 73 20 70 75 74 2e data .;; is put.
2110: 20 0a 3b 3b 0a 3b 3b 20 69 66 20 74 68 65 72 65 .;;.;; if there
2120: 20 69 73 20 6e 6f 74 68 69 6e 67 20 61 74 20 74 is nothing at t
2130: 68 61 74 20 6c 6f 63 61 74 69 6f 6e 20 74 68 65 hat location the
2140: 6e 20 74 68 65 20 72 65 63 6f 72 64 20 63 61 6e n the record can
2150: 20 62 65 20 72 65 6d 6f 76 65 64 0a 3b 3b 20 69 be removed.;; i
2160: 66 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 72 f there are no r
2170: 65 66 73 20 66 6f 72 20 61 20 70 61 72 74 69 63 efs for a partic
2180: 75 6c 61 72 20 70 6b 67 2d 69 64 20 74 68 65 6e ular pkg-id then
2190: 20 74 68 61 74 20 70 6b 67 2d 69 64 20 69 73 20 that pkg-id is
21a0: 61 20 0a 3b 3b 20 63 61 6e 64 69 64 61 74 65 20 a .;; candidate
21b0: 66 6f 72 20 72 65 6d 6f 76 61 6c 0a 3b 3b 0a 28 for removal.;;.(
21c0: 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 define (datashar
21d0: 65 3a 72 65 63 6f 72 64 2d 70 6b 67 2d 72 65 66 e:record-pkg-ref
21e0: 20 64 62 20 70 6b 67 2d 69 64 20 64 65 73 74 2d db pkg-id dest-
21f0: 6c 69 6e 6b 29 0a 20 20 28 73 71 6c 69 74 65 33 link). (sqlite3
2200: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
2210: 45 52 54 20 49 4e 54 4f 20 72 65 66 73 20 28 70 ERT INTO refs (p
2220: 6b 67 5f 69 64 2c 64 65 73 74 6c 69 6e 6b 29 20 kg_id,destlink)
2230: 56 41 4c 55 45 53 20 28 3f 2c 3f 29 3b 22 20 70 VALUES (?,?);" p
2240: 6b 67 2d 69 64 20 64 65 73 74 2d 6c 69 6e 6b 29 kg-id dest-link)
2250: 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 64 61 ). .(define (da
2260: 74 61 73 68 61 72 65 3a 63 6f 75 6e 74 2d 72 65 tashare:count-re
2270: 66 73 20 64 62 20 70 6b 67 2d 69 64 29 0a 20 20 fs db pkg-id).
2280: 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 20 (let ((res 0)).
2290: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
22a0: 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c each-row. (l
22b0: 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 20 20 ambda (count).
22c0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 63 (set! res c
22d0: 6f 75 6e 74 29 29 0a 20 20 20 20 20 64 62 0a 20 ount)). db.
22e0: 20 20 20 20 22 53 45 4c 45 43 54 20 63 6f 75 6e "SELECT coun
22f0: 74 28 69 64 29 20 46 52 4f 4d 20 72 65 66 73 20 t(id) FROM refs
2300: 57 48 45 52 45 20 70 6b 67 5f 69 64 3d 3f 3b 22 WHERE pkg_id=?;"
2310: 0a 20 20 20 20 20 70 6b 67 2d 69 64 29 0a 20 20 . pkg-id).
2320: 20 20 72 65 73 29 29 0a 0a 3b 3b 20 43 72 65 61 res))..;; Crea
2330: 74 65 20 74 68 65 20 73 71 6c 69 74 65 20 64 62 te the sqlite db
2340: 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 .(define (datash
2350: 61 72 65 3a 6f 70 65 6e 2d 64 62 20 63 6f 6e 66 are:open-db conf
2360: 69 67 64 61 74 29 20 0a 20 20 28 6c 65 74 20 28 igdat) . (let (
2370: 28 70 61 74 68 20 28 63 6f 6e 66 69 67 66 3a 6c (path (configf:l
2380: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
2390: 22 64 61 74 61 62 61 73 65 22 20 22 6c 6f 63 61 "database" "loca
23a0: 74 69 6f 6e 22 29 29 29 0a 20 20 20 20 28 69 66 tion"))). (if
23b0: 20 28 61 6e 64 20 70 61 74 68 0a 09 20 20 20 20 (and path..
23c0: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 74 (directory? pat
23d0: 68 29 0a 09 20 20 20 20 20 28 66 69 6c 65 2d 72 h).. (file-r
23e0: 65 61 64 2d 61 63 63 65 73 73 3f 20 70 61 74 68 ead-access? path
23f0: 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 70 61 ))..(let* ((dbpa
2400: 74 68 20 20 20 20 28 63 6f 6e 63 20 70 61 74 68 th (conc path
2410: 20 22 2f 64 61 74 61 73 68 61 72 65 2e 64 62 22 "/datashare.db"
2420: 29 29 0a 09 20 20 20 20 20 20 20 28 77 72 69 74 )).. (writ
2430: 65 61 62 6c 65 20 28 66 69 6c 65 2d 77 72 69 74 eable (file-writ
2440: 65 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 68 e-access? dbpath
2450: 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 65 78 )).. (dbex
2460: 69 73 74 73 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 ists (common:fi
2470: 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 61 74 le-exists? dbpat
2480: 68 29 29 0a 09 20 20 20 20 20 20 20 28 68 61 6e h)).. (han
2490: 64 6c 65 72 20 20 20 28 6d 61 6b 65 2d 62 75 73 dler (make-bus
24a0: 79 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 30 30 y-timeout 136000
24b0: 29 29 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 ))).. (handle-e
24c0: 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 xceptions.. ex
24d0: 6e 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 n.. (begin..
24e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
24f0: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
2500: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 72 6f ort* "ERROR: pro
2510: 62 6c 65 6d 20 61 63 63 65 73 73 69 6e 67 20 64 blem accessing d
2520: 62 20 22 20 64 62 70 61 74 68 0a 09 09 09 20 20 b " dbpath....
2530: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
2540: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
2550: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
2560: 29 29 0a 09 20 20 20 20 20 28 65 78 69 74 29 29 )).. (exit))
2570: 0a 09 20 20 20 28 73 65 74 21 20 64 62 20 28 73 .. (set! db (s
2580: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
2590: 62 61 73 65 20 64 62 70 61 74 68 29 29 29 0a 09 base dbpath)))..
25a0: 20 20 28 69 66 20 2a 64 62 2d 77 72 69 74 65 2d (if *db-write-
25b0: 61 63 63 65 73 73 2a 20 28 73 71 6c 69 74 65 33 access* (sqlite3
25c0: 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 :set-busy-handle
25d0: 72 21 20 64 62 20 68 61 6e 64 6c 65 72 29 29 0a r! db handler)).
25e0: 09 20 20 28 69 66 20 28 6e 6f 74 20 64 62 65 78 . (if (not dbex
25f0: 69 73 74 73 29 0a 09 20 20 20 20 20 20 28 62 65 ists).. (be
2600: 67 69 6e 0a 09 09 28 64 61 74 61 73 68 61 72 65 gin...(datashare
2610: 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 64 62 20 64 :initialize-db d
2620: 62 29 29 29 0a 09 20 20 64 62 29 0a 09 28 70 72 b))).. db)..(pr
2630: 69 6e 74 20 22 45 52 52 4f 52 3a 20 69 6e 76 61 int "ERROR: inva
2640: 6c 69 64 20 70 61 74 68 20 66 6f 72 20 73 74 6f lid path for sto
2650: 72 69 6e 67 20 64 61 74 61 62 61 73 65 3a 20 22 ring database: "
2660: 20 70 61 74 68 29 29 29 29 0a 0a 28 64 65 66 69 path))))..(defi
2670: 6e 65 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ne (open-run-clo
2680: 73 65 2d 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e se-exception-han
2690: 64 6c 69 6e 67 20 70 72 6f 63 20 69 64 62 20 2e dling proc idb .
26a0: 20 70 61 72 61 6d 73 29 0a 20 20 28 68 61 6e 64 params). (hand
26b0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
26c0: 20 65 78 6e 0a 20 20 20 28 6c 65 74 20 28 28 73 exn. (let ((s
26d0: 6c 65 65 70 2d 74 69 6d 65 20 28 72 61 6e 64 6f leep-time (rando
26e0: 6d 20 33 30 29 29 0a 20 20 20 20 20 20 20 20 20 m 30)).
26f0: 28 65 72 72 2d 73 74 61 74 75 73 20 28 28 63 6f (err-status ((co
2700: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
2710: 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 -accessor 'sqlit
2720: 65 33 20 27 73 74 61 74 75 73 20 23 66 29 20 65 e3 'status #f) e
2730: 78 6e 29 29 29 0a 20 20 20 20 20 28 63 61 73 65 xn))). (case
2740: 20 65 72 72 2d 73 74 61 74 75 73 0a 20 20 20 20 err-status.
2750: 20 20 20 28 28 62 75 73 79 29 0a 20 20 20 20 20 ((busy).
2760: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
2770: 21 20 73 6c 65 65 70 2d 74 69 6d 65 29 29 0a 20 ! sleep-time)).
2780: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
2790: 20 20 20 20 28 70 72 69 6e 74 20 22 45 58 43 45 (print "EXCE
27a0: 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 65 20 PTION: database
27b0: 6f 76 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e overloaded or un
27c0: 72 65 61 64 61 62 6c 65 2e 22 29 0a 20 20 20 20 readable.").
27d0: 20 20 20 20 28 70 72 69 6e 74 20 22 20 6d 65 73 (print " mes
27e0: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
27f0: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
2800: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
2810: 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 age) exn)).
2820: 20 20 20 28 70 72 69 6e 74 20 22 65 78 6e 3d 22 (print "exn="
2830: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 (condition->lis
2840: 74 20 65 78 6e 29 29 0a 20 20 20 20 20 20 20 20 t exn)).
2850: 28 70 72 69 6e 74 20 22 20 73 74 61 74 75 73 3a (print " status:
2860: 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
2870: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
2880: 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 r 'sqlite3 'stat
2890: 75 73 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 us) exn)).
28a0: 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 (print-call-ch
28b0: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
28c0: 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 or-port)).
28d0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
28e0: 20 73 6c 65 65 70 2d 74 69 6d 65 29 0a 20 20 20 sleep-time).
28f0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 74 72 79 (print "try
2900: 69 6e 67 20 64 62 20 63 61 6c 6c 20 6f 6e 65 20 ing db call one
2910: 6d 6f 72 65 20 74 69 6d 65 2e 2e 2e 2e 74 68 69 more time....thi
2920: 73 20 6d 61 79 20 6e 65 76 65 72 20 72 65 63 6f s may never reco
2930: 76 65 72 2c 20 69 66 20 6e 65 63 65 73 73 61 72 ver, if necessar
2940: 79 20 6b 69 6c 6c 20 70 72 6f 63 65 73 73 20 22 y kill process "
2950: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
2960: 73 2d 69 64 29 20 22 20 6f 6e 20 68 6f 73 74 20 s-id) " on host
2970: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
2980: 29 20 22 20 74 6f 20 63 6c 65 61 6e 20 75 70 22 ) " to clean up"
2990: 29 29 29 0a 20 20 20 20 20 28 61 70 70 6c 79 20 ))). (apply
29a0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 2d 65 open-run-close-e
29b0: 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 69 6e xception-handlin
29c0: 67 20 70 72 6f 63 20 69 64 62 20 70 61 72 61 6d g proc idb param
29d0: 73 29 29 0a 20 20 20 28 61 70 70 6c 79 20 6f 70 s)). (apply op
29e0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 2d 6e 6f 2d en-run-close-no-
29f0: 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 69 exception-handli
2a00: 6e 67 20 70 72 6f 63 20 69 64 62 20 70 61 72 61 ng proc idb para
2a10: 6d 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ms)))..(define (
2a20: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 2d 6e open-run-close-n
2a30: 6f 2d 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 o-exception-hand
2a40: 6c 69 6e 67 20 20 70 72 6f 63 20 69 64 62 20 2e ling proc idb .
2a50: 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 70 params). ;; (p
2a60: 72 69 6e 74 20 22 6f 70 65 6e 2d 72 75 6e 2d 63 rint "open-run-c
2a70: 6c 6f 73 65 2d 6e 6f 2d 65 78 63 65 70 74 69 6f lose-no-exceptio
2a80: 6e 2d 68 61 6e 64 6c 69 6e 67 20 53 54 41 52 54 n-handling START
2a90: 20 67 69 76 65 6e 20 61 20 64 62 3d 22 20 28 69 given a db=" (i
2aa0: 66 20 69 64 62 20 22 79 65 73 20 22 20 22 6e 6f f idb "yes " "no
2ab0: 20 22 29 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 ") ", params="
2ac0: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
2ad0: 28 28 64 62 20 28 63 6f 6e 64 0a 09 20 20 20 20 ((db (cond..
2ae0: 20 20 28 28 73 71 6c 69 74 65 33 3a 64 61 74 61 ((sqlite3:data
2af0: 62 61 73 65 3f 20 69 64 62 29 20 20 20 20 20 69 base? idb) i
2b00: 64 62 29 0a 09 20 20 20 20 20 20 28 28 6e 6f 74 db).. ((not
2b10: 20 69 64 62 29 20 20 20 20 20 20 20 20 20 20 20 idb)
2b20: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
2b30: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6f 70 ERROR: cannot op
2b40: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 77 69 74 en-run-close wit
2b50: 68 20 23 66 20 61 6e 79 6d 6f 72 65 22 29 29 0a h #f anymore")).
2b60: 09 20 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 . ((procedu
2b70: 72 65 3f 20 69 64 62 29 20 20 20 20 20 20 20 20 re? idb)
2b80: 20 20 20 20 28 69 64 62 29 29 0a 09 20 20 20 20 (idb))..
2b90: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2bb0: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 61 print "ERROR: ca
2bc0: 6e 6e 6f 74 20 6f 70 65 6e 2d 72 75 6e 2d 63 6c nnot open-run-cl
2bd0: 6f 73 65 20 77 69 74 68 20 23 66 20 61 6e 79 6d ose with #f anym
2be0: 6f 72 65 22 29 29 29 29 0a 09 20 28 72 65 73 20 ore")))).. (res
2bf0: 23 66 29 29 0a 20 20 20 20 28 73 65 74 21 20 72 #f)). (set! r
2c00: 65 73 20 28 61 70 70 6c 79 20 70 72 6f 63 20 64 es (apply proc d
2c10: 62 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 b params)). (
2c20: 69 66 20 28 6e 6f 74 20 69 64 62 29 28 73 71 6c if (not idb)(sql
2c30: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
2c40: 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 3b 3b bstruct)). ;;
2c50: 20 28 70 72 69 6e 74 20 22 6f 70 65 6e 2d 72 75 (print "open-ru
2c60: 6e 2d 63 6c 6f 73 65 2d 6e 6f 2d 65 78 63 65 70 n-close-no-excep
2c70: 74 69 6f 6e 2d 68 61 6e 64 6c 69 6e 67 20 45 4e tion-handling EN
2c80: 44 22 20 29 0a 20 20 20 20 72 65 73 29 29 0a 0a D" ). res))..
2c90: 28 64 65 66 69 6e 65 20 6f 70 65 6e 2d 72 75 6e (define open-run
2ca0: 2d 63 6c 6f 73 65 20 6f 70 65 6e 2d 72 75 6e 2d -close open-run-
2cb0: 63 6c 6f 73 65 2d 6e 6f 2d 65 78 63 65 70 74 69 close-no-excepti
2cc0: 6f 6e 2d 68 61 6e 64 6c 69 6e 67 29 0a 0a 28 64 on-handling)..(d
2cd0: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
2ce0: 3a 67 65 74 2d 70 6b 67 73 20 64 62 20 61 72 65 :get-pkgs db are
2cf0: 61 2d 66 69 6c 74 65 72 20 76 65 72 73 69 6f 6e a-filter version
2d00: 2d 66 69 6c 74 65 72 20 69 74 65 72 2d 66 69 6c -filter iter-fil
2d10: 74 65 72 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ter). (let ((re
2d20: 73 20 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c s '())). (sql
2d30: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
2d40: 77 20 3b 3b 20 72 65 70 6c 61 63 65 20 77 69 74 w ;; replace wit
2d50: 68 20 66 6f 6c 64 20 2e 2e 2e 0a 20 20 20 20 20 h fold ....
2d60: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a (lambda (a . b).
2d70: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
2d80: 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 65 (cons (list->ve
2d90: 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 62 29 29 ctor (cons a b))
2da0: 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 62 20 res))). db
2db0: 0a 20 20 20 20 20 28 63 6f 6e 63 20 22 53 45 4c . (conc "SEL
2dc0: 45 43 54 20 69 64 2c 61 72 65 61 2c 76 65 72 73 ECT id,area,vers
2dd0: 69 6f 6e 5f 6e 61 6d 65 2c 73 74 6f 72 65 5f 74 ion_name,store_t
2de0: 79 70 65 2c 63 6f 70 69 65 64 2c 73 6f 75 72 63 ype,copied,sourc
2df0: 65 5f 70 61 74 68 2c 69 74 65 72 61 74 69 6f 6e e_path,iteration
2e00: 2c 73 75 62 6d 69 74 74 65 72 2c 64 61 74 65 74 ,submitter,datet
2e10: 69 6d 65 2c 73 74 6f 72 65 67 72 70 2c 64 61 74 ime,storegrp,dat
2e20: 61 76 6f 6c 2c 71 75 61 6c 69 74 79 2c 64 69 73 avol,quality,dis
2e30: 6b 5f 69 64 2c 63 6f 6d 6d 65 6e 74 2c 73 74 6f k_id,comment,sto
2e40: 72 65 64 5f 70 61 74 68 20 22 0a 09 20 20 20 22 red_path ".. "
2e50: 20 46 52 4f 4d 20 70 6b 67 73 20 57 48 45 52 45 FROM pkgs WHERE
2e60: 20 61 72 65 61 20 6c 69 6b 65 20 3f 20 41 4e 44 area like ? AND
2e70: 20 76 65 72 73 69 6f 6e 5f 6e 61 6d 65 20 4c 49 version_name LI
2e80: 4b 45 20 3f 20 41 4e 44 20 69 74 65 72 61 74 69 KE ? AND iterati
2e90: 6f 6e 20 22 20 69 74 65 72 2d 66 69 6c 74 65 72 on " iter-filter
2ea0: 20 22 3b 22 29 0a 20 20 20 20 20 61 72 65 61 2d ";"). area-
2eb0: 66 69 6c 74 65 72 20 76 65 72 73 69 6f 6e 2d 66 filter version-f
2ec0: 69 6c 74 65 72 29 0a 20 20 20 20 28 72 65 76 65 ilter). (reve
2ed0: 72 73 65 20 72 65 73 29 29 29 0a 0a 28 64 65 66 rse res)))..(def
2ee0: 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 67 ine (datashare:g
2ef0: 65 74 2d 70 6b 67 20 64 62 20 61 72 65 61 2d 6e et-pkg db area-n
2f00: 61 6d 65 20 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 ame version-name
2f10: 20 23 21 6b 65 79 20 28 69 74 65 72 61 74 69 6f #!key (iteratio
2f20: 6e 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 n #f)). (let ((
2f30: 64 61 74 20 27 28 29 29 0a 09 28 72 65 73 20 23 dat '())..(res #
2f40: 66 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 f)). (sqlite3
2f50: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 3b 3b :for-each-row ;;
2f60: 20 72 65 70 6c 61 63 65 20 77 69 74 68 20 66 6f replace with fo
2f70: 6c 64 20 2e 2e 2e 0a 20 20 20 20 20 28 6c 61 6d ld .... (lam
2f80: 62 64 61 20 28 61 20 2e 20 62 29 0a 20 20 20 20 bda (a . b).
2f90: 20 20 20 28 73 65 74 21 20 64 61 74 20 28 63 6f (set! dat (co
2fa0: 6e 73 20 28 6c 69 73 74 2d 3e 76 65 63 74 6f 72 ns (list->vector
2fb0: 20 28 63 6f 6e 73 20 61 20 62 29 29 20 64 61 74 (cons a b)) dat
2fc0: 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 20 ))). db .
2fd0: 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 (conc "SELECT
2fe0: 69 64 2c 61 72 65 61 2c 76 65 72 73 69 6f 6e 5f id,area,version_
2ff0: 6e 61 6d 65 2c 73 74 6f 72 65 5f 74 79 70 65 2c name,store_type,
3000: 63 6f 70 69 65 64 2c 73 6f 75 72 63 65 5f 70 61 copied,source_pa
3010: 74 68 2c 69 74 65 72 61 74 69 6f 6e 2c 73 75 62 th,iteration,sub
3020: 6d 69 74 74 65 72 2c 64 61 74 65 74 69 6d 65 2c mitter,datetime,
3030: 73 74 6f 72 65 67 72 70 2c 64 61 74 61 76 6f 6c storegrp,datavol
3040: 2c 71 75 61 6c 69 74 79 2c 64 69 73 6b 5f 69 64 ,quality,disk_id
3050: 2c 63 6f 6d 6d 65 6e 74 2c 73 74 6f 72 65 64 5f ,comment,stored_
3060: 70 61 74 68 20 22 0a 09 20 20 20 22 20 46 52 4f path ".. " FRO
3070: 4d 20 70 6b 67 73 20 57 48 45 52 45 20 61 72 65 M pkgs WHERE are
3080: 61 3d 3f 20 41 4e 44 20 76 65 72 73 69 6f 6e 5f a=? AND version_
3090: 6e 61 6d 65 3d 3f 20 4f 52 44 45 52 20 42 59 20 name=? ORDER BY
30a0: 69 74 65 72 61 74 69 6f 6e 20 41 53 43 3b 22 29 iteration ASC;")
30b0: 0a 20 20 20 20 20 61 72 65 61 2d 6e 61 6d 65 20 . area-name
30c0: 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 29 0a 20 20 version-name).
30d0: 20 20 3b 3b 20 6e 6f 77 20 66 69 6c 74 65 72 20 ;; now filter
30e0: 66 6f 72 20 69 74 65 72 61 74 69 6f 6e 2c 20 65 for iteration, e
30f0: 69 74 68 65 72 20 6d 61 78 20 69 66 20 23 66 20 ither max if #f
3100: 6f 72 20 73 70 65 63 69 66 69 63 20 6f 6e 65 0a or specific one.
3110: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 (if (null? d
3120: 61 74 29 0a 09 23 66 0a 09 28 6c 65 74 20 6c 6f at)..#f..(let lo
3130: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 61 op ((hed (car da
3140: 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 t))... (tal (c
3150: 64 72 20 64 61 74 29 29 0a 09 09 20 20 20 28 63 dr dat))... (c
3160: 75 72 20 30 29 29 0a 09 20 20 28 6c 65 74 20 28 ur 0)).. (let (
3170: 28 69 74 72 20 28 64 61 74 61 73 68 61 72 65 3a (itr (datashare:
3180: 70 6b 67 2d 67 65 74 2d 69 74 65 72 61 74 69 6f pkg-get-iteratio
3190: 6e 20 68 65 64 29 29 29 0a 09 20 20 20 20 28 69 n hed))).. (i
31a0: 66 20 28 65 71 75 61 6c 3f 20 69 74 72 20 69 74 f (equal? itr it
31b0: 65 72 61 74 69 6f 6e 29 20 3b 3b 20 74 68 69 73 eration) ;; this
31c0: 20 69 73 20 74 68 65 20 6f 6e 65 20 69 66 20 69 is the one if i
31d0: 74 65 72 61 74 69 6f 6e 20 69 73 20 73 70 65 63 teration is spec
31e0: 69 66 69 65 64 0a 09 09 68 65 64 0a 09 09 28 69 ified...hed...(i
31f0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
3200: 20 20 20 20 68 65 64 0a 09 09 20 20 20 20 28 6c hed... (l
3210: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
3220: 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 0a 0a r tal)))))))))..
3230: 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 (define (datasha
3240: 72 65 3a 67 65 74 2d 76 65 72 73 69 6f 6e 73 2d re:get-versions-
3250: 66 6f 72 2d 61 72 65 61 20 64 62 20 61 72 65 61 for-area db area
3260: 2d 6e 61 6d 65 20 23 21 6b 65 79 20 28 76 65 72 -name #!key (ver
3270: 73 69 6f 6e 2d 70 61 74 74 20 23 66 29 29 0a 20 sion-patt #f)).
3280: 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 (let ((res '())
3290: 0a 09 28 64 61 74 61 20 28 6d 61 6b 65 2d 68 61 ..(data (make-ha
32a0: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
32b0: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
32c0: 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 h-row. (lamb
32d0: 64 61 20 28 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 da (version-name
32e0: 20 73 75 62 6d 69 74 74 65 72 20 69 74 65 72 61 submitter itera
32f0: 74 69 6f 6e 20 73 75 62 6d 69 74 74 65 64 2d 74 tion submitted-t
3300: 69 6d 65 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 20 ime comment).
3310: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
3320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3340: 20 20 20 20 30 20 20 20 20 20 20 20 20 20 20 20 0
3350: 31 20 20 20 20 20 20 20 20 20 32 20 20 20 20 20 1 2
3360: 20 20 20 20 20 20 33 20 20 20 20 20 20 20 20 20 3
3370: 20 20 34 0a 20 20 20 20 20 20 20 28 68 61 73 68 4. (hash
3380: 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 61 74 61 -table-set! data
3390: 20 76 65 72 73 69 6f 6e 2d 6e 61 6d 65 20 28 76 version-name (v
33a0: 65 63 74 6f 72 20 76 65 72 73 69 6f 6e 2d 6e 61 ector version-na
33b0: 6d 65 20 73 75 62 6d 69 74 74 65 72 20 69 74 65 me submitter ite
33c0: 72 61 74 69 6f 6e 20 73 75 62 6d 69 74 74 65 64 ration submitted
33d0: 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 29 29 29 -time comment)))
33e0: 0a 20 20 20 20 20 64 62 20 0a 20 20 20 20 20 22 . db . "
33f0: 53 45 4c 45 43 54 20 76 65 72 73 69 6f 6e 5f 6e SELECT version_n
3400: 61 6d 65 2c 73 75 62 6d 69 74 74 65 72 2c 69 74 ame,submitter,it
3410: 65 72 61 74 69 6f 6e 2c 64 61 74 65 74 69 6d 65 eration,datetime
3420: 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 70 6b ,comment FROM pk
3430: 67 73 20 57 48 45 52 45 20 61 72 65 61 3d 27 6d gs WHERE area='m
3440: 65 67 61 74 65 73 74 27 20 41 4e 44 20 76 65 72 egatest' AND ver
3450: 73 69 6f 6e 5f 6e 61 6d 65 20 21 3d 20 27 6c 61 sion_name != 'la
3460: 74 65 73 74 27 20 41 4e 44 20 76 65 72 73 69 6f test' AND versio
3470: 6e 5f 6e 61 6d 65 20 4c 49 4b 45 20 3f 20 4f 52 n_name LIKE ? OR
3480: 44 45 52 20 42 59 20 64 61 74 65 74 69 6d 65 20 DER BY datetime
3490: 61 73 63 3b 22 0a 20 20 20 20 20 28 6f 72 20 76 asc;". (or v
34a0: 65 72 73 69 6f 6e 2d 70 61 74 74 20 22 25 22 29 ersion-patt "%")
34b0: 29 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 ). (map (lamb
34c0: 64 61 20 28 78 29 28 68 61 73 68 2d 74 61 62 6c da (x)(hash-tabl
34d0: 65 2d 72 65 66 20 64 61 74 61 20 78 29 29 28 73 e-ref data x))(s
34e0: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
34f0: 6b 65 79 73 20 64 61 74 61 29 20 73 74 72 69 6e keys data) strin
3500: 67 2d 63 69 3e 3d 29 29 29 29 0a 0a 3b 3b 3d 3d g-ci>=))))..;;==
3510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 0a 3b 3b 20 44 41 54 41 20 49 4d 50 ====.;; DATA IMP
3560: 4f 52 54 2f 45 58 50 4f 52 54 0a 3b 3b 3d 3d 3d ORT/EXPORT.;;===
3570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35b0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 ===..(define (da
35c0: 74 61 73 68 61 72 65 3a 69 6d 70 6f 72 74 2d 64 tashare:import-d
35d0: 61 74 61 20 63 6f 6e 66 69 67 64 61 74 20 73 6f ata configdat so
35e0: 75 72 63 65 2d 70 61 74 68 20 64 65 73 74 2d 70 urce-path dest-p
35f0: 61 74 68 20 61 72 65 61 20 76 65 72 73 69 6f 6e ath area version
3600: 20 69 74 65 72 61 74 69 6f 6e 29 0a 20 20 28 6c iteration). (l
3610: 65 74 2a 20 28 28 73 70 61 63 65 2d 61 76 61 69 et* ((space-avai
3620: 6c 20 28 63 61 72 20 64 65 73 74 2d 70 61 74 68 l (car dest-path
3630: 29 29 0a 09 20 28 64 69 73 6b 2d 70 61 74 68 20 )).. (disk-path
3640: 20 20 28 63 64 72 20 64 65 73 74 2d 70 61 74 68 (cdr dest-path
3650: 29 29 0a 09 20 28 74 61 72 67 2d 70 61 74 68 20 )).. (targ-path
3660: 20 20 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 (conc disk-pat
3670: 68 20 22 2f 22 20 61 72 65 61 20 22 2f 22 20 76 h "/" area "/" v
3680: 65 72 73 69 6f 6e 20 22 2f 22 20 69 74 65 72 61 ersion "/" itera
3690: 74 69 6f 6e 29 29 0a 09 20 28 69 64 20 20 20 20 tion)).. (id
36a0: 20 20 20 20 20 20 28 64 61 74 61 73 68 61 72 65 (datashare
36b0: 3a 67 65 74 2d 69 64 20 64 62 20 61 72 65 61 20 :get-id db area
36c0: 76 65 72 73 69 6f 6e 20 69 74 65 72 61 74 69 6f version iteratio
36d0: 6e 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 n)).. (db
36e0: 20 20 20 28 64 61 74 61 73 68 61 72 65 3a 6f 70 (datashare:op
36f0: 65 6e 2d 64 62 20 63 6f 6e 66 69 67 64 61 74 29 en-db configdat)
3700: 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 73 70 )). (if (> sp
3710: 61 63 65 2d 61 76 61 69 6c 20 31 30 30 30 30 29 ace-avail 10000)
3720: 20 3b 3b 20 64 75 6d 62 20 68 65 75 72 69 73 74 ;; dumb heurist
3730: 69 63 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 63 ic..(begin.. (c
3740: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
3750: 74 61 72 67 2d 70 61 74 68 20 23 74 29 0a 09 20 targ-path #t)..
3760: 20 28 64 61 74 61 73 68 61 72 65 3a 73 65 74 2d (datashare:set-
3770: 73 74 6f 72 65 64 2d 70 61 74 68 20 64 62 20 69 stored-path db i
3780: 64 20 74 61 72 67 2d 70 61 74 68 29 0a 09 20 20 d targ-path)..
3790: 28 70 72 69 6e 74 20 22 52 75 6e 6e 69 6e 67 20 (print "Running
37a0: 63 6f 6d 6d 61 6e 64 3a 20 72 73 79 6e 63 20 2d command: rsync -
37b0: 61 76 20 22 20 73 6f 75 72 63 65 2d 70 61 74 68 av " source-path
37c0: 20 22 2f 20 22 20 74 61 72 67 2d 70 61 74 68 20 "/ " targ-path
37d0: 22 2f 22 29 0a 09 20 20 28 6c 65 74 20 28 28 74 "/").. (let ((t
37e0: 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h1 (make-thread
37f0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 (lambda ().....
3800: 20 20 20 28 6c 65 74 20 28 28 70 69 64 20 28 70 (let ((pid (p
3810: 72 6f 63 65 73 73 2d 72 75 6e 20 22 72 73 79 6e rocess-run "rsyn
3820: 63 22 20 28 6c 69 73 74 20 22 2d 61 76 22 20 28 c" (list "-av" (
3830: 63 6f 6e 63 20 73 6f 75 72 63 65 2d 70 61 74 68 conc source-path
3840: 20 22 2f 22 29 20 28 63 6f 6e 63 20 74 61 72 67 "/") (conc targ
3850: 2d 70 61 74 68 20 22 2f 22 29 29 29 29 29 0a 09 -path "/")))))..
3860: 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 65 73 ... (proces
3870: 73 2d 77 61 69 74 20 70 69 64 29 0a 09 09 09 09 s-wait pid).....
3880: 20 20 20 20 20 20 28 64 61 74 61 73 68 61 72 65 (datashare
3890: 3a 73 65 74 2d 63 6f 70 69 65 64 20 64 62 20 69 :set-copied db i
38a0: 64 20 22 79 65 73 22 29 0a 09 09 09 09 20 20 20 d "yes").....
38b0: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 (sqlite3:fina
38c0: 6c 69 7a 65 21 20 64 62 29 29 29 0a 09 09 09 09 lize! db))).....
38d0: 20 20 20 22 44 61 74 61 20 63 6f 70 79 22 29 29 "Data copy"))
38e0: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 ).. (thread-s
38f0: 74 61 72 74 21 20 74 68 31 29 29 0a 09 20 20 23 tart! th1)).. #
3900: 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 t)..(begin.. (p
3910: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 4e 6f 74 rint "ERROR: Not
3920: 20 65 6e 6f 75 67 68 20 73 70 61 63 65 20 69 6e enough space in
3930: 20 73 74 6f 72 61 67 65 20 61 72 65 61 20 22 20 storage area "
3940: 64 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 64 dest-path).. (d
3950: 61 74 61 73 68 61 72 65 3a 73 65 74 2d 63 6f 70 atashare:set-cop
3960: 69 65 64 20 64 62 20 69 64 20 22 6e 6f 22 29 0a ied db id "no").
3970: 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 . (sqlite3:fina
3980: 6c 69 7a 65 21 20 64 62 29 0a 09 20 20 23 66 29 lize! db).. #f)
3990: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 )))..(define (da
39a0: 74 61 73 68 61 72 65 3a 67 65 74 2d 61 72 65 61 tashare:get-area
39b0: 73 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 28 s configdat). (
39c0: 6c 65 74 2a 20 28 28 61 72 65 61 64 61 74 20 28 let* ((areadat (
39d0: 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 configf:get-sect
39e0: 69 6f 6e 20 63 6f 6e 66 69 67 64 61 74 20 22 61 ion configdat "a
39f0: 72 65 61 73 22 29 29 0a 09 20 28 61 72 65 61 73 reas")).. (areas
3a00: 20 20 20 28 69 66 20 61 72 65 61 64 61 74 20 28 (if areadat (
3a10: 6d 61 70 20 63 61 72 20 61 72 65 61 64 61 74 29 map car areadat)
3a20: 20 27 28 29 29 29 29 0a 20 20 20 20 61 72 65 61 '()))). area
3a30: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 s))..(define (da
3a40: 74 61 73 68 61 72 65 3a 70 75 62 6c 69 73 68 20 tashare:publish
3a50: 63 6f 6e 66 69 67 64 61 74 20 70 75 62 6c 69 73 configdat publis
3a60: 68 2d 74 79 70 65 20 61 72 65 61 2d 6e 61 6d 65 h-type area-name
3a70: 20 76 65 72 73 69 6f 6e 20 63 6f 6d 6d 65 6e 74 version comment
3a80: 20 73 70 61 74 68 20 73 75 62 6d 69 74 74 65 72 spath submitter
3a90: 20 71 75 61 6c 69 74 79 29 0a 20 20 3b 3b 20 69 quality). ;; i
3aa0: 6e 70 75 74 20 63 68 65 63 6b 73 0a 20 20 28 63 nput checks. (c
3ab0: 6f 6e 64 20 0a 20 20 20 28 28 6e 6f 74 20 28 6d ond . ((not (m
3ac0: 65 6d 62 65 72 20 61 72 65 61 2d 6e 61 6d 65 20 ember area-name
3ad0: 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 2d 61 (datashare:get-a
3ae0: 72 65 61 73 20 63 6f 6e 66 69 67 64 61 74 29 29 reas configdat))
3af0: 29 0a 20 20 20 20 28 63 6f 6e 73 20 23 66 20 28 ). (cons #f (
3b00: 63 6f 6e 63 20 22 49 6c 6c 65 67 61 6c 20 61 72 conc "Illegal ar
3b10: 65 61 20 6e 61 6d 65 20 5c 22 22 20 61 72 65 61 ea name \"" area
3b20: 2d 6e 61 6d 65 20 22 5c 22 22 29 29 29 0a 20 20 -name "\""))).
3b30: 20 28 65 6c 73 65 0a 20 20 20 20 28 6c 65 74 20 (else. (let
3b40: 28 28 64 62 20 20 20 20 20 20 20 20 20 20 28 64 ((db (d
3b50: 61 74 61 73 68 61 72 65 3a 6f 70 65 6e 2d 64 62 atashare:open-db
3b60: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 20 20 configdat))..
3b70: 28 69 74 65 72 61 74 69 6f 6e 20 20 20 28 64 61 (iteration (da
3b80: 74 61 73 68 61 72 65 3a 72 65 67 69 73 74 65 72 tashare:register
3b90: 2d 64 61 74 61 20 64 62 20 61 72 65 61 2d 6e 61 -data db area-na
3ba0: 6d 65 20 76 65 72 73 69 6f 6e 20 70 75 62 6c 69 me version publi
3bb0: 73 68 2d 74 79 70 65 20 73 75 62 6d 69 74 74 65 sh-type submitte
3bc0: 72 20 71 75 61 6c 69 74 79 20 73 70 61 74 68 20 r quality spath
3bd0: 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 28 64 65 comment)).. (de
3be0: 73 74 2d 73 74 6f 72 65 20 20 28 64 61 74 61 73 st-store (datas
3bf0: 68 61 72 65 3a 67 65 74 2d 62 65 73 74 2d 73 74 hare:get-best-st
3c00: 6f 72 61 67 65 20 63 6f 6e 66 69 67 64 61 74 29 orage configdat)
3c10: 29 29 0a 20 20 20 20 20 20 28 69 66 20 69 74 65 )). (if ite
3c20: 72 61 74 69 6f 6e 0a 09 20 20 28 69 66 20 28 65 ration.. (if (e
3c30: 71 3f 20 27 63 6f 70 79 20 70 75 62 6c 69 73 68 q? 'copy publish
3c40: 2d 74 79 70 65 29 0a 09 20 20 20 20 20 20 28 62 -type).. (b
3c50: 65 67 69 6e 0a 09 09 28 64 61 74 61 73 68 61 72 egin...(datashar
3c60: 65 3a 69 6d 70 6f 72 74 2d 64 61 74 61 20 63 6f e:import-data co
3c70: 6e 66 69 67 64 61 74 20 73 70 61 74 68 20 64 65 nfigdat spath de
3c80: 73 74 2d 73 74 6f 72 65 20 61 72 65 61 2d 6e 61 st-store area-na
3c90: 6d 65 20 76 65 72 73 69 6f 6e 20 69 74 65 72 61 me version itera
3ca0: 74 69 6f 6e 29 0a 09 09 28 6c 65 74 20 28 28 69 tion)...(let ((i
3cb0: 64 20 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 d (datashare:get
3cc0: 2d 69 64 20 64 62 20 61 72 65 61 2d 6e 61 6d 65 -id db area-name
3cd0: 20 76 65 72 73 69 6f 6e 20 69 74 65 72 61 74 69 version iterati
3ce0: 6f 6e 29 29 29 0a 09 09 20 20 28 64 61 74 61 73 on)))... (datas
3cf0: 68 61 72 65 3a 73 65 74 2d 6c 61 74 65 73 74 20 hare:set-latest
3d00: 64 62 20 69 64 20 61 72 65 61 2d 6e 61 6d 65 20 db id area-name
3d10: 76 65 72 73 69 6f 6e 20 69 74 65 72 61 74 69 6f version iteratio
3d20: 6e 29 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 n))).. (let
3d30: 20 28 28 69 64 20 28 64 61 74 61 73 68 61 72 65 ((id (datashare
3d40: 3a 67 65 74 2d 69 64 20 64 62 20 61 72 65 61 2d :get-id db area-
3d50: 6e 61 6d 65 20 76 65 72 73 69 6f 6e 20 69 74 65 name version ite
3d60: 72 61 74 69 6f 6e 29 29 29 0a 09 09 28 64 61 74 ration)))...(dat
3d70: 61 73 68 61 72 65 3a 73 65 74 2d 73 74 6f 72 65 ashare:set-store
3d80: 64 2d 70 61 74 68 20 64 62 20 69 64 20 73 70 61 d-path db id spa
3d90: 74 68 29 0a 09 09 28 64 61 74 61 73 68 61 72 65 th)...(datashare
3da0: 3a 73 65 74 2d 63 6f 70 69 65 64 20 64 62 20 69 :set-copied db i
3db0: 64 20 22 79 65 73 22 29 0a 09 09 28 64 61 74 61 d "yes")...(data
3dc0: 73 68 61 72 65 3a 73 65 74 2d 63 6f 70 69 65 64 share:set-copied
3dd0: 20 64 62 20 69 64 20 22 6e 2f 61 22 29 0a 09 09 db id "n/a")...
3de0: 28 64 61 74 61 73 68 61 72 65 3a 73 65 74 2d 6c (datashare:set-l
3df0: 61 74 65 73 74 20 64 62 20 69 64 20 61 72 65 61 atest db id area
3e00: 2d 6e 61 6d 65 20 76 65 72 73 69 6f 6e 20 69 74 -name version it
3e10: 65 72 61 74 69 6f 6e 29 29 29 0a 09 20 20 28 70 eration))).. (p
3e20: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 rint "ERROR: Fai
3e30: 6c 65 64 20 74 6f 20 67 65 74 20 61 6e 20 69 74 led to get an it
3e40: 65 72 61 74 69 6f 6e 20 6e 75 6d 62 65 72 22 29 eration number")
3e50: 29 0a 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 ). (sqlite3
3e60: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 20 :finalize! db).
3e70: 20 20 20 20 20 28 63 6f 6e 73 20 23 74 20 22 53 (cons #t "S
3e80: 75 63 63 65 73 73 66 75 6c 6c 79 20 73 61 76 65 uccessfully save
3e90: 64 20 64 61 74 61 22 29 29 29 29 29 0a 0a 28 64 d data")))))..(d
3ea0: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
3eb0: 3a 67 65 74 2d 62 65 73 74 2d 73 74 6f 72 61 67 :get-best-storag
3ec0: 65 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 28 e configdat). (
3ed0: 6c 65 74 2a 20 28 28 73 74 6f 72 61 67 65 20 20 let* ((storage
3ee0: 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (configf:look
3ef0: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 up configdat "se
3f00: 74 74 69 6e 67 73 22 20 22 73 74 6f 72 61 67 65 ttings" "storage
3f10: 22 29 29 0a 09 20 28 73 74 6f 72 65 2d 61 72 65 ")).. (store-are
3f20: 61 73 20 28 69 66 20 73 74 6f 72 61 67 65 20 28 as (if storage (
3f30: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 6f string-split sto
3f40: 72 61 67 65 29 20 27 28 29 29 29 29 0a 20 20 20 rage) '()))).
3f50: 20 28 70 72 69 6e 74 20 22 4c 6f 6f 6b 69 6e 67 (print "Looking
3f60: 20 66 6f 72 20 61 76 61 69 6c 61 62 6c 65 20 73 for available s
3f70: 70 61 63 65 20 69 6e 20 22 20 73 74 6f 72 65 2d pace in " store-
3f80: 61 72 65 61 73 29 0a 20 20 20 20 28 64 61 74 61 areas). (data
3f90: 73 68 61 72 65 3a 66 69 6e 64 2d 6d 6f 73 74 2d share:find-most-
3fa0: 73 70 61 63 65 20 73 74 6f 72 65 2d 61 72 65 61 space store-area
3fb0: 73 29 29 29 0a 0a 3b 3b 20 28 73 74 72 69 6e 67 s)))..;; (string
3fc0: 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 73 74 2d 72 ->number (list-r
3fd0: 65 66 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 ef (with-input-f
3fe0: 72 6f 6d 2d 70 69 70 65 20 22 64 66 20 2d 42 31 rom-pipe "df -B1
3ff0: 30 30 30 30 30 30 20 2f 74 6d 70 22 20 28 6c 61 000000 /tmp" (la
4000: 6d 62 64 61 20 28 29 28 72 65 61 64 2d 6c 69 6e mbda ()(read-lin
4010: 65 29 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 e)(string-split
4020: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 20 33 (read-line)))) 3
4030: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 ))..(define (dat
4040: 61 73 68 61 72 65 3a 66 69 6e 64 2d 6d 6f 73 74 ashare:find-most
4050: 2d 73 70 61 63 65 20 70 61 74 68 73 29 0a 20 20 -space paths).
4060: 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 (fold (lambda (a
4070: 72 65 61 20 72 65 73 29 0a 09 20 20 3b 3b 20 28 rea res).. ;; (
4080: 70 72 69 6e 74 20 22 61 72 65 61 3d 22 20 61 72 print "area=" ar
4090: 65 61 20 22 20 72 65 73 3d 22 20 72 65 73 29 0a ea " res=" res).
40a0: 09 20 20 28 6c 65 74 20 28 28 6d 61 78 73 70 61 . (let ((maxspa
40b0: 63 65 20 28 63 61 72 20 72 65 73 29 29 0a 09 09 ce (car res))...
40c0: 28 63 75 72 72 70 61 74 68 20 28 63 64 72 20 72 (currpath (cdr r
40d0: 65 73 29 29 29 0a 09 20 20 20 20 3b 3b 20 28 70 es))).. ;; (p
40e0: 72 69 6e 74 20 63 75 72 72 70 61 74 68 20 22 20 rint currpath "
40f0: 22 20 6d 61 78 73 70 61 63 65 29 0a 09 20 20 20 " maxspace)..
4100: 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 (if (file-write
4110: 2d 61 63 63 65 73 73 3f 20 61 72 65 61 29 0a 09 -access? area)..
4120: 09 28 6c 65 74 20 28 28 63 75 72 72 73 70 61 63 .(let ((currspac
4130: 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 e (string->numbe
4140: 72 0a 09 09 09 09 20 20 28 6c 69 73 74 2d 72 65 r..... (list-re
4150: 66 0a 09 09 09 09 20 20 20 28 77 69 74 68 2d 69 f..... (with-i
4160: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a nput-from-pipe .
4170: 09 09 09 09 20 20 20 20 3b 3b 20 28 63 6f 6e 63 .... ;; (conc
4180: 20 22 64 66 20 2d 2d 6f 75 74 70 75 74 3d 61 76 "df --output=av
4190: 61 69 6c 20 22 20 61 72 65 61 29 0a 09 09 09 09 ail " area).....
41a0: 20 20 20 20 28 63 6f 6e 63 20 22 64 66 20 2d 42 (conc "df -B
41b0: 31 30 30 30 30 30 30 20 22 20 61 72 65 61 29 0a 1000000 " area).
41c0: 09 09 09 09 20 20 20 20 3b 3b 20 28 6c 61 6d 62 .... ;; (lamb
41d0: 64 61 20 28 29 28 72 65 61 64 29 28 72 65 61 64 da ()(read)(read
41e0: 29 29 0a 09 09 09 09 20 20 20 20 28 6c 61 6d 62 ))..... (lamb
41f0: 64 61 20 28 29 28 72 65 61 64 2d 6c 69 6e 65 29 da ()(read-line)
4200: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 72 (string-split (r
4210: 65 61 64 2d 6c 69 6e 65 29 29 29 29 0a 09 09 09 ead-line))))....
4220: 09 20 20 20 33 29 29 29 29 0a 09 09 20 20 28 69 . 3))))... (i
4230: 66 20 28 3e 20 63 75 72 72 73 70 61 63 65 20 6d f (> currspace m
4240: 61 78 73 70 61 63 65 29 20 0a 09 09 20 20 20 20 axspace) ...
4250: 20 20 28 63 6f 6e 73 20 63 75 72 72 73 70 61 63 (cons currspac
4260: 65 20 61 72 65 61 29 0a 09 09 20 20 20 20 20 20 e area)...
4270: 72 65 73 29 29 0a 09 09 72 65 73 29 29 29 0a 09 res))...res)))..
4280: 28 63 6f 6e 73 20 30 20 23 66 29 0a 09 70 61 74 (cons 0 #f)..pat
4290: 68 73 29 29 0a 0a 3b 3b 20 72 65 6d 6f 76 65 20 hs))..;; remove
42a0: 65 78 69 73 74 69 6e 67 20 6c 69 6e 6b 20 61 6e existing link an
42b0: 64 20 69 66 20 70 6f 73 73 69 62 6c 65 20 2e 2e d if possible ..
42c0: 2e 0a 3b 3b 20 63 72 65 61 74 65 20 70 61 74 68 ..;; create path
42d0: 20 74 6f 20 6e 65 78 74 20 6f 66 20 74 69 70 20 to next of tip
42e0: 6f 66 20 74 61 72 67 65 74 2c 20 63 72 65 61 74 of target, creat
42f0: 65 20 6c 69 6e 6b 20 62 61 63 6b 20 74 6f 20 73 e link back to s
4300: 6f 75 72 63 65 0a 28 64 65 66 69 6e 65 20 28 64 ource.(define (d
4310: 61 74 61 73 68 61 72 65 3a 62 75 69 6c 64 2d 64 atashare:build-d
4320: 69 72 2d 6d 61 6b 65 2d 6c 69 6e 6b 20 73 6f 75 ir-make-link sou
4330: 72 63 65 20 74 61 72 67 65 74 29 0a 20 20 28 69 rce target). (i
4340: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
4350: 78 69 73 74 73 3f 20 74 61 72 67 65 74 29 28 64 xists? target)(d
4360: 61 74 61 73 68 61 72 65 3a 62 61 63 6b 75 70 2d atashare:backup-
4370: 6d 6f 76 65 20 74 61 72 67 65 74 29 29 0a 20 20 move target)).
4380: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
4390: 79 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 y (pathname-dire
43a0: 63 74 6f 72 79 20 74 61 72 67 65 74 29 20 23 74 ctory target) #t
43b0: 29 0a 20 20 28 63 72 65 61 74 65 2d 73 79 6d 62 ). (create-symb
43c0: 6f 6c 69 63 2d 6c 69 6e 6b 20 73 6f 75 72 63 65 olic-link source
43d0: 20 74 61 72 67 65 74 29 29 0a 0a 28 64 65 66 69 target))..(defi
43e0: 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 62 61 ne (datashare:ba
43f0: 63 6b 75 70 2d 6d 6f 76 65 20 70 61 74 68 29 0a ckup-move path).
4400: 20 20 28 6c 65 74 2a 20 28 28 74 72 61 73 68 64 (let* ((trashd
4410: 69 72 20 20 28 63 6f 6e 63 20 28 70 61 74 68 6e ir (conc (pathn
4420: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 ame-directory pa
4430: 74 68 29 20 22 2f 2e 74 72 61 73 68 22 29 29 0a th) "/.trash")).
4440: 09 20 28 74 72 61 73 68 66 69 6c 65 20 28 63 6f . (trashfile (co
4450: 6e 63 20 74 72 61 73 68 64 69 72 20 22 2f 22 20 nc trashdir "/"
4460: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4470: 29 20 22 2d 22 20 28 70 61 74 68 6e 61 6d 65 2d ) "-" (pathname-
4480: 66 69 6c 65 20 70 61 74 68 29 29 29 29 0a 20 20 file path)))).
4490: 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 (create-direct
44a0: 6f 72 79 20 74 72 61 73 68 64 69 72 20 23 74 29 ory trashdir #t)
44b0: 0a 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 . (if (direct
44c0: 6f 72 79 3f 20 70 61 74 68 29 0a 09 28 73 79 73 ory? path)..(sys
44d0: 74 65 6d 20 28 63 6f 6e 63 20 22 6d 76 20 22 20 tem (conc "mv "
44e0: 70 61 74 68 20 22 20 22 20 74 72 61 73 68 66 69 path " " trashfi
44f0: 6c 65 29 29 0a 09 28 66 69 6c 65 2d 6d 6f 76 65 le))..(file-move
4500: 20 70 61 74 68 20 74 72 61 73 68 2d 66 69 6c 65 path trash-file
4510: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
4520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
4560: 3b 20 47 55 49 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ; GUI.;;========
4570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
45b0: 3b 3b 20 54 68 65 20 6d 61 69 6e 20 6d 65 6e 75 ;; The main menu
45c0: 20 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 .(define (datas
45d0: 68 61 72 65 3a 6d 61 69 6e 2d 6d 65 6e 75 29 0a hare:main-menu).
45e0: 20 20 28 69 75 70 3a 6d 65 6e 75 20 3b 3b 20 61 (iup:menu ;; a
45f0: 20 6d 65 6e 75 20 69 73 20 61 20 73 70 65 63 69 menu is a speci
4600: 61 6c 20 61 74 74 72 69 62 75 74 65 20 74 6f 20 al attribute to
4610: 61 20 64 69 61 6c 6f 67 20 28 74 68 69 6e 6b 20 a dialog (think
4620: 47 6e 6f 6d 65 20 70 75 74 74 69 6e 67 20 74 68 Gnome putting th
4630: 65 20 6d 65 6e 75 20 61 74 20 73 63 72 65 65 6e e menu at screen
4640: 20 74 6f 70 29 0a 20 20 20 28 69 75 70 3a 6d 65 top). (iup:me
4650: 6e 75 2d 69 74 65 6d 20 22 46 69 6c 65 73 22 20 nu-item "Files"
4660: 28 69 75 70 3a 6d 65 6e 75 20 20 20 3b 3b 20 4e (iup:menu ;; N
4670: 6f 74 65 20 74 68 61 74 20 79 6f 75 20 63 61 6e ote that you can
4680: 20 75 73 65 20 65 69 74 68 65 72 20 23 3a 61 63 use either #:ac
4690: 74 69 6f 6e 20 6f 72 20 61 63 74 69 6f 6e 3a 20 tion or action:
46a0: 66 6f 72 20 6f 70 74 69 6f 6e 73 0a 09 09 20 20 for options...
46b0: 20 20 20 20 20 28 69 75 70 3a 6d 65 6e 75 2d 69 (iup:menu-i
46c0: 74 65 6d 20 22 4f 70 65 6e 22 20 20 61 63 74 69 tem "Open" acti
46d0: 6f 6e 3a 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a on: (lambda (obj
46e0: 29 0a 09 09 09 09 09 09 09 28 69 75 70 3a 73 68 )........(iup:sh
46f0: 6f 77 20 28 69 75 70 3a 66 69 6c 65 2d 64 69 61 ow (iup:file-dia
4700: 6c 6f 67 29 29 0a 09 09 09 09 09 09 09 28 70 72 log))........(pr
4710: 69 6e 74 20 22 46 69 6c 65 2d 3e 6f 70 65 6e 20 int "File->open
4720: 22 20 6f 62 6a 29 29 29 0a 09 09 20 20 20 20 20 " obj)))...
4730: 20 20 28 69 75 70 3a 6d 65 6e 75 2d 69 74 65 6d (iup:menu-item
4740: 20 22 53 61 76 65 22 20 20 23 3a 61 63 74 69 6f "Save" #:actio
4750: 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 28 n (lambda (obj)(
4760: 70 72 69 6e 74 20 22 46 69 6c 65 2d 3e 73 61 76 print "File->sav
4770: 65 20 22 20 6f 62 6a 29 29 29 0a 09 09 20 20 20 e " obj)))...
4780: 20 20 20 20 28 69 75 70 3a 6d 65 6e 75 2d 69 74 (iup:menu-it
4790: 65 6d 20 22 45 78 69 74 22 20 20 23 3a 61 63 74 em "Exit" #:act
47a0: 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a ion (lambda (obj
47b0: 29 28 65 78 69 74 29 29 29 29 29 0a 20 20 20 28 )(exit))))). (
47c0: 69 75 70 3a 6d 65 6e 75 2d 69 74 65 6d 20 22 54 iup:menu-item "T
47d0: 6f 6f 6c 73 22 20 28 69 75 70 3a 6d 65 6e 75 0a ools" (iup:menu.
47e0: 09 09 20 20 20 20 20 20 20 28 69 75 70 3a 6d 65 .. (iup:me
47f0: 6e 75 2d 69 74 65 6d 20 22 43 72 65 61 74 65 20 nu-item "Create
4800: 6e 65 77 20 62 6c 61 68 22 20 23 3a 61 63 74 69 new blah" #:acti
4810: 6f 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 on (lambda (obj)
4820: 28 70 72 69 6e 74 20 22 54 6f 6f 6c 73 2d 3e 6e (print "Tools->n
4830: 65 77 20 62 6c 61 68 22 29 29 29 0a 09 09 20 20 ew blah")))...
4840: 20 20 20 20 20 3b 3b 20 28 69 75 70 3a 6d 65 6e ;; (iup:men
4850: 75 2d 69 74 65 6d 20 22 53 68 6f 77 20 64 69 61 u-item "Show dia
4860: 6c 6f 67 22 20 20 20 20 20 23 3a 61 63 74 69 6f log" #:actio
4870: 6e 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 0a n (lambda (obj).
4880: 09 09 20 20 20 20 20 20 20 3b 3b 20 20 09 09 09 .. ;; ...
4890: 09 09 20 20 20 28 73 68 6f 77 20 6d 65 73 73 61 .. (show messa
48a0: 67 65 2d 77 69 6e 64 6f 77 0a 09 09 20 20 20 20 ge-window...
48b0: 20 20 20 3b 3b 20 20 09 09 09 09 09 20 20 20 20 ;; .....
48c0: 20 23 3a 6d 6f 64 61 6c 3f 20 23 74 0a 09 09 20 #:modal? #t...
48d0: 20 20 20 20 20 20 3b 3b 20 20 09 09 09 09 09 20 ;; .....
48e0: 20 20 20 20 3b 3b 20 73 65 74 20 70 6f 73 69 74 ;; set posit
48f0: 6f 6e 20 75 73 69 6e 67 20 63 6f 6f 72 64 69 6e on using coordin
4900: 61 74 65 73 20 6f 72 20 63 65 6e 74 65 72 2c 20 ates or center,
4910: 73 74 61 72 74 2c 20 74 6f 70 2c 20 6c 65 66 74 start, top, left
4920: 2c 20 65 6e 64 2c 20 62 6f 74 74 6f 6d 2c 20 72 , end, bottom, r
4930: 69 67 68 74 2c 20 70 61 72 65 6e 74 2d 63 65 6e ight, parent-cen
4940: 74 65 72 2c 20 63 75 72 72 65 6e 74 0a 09 09 20 ter, current...
4950: 20 20 20 20 20 20 3b 3b 20 20 09 09 09 09 09 20 ;; .....
4960: 20 20 20 20 3b 3b 20 23 3a 78 20 27 6d 6f 75 73 ;; #:x 'mous
4970: 65 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 09 e... ;; .
4980: 09 09 09 09 20 20 20 20 20 3b 3b 20 23 3a 79 20 .... ;; #:y
4990: 27 6d 6f 75 73 65 0a 09 09 20 20 20 20 20 20 20 'mouse...
49a0: 3b 3b 20 20 29 09 09 09 09 09 20 20 20 20 20 0a ;; )..... .
49b0: 09 09 20 20 20 20 20 20 20 29 29 29 29 0a 0a 28 .. ))))..(
49c0: 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 define (datashar
49d0: 65 3a 70 75 62 6c 69 73 68 2d 76 69 65 77 20 63 e:publish-view c
49e0: 6f 6e 66 69 67 64 61 74 29 0a 20 20 3b 3b 20 28 onfigdat). ;; (
49f0: 70 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e pp (hash-table->
4a00: 61 6c 69 73 74 20 63 6f 6e 66 69 67 64 61 74 29 alist configdat)
4a10: 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 72 65 61 ). (let* ((area
4a20: 73 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 s (configf
4a30: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 63 6f 6e :get-section con
4a40: 66 69 67 64 61 74 20 22 61 72 65 61 73 22 29 29 figdat "areas"))
4a50: 0a 09 20 28 6c 61 62 65 6c 2d 73 69 7a 65 20 20 .. (label-size
4a60: 22 37 30 78 22 29 0a 09 20 28 61 72 65 61 73 2d "70x").. (areas-
4a70: 73 65 6c 20 20 20 28 69 75 70 3a 6c 69 73 74 62 sel (iup:listb
4a80: 6f 78 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 ox #:expand "HOR
4a90: 49 5a 4f 4e 54 41 4c 22 20 23 3a 64 72 6f 70 64 IZONTAL" #:dropd
4aa0: 6f 77 6e 20 22 59 45 53 22 29 29 0a 09 20 28 76 own "YES")).. (v
4ab0: 65 72 73 69 6f 6e 2d 74 62 20 20 28 69 75 70 3a ersion-tb (iup:
4ac0: 74 65 78 74 62 6f 78 20 23 3a 65 78 70 61 6e 64 textbox #:expand
4ad0: 20 22 48 4f 52 49 5a 4f 4e 54 41 4c 22 29 29 20 "HORIZONTAL"))
4ae0: 3b 3b 20 20 23 3a 73 69 7a 65 20 22 35 30 78 22 ;; #:size "50x"
4af0: 29 29 0a 09 20 28 61 72 65 61 73 2d 73 65 6c 20 )).. (areas-sel
4b00: 20 20 28 69 75 70 3a 6c 69 73 74 62 6f 78 20 23 (iup:listbox #
4b10: 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e :expand "HORIZON
4b20: 54 41 4c 22 20 23 3a 64 72 6f 70 64 6f 77 6e 20 TAL" #:dropdown
4b30: 22 59 45 53 22 29 29 0a 09 20 28 63 6f 6d 70 6f "YES")).. (compo
4b40: 6e 65 6e 74 20 20 20 28 69 75 70 3a 6c 69 73 74 nent (iup:list
4b50: 62 6f 78 20 23 3a 65 78 70 61 6e 64 20 22 48 4f box #:expand "HO
4b60: 52 49 5a 4f 4e 54 41 4c 22 20 23 3a 64 72 6f 70 RIZONTAL" #:drop
4b70: 64 6f 77 6e 20 22 59 45 53 22 20 29 29 0a 09 20 down "YES" ))..
4b80: 28 76 65 72 73 69 6f 6e 2d 76 61 6c 20 28 69 75 (version-val (iu
4b90: 70 3a 74 65 78 74 62 6f 78 20 23 3a 65 78 70 61 p:textbox #:expa
4ba0: 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c 22 20 nd "HORIZONTAL"
4bb0: 23 3a 73 69 7a 65 20 22 35 30 78 22 29 29 0a 09 #:size "50x"))..
4bc0: 20 3b 3b 20 28 63 6f 70 79 2d 6c 69 6e 6b 20 20 ;; (copy-link
4bd0: 20 28 69 75 70 3a 74 6f 67 67 6c 65 20 20 23 3a (iup:toggle #:
4be0: 65 78 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 expand "HORIZONT
4bf0: 41 4c 22 29 29 0a 09 20 3b 3b 20 28 69 74 65 72 AL")).. ;; (iter
4c00: 61 74 69 6f 6e 20 20 20 28 69 75 70 3a 74 65 78 ation (iup:tex
4c10: 74 62 6f 78 20 23 3a 65 78 70 61 6e 64 20 22 59 tbox #:expand "Y
4c20: 45 53 22 20 23 3a 73 69 7a 65 20 22 32 30 78 22 ES" #:size "20x"
4c30: 29 29 0a 09 20 3b 3b 20 28 69 74 65 72 61 74 69 )).. ;; (iterati
4c40: 6f 6e 20 20 20 28 69 75 70 3a 74 65 78 74 62 6f on (iup:textbo
4c50: 78 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 x #:expand "HORI
4c60: 5a 4f 4e 54 41 4c 22 20 23 3a 73 69 7a 65 20 22 ZONTAL" #:size "
4c70: 32 30 78 22 29 29 0a 09 20 28 61 72 65 61 2d 66 20x")).. (area-f
4c80: 69 6c 74 65 72 20 28 69 75 70 3a 74 65 78 74 62 ilter (iup:textb
4c90: 6f 78 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 ox #:expand "HOR
4ca0: 49 5a 4f 4e 54 41 4c 22 20 23 3a 76 61 6c 75 65 IZONTAL" #:value
4cb0: 20 22 25 22 29 29 0a 09 20 28 63 6f 6d 6d 65 6e "%")).. (commen
4cc0: 74 2d 74 62 20 20 28 69 75 70 3a 74 65 78 74 62 t-tb (iup:textb
4cd0: 6f 78 20 23 3a 65 78 70 61 6e 64 20 22 59 45 53 ox #:expand "YES
4ce0: 22 20 23 3a 6d 75 6c 74 69 6c 69 6e 65 20 22 59 " #:multiline "Y
4cf0: 45 53 22 29 29 0a 09 20 28 73 6f 75 72 63 65 2d ES")).. (source-
4d00: 74 62 20 20 20 28 69 75 70 3a 74 65 78 74 62 6f tb (iup:textbo
4d10: 78 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 x #:expand "HORI
4d20: 5a 4f 4e 54 41 4c 22 0a 09 09 09 09 20 20 20 23 ZONTAL"..... #
4d30: 3a 76 61 6c 75 65 20 28 6f 72 20 28 63 6f 6e 66 :value (or (conf
4d40: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
4d50: 67 64 61 74 20 22 73 65 74 74 69 6e 67 73 22 20 gdat "settings"
4d60: 22 62 61 73 65 70 61 74 68 22 29 0a 09 09 09 09 "basepath").....
4d70: 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 09 20 . "")))..
4d80: 28 70 75 62 6c 69 73 68 20 20 20 20 20 28 6c 61 (publish (la
4d90: 6d 62 64 61 20 28 70 75 62 6c 69 73 68 2d 74 79 mbda (publish-ty
4da0: 70 65 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 61 pe)....(let* ((a
4db0: 72 65 61 2d 6e 75 6d 20 20 20 20 28 6f 72 20 28 rea-num (or (
4dc0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
4dd0: 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 61 72 iup:attribute ar
4de0: 65 61 73 2d 73 65 6c 20 22 56 41 4c 55 45 22 29 eas-sel "VALUE")
4df0: 29 20 30 29 29 0a 09 09 09 20 20 20 20 20 20 20 ) 0))....
4e00: 28 61 72 65 61 2d 64 61 74 20 20 20 20 28 69 66 (area-dat (if
4e10: 20 28 3e 20 61 72 65 61 2d 6e 75 6d 20 30 29 28 (> area-num 0)(
4e20: 6c 69 73 74 2d 72 65 66 20 61 72 65 61 73 20 28 list-ref areas (
4e30: 2d 20 61 72 65 61 2d 6e 75 6d 20 31 29 29 27 28 - area-num 1))'(
4e40: 22 4e 4f 54 20 53 45 4c 45 43 54 45 44 22 20 22 "NOT SELECTED" "
4e50: 4e 4f 54 20 53 45 4c 45 43 54 45 44 22 29 29 29 NOT SELECTED")))
4e60: 0a 09 09 09 20 20 20 20 20 20 20 28 61 72 65 61 .... (area
4e70: 2d 70 61 74 68 20 20 20 28 63 61 64 72 20 61 72 -path (cadr ar
4e80: 65 61 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 ea-dat))....
4e90: 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 20 20 (area-name
4ea0: 28 63 61 72 20 20 61 72 65 61 2d 64 61 74 29 29 (car area-dat))
4eb0: 0a 09 09 09 20 20 20 20 20 20 20 28 76 65 72 73 .... (vers
4ec0: 69 6f 6e 20 20 20 20 20 28 69 75 70 3a 61 74 74 ion (iup:att
4ed0: 72 69 62 75 74 65 20 76 65 72 73 69 6f 6e 2d 74 ribute version-t
4ee0: 62 20 22 56 41 4c 55 45 22 29 29 0a 09 09 09 20 b "VALUE"))....
4ef0: 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 (comment
4f00: 20 20 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 (iup:attribut
4f10: 65 20 63 6f 6d 6d 65 6e 74 2d 74 62 20 22 56 41 e comment-tb "VA
4f20: 4c 55 45 22 29 29 0a 09 09 09 20 20 20 20 20 20 LUE"))....
4f30: 20 28 73 70 61 74 68 20 20 20 20 20 20 20 28 69 (spath (i
4f40: 75 70 3a 61 74 74 72 69 62 75 74 65 20 73 6f 75 up:attribute sou
4f50: 72 63 65 2d 74 62 20 20 22 56 41 4c 55 45 22 29 rce-tb "VALUE")
4f60: 29 0a 09 09 09 20 20 20 20 20 20 20 28 73 75 62 ).... (sub
4f70: 6d 69 74 74 65 72 20 20 20 28 63 75 72 72 65 6e mitter (curren
4f80: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 0a 09 09 t-user-name))...
4f90: 09 20 20 20 20 20 20 20 28 71 75 61 6c 69 74 79 . (quality
4fa0: 20 20 20 20 20 32 29 29 0a 09 09 09 20 20 28 64 2)).... (d
4fb0: 61 74 61 73 68 61 72 65 3a 70 75 62 6c 69 73 68 atashare:publish
4fc0: 20 63 6f 6e 66 69 67 64 61 74 20 70 75 62 6c 69 configdat publi
4fd0: 73 68 2d 74 79 70 65 20 61 72 65 61 2d 6e 61 6d sh-type area-nam
4fe0: 65 20 76 65 72 73 69 6f 6e 20 63 6f 6d 6d 65 6e e version commen
4ff0: 74 20 73 70 61 74 68 20 73 75 62 6d 69 74 74 65 t spath submitte
5000: 72 20 71 75 61 6c 69 74 79 29 29 29 29 0a 09 20 r quality))))..
5010: 28 63 6f 70 79 20 20 20 20 20 20 20 20 28 69 75 (copy (iu
5020: 70 3a 62 75 74 74 6f 6e 20 22 43 6f 70 79 20 61 p:button "Copy a
5030: 6e 64 20 50 75 62 6c 69 73 68 22 0a 09 09 09 09 nd Publish".....
5040: 20 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 #:expand "HORI
5050: 5a 4f 4e 54 41 4c 22 0a 09 09 09 09 20 20 23 3a ZONTAL"..... #:
5060: 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 action (lambda (
5070: 6f 62 6a 29 0a 09 09 09 09 09 20 20 20 20 20 28 obj)...... (
5080: 70 75 62 6c 69 73 68 20 27 63 6f 70 79 29 29 29 publish 'copy)))
5090: 29 0a 09 20 28 6c 69 6e 6b 20 20 20 20 20 20 20 ).. (link
50a0: 20 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 4c 69 (iup:button "Li
50b0: 6e 6b 20 61 6e 64 20 50 75 62 6c 69 73 68 22 0a nk and Publish".
50c0: 09 09 09 09 20 20 23 3a 65 78 70 61 6e 64 20 22 .... #:expand "
50d0: 48 4f 52 49 5a 4f 4e 54 41 4c 22 0a 09 09 09 09 HORIZONTAL".....
50e0: 20 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 #:action (lamb
50f0: 64 61 20 28 6f 62 6a 29 0a 09 09 09 09 09 20 20 da (obj)......
5100: 20 20 20 28 70 75 62 6c 69 73 68 20 27 6c 69 6e (publish 'lin
5110: 6b 29 29 29 29 0a 09 20 28 62 72 6f 77 73 65 2d k)))).. (browse-
5120: 62 74 6e 20 20 28 69 75 70 3a 62 75 74 74 6f 6e btn (iup:button
5130: 20 22 42 72 6f 77 73 65 22 0a 09 09 09 09 20 20 "Browse".....
5140: 23 3a 73 69 7a 65 20 22 34 30 78 22 0a 09 09 09 #:size "40x"....
5150: 09 20 20 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d . #:action (lam
5160: 62 64 61 20 28 6f 62 6a 29 0a 09 09 09 09 09 20 bda (obj)......
5170: 20 20 20 20 28 6c 65 74 2a 20 28 28 66 64 20 20 (let* ((fd
5180: 28 69 75 70 3a 66 69 6c 65 2d 64 69 61 6c 6f 67 (iup:file-dialog
5190: 20 23 3a 64 69 61 6c 6f 67 74 79 70 65 20 22 44 #:dialogtype "D
51a0: 49 52 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 IR")).......
51b0: 28 74 6f 70 20 28 69 75 70 3a 73 68 6f 77 20 66 (top (iup:show f
51c0: 64 20 23 3a 6d 6f 64 61 6c 3f 20 22 59 45 53 22 d #:modal? "YES"
51d0: 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 )))......
51e0: 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 (iup:attribute-s
51f0: 65 74 21 20 73 6f 75 72 63 65 2d 74 62 20 22 56 et! source-tb "V
5200: 41 4c 55 45 22 0a 09 09 09 09 09 09 09 09 20 20 ALUE".........
5210: 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 (iup:attribute
5220: 66 64 20 22 56 41 4c 55 45 22 29 29 0a 09 09 09 fd "VALUE"))....
5230: 09 09 20 20 20 20 20 20 20 28 69 75 70 3a 64 65 .. (iup:de
5240: 73 74 72 6f 79 21 20 66 64 29 29 29 29 29 29 0a stroy! fd)))))).
5250: 20 20 20 20 28 70 72 69 6e 74 20 22 61 72 65 61 (print "area
5260: 73 22 29 0a 20 20 20 20 3b 3b 20 28 70 70 20 61 s"). ;; (pp a
5270: 72 65 61 73 29 0a 20 20 20 20 28 66 6f 6c 64 20 reas). (fold
5280: 28 6c 61 6d 62 64 61 20 28 61 72 65 61 64 61 74 (lambda (areadat
5290: 20 6e 75 6d 29 0a 09 20 20 20 20 3b 3b 20 28 70 num).. ;; (p
52a0: 72 69 6e 74 20 22 41 64 64 69 6e 67 20 6e 75 6d rint "Adding num
52b0: 3d 22 20 6e 75 6d 20 22 2c 20 61 72 65 61 64 61 =" num ", areada
52c0: 74 3d 22 20 61 72 65 61 64 61 74 29 0a 09 20 20 t=" areadat)..
52d0: 20 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 (iup:attribute
52e0: 2d 73 65 74 21 20 61 72 65 61 73 2d 73 65 6c 20 -set! areas-sel
52f0: 28 63 6f 6e 63 20 6e 75 6d 29 20 28 63 61 72 20 (conc num) (car
5300: 61 72 65 61 64 61 74 29 29 0a 09 20 20 20 20 28 areadat)).. (
5310: 2b 20 31 20 6e 75 6d 29 29 0a 09 20 20 31 20 61 + 1 num)).. 1 a
5320: 72 65 61 73 29 0a 20 20 20 20 28 69 75 70 3a 76 reas). (iup:v
5330: 62 6f 78 0a 20 20 20 20 20 28 69 75 70 3a 68 62 box. (iup:hb
5340: 6f 78 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 41 ox (iup:label "A
5350: 72 65 61 3a 22 20 20 20 20 20 20 20 20 23 3a 73 rea:" #:s
5360: 69 7a 65 20 6c 61 62 65 6c 2d 73 69 7a 65 29 20 ize label-size)
5370: 3b 3b 20 61 72 65 61 2d 66 69 6c 74 65 72 20 0a ;; area-filter .
5380: 09 20 20 20 20 20 20 20 61 72 65 61 73 2d 73 65 . areas-se
5390: 6c 29 0a 20 20 20 20 20 28 69 75 70 3a 68 62 6f l). (iup:hbo
53a0: 78 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 56 65 x (iup:label "Ve
53b0: 72 73 69 6f 6e 3a 22 20 20 20 20 20 23 3a 73 69 rsion:" #:si
53c0: 7a 65 20 6c 61 62 65 6c 2d 73 69 7a 65 29 20 20 ze label-size)
53d0: 20 76 65 72 73 69 6f 6e 2d 74 62 29 0a 20 20 20 version-tb).
53e0: 20 20 3b 3b 20 28 69 75 70 3a 68 62 6f 78 20 28 ;; (iup:hbox (
53f0: 69 75 70 3a 6c 61 62 65 6c 20 22 4c 69 6e 6b 20 iup:label "Link
5400: 6f 6e 6c 79 22 20 20 20 20 23 3a 73 69 7a 65 20 only" #:size
5410: 6c 61 62 65 6c 2d 73 69 7a 65 29 20 20 20 63 6f label-size) co
5420: 70 79 2d 6c 69 6e 6b 29 0a 20 20 20 20 20 3b 3b py-link). ;;
5430: 20 09 20 20 20 20 20 20 20 28 69 75 70 3a 6c 61 . (iup:la
5440: 62 65 6c 20 22 49 74 65 72 61 74 69 6f 6e 3a 22 bel "Iteration:"
5450: 29 20 20 20 69 74 65 72 61 74 69 6f 6e 29 0a 20 ) iteration).
5460: 20 20 20 20 28 69 75 70 3a 68 62 6f 78 20 28 69 (iup:hbox (i
5470: 75 70 3a 6c 61 62 65 6c 20 22 43 6f 6d 6d 65 6e up:label "Commen
5480: 74 3a 22 20 20 20 20 20 23 3a 73 69 7a 65 20 6c t:" #:size l
5490: 61 62 65 6c 2d 73 69 7a 65 29 20 20 20 63 6f 6d abel-size) com
54a0: 6d 65 6e 74 2d 74 62 29 0a 20 20 20 20 20 28 69 ment-tb). (i
54b0: 75 70 3a 68 62 6f 78 20 28 69 75 70 3a 6c 61 62 up:hbox (iup:lab
54c0: 65 6c 20 22 53 6f 75 72 63 65 20 62 61 73 65 20 el "Source base
54d0: 70 61 74 68 3a 22 20 23 3a 73 69 7a 65 20 6c 61 path:" #:size la
54e0: 62 65 6c 2d 73 69 7a 65 29 20 20 20 73 6f 75 72 bel-size) sour
54f0: 63 65 2d 74 62 20 62 72 6f 77 73 65 2d 62 74 6e ce-tb browse-btn
5500: 29 0a 20 20 20 20 20 28 69 75 70 3a 68 62 6f 78 ). (iup:hbox
5510: 20 63 6f 70 79 20 6c 69 6e 6b 29 29 29 29 0a 0a copy link))))..
5520: 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 (define (datasha
5530: 72 65 3a 6c 73 74 2d 3e 70 61 74 68 20 70 61 74 re:lst->path pat
5540: 68 6c 73 74 29 0a 20 20 28 63 6f 6e 63 20 22 2f hlst). (conc "/
5550: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
5560: 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 perse (map conc
5570: 70 61 74 68 6c 73 74 29 20 22 2f 22 29 29 29 0a pathlst) "/"))).
5580: 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 .(define (datash
5590: 61 72 65 3a 70 61 74 68 2d 3e 6c 73 74 20 70 61 are:path->lst pa
55a0: 74 68 29 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 th). (string-sp
55b0: 6c 69 74 20 70 61 74 68 20 22 2f 22 29 29 0a 0a lit path "/"))..
55c0: 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 (define (datasha
55d0: 72 65 3a 70 61 74 68 64 61 74 2d 61 70 70 6c 79 re:pathdat-apply
55e0: 2d 68 65 75 72 69 73 74 69 63 73 20 63 6f 6e 66 -heuristics conf
55f0: 69 67 64 61 74 20 70 61 74 68 29 0a 20 20 28 63 igdat path). (c
5600: 6f 6e 64 0a 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a ond. ((common:
5610: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 74 file-exists? pat
5620: 68 29 20 22 66 6f 75 6e 64 22 29 0a 20 20 20 28 h) "found"). (
5630: 65 6c 73 65 20 28 63 6f 6e 63 20 70 61 74 68 20 else (conc path
5640: 22 20 6e 6f 74 20 69 6e 73 74 61 6c 6c 65 64 22 " not installed"
5650: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 ))))..(define (d
5660: 61 74 61 73 68 61 72 65 3a 67 65 74 2d 76 69 65 atashare:get-vie
5670: 77 20 63 6f 6e 66 69 67 64 61 74 29 0a 20 20 28 w configdat). (
5680: 69 75 70 3a 76 62 6f 78 0a 20 20 20 28 69 75 70 iup:vbox. (iup
5690: 3a 68 62 6f 78 0a 20 20 20 20 28 6c 65 74 2a 20 :hbox. (let*
56a0: 28 28 6c 61 62 65 6c 2d 73 69 7a 65 20 20 20 20 ((label-size
56b0: 20 22 36 30 78 22 29 0a 09 20 20 20 3b 3b 20 66 "60x").. ;; f
56c0: 69 6c 74 65 72 20 65 6c 65 6d 65 6e 74 73 0a 09 ilter elements..
56d0: 20 20 20 28 61 72 65 61 2d 66 69 6c 74 65 72 20 (area-filter
56e0: 20 20 20 22 25 22 29 0a 09 20 20 20 28 76 65 72 "%").. (ver
56f0: 73 69 6f 6e 2d 66 69 6c 74 65 72 20 22 25 22 29 sion-filter "%")
5700: 0a 09 20 20 20 28 69 74 65 72 2d 66 69 6c 74 65 .. (iter-filte
5710: 72 20 20 20 20 22 3e 3d 20 30 22 29 0a 09 20 20 r ">= 0")..
5720: 20 3b 3b 20 72 65 76 65 72 73 65 20 6c 6f 6f 6b ;; reverse look
5730: 75 70 20 66 72 6f 6d 20 70 61 74 68 20 74 6f 20 up from path to
5740: 64 61 74 61 20 66 6f 72 20 73 72 63 20 61 6e 64 data for src and
5750: 20 69 6e 73 74 61 6c 6c 65 64 0a 09 20 20 20 28 installed.. (
5760: 73 72 63 64 61 74 20 20 20 20 20 20 20 20 20 28 srcdat (
5770: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
5780: 29 20 3b 3b 20 72 65 76 65 72 73 65 20 6c 6f 6f ) ;; reverse loo
5790: 6b 75 70 0a 09 20 20 20 28 69 6e 73 74 61 6c 6c kup.. (install
57a0: 65 64 2d 64 61 74 20 20 28 6d 61 6b 65 2d 68 61 ed-dat (make-ha
57b0: 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 3b sh-table)).. ;
57c0: 3b 20 63 6f 6e 66 69 67 20 76 61 6c 75 65 73 0a ; config values.
57d0: 09 20 20 20 28 62 61 73 65 70 61 74 68 20 20 20 . (basepath
57e0: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (configf:loo
57f0: 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 kup configdat "s
5800: 65 74 74 69 6e 67 73 22 20 22 62 61 73 65 70 61 ettings" "basepa
5810: 74 68 22 29 29 0a 09 20 20 20 3b 3b 20 67 75 69 th")).. ;; gui
5820: 20 65 6c 65 6d 65 6e 74 73 0a 09 20 20 20 28 73 elements.. (s
5830: 75 62 6d 69 74 74 65 72 20 20 20 20 20 20 28 69 ubmitter (i
5840: 75 70 3a 6c 61 62 65 6c 20 22 22 20 23 3a 65 78 up:label "" #:ex
5850: 70 61 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c pand "HORIZONTAL
5860: 22 29 29 0a 09 20 20 20 28 64 61 74 65 2d 73 75 ")).. (date-su
5870: 62 6d 69 74 74 65 64 20 28 69 75 70 3a 6c 61 62 bmitted (iup:lab
5880: 65 6c 20 22 22 20 23 3a 65 78 70 61 6e 64 20 22 el "" #:expand "
5890: 48 4f 52 49 5a 4f 4e 54 41 4c 22 29 29 0a 09 20 HORIZONTAL"))..
58a0: 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 (comment
58b0: 20 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 22 20 (iup:label ""
58c0: 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 5a 4f #:expand "HORIZO
58d0: 4e 54 41 4c 22 29 29 0a 09 20 20 20 28 63 6f 70 NTAL")).. (cop
58e0: 79 2d 6c 69 6e 6b 20 20 20 20 20 20 28 69 75 70 y-link (iup
58f0: 3a 6c 61 62 65 6c 20 22 22 20 23 3a 65 78 70 61 :label "" #:expa
5900: 6e 64 20 22 48 4f 52 49 5a 4f 4e 54 41 4c 22 29 nd "HORIZONTAL")
5910: 29 0a 09 20 20 20 28 71 75 61 6c 69 74 79 20 20 ).. (quality
5920: 20 20 20 20 20 20 28 69 75 70 3a 6c 61 62 65 6c (iup:label
5930: 20 22 22 20 23 3a 65 78 70 61 6e 64 20 22 48 4f "" #:expand "HO
5940: 52 49 5a 4f 4e 54 41 4c 22 29 29 0a 09 20 20 20 RIZONTAL"))..
5950: 28 69 6e 73 74 61 6c 6c 65 64 2d 73 74 61 74 75 (installed-statu
5960: 73 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 22 20 s (iup:label ""
5970: 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 5a 4f #:expand "HORIZO
5980: 4e 54 41 4c 22 29 29 0a 09 20 20 20 3b 3b 20 6d NTAL")).. ;; m
5990: 69 73 63 20 0a 09 20 20 20 28 63 75 72 72 2d 72 isc .. (curr-r
59a0: 65 63 6f 72 64 20 20 20 20 23 66 29 0a 09 20 20 ecord #f)..
59b0: 20 3b 3b 20 28 73 6f 75 72 63 65 2d 64 61 74 61 ;; (source-data
59c0: 20 20 20 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 (iup:label "
59d0: 22 20 23 3a 65 78 70 61 6e 64 20 22 48 4f 52 49 " #:expand "HORI
59e0: 5a 4f 4e 54 41 4c 22 29 29 0a 09 20 20 20 28 74 ZONTAL")).. (t
59f0: 62 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 b (i
5a00: 75 70 3a 74 72 65 65 62 6f 78 0a 09 09 09 20 20 up:treebox....
5a10: 20 20 23 3a 76 61 6c 75 65 20 30 0a 09 09 09 20 #:value 0....
5a20: 20 20 20 23 3a 6e 61 6d 65 20 22 50 61 63 6b 61 #:name "Packa
5a30: 67 65 73 22 0a 09 09 09 20 20 20 20 23 3a 65 78 ges".... #:ex
5a40: 70 61 6e 64 20 22 59 45 53 22 0a 09 09 09 20 20 pand "YES"....
5a50: 20 20 23 3a 61 64 64 65 78 70 61 6e 64 65 64 20 #:addexpanded
5a60: 22 4e 4f 22 0a 09 09 09 20 20 20 20 23 3a 73 65 "NO".... #:se
5a70: 6c 65 63 74 69 6f 6e 2d 63 62 0a 09 09 09 20 20 lection-cb....
5a80: 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 69 (lambda (obj i
5a90: 64 20 73 74 61 74 65 29 0a 09 09 09 20 20 20 20 d state)....
5aa0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6f 62 6a ;; (print "obj
5ab0: 3a 20 22 20 6f 62 6a 20 22 2c 20 69 64 3a 20 22 : " obj ", id: "
5ac0: 20 69 64 20 22 2c 20 73 74 61 74 65 3a 20 22 20 id ", state: "
5ad0: 73 74 61 74 65 29 0a 09 09 09 20 20 20 20 20 20 state)....
5ae0: 28 6c 65 74 2a 20 28 28 70 61 74 68 20 20 20 28 (let* ((path (
5af0: 64 61 74 61 73 68 61 72 65 3a 6c 73 74 2d 3e 70 datashare:lst->p
5b00: 61 74 68 20 28 63 64 72 20 28 74 72 65 65 3a 6e ath (cdr (tree:n
5b10: 6f 64 65 2d 3e 70 61 74 68 20 6f 62 6a 20 69 64 ode->path obj id
5b20: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 72 ))))..... (r
5b30: 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c ecord (hash-tabl
5b40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 72 e-ref/default sr
5b50: 63 64 61 74 20 70 61 74 68 20 23 66 29 29 29 0a cdat path #f))).
5b60: 09 09 09 09 28 69 66 20 72 65 63 6f 72 64 0a 09 ....(if record..
5b70: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
5b80: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 63 75 .. (set! cu
5b90: 72 72 2d 72 65 63 6f 72 64 20 72 65 63 6f 72 64 rr-record record
5ba0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 75 70 )..... (iup
5bb0: 3a 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 :attribute-set!
5bc0: 73 75 62 6d 69 74 74 65 72 20 20 20 20 20 20 22 submitter "
5bd0: 54 49 54 4c 45 22 20 28 64 61 74 61 73 68 61 72 TITLE" (datashar
5be0: 65 3a 70 6b 67 2d 67 65 74 2d 73 75 62 6d 69 74 e:pkg-get-submit
5bf0: 74 65 72 20 72 65 63 6f 72 64 29 29 0a 09 09 09 ter record))....
5c00: 09 20 20 20 20 20 20 28 69 75 70 3a 61 74 74 72 . (iup:attr
5c10: 69 62 75 74 65 2d 73 65 74 21 20 64 61 74 65 2d ibute-set! date-
5c20: 73 75 62 6d 69 74 74 65 64 20 22 54 49 54 4c 45 submitted "TITLE
5c30: 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
5c40: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
5c50: 74 69 6d 65 20 28 64 61 74 61 73 68 61 72 65 3a time (datashare:
5c60: 70 6b 67 2d 67 65 74 2d 64 61 74 65 74 69 6d 65 pkg-get-datetime
5c70: 20 72 65 63 6f 72 64 29 29 29 29 0a 09 09 09 09 record)))).....
5c80: 20 20 20 20 20 20 28 69 75 70 3a 61 74 74 72 69 (iup:attri
5c90: 62 75 74 65 2d 73 65 74 21 20 63 6f 6d 6d 65 6e bute-set! commen
5ca0: 74 20 20 20 20 20 20 20 20 22 54 49 54 4c 45 22 t "TITLE"
5cb0: 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d (datashare:pkg-
5cc0: 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 72 65 63 6f get-comment reco
5cd0: 72 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 rd))..... (
5ce0: 69 75 70 3a 61 74 74 72 69 62 75 74 65 2d 73 65 iup:attribute-se
5cf0: 74 21 20 71 75 61 6c 69 74 79 20 20 20 20 20 20 t! quality
5d00: 20 20 22 54 49 54 4c 45 22 20 28 64 61 74 61 73 "TITLE" (datas
5d10: 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 71 75 61 hare:pkg-get-qua
5d20: 6c 69 74 79 20 72 65 63 6f 72 64 29 29 0a 09 09 lity record))...
5d30: 09 09 20 20 20 20 20 20 28 69 75 70 3a 61 74 74 .. (iup:att
5d40: 72 69 62 75 74 65 2d 73 65 74 21 20 63 6f 70 79 ribute-set! copy
5d50: 2d 6c 69 6e 6b 20 20 20 20 20 20 22 54 49 54 4c -link "TITL
5d60: 45 22 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b E" (datashare:pk
5d70: 67 2d 67 65 74 2d 73 74 6f 72 65 5f 74 79 70 65 g-get-store_type
5d80: 20 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 record)).....
5d90: 20 20 20 20 29 29 0a 09 09 09 09 3b 3b 20 28 70 )).....;; (p
5da0: 72 69 6e 74 20 20 22 69 64 3d 22 20 69 64 20 22 rint "id=" id "
5db0: 20 70 61 74 68 3d 22 20 70 61 74 68 20 22 20 72 path=" path " r
5dc0: 65 63 6f 72 64 3d 22 20 72 65 63 6f 72 64 29 3b ecord=" record);
5dd0: 3b 20 28 74 72 65 65 3a 6e 6f 64 65 2d 3e 70 61 ; (tree:node->pa
5de0: 74 68 20 6f 62 6a 20 69 64 29 20 22 20 72 75 6e th obj id) " run
5df0: 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 29 0a 09 -id: " run-id)..
5e00: 09 09 09 29 29 29 29 0a 09 20 20 20 28 74 62 32 ...)))).. (tb2
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 75 (iu
5e20: 70 3a 74 72 65 65 62 6f 78 0a 09 09 09 20 20 20 p:treebox....
5e30: 20 23 3a 76 61 6c 75 65 20 30 0a 09 09 09 20 20 #:value 0....
5e40: 20 20 23 3a 6e 61 6d 65 20 22 49 6e 73 74 61 6c #:name "Instal
5e50: 6c 65 64 22 0a 09 09 09 20 20 20 20 23 3a 65 78 led".... #:ex
5e60: 70 61 6e 64 20 22 59 45 53 22 0a 09 09 09 20 20 pand "YES"....
5e70: 20 20 23 3a 61 64 64 65 78 70 61 6e 64 65 64 20 #:addexpanded
5e80: 22 4e 4f 22 0a 09 09 09 20 20 20 20 23 3a 73 65 "NO".... #:se
5e90: 6c 65 63 74 69 6f 6e 2d 63 62 0a 09 09 09 20 20 lection-cb....
5ea0: 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 69 (lambda (obj i
5eb0: 64 20 73 74 61 74 65 29 0a 09 09 09 20 20 20 20 d state)....
5ec0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6f 62 6a ;; (print "obj
5ed0: 3a 20 22 20 6f 62 6a 20 22 2c 20 69 64 3a 20 22 : " obj ", id: "
5ee0: 20 69 64 20 22 2c 20 73 74 61 74 65 3a 20 22 20 id ", state: "
5ef0: 73 74 61 74 65 29 0a 09 09 09 20 20 20 20 20 20 state)....
5f00: 28 6c 65 74 2a 20 28 28 70 61 74 68 20 20 20 28 (let* ((path (
5f10: 64 61 74 61 73 68 61 72 65 3a 6c 73 74 2d 3e 70 datashare:lst->p
5f20: 61 74 68 20 28 63 64 72 20 28 74 72 65 65 3a 6e ath (cdr (tree:n
5f30: 6f 64 65 2d 3e 70 61 74 68 20 6f 62 6a 20 69 64 ode->path obj id
5f40: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 ))))..... (s
5f50: 74 61 74 75 73 20 28 68 61 73 68 2d 74 61 62 6c tatus (hash-tabl
5f60: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 6e e-ref/default in
5f70: 73 74 61 6c 6c 65 64 2d 64 61 74 20 70 61 74 68 stalled-dat path
5f80: 20 23 66 29 29 29 0a 09 09 09 09 28 69 75 70 3a #f))).....(iup:
5f90: 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 69 attribute-set! i
5fa0: 6e 73 74 61 6c 6c 65 64 2d 73 74 61 74 75 73 20 nstalled-status
5fb0: 22 54 49 54 4c 45 22 20 28 69 66 20 73 74 61 74 "TITLE" (if stat
5fc0: 75 73 20 73 74 61 74 75 73 20 22 22 29 29 0a 09 us status ""))..
5fd0: 09 09 09 29 29 29 29 0a 09 20 20 20 28 72 65 66 ...)))).. (ref
5fe0: 72 65 73 68 20 20 20 20 20 20 20 20 28 6c 61 6d resh (lam
5ff0: 62 64 61 20 28 6f 62 6a 29 0a 09 09 09 20 20 20 bda (obj)....
6000: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
6010: 28 64 61 74 61 73 68 61 72 65 3a 6f 70 65 6e 2d (datashare:open-
6020: 64 62 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 09 db configdat))..
6030: 09 09 09 20 20 20 20 28 61 72 65 61 73 20 28 6f ... (areas (o
6040: 72 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 r (configf:get-s
6050: 65 63 74 69 6f 6e 20 63 6f 6e 66 69 67 64 61 74 ection configdat
6060: 20 22 61 72 65 61 73 22 29 20 27 28 29 29 29 29 "areas") '())))
6070: 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 0a 09 09 .... ;;...
6080: 09 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 . ;; first
6090: 20 75 70 64 61 74 65 20 74 68 65 20 53 6f 75 72 update the Sour
60a0: 63 65 73 0a 09 09 09 20 20 20 20 20 20 20 3b 3b ces.... ;;
60b0: 0a 09 09 09 20 20 20 20 20 20 20 28 66 6f 72 2d .... (for-
60c0: 65 61 63 68 0a 09 09 09 09 28 6c 61 6d 62 64 61 each.....(lambda
60d0: 20 28 70 6b 67 69 74 65 6d 29 0a 09 09 09 09 20 (pkgitem).....
60e0: 20 28 6c 65 74 2a 20 28 28 70 6b 67 2d 70 61 74 (let* ((pkg-pat
60f0: 68 20 20 20 28 6c 69 73 74 20 28 64 61 74 61 73 h (list (datas
6100: 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 61 72 65 hare:pkg-get-are
6110: 61 20 20 70 6b 67 69 74 65 6d 29 0a 09 09 09 09 a pkgitem).....
6120: 09 09 09 20 20 20 28 64 61 74 61 73 68 61 72 65 ... (datashare
6130: 3a 70 6b 67 2d 67 65 74 2d 76 65 72 73 69 6f 6e :pkg-get-version
6140: 5f 6e 61 6d 65 20 70 6b 67 69 74 65 6d 29 0a 09 _name pkgitem)..
6150: 09 09 09 09 09 09 20 20 20 28 64 61 74 61 73 68 ...... (datash
6160: 61 72 65 3a 70 6b 67 2d 67 65 74 2d 69 74 65 72 are:pkg-get-iter
6170: 61 74 69 6f 6e 20 70 6b 67 69 74 65 6d 29 29 29 ation pkgitem)))
6180: 0a 09 09 09 09 09 20 28 70 6b 67 2d 69 64 20 20 ...... (pkg-id
6190: 20 20 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b (datashare:pk
61a0: 67 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 g-get-id
61b0: 20 20 70 6b 67 69 74 65 6d 29 29 0a 09 09 09 09 pkgitem)).....
61c0: 09 20 28 70 61 74 68 20 20 20 20 20 20 20 28 64 . (path (d
61d0: 61 74 61 73 68 61 72 65 3a 6c 73 74 2d 3e 70 61 atashare:lst->pa
61e0: 74 68 20 70 6b 67 2d 70 61 74 68 29 29 29 0a 09 th pkg-path)))..
61f0: 09 09 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ... ;; (print
6200: 20 22 74 72 65 65 3a 61 64 64 2d 6e 6f 64 65 20 "tree:add-node
6210: 74 62 3d 22 20 74 62 20 22 2c 20 70 6b 67 2d 70 tb=" tb ", pkg-p
6220: 61 74 68 3d 22 20 70 6b 67 2d 70 61 74 68 20 22 ath=" pkg-path "
6230: 2c 20 70 6b 67 2d 69 64 3d 22 20 70 6b 67 2d 69 , pkg-id=" pkg-i
6240: 64 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 d)..... (if (
6250: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
6260: 72 65 66 2f 64 65 66 61 75 6c 74 20 73 72 63 64 ref/default srcd
6270: 61 74 20 70 61 74 68 20 23 66 29 29 0a 09 09 09 at path #f))....
6280: 09 09 28 74 72 65 65 3a 61 64 64 2d 6e 6f 64 65 ..(tree:add-node
6290: 20 74 62 20 22 50 61 63 6b 61 67 65 73 22 20 70 tb "Packages" p
62a0: 6b 67 2d 70 61 74 68 20 75 73 65 72 64 61 74 61 kg-path userdata
62b0: 3a 20 28 63 6f 6e 63 20 22 70 6b 67 2d 69 64 3a : (conc "pkg-id:
62c0: 20 22 20 70 6b 67 2d 69 64 29 29 29 0a 09 09 09 " pkg-id)))....
62d0: 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 . ;; (print "
62e0: 70 61 74 68 3d 22 20 70 61 74 68 20 22 20 70 6b path=" path " pk
62f0: 67 69 74 65 6d 3d 22 20 70 6b 67 69 74 65 6d 29 gitem=" pkgitem)
6300: 0a 09 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 ..... (hash-t
6310: 61 62 6c 65 2d 73 65 74 21 20 73 72 63 64 61 74 able-set! srcdat
6320: 20 70 61 74 68 20 70 6b 67 69 74 65 6d 29 29 29 path pkgitem)))
6330: 0a 09 09 09 09 28 64 61 74 61 73 68 61 72 65 3a .....(datashare:
6340: 67 65 74 2d 70 6b 67 73 20 64 62 20 61 72 65 61 get-pkgs db area
6350: 2d 66 69 6c 74 65 72 20 76 65 72 73 69 6f 6e 2d -filter version-
6360: 66 69 6c 74 65 72 20 69 74 65 72 2d 66 69 6c 74 filter iter-filt
6370: 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 20 3b er)).... ;
6380: 3b 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 20 74 ;.... ;; t
6390: 68 65 6e 20 75 70 64 61 74 65 20 74 68 65 20 69 hen update the i
63a0: 6e 73 74 61 6c 6c 65 64 0a 09 09 09 20 20 20 20 nstalled....
63b0: 20 20 20 3b 3b 0a 09 09 09 20 20 20 20 20 20 20 ;;....
63c0: 28 66 6f 72 2d 65 61 63 68 0a 09 09 09 09 28 6c (for-each.....(l
63d0: 61 6d 62 64 61 20 28 61 72 65 61 29 0a 09 09 09 ambda (area)....
63e0: 09 20 20 28 6c 65 74 2a 20 28 28 70 61 74 68 20 . (let* ((path
63f0: 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 63 (conc "/" (c
6400: 61 64 72 20 61 72 65 61 29 29 29 0a 09 09 09 09 adr area))).....
6410: 09 20 28 66 75 6c 6c 70 61 74 68 20 28 63 6f 6e . (fullpath (con
6420: 63 20 62 61 73 65 70 61 74 68 20 70 61 74 68 29 c basepath path)
6430: 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 ))..... (if (
6440: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
6450: 72 65 66 2f 64 65 66 61 75 6c 74 20 69 6e 73 74 ref/default inst
6460: 61 6c 6c 65 64 2d 64 61 74 20 70 61 74 68 20 23 alled-dat path #
6470: 66 29 29 0a 09 09 09 09 09 28 74 72 65 65 3a 61 f))......(tree:a
6480: 64 64 2d 6e 6f 64 65 20 74 62 32 20 22 49 6e 73 dd-node tb2 "Ins
6490: 74 61 6c 6c 65 64 22 20 28 64 61 74 61 73 68 61 talled" (datasha
64a0: 72 65 3a 70 61 74 68 2d 3e 6c 73 74 20 70 61 74 re:path->lst pat
64b0: 68 29 29 29 0a 09 09 09 09 20 20 20 20 28 68 61 h)))..... (ha
64c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 69 6e sh-table-set! in
64d0: 73 74 61 6c 6c 65 64 2d 64 61 74 20 70 61 74 68 stalled-dat path
64e0: 20 28 64 61 74 61 73 68 61 72 65 3a 70 61 74 68 (datashare:path
64f0: 64 61 74 2d 61 70 70 6c 79 2d 68 65 75 72 69 73 dat-apply-heuris
6500: 74 69 63 73 20 63 6f 6e 66 69 67 64 61 74 20 66 tics configdat f
6510: 75 6c 6c 70 61 74 68 29 29 29 29 0a 09 09 09 09 ullpath)))).....
6520: 61 72 65 61 73 29 0a 09 09 09 20 20 20 20 20 20 areas)....
6530: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali
6540: 7a 65 21 20 64 62 29 29 29 29 0a 09 20 20 20 28 ze! db)))).. (
6550: 61 70 70 6c 79 20 20 20 20 20 20 20 20 20 20 28 apply (
6560: 69 75 70 3a 62 75 74 74 6f 6e 20 22 41 70 70 6c iup:button "Appl
6570: 79 22 0a 09 09 09 09 20 20 20 20 20 20 20 23 3a y"..... #:
6580: 61 63 74 69 6f 6e 0a 09 09 09 09 20 20 20 20 20 action.....
6590: 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 0a (lambda (obj).
65a0: 09 09 09 09 09 20 28 69 66 20 63 75 72 72 2d 72 ..... (if curr-r
65b0: 65 63 6f 72 64 0a 09 09 09 09 09 20 20 20 20 20 ecord......
65c0: 28 6c 65 74 2a 20 28 28 61 72 65 61 20 20 20 20 (let* ((area
65d0: 20 20 20 20 28 64 61 74 61 73 68 61 72 65 3a 70 (datashare:p
65e0: 6b 67 2d 67 65 74 2d 61 72 65 61 20 20 20 20 20 kg-get-area
65f0: 20 20 20 63 75 72 72 2d 72 65 63 6f 72 64 29 29 curr-record))
6600: 0a 09 09 09 09 09 09 20 20 20 20 28 73 74 6f 72 ....... (stor
6610: 65 64 2d 70 61 74 68 20 28 64 61 74 61 73 68 61 ed-path (datasha
6620: 72 65 3a 70 6b 67 2d 67 65 74 2d 73 74 6f 72 65 re:pkg-get-store
6630: 64 5f 70 61 74 68 20 63 75 72 72 2d 72 65 63 6f d_path curr-reco
6640: 72 64 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 rd))....... (
6650: 73 6f 75 72 63 65 2d 74 79 70 65 20 28 64 61 74 source-type (dat
6660: 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 73 ashare:pkg-get-s
6670: 74 6f 72 65 5f 74 79 70 65 20 20 63 75 72 72 2d tore_type curr-
6680: 72 65 63 6f 72 64 29 29 0a 09 09 09 09 09 09 20 record)).......
6690: 20 20 20 28 73 6f 75 72 63 65 2d 70 61 74 68 20 (source-path
66a0: 28 63 61 73 65 20 73 6f 75 72 63 65 2d 74 79 70 (case source-typ
66b0: 65 20 3b 3b 20 20 28 65 71 75 61 6c 3f 20 73 6f e ;; (equal? so
66c0: 75 72 63 65 2d 74 79 70 65 20 22 6c 69 6e 6b 22 urce-type "link"
66d0: 29 29 0a 09 09 09 09 09 09 09 09 20 20 20 28 28 ))......... ((
66e0: 6c 69 6e 6b 29 28 64 61 74 61 73 68 61 72 65 3a link)(datashare:
66f0: 70 6b 67 2d 67 65 74 2d 73 6f 75 72 63 65 2d 70 pkg-get-source-p
6700: 61 74 68 20 63 75 72 72 2d 72 65 63 6f 72 64 29 ath curr-record)
6710: 29 0a 09 09 09 09 09 09 09 09 20 20 20 28 28 63 )......... ((c
6720: 6f 70 79 29 73 74 6f 72 65 64 2d 70 61 74 68 29 opy)stored-path)
6730: 0a 09 09 09 09 09 09 09 09 20 20 20 28 65 6c 73 ......... (els
6740: 65 20 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 e #f))).......
6750: 20 20 28 64 65 73 74 2d 73 74 75 62 20 20 20 28 (dest-stub (
6760: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 configf:lookup c
6770: 6f 6e 66 69 67 64 61 74 20 22 61 72 65 61 73 22 onfigdat "areas"
6780: 20 61 72 65 61 29 29 0a 09 09 09 09 09 09 20 20 area)).......
6790: 20 20 28 74 61 72 67 65 74 2d 70 61 74 68 20 28 (target-path (
67a0: 63 6f 6e 63 20 62 61 73 65 70 61 74 68 20 22 2f conc basepath "/
67b0: 22 20 64 65 73 74 2d 73 74 75 62 29 29 29 0a 09 " dest-stub)))..
67c0: 09 09 09 09 20 20 20 20 20 20 20 28 64 61 74 61 .... (data
67d0: 73 68 61 72 65 3a 62 75 69 6c 64 2d 64 69 72 2d share:build-dir-
67e0: 6d 61 6b 65 2d 6c 69 6e 6b 20 73 74 6f 72 65 64 make-link stored
67f0: 2d 70 61 74 68 20 74 61 72 67 65 74 2d 70 61 74 -path target-pat
6800: 68 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 h)...... (
6810: 70 72 69 6e 74 20 22 43 72 65 61 74 69 6e 67 20 print "Creating
6820: 6c 69 6e 6b 20 66 72 6f 6d 20 22 20 73 74 6f 72 link from " stor
6830: 65 64 2d 70 61 74 68 20 22 20 74 6f 20 22 20 74 ed-path " to " t
6840: 61 72 67 65 74 2d 70 61 74 68 29 29 29 29 29 29 arget-path))))))
6850: 29 0a 20 20 20 20 20 20 28 69 75 70 3a 76 62 6f ). (iup:vbo
6860: 78 20 0a 20 20 20 20 20 20 20 28 69 75 70 3a 68 x . (iup:h
6870: 62 6f 78 20 74 62 20 74 62 32 29 0a 20 20 20 20 box tb tb2).
6880: 20 20 20 28 69 75 70 3a 66 72 61 6d 65 20 0a 09 (iup:frame ..
6890: 23 3a 74 69 74 6c 65 20 22 53 6f 75 72 63 65 20 #:title "Source
68a0: 49 6e 66 6f 22 0a 09 28 69 75 70 3a 76 62 6f 78 Info"..(iup:vbox
68b0: 0a 09 20 28 69 75 70 3a 68 62 6f 78 20 28 69 75 .. (iup:hbox (iu
68c0: 70 3a 62 75 74 74 6f 6e 20 22 52 65 66 72 65 73 p:button "Refres
68d0: 68 22 20 23 3a 61 63 74 69 6f 6e 20 72 65 66 72 h" #:action refr
68e0: 65 73 68 29 20 61 70 70 6c 79 29 0a 09 20 28 69 esh) apply).. (i
68f0: 75 70 3a 68 62 6f 78 20 28 69 75 70 3a 6c 61 62 up:hbox (iup:lab
6900: 65 6c 20 22 53 75 62 6d 69 74 74 65 72 3a 20 22 el "Submitter: "
6910: 29 20 3b 3b 20 20 23 3a 73 69 7a 65 20 6c 61 62 ) ;; #:size lab
6920: 65 6c 2d 73 69 7a 65 29 0a 09 09 20 20 20 73 75 el-size)... su
6930: 62 6d 69 74 74 65 72 20 0a 09 09 20 20 20 28 69 bmitter ... (i
6940: 75 70 3a 6c 61 62 65 6c 20 22 53 75 62 6d 69 74 up:label "Submit
6950: 74 65 64 20 6f 6e 3a 20 22 29 20 3b 3b 20 20 23 ted on: ") ;; #
6960: 3a 73 69 7a 65 20 6c 61 62 65 6c 2d 73 69 7a 65 :size label-size
6970: 29 0a 09 09 20 20 20 64 61 74 65 2d 73 75 62 6d )... date-subm
6980: 69 74 74 65 64 29 0a 09 20 28 69 75 70 3a 68 62 itted).. (iup:hb
6990: 6f 78 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 44 ox (iup:label "D
69a0: 61 74 61 20 73 74 6f 72 65 64 3a 20 22 29 0a 09 ata stored: ")..
69b0: 09 20 20 20 63 6f 70 79 2d 6c 69 6e 6b 0a 09 09 . copy-link...
69c0: 20 20 20 28 69 75 70 3a 6c 61 62 65 6c 20 22 51 (iup:label "Q
69d0: 75 61 6c 69 74 79 3a 20 22 29 0a 09 09 20 20 20 uality: ")...
69e0: 71 75 61 6c 69 74 79 29 0a 09 20 28 69 75 70 3a quality).. (iup:
69f0: 68 62 6f 78 20 28 69 75 70 3a 6c 61 62 65 6c 20 hbox (iup:label
6a00: 22 43 6f 6d 6d 65 6e 74 3a 20 22 29 0a 09 09 20 "Comment: ")...
6a10: 20 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 20 comment))).
6a20: 20 20 20 20 28 69 75 70 3a 66 72 61 6d 65 0a 09 (iup:frame..
6a30: 23 3a 74 69 74 6c 65 20 22 49 6e 73 74 61 6c 6c #:title "Install
6a40: 65 64 20 49 6e 66 6f 22 0a 09 28 69 75 70 3a 76 ed Info"..(iup:v
6a50: 62 6f 78 0a 09 20 28 69 75 70 3a 68 62 6f 78 20 box.. (iup:hbox
6a60: 28 69 75 70 3a 6c 61 62 65 6c 20 22 49 6e 73 74 (iup:label "Inst
6a70: 61 6c 6c 65 64 20 73 74 61 74 75 73 2f 70 61 74 alled status/pat
6a80: 68 3a 20 22 29 20 69 6e 73 74 61 6c 6c 65 64 2d h: ") installed-
6a90: 73 74 61 74 75 73 29 29 29 0a 20 20 20 20 20 20 status))).
6aa0: 20 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 )))))..(define
6ab0: 28 64 61 74 61 73 68 61 72 65 3a 6d 61 6e 61 67 (datashare:manag
6ac0: 65 2d 76 69 65 77 20 63 6f 6e 66 69 67 64 61 74 e-view configdat
6ad0: 29 0a 20 20 28 69 75 70 3a 76 62 6f 78 0a 20 20 ). (iup:vbox.
6ae0: 20 28 69 75 70 3a 68 62 6f 78 20 0a 20 20 20 20 (iup:hbox .
6af0: 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 50 75 73 (iup:button "Pus
6b00: 68 6d 65 22 0a 09 09 23 3a 65 78 70 61 6e 64 20 hme"...#:expand
6b10: 22 59 45 53 22 0a 09 09 29 29 29 29 0a 0a 28 64 "YES"...))))..(d
6b20: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
6b30: 3a 67 75 69 20 63 6f 6e 66 69 67 64 61 74 29 0a :gui configdat).
6b40: 20 20 28 69 75 70 3a 73 68 6f 77 0a 20 20 20 28 (iup:show. (
6b50: 69 75 70 3a 64 69 61 6c 6f 67 20 0a 20 20 20 20 iup:dialog .
6b60: 23 3a 74 69 74 6c 65 20 28 63 6f 6e 63 20 22 44 #:title (conc "D
6b70: 61 74 61 53 68 61 72 65 20 64 61 73 68 62 6f 61 ataShare dashboa
6b80: 72 64 20 22 20 28 63 75 72 72 65 6e 74 2d 75 73 rd " (current-us
6b90: 65 72 2d 6e 61 6d 65 29 20 22 3a 22 20 28 63 75 er-name) ":" (cu
6ba0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
6bb0: 29 20 20 20 0a 20 20 20 20 23 3a 6d 65 6e 75 20 ) . #:menu
6bc0: 28 64 61 74 61 73 68 61 72 65 3a 6d 61 69 6e 2d (datashare:main-
6bd0: 6d 65 6e 75 29 0a 20 20 20 20 28 6c 65 74 2a 20 menu). (let*
6be0: 28 28 74 61 62 73 20 28 69 75 70 3a 74 61 62 73 ((tabs (iup:tabs
6bf0: 0a 09 09 20 20 23 3a 74 61 62 63 68 61 6e 67 65 ... #:tabchange
6c00: 70 6f 73 2d 63 62 20 28 6c 61 6d 62 64 61 20 28 pos-cb (lambda (
6c10: 6f 62 6a 20 63 75 72 72 20 70 72 65 76 29 0a 09 obj curr prev)..
6c20: 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 2a ... (set! *
6c30: 64 61 74 61 73 68 61 72 65 3a 63 75 72 72 65 6e datashare:curren
6c40: 74 2d 74 61 62 2d 6e 75 6d 62 65 72 2a 20 63 75 t-tab-number* cu
6c50: 72 72 29 29 0a 09 09 20 20 28 64 61 74 61 73 68 rr))... (datash
6c60: 61 72 65 3a 70 75 62 6c 69 73 68 2d 76 69 65 77 are:publish-view
6c70: 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 09 20 20 configdat)...
6c80: 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 2d 76 (datashare:get-v
6c90: 69 65 77 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 iew configdat)..
6ca0: 09 20 20 28 64 61 74 61 73 68 61 72 65 3a 6d 61 . (datashare:ma
6cb0: 6e 61 67 65 2d 76 69 65 77 20 63 6f 6e 66 69 67 nage-view config
6cc0: 64 61 74 29 0a 09 09 20 20 29 29 29 0a 09 3b 3b dat)... )))..;;
6cd0: 20 28 73 65 74 21 20 28 69 75 70 3a 63 61 6c 6c (set! (iup:call
6ce0: 62 61 63 6b 20 74 61 62 73 20 74 61 62 63 68 61 back tabs tabcha
6cf0: 6e 67 65 2d 63 62 3a 29 20 28 6c 61 6d 62 64 61 nge-cb:) (lambda
6d00: 20 28 61 20 62 20 63 29 28 70 72 69 6e 74 20 22 (a b c)(print "
6d10: 53 57 49 54 43 48 45 44 20 54 4f 20 54 41 42 3a SWITCHED TO TAB:
6d20: 20 22 20 61 20 22 20 22 20 62 20 22 20 22 20 63 " a " " b " " c
6d30: 29 29 29 0a 09 28 69 75 70 3a 61 74 74 72 69 62 )))..(iup:attrib
6d40: 75 74 65 2d 73 65 74 21 20 74 61 62 73 20 22 54 ute-set! tabs "T
6d50: 41 42 54 49 54 4c 45 30 22 20 22 50 75 62 6c 69 ABTITLE0" "Publi
6d60: 73 68 22 29 0a 09 28 69 75 70 3a 61 74 74 72 69 sh")..(iup:attri
6d70: 62 75 74 65 2d 73 65 74 21 20 74 61 62 73 20 22 bute-set! tabs "
6d80: 54 41 42 54 49 54 4c 45 31 22 20 22 47 65 74 22 TABTITLE1" "Get"
6d90: 29 0a 09 28 69 75 70 3a 61 74 74 72 69 62 75 74 )..(iup:attribut
6da0: 65 2d 73 65 74 21 20 74 61 62 73 20 22 54 41 42 e-set! tabs "TAB
6db0: 54 49 54 4c 45 32 22 20 22 4d 61 6e 61 67 65 22 TITLE2" "Manage"
6dc0: 29 0a 09 3b 3b 20 28 69 75 70 3a 61 74 74 72 69 )..;; (iup:attri
6dd0: 62 75 74 65 2d 73 65 74 21 20 74 61 62 73 20 22 bute-set! tabs "
6de0: 42 47 43 4f 4c 4f 52 22 20 22 31 39 30 20 31 39 BGCOLOR" "190 19
6df0: 30 20 31 39 30 22 29 0a 09 74 61 62 73 29 29 29 0 190")..tabs)))
6e00: 0a 20 20 28 69 75 70 3a 6d 61 69 6e 2d 6c 6f 6f . (iup:main-loo
6e10: 70 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d p))..;;=========
6e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
6e60: 20 4d 49 53 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d MISC.;;========
6e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
6eb0: 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 68 .(define (datash
6ec0: 61 72 65 3a 64 6f 2d 61 73 2d 63 61 6c 6c 69 6e are:do-as-callin
6ed0: 67 2d 75 73 65 72 20 70 72 6f 63 29 0a 20 20 28 g-user proc). (
6ee0: 6c 65 74 20 28 28 65 69 64 20 28 63 75 72 72 65 let ((eid (curre
6ef0: 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 nt-effective-use
6f00: 72 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 28 r-id)). (
6f10: 63 69 64 20 28 63 75 72 72 65 6e 74 2d 75 73 65 cid (current-use
6f20: 72 2d 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 r-id))). (if
6f30: 28 6e 6f 74 20 28 65 71 3f 20 65 69 64 20 63 69 (not (eq? eid ci
6f40: 64 29 29 20 3b 3b 20 72 75 6e 6e 69 6e 67 20 73 d)) ;; running s
6f50: 75 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 uid.
6f60: 28 73 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 (set! (current-e
6f70: 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 ffective-user-id
6f80: 29 20 63 69 64 29 29 0a 20 20 20 20 3b 3b 20 28 ) cid)). ;; (
6f90: 70 72 69 6e 74 20 22 72 75 6e 6e 69 6e 67 20 61 print "running a
6fa0: 73 20 22 20 28 63 75 72 72 65 6e 74 2d 65 66 66 s " (current-eff
6fb0: 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 29 29 ective-user-id))
6fc0: 0a 20 20 20 20 28 70 72 6f 63 29 0a 20 20 20 20 . (proc).
6fd0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 65 69 (if (not (eq? ei
6fe0: 64 20 63 69 64 29 29 0a 20 20 20 20 20 20 20 20 d cid)).
6ff0: 28 73 65 74 21 20 28 63 75 72 72 65 6e 74 2d 65 (set! (current-e
7000: 66 66 65 63 74 69 76 65 2d 75 73 65 72 2d 69 64 ffective-user-id
7010: 29 20 65 69 64 29 29 29 29 0a 0a 28 64 65 66 69 ) eid))))..(defi
7020: 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 66 69 ne (datashare:fi
7030: 6e 64 20 6e 61 6d 65 20 70 61 74 68 73 29 0a 20 nd name paths).
7040: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 68 (if (null? path
7050: 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 s). #f.
7060: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
7070: 64 20 28 63 61 72 20 70 61 74 68 73 29 29 0a 09 d (car paths))..
7080: 09 20 28 74 61 6c 20 28 63 64 72 20 70 61 74 68 . (tal (cdr path
7090: 73 29 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f s)))..(if (commo
70a0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 n:file-exists? (
70b0: 63 6f 6e 63 20 68 65 64 20 22 2f 22 20 6e 61 6d conc hed "/" nam
70c0: 65 29 29 0a 09 20 20 20 20 68 65 64 0a 09 20 20 e)).. hed..
70d0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
70e0: 29 0a 09 09 23 66 0a 09 09 28 6c 6f 6f 70 20 28 )...#f...(loop (
70f0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
7100: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
7110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7150: 3d 0a 3b 3b 20 4d 41 49 4e 0a 3b 3b 3d 3d 3d 3d =.;; MAIN.;;====
7160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71a0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 ==..(define (dat
71b0: 61 73 68 61 72 65 3a 6c 6f 61 64 2d 63 6f 6e 66 ashare:load-conf
71c0: 69 67 20 65 78 65 2d 64 69 72 20 65 78 65 2d 6e ig exe-dir exe-n
71d0: 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 ame). (let* ((f
71e0: 6e 61 6d 65 20 20 20 28 63 6f 6e 63 20 65 78 65 name (conc exe
71f0: 2d 64 69 72 20 22 2f 2e 22 20 65 78 65 2d 6e 61 -dir "/." exe-na
7200: 6d 65 20 22 2e 63 6f 6e 66 69 67 22 29 29 29 0a me ".config"))).
7210: 20 20 20 20 28 69 6e 69 3a 70 72 6f 70 65 72 74 (ini:propert
7220: 79 2d 73 65 70 61 72 61 74 6f 72 2d 70 61 74 74 y-separator-patt
7230: 20 22 20 2a 20 20 2a 22 29 0a 20 20 20 20 28 69 " * *"). (i
7240: 6e 69 3a 70 72 6f 70 65 72 74 79 2d 73 65 70 61 ni:property-sepa
7250: 72 61 74 6f 72 20 23 5c 73 70 61 63 65 29 0a 20 rator #\space).
7260: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 (if (common:f
7270: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d ile-exists? fnam
7280: 65 29 0a 09 3b 3b 20 28 69 6e 69 3a 72 65 61 64 e)..;; (ini:read
7290: 2d 69 6e 69 20 66 6e 61 6d 65 29 0a 09 28 72 65 -ini fname)..(re
72a0: 61 64 2d 63 6f 6e 66 69 67 20 66 6e 61 6d 65 20 ad-config fname
72b0: 23 66 20 23 74 29 0a 09 28 6d 61 6b 65 2d 68 61 #f #t)..(make-ha
72c0: 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 0a 28 64 sh-table))))..(d
72d0: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
72e0: 3a 70 72 6f 63 65 73 73 2d 61 63 74 69 6f 6e 20 :process-action
72f0: 63 6f 6e 66 69 67 64 61 74 20 61 63 74 69 6f 6e configdat action
7300: 20 2e 20 61 72 67 73 29 0a 20 20 28 63 61 73 65 . args). (case
7310: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
7320: 20 61 63 74 69 6f 6e 29 0a 20 20 20 20 28 28 67 action). ((g
7330: 65 74 29 0a 20 20 20 20 20 28 69 66 20 28 3c 20 et). (if (<
7340: 28 6c 65 6e 67 74 68 20 61 72 67 73 29 20 32 29 (length args) 2)
7350: 0a 09 20 28 62 65 67 69 6e 20 0a 09 20 20 20 28 .. (begin .. (
7360: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 4d 69 print "ERROR: Mi
7370: 73 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 73 3b ssing arguments;
7380: 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 " (string-inter
7390: 73 70 65 72 73 65 20 61 72 67 73 20 22 2c 20 22 sperse args ", "
73a0: 29 29 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 )).. (exit 1))
73b0: 0a 09 20 28 6c 65 74 2a 20 28 28 62 61 73 65 70 .. (let* ((basep
73c0: 61 74 68 20 20 20 20 28 63 6f 6e 66 69 67 66 3a ath (configf:
73d0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
73e0: 20 22 73 65 74 74 69 6e 67 73 22 20 22 62 61 73 "settings" "bas
73f0: 65 70 61 74 68 22 29 29 0a 09 09 28 64 62 20 20 epath"))...(db
7400: 20 20 20 20 20 20 20 20 28 64 61 74 61 73 68 61 (datasha
7410: 72 65 3a 6f 70 65 6e 2d 64 62 20 63 6f 6e 66 69 re:open-db confi
7420: 67 64 61 74 29 29 0a 09 09 28 61 72 65 61 20 20 gdat))...(area
7430: 20 20 20 20 20 20 28 63 61 72 20 61 72 67 73 29 (car args)
7440: 29 0a 09 09 28 76 65 72 73 69 6f 6e 20 20 20 20 )...(version
7450: 20 28 63 61 64 72 20 61 72 67 73 29 29 20 3b 3b (cadr args)) ;;
7460: 20 20 20 20 69 74 65 72 61 74 69 6f 6e 0a 09 09 iteration...
7470: 28 72 65 6d 61 72 67 73 20 20 20 20 20 28 61 72 (remargs (ar
7480: 67 73 3a 67 65 74 2d 61 72 67 73 20 61 72 67 73 gs:get-args args
7490: 20 27 28 22 2d 69 22 29 20 27 28 29 20 61 72 67 '("-i") '() arg
74a0: 73 3a 61 72 67 2d 68 61 73 68 20 30 29 29 0a 09 s:arg-hash 0))..
74b0: 09 28 69 74 65 72 61 74 69 6f 6e 20 20 20 28 69 .(iteration (i
74c0: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
74d0: 22 2d 69 22 29 28 73 74 72 69 6e 67 2d 3e 6e 75 "-i")(string->nu
74e0: 6d 62 65 72 20 28 61 72 67 73 3a 67 65 74 2d 61 mber (args:get-a
74f0: 72 67 20 22 2d 69 22 29 29 20 23 66 29 29 0a 09 rg "-i")) #f))..
7500: 09 28 63 75 72 72 2d 72 65 63 6f 72 64 20 28 64 .(curr-record (d
7510: 61 74 61 73 68 61 72 65 3a 67 65 74 2d 70 6b 67 atashare:get-pkg
7520: 20 64 62 20 61 72 65 61 20 76 65 72 73 69 6f 6e db area version
7530: 20 69 74 65 72 61 74 69 6f 6e 3a 20 69 74 65 72 iteration: iter
7540: 61 74 69 6f 6e 29 29 29 0a 09 20 20 20 28 69 66 ation))).. (if
7550: 20 28 6e 6f 74 20 63 75 72 72 2d 72 65 63 6f 72 (not curr-recor
7560: 64 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 d).. (begi
7570: 6e 0a 09 09 20 28 70 72 69 6e 74 20 22 45 52 52 n... (print "ERR
7580: 4f 52 3a 20 4e 6f 20 6d 61 74 63 68 69 6e 67 20 OR: No matching
7590: 72 65 63 6f 72 64 20 66 6f 75 6e 64 3b 20 61 72 record found; ar
75a0: 65 61 3d 22 20 61 72 65 61 20 22 2c 20 76 65 72 ea=" area ", ver
75b0: 73 69 6f 6e 3d 22 20 76 65 72 73 69 6f 6e 20 22 sion=" version "
75c0: 2c 20 69 74 65 72 61 74 69 6f 6e 3d 22 20 28 69 , iteration=" (i
75d0: 66 20 69 74 65 72 61 74 69 6f 6e 20 69 74 65 72 f iteration iter
75e0: 61 74 69 6f 6e 20 22 28 6d 61 78 29 22 29 29 0a ation "(max)")).
75f0: 09 09 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 .. (exit 1))..
7600: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 6f (let* ((sto
7610: 72 65 64 2d 70 61 74 68 20 28 64 61 74 61 73 68 red-path (datash
7620: 61 72 65 3a 70 6b 67 2d 67 65 74 2d 73 74 6f 72 are:pkg-get-stor
7630: 65 64 5f 70 61 74 68 20 63 75 72 72 2d 72 65 63 ed_path curr-rec
7640: 6f 72 64 29 29 0a 09 09 20 20 20 20 20 20 28 73 ord))... (s
7650: 6f 75 72 63 65 2d 74 79 70 65 20 28 64 61 74 61 ource-type (data
7660: 73 68 61 72 65 3a 70 6b 67 2d 67 65 74 2d 73 74 share:pkg-get-st
7670: 6f 72 65 5f 74 79 70 65 20 20 63 75 72 72 2d 72 ore_type curr-r
7680: 65 63 6f 72 64 29 29 0a 09 09 20 20 20 20 20 20 ecord))...
7690: 28 73 6f 75 72 63 65 2d 70 61 74 68 20 28 63 61 (source-path (ca
76a0: 73 65 20 73 6f 75 72 63 65 2d 74 79 70 65 20 3b se source-type ;
76b0: 3b 20 20 28 65 71 75 61 6c 3f 20 73 6f 75 72 63 ; (equal? sourc
76c0: 65 2d 74 79 70 65 20 22 6c 69 6e 6b 22 29 29 0a e-type "link")).
76d0: 09 09 09 09 20 20 20 20 20 28 28 6c 69 6e 6b 29 .... ((link)
76e0: 20 28 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d (datashare:pkg-
76f0: 67 65 74 2d 73 6f 75 72 63 65 2d 70 61 74 68 20 get-source-path
7700: 63 75 72 72 2d 72 65 63 6f 72 64 29 29 0a 09 09 curr-record))...
7710: 09 09 20 20 20 20 20 28 28 63 6f 70 79 29 20 73 .. ((copy) s
7720: 74 6f 72 65 64 2d 70 61 74 68 29 0a 09 09 09 09 tored-path).....
7730: 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 (else #f)))
7740: 0a 09 09 20 20 20 20 20 20 28 64 65 73 74 2d 73 ... (dest-s
7750: 74 75 62 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c tub (configf:l
7760: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
7770: 22 61 72 65 61 73 22 20 61 72 65 61 29 29 0a 09 "areas" area))..
7780: 09 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 . (target-p
7790: 61 74 68 20 28 63 6f 6e 63 20 62 61 73 65 70 61 ath (conc basepa
77a0: 74 68 20 22 2f 22 20 64 65 73 74 2d 73 74 75 62 th "/" dest-stub
77b0: 29 29 29 0a 09 09 20 28 64 61 74 61 73 68 61 72 )))... (datashar
77c0: 65 3a 62 75 69 6c 64 2d 64 69 72 2d 6d 61 6b 65 e:build-dir-make
77d0: 2d 6c 69 6e 6b 20 73 74 6f 72 65 64 2d 70 61 74 -link stored-pat
77e0: 68 20 74 61 72 67 65 74 2d 70 61 74 68 29 0a 09 h target-path)..
77f0: 09 20 28 64 61 74 61 73 68 61 72 65 3a 72 65 63 . (datashare:rec
7800: 6f 72 64 2d 70 6b 67 2d 72 65 66 20 64 62 20 28 ord-pkg-ref db (
7810: 64 61 74 61 73 68 61 72 65 3a 70 6b 67 2d 67 65 datashare:pkg-ge
7820: 74 2d 69 64 20 63 75 72 72 2d 72 65 63 6f 72 64 t-id curr-record
7830: 29 20 74 61 72 67 65 74 2d 70 61 74 68 29 0a 09 ) target-path)..
7840: 09 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c . (sqlite3:final
7850: 69 7a 65 21 20 64 62 29 0a 09 09 20 28 70 72 69 ize! db)... (pri
7860: 6e 74 20 22 43 72 65 61 74 69 6e 67 20 6c 69 6e nt "Creating lin
7870: 6b 20 66 72 6f 6d 20 22 20 73 74 6f 72 65 64 2d k from " stored-
7880: 70 61 74 68 20 22 20 74 6f 20 22 20 74 61 72 67 path " to " targ
7890: 65 74 2d 70 61 74 68 29 29 29 29 29 29 0a 20 20 et-path)))))).
78a0: 20 20 28 28 70 75 62 6c 69 73 68 29 0a 20 20 20 ((publish).
78b0: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
78c0: 20 61 72 67 73 29 20 33 29 0a 09 20 28 62 65 67 args) 3).. (beg
78d0: 69 6e 20 0a 09 20 20 20 28 70 72 69 6e 74 20 22 in .. (print "
78e0: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 61 ERROR: Missing a
78f0: 72 67 75 6d 65 6e 74 73 3b 20 22 20 28 73 74 72 rguments; " (str
7900: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
7910: 61 72 67 73 20 22 2c 20 22 29 29 0a 09 20 20 20 args ", "))..
7920: 28 65 78 69 74 20 31 29 29 0a 09 20 28 6c 65 74 (exit 1)).. (let
7930: 2a 20 28 28 73 72 63 70 61 74 68 20 20 28 6c 69 * ((srcpath (li
7940: 73 74 2d 72 65 66 20 61 72 67 73 20 30 29 29 0a st-ref args 0)).
7950: 09 09 28 61 72 65 61 6e 61 6d 65 20 28 6c 69 73 ..(areaname (lis
7960: 74 2d 72 65 66 20 61 72 67 73 20 31 29 29 0a 09 t-ref args 1))..
7970: 09 28 76 65 72 73 69 6f 6e 20 20 28 6c 69 73 74 .(version (list
7980: 2d 72 65 66 20 61 72 67 73 20 32 29 29 0a 09 09 -ref args 2))...
7990: 28 72 65 6d 61 72 67 73 20 20 28 61 72 67 73 3a (remargs (args:
79a0: 67 65 74 2d 61 72 67 73 20 28 64 72 6f 70 20 61 get-args (drop a
79b0: 72 67 73 20 32 29 0a 09 09 09 09 09 20 27 28 22 rgs 2)...... '("
79c0: 2d 74 79 70 65 22 20 3b 3b 20 6c 69 6e 6b 20 6f -type" ;; link o
79d0: 72 20 63 6f 70 79 20 28 64 65 66 61 75 6c 74 20 r copy (default
79e0: 69 73 20 63 6f 70 79 29 0a 09 09 09 09 09 20 20 is copy)......
79f0: 20 22 2d 6d 22 29 0a 20 09 09 09 09 09 20 27 28 "-m"). ..... '(
7a00: 29 0a 20 09 09 09 09 09 20 61 72 67 73 3a 61 72 ). ..... args:ar
7a10: 67 2d 68 61 73 68 0a 20 09 09 09 09 09 20 30 29 g-hash. ..... 0)
7a20: 29 0a 09 09 28 70 75 62 6c 69 73 68 2d 74 79 70 )...(publish-typ
7a30: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 e (if (equal? (a
7a40: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 79 rgs:get-arg "-ty
7a50: 70 65 22 29 20 22 6c 69 6e 6b 22 29 20 27 6c 69 pe") "link") 'li
7a60: 6e 6b 20 27 63 6f 70 79 29 29 0a 09 09 28 63 6f nk 'copy))...(co
7a70: 6d 6d 65 6e 74 20 20 20 20 20 20 28 6f 72 20 28 mment (or (
7a80: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d args:get-arg "-m
7a90: 22 29 20 22 22 29 29 0a 09 09 28 73 75 62 6d 69 ") ""))...(submi
7aa0: 74 74 65 72 20 20 20 20 28 63 75 72 72 65 6e 74 tter (current
7ab0: 2d 75 73 65 72 2d 6e 61 6d 65 29 29 0a 09 09 28 -user-name))...(
7ac0: 71 75 61 6c 69 74 79 20 20 20 20 20 20 28 61 72 quality (ar
7ad0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 71 75 61 gs:get-arg "-qua
7ae0: 6c 69 74 79 22 29 29 0a 09 09 28 70 75 62 6c 69 lity"))...(publi
7af0: 73 68 2d 72 65 73 20 20 28 64 61 74 61 73 68 61 sh-res (datasha
7b00: 72 65 3a 70 75 62 6c 69 73 68 20 63 6f 6e 66 69 re:publish confi
7b10: 67 64 61 74 20 70 75 62 6c 69 73 68 2d 74 79 70 gdat publish-typ
7b20: 65 20 61 72 65 61 6e 61 6d 65 20 76 65 72 73 69 e areaname versi
7b30: 6f 6e 20 63 6f 6d 6d 65 6e 74 20 73 72 63 70 61 on comment srcpa
7b40: 74 68 20 73 75 62 6d 69 74 74 65 72 20 71 75 61 th submitter qua
7b50: 6c 69 74 79 29 29 29 0a 09 20 20 20 28 69 66 20 lity))).. (if
7b60: 28 6e 6f 74 20 28 63 61 72 20 70 75 62 6c 69 73 (not (car publis
7b70: 68 2d 72 65 73 29 29 0a 09 20 20 20 20 20 20 20 h-res))..
7b80: 28 62 65 67 69 6e 0a 09 09 20 28 70 72 69 6e 74 (begin... (print
7b90: 20 22 45 52 52 4f 52 3a 20 22 20 28 63 64 72 20 "ERROR: " (cdr
7ba0: 70 75 62 6c 69 73 68 2d 72 65 73 29 29 0a 09 09 publish-res))...
7bb0: 20 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 20 (exit 1)))))).
7bc0: 20 20 20 28 28 6c 69 73 74 2d 76 65 72 73 69 6f ((list-versio
7bd0: 6e 73 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 ns). (let ((
7be0: 61 72 65 61 2d 6e 61 6d 65 20 28 63 61 72 20 61 area-name (car a
7bf0: 72 67 73 29 29 20 3b 3b 20 20 20 20 20 20 76 65 rgs)) ;; ve
7c00: 72 73 69 6f 6e 20 70 61 74 74 20 20 20 66 75 6c rsion patt ful
7c10: 6c 20 70 72 69 6e 74 0a 09 20 20 20 28 72 65 6d l print.. (rem
7c20: 61 72 67 73 20 20 20 28 61 72 67 73 3a 67 65 74 args (args:get
7c30: 2d 61 72 67 73 20 61 72 67 73 20 27 28 22 2d 76 -args args '("-v
7c40: 70 61 74 74 22 29 20 27 28 22 2d 66 75 6c 6c 22 patt") '("-full"
7c50: 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 20 ) args:arg-hash
7c60: 30 29 29 0a 09 20 20 20 28 64 62 20 20 20 20 20 0)).. (db
7c70: 20 20 20 28 64 61 74 61 73 68 61 72 65 3a 6f 70 (datashare:op
7c80: 65 6e 2d 64 62 20 63 6f 6e 66 69 67 64 61 74 29 en-db configdat)
7c90: 29 0a 09 20 20 20 28 76 65 72 73 69 6f 6e 73 20 ).. (versions
7ca0: 20 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 2d (datashare:get-
7cb0: 76 65 72 73 69 6f 6e 73 2d 66 6f 72 2d 61 72 65 versions-for-are
7cc0: 61 20 64 62 20 28 63 61 72 20 61 72 67 73 29 20 a db (car args)
7cd0: 76 65 72 73 69 6f 6e 2d 70 61 74 74 3a 20 28 61 version-patt: (a
7ce0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 76 70 rgs:get-arg "-vp
7cf0: 61 74 74 22 29 29 29 29 0a 20 20 20 20 20 20 20 att")))).
7d00: 3b 3b 20 28 70 72 69 6e 74 20 22 61 72 65 61 2d ;; (print "area-
7d10: 6e 61 6d 65 3d 22 20 61 72 65 61 2d 6e 61 6d 65 name=" area-name
7d20: 20 22 20 61 72 67 73 3d 22 20 61 72 67 73 20 22 " args=" args "
7d30: 20 2a 61 72 67 73 2d 68 61 73 68 2a 3d 22 20 28 *args-hash*=" (
7d40: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
7d50: 74 20 2a 61 72 67 73 2d 68 61 73 68 2a 29 29 0a t *args-hash*)).
7d60: 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
7d70: 62 64 61 20 28 78 29 0a 09 20 20 20 20 20 20 28 bda (x).. (
7d80: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
7d90: 20 22 2d 66 75 6c 6c 22 29 0a 09 09 20 20 28 66 "-full")... (f
7da0: 6f 72 6d 61 74 20 23 74 20 0a 09 09 09 20 20 22 ormat #t .... "
7db0: 7e 31 30 61 7e 31 30 61 7e 34 61 7e 32 37 61 7e ~10a~10a~4a~27a~
7dc0: 33 30 61 5c 6e 22 0a 09 09 09 20 20 28 76 65 63 30a\n".... (vec
7dd0: 74 6f 72 2d 72 65 66 20 78 20 30 29 0a 09 09 09 tor-ref x 0)....
7de0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
7df0: 31 29 20 0a 09 09 09 20 20 28 76 65 63 74 6f 72 1) .... (vector
7e00: 2d 72 65 66 20 78 20 32 29 20 0a 09 09 09 20 20 -ref x 2) ....
7e10: 28 63 6f 6e 63 20 22 5c 22 22 20 28 74 69 6d 65 (conc "\"" (time
7e20: 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
7e30: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 28 76 s->local-time (v
7e40: 65 63 74 6f 72 2d 72 65 66 20 78 20 33 29 29 29 ector-ref x 3)))
7e50: 20 22 5c 22 22 29 0a 09 09 09 20 20 28 63 6f 6e "\"").... (con
7e60: 63 20 22 5c 22 22 20 28 76 65 63 74 6f 72 2d 72 c "\"" (vector-r
7e70: 65 66 20 78 20 34 29 20 22 5c 22 22 29 29 0a 09 ef x 4) "\""))..
7e80: 09 20 20 28 70 72 69 6e 74 20 28 76 65 63 74 6f . (print (vecto
7e90: 72 2d 72 65 66 20 78 20 30 29 29 29 29 0a 09 20 r-ref x 0))))..
7ea0: 20 20 20 76 65 72 73 69 6f 6e 73 29 0a 20 20 20 versions).
7eb0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e (sqlite3:fin
7ec0: 61 6c 69 7a 65 21 20 64 62 29 29 29 29 29 0a 0a alize! db)))))..
7ed0: 3b 3b 20 65 61 73 65 20 64 65 62 75 67 67 69 6e ;; ease debuggin
7ee0: 67 20 62 79 20 6c 6f 61 64 69 6e 67 20 7e 2f 2e g by loading ~/.
7ef0: 64 61 73 68 62 6f 61 72 64 72 63 20 2d 20 52 45 dashboardrc - RE
7f00: 4d 4f 56 45 20 46 52 4f 4d 20 50 52 4f 44 55 43 MOVE FROM PRODUC
7f10: 54 49 4f 4e 21 0a 28 6c 65 74 20 28 28 64 65 62 TION!.(let ((deb
7f20: 75 67 63 6f 6e 74 72 6f 6c 66 20 28 63 6f 6e 63 ugcontrolf (conc
7f30: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
7f40: 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 t-variable "HOME
7f50: 22 29 20 22 2f 2e 64 61 74 61 73 68 61 72 65 72 ") "/.datasharer
7f60: 63 22 29 29 29 0a 20 20 28 69 66 20 28 63 6f 6d c"))). (if (com
7f70: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
7f80: 20 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 29 0a debugcontrolf).
7f90: 20 20 20 20 20 20 28 6c 6f 61 64 20 64 65 62 75 (load debu
7fa0: 67 63 6f 6e 74 72 6f 6c 66 29 29 29 0a 0a 28 64 gcontrolf)))..(d
7fb0: 65 66 69 6e 65 20 28 6d 61 69 6e 29 0a 20 20 28 efine (main). (
7fc0: 6c 65 74 2a 20 28 28 61 72 67 73 20 20 20 20 20 let* ((args
7fd0: 20 28 61 72 67 76 29 29 0a 09 20 28 70 72 6f 67 (argv)).. (prog
7fe0: 20 20 20 20 20 20 28 63 61 72 20 61 72 67 73 29 (car args)
7ff0: 29 0a 09 20 28 72 65 6d 61 20 20 20 20 20 20 28 ).. (rema (
8000: 63 64 72 20 61 72 67 73 29 29 0a 09 20 28 65 78 cdr args)).. (ex
8010: 65 2d 6e 61 6d 65 20 20 28 70 61 74 68 6e 61 6d e-name (pathnam
8020: 65 2d 66 69 6c 65 20 28 63 61 72 20 28 61 72 67 e-file (car (arg
8030: 76 29 29 29 29 0a 09 20 28 65 78 65 2d 64 69 72 v)))).. (exe-dir
8040: 20 20 20 28 6f 72 20 28 70 61 74 68 6e 61 6d 65 (or (pathname
8050: 2d 64 69 72 65 63 74 6f 72 79 20 70 72 6f 67 29 -directory prog)
8060: 0a 09 09 09 28 64 61 74 61 73 68 61 72 65 3a 66 ....(datashare:f
8070: 69 6e 64 20 65 78 65 2d 6e 61 6d 65 20 28 73 74 ind exe-name (st
8080: 72 69 6e 67 2d 73 70 6c 69 74 20 28 67 65 74 2d ring-split (get-
8090: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
80a0: 61 62 6c 65 20 22 50 41 54 48 22 29 20 22 3a 22 able "PATH") ":"
80b0: 29 29 29 29 0a 09 20 28 63 6f 6e 66 69 67 64 61 )))).. (configda
80c0: 74 20 28 64 61 74 61 73 68 61 72 65 3a 6c 6f 61 t (datashare:loa
80d0: 64 2d 63 6f 6e 66 69 67 20 65 78 65 2d 64 69 72 d-config exe-dir
80e0: 20 65 78 65 2d 6e 61 6d 65 29 29 29 0a 20 20 20 exe-name))).
80f0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 20 6f (cond. ;; o
8100: 6e 65 2d 77 6f 72 64 20 63 6f 6d 6d 61 6e 64 73 ne-word commands
8110: 0a 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e . ((eq? (len
8120: 67 74 68 20 72 65 6d 61 29 20 31 29 0a 20 20 20 gth rema) 1).
8130: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
8140: 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 72 20 72 65 ->symbol (car re
8150: 6d 61 29 29 0a 09 28 28 68 65 6c 70 20 2d 68 20 ma))..((help -h
8160: 2d 68 65 6c 70 20 2d 2d 68 20 2d 2d 68 65 6c 70 -help --h --help
8170: 29 0a 09 20 28 70 72 69 6e 74 20 64 61 74 61 73 ).. (print datas
8180: 68 61 72 65 3a 68 65 6c 70 29 29 0a 09 28 28 6c hare:help))..((l
8190: 69 73 74 2d 61 72 65 61 73 29 0a 09 20 28 6d 61 ist-areas).. (ma
81a0: 70 20 70 72 69 6e 74 20 28 64 61 74 61 73 68 61 p print (datasha
81b0: 72 65 3a 67 65 74 2d 61 72 65 61 73 20 63 6f 6e re:get-areas con
81c0: 66 69 67 64 61 74 29 29 29 0a 09 28 65 6c 73 65 figdat)))..(else
81d0: 0a 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 .. (print "ERROR
81e0: 3a 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 63 : Unrecognised c
81f0: 6f 6d 6d 61 6e 64 2e 20 54 72 79 20 5c 22 64 61 ommand. Try \"da
8200: 74 61 73 68 61 72 65 20 68 65 6c 70 5c 22 22 29 tashare help\"")
8210: 29 29 29 0a 20 20 20 20 20 3b 3b 20 6d 75 6c 74 ))). ;; mult
8220: 69 2d 77 6f 72 64 20 63 6f 6d 6d 61 6e 64 73 0a i-word commands.
8230: 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 6d ((null? rem
8240: 61 29 28 64 61 74 61 73 68 61 72 65 3a 67 75 69 a)(datashare:gui
8250: 20 63 6f 6e 66 69 67 64 61 74 29 29 0a 20 20 20 configdat)).
8260: 20 20 28 28 3e 3d 20 28 6c 65 6e 67 74 68 20 72 ((>= (length r
8270: 65 6d 61 29 20 32 29 0a 20 20 20 20 20 20 28 61 ema) 2). (a
8280: 70 70 6c 79 20 64 61 74 61 73 68 61 72 65 3a 70 pply datashare:p
8290: 72 6f 63 65 73 73 2d 61 63 74 69 6f 6e 20 63 6f rocess-action co
82a0: 6e 66 69 67 64 61 74 20 28 63 61 72 20 72 65 6d nfigdat (car rem
82b0: 61 29 28 63 64 72 20 72 65 6d 61 29 29 29 0a 20 a)(cdr rema))).
82c0: 20 20 20 20 28 65 6c 73 65 20 28 70 72 69 6e 74 (else (print
82d0: 20 22 45 52 52 4f 52 3a 20 55 6e 72 65 63 6f 67 "ERROR: Unrecog
82e0: 6e 69 73 65 64 20 63 6f 6d 6d 61 6e 64 2e 20 54 nised command. T
82f0: 72 79 20 5c 22 64 61 74 61 73 68 61 72 65 20 68 ry \"datashare h
8300: 65 6c 70 5c 22 22 29 29 29 29 29 0a 0a 28 6d 61 elp\"")))))..(ma
8310: 69 6e 29 0a in).