Artifact
7b598fa3cfbe836f85aad352d3d0e99b97918a7d:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 75 73 65 20 PURPOSE...(use
0150: 73 73 61 78 29 0a 28 75 73 65 20 73 78 6d 6c 2d ssax).(use sxml-
0160: 73 65 72 69 61 6c 69 7a 65 72 29 0a 28 75 73 65 serializer).(use
0170: 20 73 78 6d 6c 2d 6d 6f 64 69 66 69 63 61 74 69 sxml-modificati
0180: 6f 6e 73 29 0a 28 75 73 65 20 72 65 67 65 78 29 ons).(use regex)
0190: 0a 28 75 73 65 20 73 72 66 69 2d 36 39 29 0a 28 .(use srfi-69).(
01a0: 75 73 65 20 72 65 67 65 78 2d 63 61 73 65 29 0a use regex-case).
01b0: 28 75 73 65 20 70 6f 73 69 78 29 0a 28 75 73 65 (use posix).(use
01c0: 20 6a 73 6f 6e 29 0a 28 75 73 65 20 63 73 76 29 json).(use csv)
01d0: 0a 28 75 73 65 20 73 72 66 69 2d 31 38 29 0a 28 .(use srfi-18).(
01e0: 75 73 65 20 66 6f 72 6d 61 74 29 0a 0a 28 72 65 use format)..(re
01f0: 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 69 75 quire-library iu
0200: 70 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 p).(import (pref
0210: 69 78 20 69 75 70 20 69 75 70 3a 29 29 0a 28 72 ix iup iup:)).(r
0220: 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 69 equire-library i
0230: 6e 69 2d 66 69 6c 65 29 0a 28 69 6d 70 6f 72 74 ni-file).(import
0240: 20 28 70 72 65 66 69 78 20 69 6e 69 2d 66 69 6c (prefix ini-fil
0250: 65 20 69 6e 69 3a 29 29 0a 0a 28 75 73 65 20 63 e ini:))..(use c
0260: 61 6e 76 61 73 2d 64 72 61 77 29 0a 28 69 6d 70 anvas-draw).(imp
0270: 6f 72 74 20 63 61 6e 76 61 73 2d 64 72 61 77 2d ort canvas-draw-
0280: 69 75 70 29 0a 0a 28 75 73 65 20 73 71 6c 69 74 iup)..(use sqlit
0290: 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 e3 srfi-1 posix
02a0: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
02b0: 20 73 72 66 69 2d 36 39 29 0a 28 69 6d 70 6f 72 srfi-69).(impor
02c0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
02d0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 69 3 sqlite3:))..(i
02e0: 6e 63 6c 75 64 65 20 22 6d 65 67 61 74 65 73 74 nclude "megatest
02f0: 2d 66 6f 73 73 69 6c 2d 68 61 73 68 2e 73 63 6d -fossil-hash.scm
0300: 22 29 0a 0a 3b 3b 0a 3b 3b 20 47 4c 4f 42 41 4c ")..;;.;; GLOBAL
0310: 53 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 64 61 S.;;.(define *da
0320: 74 61 73 68 61 72 65 3a 63 75 72 72 65 6e 74 2d tashare:current-
0330: 74 61 62 2d 6e 75 6d 62 65 72 2a 20 30 29 0a 28 tab-number* 0).(
0340: 64 65 66 69 6e 65 20 64 61 74 61 73 68 61 72 65 define datashare
0350: 3a 68 65 6c 70 20 28 63 6f 6e 63 20 22 55 73 61 :help (conc "Usa
0360: 67 65 3a 20 64 61 74 61 73 68 61 72 65 20 5b 61 ge: datashare [a
0370: 63 74 69 6f 6e 20 5b 70 61 72 61 6d 73 20 2e 2e ction [params ..
0380: 2e 5d 5d 0a 0a 4e 6f 74 65 3a 20 72 75 6e 20 64 .]]..Note: run d
0390: 61 74 61 73 68 61 72 65 20 77 69 74 68 6f 75 74 atashare without
03a0: 20 70 61 72 61 6d 65 74 65 72 73 20 74 6f 20 73 parameters to s
03b0: 74 61 72 74 20 74 68 65 20 67 75 69 2e 0a 0a 20 tart the gui...
03c0: 20 70 75 62 6c 69 73 68 20 3c 61 72 65 61 3e 20 publish <area>
03d0: 3c 6b 65 79 3e 20 5b 67 72 6f 75 70 5d 20 20 20 <key> [group]
03e0: 20 20 20 20 20 3a 20 50 75 62 6c 69 73 68 20 64 : Publish d
03f0: 61 74 61 20 74 6f 20 73 68 61 72 65 2c 20 75 73 ata to share, us
0400: 65 20 67 72 6f 75 70 20 74 6f 20 70 72 6f 74 65 e group to prote
0410: 63 74 20 28 69 29 0a 20 20 67 65 74 20 3c 61 72 ct (i). get <ar
0420: 65 61 3e 20 3c 6b 65 79 3e 20 5b 64 65 73 74 70 ea> <key> [destp
0430: 61 74 68 5d 20 20 20 20 20 20 20 20 20 3a 20 47 ath] : G
0440: 65 74 20 61 20 6c 69 6e 6b 20 74 6f 20 64 61 74 et a link to dat
0450: 61 2c 20 70 75 74 20 74 68 65 20 6c 69 6e 6b 20 a, put the link
0460: 69 6e 20 64 65 73 74 70 61 74 68 20 28 69 69 29 in destpath (ii)
0470: 0a 20 20 75 70 64 61 74 65 20 3c 61 72 65 61 3e . update <area>
0480: 20 3c 6b 65 79 3e 20 20 20 20 20 20 20 20 20 20 <key>
0490: 20 20 20 20 20 20 20 3a 20 55 70 64 61 74 65 20 : Update
04a0: 74 68 65 20 6c 69 6e 6b 20 74 6f 20 64 61 74 61 the link to data
04b0: 20 74 6f 20 74 68 65 20 6c 61 74 65 73 74 20 69 to the latest i
04c0: 74 65 72 61 74 69 6f 6e 2e 0a 0a 28 69 29 20 20 teration...(i)
04d0: 55 73 65 73 20 67 72 6f 75 70 20 6f 77 6e 65 72 Uses group owner
04e0: 73 68 69 70 20 6f 66 20 66 69 6c 65 73 20 74 6f ship of files to
04f0: 20 62 65 20 70 75 62 6c 69 73 68 65 64 20 66 6f be published fo
0500: 72 20 67 72 6f 75 70 20 69 66 20 6e 6f 74 20 73 r group if not s
0510: 70 65 63 69 66 69 65 64 0a 28 69 69 29 20 55 73 pecified.(ii) Us
0520: 65 73 20 6c 6f 63 61 6c 20 70 61 74 68 20 6f 72 es local path or
0530: 20 6c 6f 6f 6b 73 20 75 70 20 73 63 72 69 70 74 looks up script
0540: 20 74 6f 20 66 69 6e 64 20 70 61 74 68 20 69 6e to find path in
0550: 20 63 6f 6e 66 69 67 73 0a 0a 50 61 72 74 20 6f configs..Part o
0560: 66 20 74 68 65 20 4d 65 67 61 74 65 73 74 20 74 f the Megatest t
0570: 6f 6f 6c 20 73 75 69 74 65 2e 20 4c 65 61 72 6e ool suite. Learn
0580: 20 6d 6f 72 65 20 61 74 20 68 74 74 70 3a 2f 2f more at http://
0590: 77 77 77 2e 6b 69 61 74 6f 61 2e 63 6f 6d 2f 66 www.kiatoa.com/f
05a0: 6f 73 73 69 6c 73 2f 6d 65 67 61 74 65 73 74 0a ossils/megatest.
05b0: 0a 56 65 72 73 69 6f 6e 3a 20 22 20 6d 65 67 61 .Version: " mega
05c0: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
05d0: 29 29 20 3b 3b 20 22 0a 0a 3b 3b 3d 3d 3d 3d 3d )) ;; "..;;=====
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 0a 3b 3b 20 44 42 0a 3b 3b 3d 3d 3d 3d 3d 3d =.;; DB.;;======
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 ..(define (datas
0680: 68 61 72 65 3a 69 6e 69 74 69 61 6c 69 7a 65 2d hare:initialize-
0690: 64 62 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 db db). (for-ea
06a0: 63 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 71 ch. (lambda (q
06b0: 72 79 29 0a 20 20 20 20 20 28 73 71 6c 69 74 65 ry). (sqlite
06c0: 33 3a 65 78 65 63 75 74 65 20 64 62 20 71 72 79 3:execute db qry
06d0: 29 29 0a 20 20 20 28 6c 69 73 74 20 0a 20 20 20 )). (list .
06e0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 70 "CREATE TABLE p
06f0: 6b 67 73 20 0a 20 20 20 20 20 20 20 20 20 28 69 kgs . (i
0700: 64 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 d INTEGER
0710: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 PRIMARY KEY,.
0720: 20 20 20 20 20 20 20 20 61 72 65 61 20 20 20 20 area
0730: 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 TEXT,.
0740: 20 20 6b 65 79 20 20 20 20 20 20 20 54 45 58 54 key TEXT
0750: 2c 0a 20 20 20 20 20 20 20 20 20 20 69 74 65 72 ,. iter
0760: 61 74 69 6f 6e 20 49 4e 54 45 47 45 52 2c 0a 20 ation INTEGER,.
0770: 20 20 20 20 20 20 20 20 20 73 75 62 6d 69 74 74 submitt
0780: 65 72 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 er TEXT,.
0790: 20 20 20 64 61 74 65 74 69 6d 65 20 20 54 45 58 datetime TEX
07a0: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 73 74 6f T,. sto
07b0: 72 65 67 72 70 20 20 54 45 58 54 2c 0a 20 20 20 regrp TEXT,.
07c0: 20 20 20 20 20 20 20 64 69 73 6b 5f 69 64 20 20 disk_id
07d0: 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 INTEGER,.
07e0: 20 20 20 20 63 6f 6d 6d 65 6e 74 20 20 20 54 45 comment TE
07f0: 58 54 29 3b 22 0a 20 20 20 20 22 43 52 45 41 54 XT);". "CREAT
0800: 45 20 54 41 42 4c 45 20 72 65 66 73 0a 20 20 20 E TABLE refs.
0810: 20 20 20 20 20 20 28 69 64 20 20 20 20 20 20 20 (id
0820: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
0830: 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 KEY,.
0840: 70 6b 67 5f 69 64 20 20 20 20 49 4e 54 45 47 45 pkg_id INTEGE
0850: 52 2c 0a 20 20 20 20 20 20 20 20 20 20 64 65 73 R,. des
0860: 74 6c 69 6e 6b 20 20 54 45 58 54 29 3b 22 0a 20 tlink TEXT);".
0870: 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 "CREATE TABLE
0880: 20 64 69 73 6b 73 0a 20 20 20 20 20 20 20 20 20 disks.
0890: 28 69 64 20 20 20 20 20 20 20 20 20 49 4e 54 45 (id INTE
08a0: 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c GER PRIMARY KEY,
08b0: 0a 20 20 20 20 20 20 20 20 20 20 73 74 6f 72 65 . store
08c0: 67 72 70 20 20 20 54 45 58 54 2c 0a 20 20 20 20 grp TEXT,.
08d0: 20 20 20 20 20 20 70 61 74 68 20 20 20 20 20 20 path
08e0: 20 54 45 58 54 29 3b 22 29 29 29 0a 0a 3b 3b 20 TEXT);")))..;;
08f0: 43 72 65 61 74 65 20 74 68 65 20 73 71 6c 69 74 Create the sqlit
0900: 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 64 61 e db.(define (da
0910: 74 61 73 68 61 72 65 3a 6f 70 65 6e 2d 64 62 20 tashare:open-db
0920: 70 61 74 68 29 20 0a 20 20 28 69 66 20 28 61 6e path) . (if (an
0930: 64 20 70 61 74 68 0a 09 20 20 20 28 64 69 72 65 d path.. (dire
0940: 63 74 6f 72 79 3f 20 70 61 74 68 29 0a 09 20 20 ctory? path)..
0950: 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 (file-read-acce
0960: 73 73 3f 20 70 61 74 68 29 29 0a 20 20 20 20 20 ss? path)).
0970: 20 28 6c 65 74 2a 20 28 28 64 62 70 61 74 68 20 (let* ((dbpath
0980: 20 20 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f (conc path "/
0990: 64 61 74 61 73 68 61 72 65 2e 64 62 22 29 29 0a datashare.db")).
09a0: 09 20 20 20 20 20 28 77 72 69 74 65 61 62 6c 65 . (writeable
09b0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
09c0: 65 73 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 ess? dbpath))..
09d0: 20 20 20 20 28 64 62 65 78 69 73 74 73 20 20 28 (dbexists (
09e0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 file-exists? dbp
09f0: 61 74 68 29 29 0a 09 20 20 20 20 20 28 68 61 6e ath)).. (han
0a00: 64 6c 65 72 20 20 20 28 6d 61 6b 65 2d 62 75 73 dler (make-bus
0a10: 79 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 30 30 y-timeout 136000
0a20: 29 29 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 63 )))..(handle-exc
0a30: 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 eptions.. exn..
0a40: 28 62 65 67 69 6e 0a 09 20 20 20 28 64 65 62 75 (begin.. (debu
0a50: 67 3a 70 72 69 6e 74 20 32 20 22 45 52 52 4f 52 g:print 2 "ERROR
0a60: 3a 20 70 72 6f 62 6c 65 6d 20 61 63 63 65 73 73 : problem access
0a70: 69 6e 67 20 64 62 20 22 20 64 62 70 61 74 68 0a ing db " dbpath.
0a80: 09 09 09 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 ...((condition-p
0a90: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
0aa0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
0ab0: 65 78 6e 29 29 0a 09 20 20 20 28 65 78 69 74 29 exn)).. (exit)
0ac0: 29 0a 09 20 28 73 65 74 21 20 64 62 20 28 73 71 ).. (set! db (sq
0ad0: 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 lite3:open-datab
0ae0: 61 73 65 20 64 62 70 61 74 68 29 29 29 0a 09 28 ase dbpath)))..(
0af0: 69 66 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 if *db-write-acc
0b00: 65 73 73 2a 20 28 73 71 6c 69 74 65 33 3a 73 65 ess* (sqlite3:se
0b10: 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 t-busy-handler!
0b20: 64 62 20 68 61 6e 64 6c 65 72 29 29 0a 09 28 69 db handler))..(i
0b30: 66 20 28 6e 6f 74 20 64 62 65 78 69 73 74 73 29 f (not dbexists)
0b40: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
0b50: 20 20 20 20 28 64 61 74 61 73 68 61 72 65 3a 69 (datashare:i
0b60: 6e 69 74 69 61 6c 69 7a 65 2d 64 62 20 64 62 29 nitialize-db db)
0b70: 29 29 0a 09 64 62 29 29 29 0a 0a 3b 3b 3d 3d 3d ))..db)))..;;===
0b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0bc0: 3d 3d 3d 0a 3b 3b 20 47 55 49 0a 3b 3b 3d 3d 3d ===.;; GUI.;;===
0bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c10: 3d 3d 3d 0a 0a 3b 3b 20 54 68 65 20 6d 61 69 6e ===..;; The main
0c20: 20 6d 65 6e 75 20 0a 28 64 65 66 69 6e 65 20 28 menu .(define (
0c30: 64 61 74 61 73 68 61 72 65 3a 6d 61 69 6e 2d 6d datashare:main-m
0c40: 65 6e 75 29 0a 20 20 28 69 75 70 3a 6d 65 6e 75 enu). (iup:menu
0c50: 20 3b 3b 20 61 20 6d 65 6e 75 20 69 73 20 61 20 ;; a menu is a
0c60: 73 70 65 63 69 61 6c 20 61 74 74 72 69 62 75 74 special attribut
0c70: 65 20 74 6f 20 61 20 64 69 61 6c 6f 67 20 28 74 e to a dialog (t
0c80: 68 69 6e 6b 20 47 6e 6f 6d 65 20 70 75 74 74 69 hink Gnome putti
0c90: 6e 67 20 74 68 65 20 6d 65 6e 75 20 61 74 20 73 ng the menu at s
0ca0: 63 72 65 65 6e 20 74 6f 70 29 0a 20 20 20 28 69 creen top). (i
0cb0: 75 70 3a 6d 65 6e 75 2d 69 74 65 6d 20 22 46 69 up:menu-item "Fi
0cc0: 6c 65 73 22 20 28 69 75 70 3a 6d 65 6e 75 20 20 les" (iup:menu
0cd0: 20 3b 3b 20 4e 6f 74 65 20 74 68 61 74 20 79 6f ;; Note that yo
0ce0: 75 20 63 61 6e 20 75 73 65 20 65 69 74 68 65 72 u can use either
0cf0: 20 23 3a 61 63 74 69 6f 6e 20 6f 72 20 61 63 74 #:action or act
0d00: 69 6f 6e 3a 20 66 6f 72 20 6f 70 74 69 6f 6e 73 ion: for options
0d10: 0a 09 09 20 20 20 20 20 20 20 28 69 75 70 3a 6d ... (iup:m
0d20: 65 6e 75 2d 69 74 65 6d 20 22 4f 70 65 6e 22 20 enu-item "Open"
0d30: 20 61 63 74 69 6f 6e 3a 20 28 6c 61 6d 62 64 61 action: (lambda
0d40: 20 28 6f 62 6a 29 0a 09 09 09 09 09 09 09 28 69 (obj)........(i
0d50: 75 70 3a 73 68 6f 77 20 28 69 75 70 3a 66 69 6c up:show (iup:fil
0d60: 65 2d 64 69 61 6c 6f 67 29 29 0a 09 09 09 09 09 e-dialog))......
0d70: 09 09 28 70 72 69 6e 74 20 22 46 69 6c 65 2d 3e ..(print "File->
0d80: 6f 70 65 6e 20 22 20 6f 62 6a 29 29 29 0a 09 09 open " obj)))...
0d90: 20 20 20 20 20 20 20 28 69 75 70 3a 6d 65 6e 75 (iup:menu
0da0: 2d 69 74 65 6d 20 22 53 61 76 65 22 20 20 23 3a -item "Save" #:
0db0: 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 action (lambda (
0dc0: 6f 62 6a 29 28 70 72 69 6e 74 20 22 46 69 6c 65 obj)(print "File
0dd0: 2d 3e 73 61 76 65 20 22 20 6f 62 6a 29 29 29 0a ->save " obj))).
0de0: 09 09 20 20 20 20 20 20 20 28 69 75 70 3a 6d 65 .. (iup:me
0df0: 6e 75 2d 69 74 65 6d 20 22 45 78 69 74 22 20 20 nu-item "Exit"
0e00: 23 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 #:action (lambda
0e10: 20 28 6f 62 6a 29 28 65 78 69 74 29 29 29 29 29 (obj)(exit)))))
0e20: 0a 20 20 20 28 69 75 70 3a 6d 65 6e 75 2d 69 74 . (iup:menu-it
0e30: 65 6d 20 22 54 6f 6f 6c 73 22 20 28 69 75 70 3a em "Tools" (iup:
0e40: 6d 65 6e 75 0a 09 09 20 20 20 20 20 20 20 28 69 menu... (i
0e50: 75 70 3a 6d 65 6e 75 2d 69 74 65 6d 20 22 43 72 up:menu-item "Cr
0e60: 65 61 74 65 20 6e 65 77 20 62 6c 61 68 22 20 23 eate new blah" #
0e70: 3a 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 :action (lambda
0e80: 28 6f 62 6a 29 28 70 72 69 6e 74 20 22 54 6f 6f (obj)(print "Too
0e90: 6c 73 2d 3e 6e 65 77 20 62 6c 61 68 22 29 29 29 ls->new blah")))
0ea0: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 28 69 75 ... ;; (iu
0eb0: 70 3a 6d 65 6e 75 2d 69 74 65 6d 20 22 53 68 6f p:menu-item "Sho
0ec0: 77 20 64 69 61 6c 6f 67 22 20 20 20 20 20 23 3a w dialog" #:
0ed0: 61 63 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 action (lambda (
0ee0: 6f 62 6a 29 0a 09 09 20 20 20 20 20 20 20 3b 3b obj)... ;;
0ef0: 20 20 09 09 09 09 09 20 20 20 28 73 68 6f 77 20 ..... (show
0f00: 6d 65 73 73 61 67 65 2d 77 69 6e 64 6f 77 0a 09 message-window..
0f10: 09 20 20 20 20 20 20 20 3b 3b 20 20 09 09 09 09 . ;; ....
0f20: 09 20 20 20 20 20 23 3a 6d 6f 64 61 6c 3f 20 23 . #:modal? #
0f30: 74 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 09 t... ;; .
0f40: 09 09 09 09 20 20 20 20 20 3b 3b 20 73 65 74 20 .... ;; set
0f50: 70 6f 73 69 74 6f 6e 20 75 73 69 6e 67 20 63 6f positon using co
0f60: 6f 72 64 69 6e 61 74 65 73 20 6f 72 20 63 65 6e ordinates or cen
0f70: 74 65 72 2c 20 73 74 61 72 74 2c 20 74 6f 70 2c ter, start, top,
0f80: 20 6c 65 66 74 2c 20 65 6e 64 2c 20 62 6f 74 74 left, end, bott
0f90: 6f 6d 2c 20 72 69 67 68 74 2c 20 70 61 72 65 6e om, right, paren
0fa0: 74 2d 63 65 6e 74 65 72 2c 20 63 75 72 72 65 6e t-center, curren
0fb0: 74 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 09 t... ;; .
0fc0: 09 09 09 09 20 20 20 20 20 3b 3b 20 23 3a 78 20 .... ;; #:x
0fd0: 27 6d 6f 75 73 65 0a 09 09 20 20 20 20 20 20 20 'mouse...
0fe0: 3b 3b 20 20 09 09 09 09 09 20 20 20 20 20 3b 3b ;; ..... ;;
0ff0: 20 23 3a 79 20 27 6d 6f 75 73 65 0a 09 09 20 20 #:y 'mouse...
1000: 20 20 20 20 20 3b 3b 20 20 29 09 09 09 09 09 20 ;; ).....
1010: 20 20 20 20 0a 09 09 20 20 20 20 20 20 20 29 29 ... ))
1020: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 ))..(define (dat
1030: 61 73 68 61 72 65 3a 70 75 62 6c 69 73 68 2d 76 ashare:publish-v
1040: 69 65 77 29 0a 20 20 28 69 75 70 3a 76 62 6f 78 iew). (iup:vbox
1050: 0a 20 20 20 28 69 75 70 3a 68 62 6f 78 20 0a 20 . (iup:hbox .
1060: 20 20 20 28 69 75 70 3a 62 75 74 74 6f 6e 20 22 (iup:button "
1070: 50 75 73 68 6d 65 22 20 0a 09 09 23 3a 65 78 70 Pushme" ...#:exp
1080: 61 6e 64 20 22 59 45 53 22 0a 09 09 29 29 29 29 and "YES"...))))
1090: 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 61 73 ..(define (datas
10a0: 68 61 72 65 3a 67 65 74 2d 76 69 65 77 29 0a 20 hare:get-view).
10b0: 20 28 69 75 70 3a 76 62 6f 78 0a 20 20 20 28 69 (iup:vbox. (i
10c0: 75 70 3a 68 62 6f 78 20 0a 20 20 20 20 28 69 75 up:hbox . (iu
10d0: 70 3a 62 75 74 74 6f 6e 20 22 50 75 73 68 6d 65 p:button "Pushme
10e0: 22 0a 09 09 23 3a 65 78 70 61 6e 64 20 22 59 45 "...#:expand "YE
10f0: 53 22 0a 09 09 29 29 29 29 0a 0a 28 64 65 66 69 S"...))))..(defi
1100: 6e 65 20 28 64 61 74 61 73 68 61 72 65 3a 6d 61 ne (datashare:ma
1110: 6e 61 67 65 2d 76 69 65 77 29 0a 20 20 28 69 75 nage-view). (iu
1120: 70 3a 76 62 6f 78 0a 20 20 20 28 69 75 70 3a 68 p:vbox. (iup:h
1130: 62 6f 78 20 0a 20 20 20 20 28 69 75 70 3a 62 75 box . (iup:bu
1140: 74 74 6f 6e 20 22 50 75 73 68 6d 65 22 0a 09 09 tton "Pushme"...
1150: 23 3a 65 78 70 61 6e 64 20 22 59 45 53 22 0a 09 #:expand "YES"..
1160: 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 .))))..(define (
1170: 64 61 74 61 73 68 61 72 65 3a 67 75 69 29 0a 20 datashare:gui).
1180: 20 28 69 75 70 3a 73 68 6f 77 0a 20 20 20 28 69 (iup:show. (i
1190: 75 70 3a 64 69 61 6c 6f 67 20 0a 20 20 20 20 23 up:dialog . #
11a0: 3a 74 69 74 6c 65 20 28 63 6f 6e 63 20 22 44 61 :title (conc "Da
11b0: 74 61 53 68 61 72 65 20 64 61 73 68 62 6f 61 72 taShare dashboar
11c0: 64 20 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 d " (current-use
11d0: 72 2d 6e 61 6d 65 29 20 22 3a 22 20 28 63 75 72 r-name) ":" (cur
11e0: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
11f0: 0a 20 20 20 20 23 3a 6d 65 6e 75 20 28 64 61 74 . #:menu (dat
1200: 61 73 68 61 72 65 3a 6d 61 69 6e 2d 6d 65 6e 75 ashare:main-menu
1210: 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 ). (let* ((ta
1220: 62 73 20 28 69 75 70 3a 74 61 62 73 0a 09 09 20 bs (iup:tabs...
1230: 20 23 3a 74 61 62 63 68 61 6e 67 65 70 6f 73 2d #:tabchangepos-
1240: 63 62 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 20 cb (lambda (obj
1250: 63 75 72 72 20 70 72 65 76 29 0a 09 09 09 09 20 curr prev).....
1260: 20 20 20 20 20 28 73 65 74 21 20 2a 64 61 74 61 (set! *data
1270: 73 68 61 72 65 3a 63 75 72 72 65 6e 74 2d 74 61 share:current-ta
1280: 62 2d 6e 75 6d 62 65 72 2a 20 63 75 72 72 29 29 b-number* curr))
1290: 0a 09 09 20 20 28 64 61 74 61 73 68 61 72 65 3a ... (datashare:
12a0: 70 75 62 6c 69 73 68 2d 76 69 65 77 29 0a 09 09 publish-view)...
12b0: 20 20 28 64 61 74 61 73 68 61 72 65 3a 67 65 74 (datashare:get
12c0: 2d 76 69 65 77 29 0a 09 09 20 20 28 64 61 74 61 -view)... (data
12d0: 73 68 61 72 65 3a 6d 61 6e 61 67 65 2d 76 69 65 share:manage-vie
12e0: 77 29 0a 09 09 20 20 29 29 29 0a 09 3b 3b 20 28 w)... )))..;; (
12f0: 73 65 74 21 20 28 69 75 70 3a 63 61 6c 6c 62 61 set! (iup:callba
1300: 63 6b 20 74 61 62 73 20 74 61 62 63 68 61 6e 67 ck tabs tabchang
1310: 65 2d 63 62 3a 29 20 28 6c 61 6d 62 64 61 20 28 e-cb:) (lambda (
1320: 61 20 62 20 63 29 28 70 72 69 6e 74 20 22 53 57 a b c)(print "SW
1330: 49 54 43 48 45 44 20 54 4f 20 54 41 42 3a 20 22 ITCHED TO TAB: "
1340: 20 61 20 22 20 22 20 62 20 22 20 22 20 63 29 29 a " " b " " c))
1350: 29 0a 09 28 69 75 70 3a 61 74 74 72 69 62 75 74 )..(iup:attribut
1360: 65 2d 73 65 74 21 20 74 61 62 73 20 22 54 41 42 e-set! tabs "TAB
1370: 54 49 54 4c 45 30 22 20 22 50 75 62 6c 69 73 68 TITLE0" "Publish
1380: 22 29 0a 09 28 69 75 70 3a 61 74 74 72 69 62 75 ")..(iup:attribu
1390: 74 65 2d 73 65 74 21 20 74 61 62 73 20 22 54 41 te-set! tabs "TA
13a0: 42 54 49 54 4c 45 31 22 20 22 47 65 74 22 29 0a BTITLE1" "Get").
13b0: 09 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 2d .(iup:attribute-
13c0: 73 65 74 21 20 74 61 62 73 20 22 54 41 42 54 49 set! tabs "TABTI
13d0: 54 4c 45 32 22 20 22 4d 61 6e 61 67 65 22 29 0a TLE2" "Manage").
13e0: 09 3b 3b 20 28 69 75 70 3a 61 74 74 72 69 62 75 .;; (iup:attribu
13f0: 74 65 2d 73 65 74 21 20 74 61 62 73 20 22 42 47 te-set! tabs "BG
1400: 43 4f 4c 4f 52 22 20 22 31 39 30 20 31 39 30 20 COLOR" "190 190
1410: 31 39 30 22 29 0a 09 74 61 62 73 29 29 29 0a 20 190")..tabs))).
1420: 20 28 69 75 70 3a 6d 61 69 6e 2d 6c 6f 6f 70 29 (iup:main-loop)
1430: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1440: 3d 3d 3d 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 0a 3b 3b 20 4d ===========.;; M
1480: 41 49 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d AIN.;;==========
1490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
14d0: 65 66 69 6e 65 20 28 64 61 74 61 73 68 61 72 65 efine (datashare
14e0: 3a 6c 6f 61 64 2d 63 6f 6e 66 69 67 20 70 61 74 :load-config pat
14f0: 68 29 0a 20 20 28 6c 65 74 20 28 28 66 6e 61 6d h). (let ((fnam
1500: 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 2e e (conc path "/.
1510: 64 61 74 61 73 68 61 72 65 2e 63 6f 6e 66 69 67 datashare.config
1520: 22 29 29 29 0a 20 20 20 20 28 69 6e 69 3a 70 72 "))). (ini:pr
1530: 6f 70 65 72 74 79 2d 73 65 70 61 72 61 74 6f 72 operty-separator
1540: 2d 70 61 74 74 20 22 20 2a 20 20 2a 22 29 0a 20 -patt " * *").
1550: 20 20 20 28 69 6e 69 3a 70 72 6f 70 65 72 74 79 (ini:property
1560: 2d 73 65 70 61 72 61 74 6f 72 20 23 5c 73 70 61 -separator #\spa
1570: 63 65 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c ce). (if (fil
1580: 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 e-exists? fname)
1590: 0a 09 28 69 6e 69 3a 72 65 61 64 20 66 6e 61 6d ..(ini:read fnam
15a0: 65 29 0a 09 27 28 29 29 29 29 0a 0a 28 64 65 66 e)..'())))..(def
15b0: 69 6e 65 20 28 6d 61 69 6e 29 0a 20 20 28 6c 65 ine (main). (le
15c0: 74 2a 20 28 28 61 72 67 73 20 28 61 72 67 76 29 t* ((args (argv)
15d0: 29 0a 09 20 28 70 72 6f 67 20 28 63 61 72 20 61 ).. (prog (car a
15e0: 72 67 73 29 29 0a 09 20 28 72 65 6d 61 20 28 63 rgs)).. (rema (c
15f0: 64 72 20 61 72 67 73 29 29 0a 09 20 28 63 6f 6e dr args)).. (con
1600: 66 20 28 64 61 74 61 73 68 61 72 65 3a 6c 6f 61 f (datashare:loa
1610: 64 2d 63 6f 6e 66 69 67 20 28 70 61 74 68 6e 61 d-config (pathna
1620: 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 70 72 6f me-directory pro
1630: 67 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a g)))). (cond.
1640: 20 20 20 20 20 28 28 65 71 3f 20 28 6c 65 6e 67 ((eq? (leng
1650: 74 68 20 72 65 6d 61 29 20 31 29 0a 20 20 20 20 th rema) 1).
1660: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
1670: 3e 73 79 6d 62 6f 6c 20 28 63 61 72 20 72 65 6d >symbol (car rem
1680: 61 29 29 0a 09 28 28 68 65 6c 70 20 2d 68 20 2d a))..((help -h -
1690: 68 65 6c 70 20 2d 2d 68 20 2d 2d 68 65 6c 70 29 help --h --help)
16a0: 0a 09 20 28 70 72 69 6e 74 20 64 61 74 61 73 68 .. (print datash
16b0: 61 72 65 3a 68 65 6c 70 29 29 0a 09 28 65 6c 73 are:help))..(els
16c0: 65 0a 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f e.. (print "ERRO
16d0: 52 3a 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 R: Unrecognised
16e0: 63 6f 6d 6d 61 6e 64 2e 20 54 72 79 20 5c 22 64 command. Try \"d
16f0: 61 74 61 73 68 61 72 65 20 68 65 6c 70 5c 22 22 atashare help\""
1700: 29 29 29 29 0a 20 20 20 20 20 28 28 6e 75 6c 6c )))). ((null
1710: 3f 20 72 65 6d 61 29 28 64 61 74 61 73 68 61 72 ? rema)(datashar
1720: 65 3a 67 75 69 29 29 0a 20 20 20 20 20 28 28 3e e:gui)). ((>
1730: 3d 20 28 6c 65 6e 67 74 68 20 72 65 6d 61 29 20 = (length rema)
1740: 32 29 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 2). (apply
1750: 70 72 6f 63 65 73 73 2d 61 63 74 69 6f 6e 20 28 process-action (
1760: 63 61 72 20 72 65 6d 61 29 28 63 64 72 20 72 65 car rema)(cdr re
1770: 6d 61 29 29 29 0a 20 20 20 20 20 28 65 6c 73 65 ma))). (else
1780: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
1790: 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 63 6f 6d Unrecognised com
17a0: 6d 61 6e 64 2e 20 54 72 79 20 5c 22 64 61 74 61 mand. Try \"data
17b0: 73 68 61 72 65 20 68 65 6c 70 5c 22 22 29 29 29 share help\"")))
17c0: 29 29 0a 0a 28 6d 61 69 6e 29 ))..(main)