0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 64 62 66 69 6c 65 29 29 0a 3b 3b unit dbfile)).;;
03a0: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
03b0: 64 65 62 75 67 70 72 69 6e 74 29 29 0a 28 64 65 debugprint)).(de
03c0: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d clare (uses comm
03d0: 6f 6e 6d 6f 64 29 29 0a 0a 28 6d 6f 64 75 6c 65 onmod))..(module
03e0: 20 64 62 66 69 6c 65 0a 09 2a 0a 09 0a 20 20 28 dbfile..*... (
03f0: 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 20 import scheme..
0400: 20 63 68 69 63 6b 65 6e 0a 09 20 20 64 61 74 61 chicken.. data
0410: 2d 73 74 72 75 63 74 75 72 65 73 0a 09 20 20 65 -structures.. e
0420: 78 74 72 61 73 0a 09 20 20 6d 61 74 63 68 61 62 xtras.. matchab
0430: 6c 65 29 0a 20 20 0a 28 69 6d 70 6f 72 74 20 28 le). .(import (
0440: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0450: 71 6c 69 74 65 33 3a 29 0a 09 70 6f 73 69 78 20 qlite3:)..posix
0460: 74 79 70 65 64 2d 72 65 63 6f 72 64 73 20 73 72 typed-records sr
0470: 66 69 2d 31 38 20 73 72 66 69 2d 31 0a 09 73 72 fi-18 srfi-1..sr
0480: 66 69 2d 36 39 0a 09 73 74 61 63 6b 0a 09 66 69 fi-69..stack..fi
0490: 6c 65 73 0a 09 70 6f 72 74 73 0a 0a 09 63 6f 6d les..ports...com
04a0: 6d 6f 6e 6d 6f 64 0a 09 29 0a 0a 3b 3b 20 28 69 monmod..)..;; (i
04b0: 6d 70 6f 72 74 20 64 65 62 75 67 70 72 69 6e 74 mport debugprint
04c0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
0510: 52 20 45 20 43 20 4f 20 52 20 44 20 53 0a 3b 3b R E C O R D S.;;
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 61 20 73 69 6e ======..;; a sin
0570: 67 6c 65 20 4d 65 67 61 74 65 73 74 20 61 72 65 gle Megatest are
0580: 61 20 77 69 74 68 20 69 74 27 73 20 6d 75 6c 74 a with it's mult
0590: 69 70 6c 65 20 64 62 73 20 69 73 0a 3b 3b 20 6d iple dbs is.;; m
05a0: 61 6e 61 67 65 64 20 69 6e 20 61 20 64 62 73 74 anaged in a dbst
05b0: 72 75 63 74 0a 3b 3b 0a 28 64 65 66 73 74 72 75 ruct.;;.(defstru
05c0: 63 74 20 64 62 72 3a 64 62 73 74 72 75 63 74 0a ct dbr:dbstruct.
05d0: 20 20 28 61 72 65 61 70 61 74 68 20 20 23 66 29 (areapath #f)
05e0: 0a 20 20 28 68 6f 6d 65 68 6f 73 74 20 20 23 66 . (homehost #f
05f0: 29 0a 20 20 28 74 6d 70 70 61 74 68 20 20 20 23 ). (tmppath #
0600: 66 29 0a 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 f). (read-only
0610: 23 66 29 0a 20 20 28 73 75 62 64 62 73 20 28 6d #f). (subdbs (m
0620: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0630: 0a 20 20 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4e . )..;; NOTE: N
0640: 65 65 64 20 6f 6e 65 20 64 62 72 3a 73 75 62 64 eed one dbr:subd
0650: 62 20 70 65 72 20 6d 61 69 6e 2e 64 62 2c 20 31 b per main.db, 1
0660: 2e 64 62 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 73 .db ....;;.(defs
0670: 74 72 75 63 74 20 64 62 72 3a 73 75 62 64 62 0a truct dbr:subdb.
0680: 20 20 28 64 62 6e 61 6d 65 20 20 20 20 20 20 23 (dbname #
0690: 66 29 20 3b 3b 20 2e 64 62 2f 31 2e 64 62 0a 20 f) ;; .db/1.db.
06a0: 20 28 6d 74 64 62 66 69 6c 65 20 20 20 20 23 66 (mtdbfile #f
06b0: 29 20 3b 3b 20 6d 74 72 61 68 2f 2e 64 62 2f 31 ) ;; mtrah/.db/1
06c0: 2e 64 62 0a 20 20 28 6d 74 64 62 64 61 74 20 20 .db. (mtdbdat
06d0: 20 20 20 23 66 29 20 3b 3b 20 6f 6e 6c 79 20 6e #f) ;; only n
06e0: 65 65 64 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 eed one of these
06f0: 20 66 6f 72 20 73 79 6e 63 69 6e 67 0a 20 20 3b for syncing. ;
0700: 3b 20 28 64 62 64 61 74 73 20 20 20 20 20 20 28 ; (dbdats (
0710: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0720: 29 20 20 3b 3b 20 69 64 20 3d 3e 20 64 62 64 61 ) ;; id => dbda
0730: 74 20 0a 20 20 28 74 6d 70 64 62 66 69 6c 65 20 t . (tmpdbfile
0740: 20 20 23 66 29 20 3b 3b 20 2f 74 6d 70 2f 2e 2e #f) ;; /tmp/..
0750: 2e 2f 2e 64 62 2f 31 2e 64 62 0a 20 20 3b 3b 20 ./.db/1.db. ;;
0760: 28 72 65 66 6e 64 62 66 69 6c 65 20 20 23 66 29 (refndbfile #f)
0770: 20 3b 3b 20 2f 74 6d 70 2f 2e 2e 2e 2f 2e 64 62 ;; /tmp/.../.db
0780: 2f 31 2e 64 62 5f 72 65 66 0a 20 20 28 64 62 73 /1.db_ref. (dbs
0790: 74 61 63 6b 20 20 20 20 20 28 6d 61 6b 65 2d 73 tack (make-s
07a0: 74 61 63 6b 29 29 20 3b 3b 20 73 74 61 63 6b 20 tack)) ;; stack
07b0: 66 6f 72 20 74 6d 70 20 64 62 72 3a 64 62 64 61 for tmp dbr:dbda
07c0: 74 2c 0a 20 20 28 68 6f 6d 65 68 6f 73 74 20 20 t,. (homehost
07d0: 20 20 23 66 29 20 3b 3b 20 6e 6f 74 20 75 73 65 #f) ;; not use
07e0: 64 20 79 65 74 0a 20 20 28 6f 6e 2d 68 6f 6d 65 d yet. (on-home
07f0: 68 6f 73 74 20 23 66 29 20 3b 3b 20 6e 6f 74 20 host #f) ;; not
0800: 75 73 65 64 20 79 65 74 0a 20 20 28 72 65 61 64 used yet. (read
0810: 2d 6f 6e 6c 79 20 20 20 23 66 29 0a 20 20 28 6c -only #f). (l
0820: 61 73 74 2d 73 79 6e 63 20 20 20 30 29 0a 20 20 ast-sync 0).
0830: 28 6c 61 73 74 2d 77 72 69 74 65 20 20 28 63 75 (last-write (cu
0840: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
0850: 20 20 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )
0860: 20 20 20 3b 3b 20 67 6f 61 6c 20 69 73 20 74 6f ;; goal is to
0870: 20 63 6f 6e 76 65 72 67 65 20 6f 6e 20 6f 6e 65 converge on one
0880: 20 73 74 72 75 63 74 20 66 6f 72 20 61 6e 20 61 struct for an a
0890: 72 65 61 20 62 75 74 20 66 6f 72 20 6e 6f 77 20 rea but for now
08a0: 69 74 20 69 73 20 74 6f 6f 20 63 6f 6e 66 75 73 it is too confus
08b0: 69 6e 67 0a 0a 3b 3b 20 6e 65 65 64 20 74 6f 20 ing..;; need to
08c0: 6b 65 65 70 20 64 62 68 61 6e 64 6c 65 73 20 61 keep dbhandles a
08d0: 6e 64 20 63 61 63 68 65 64 20 73 74 61 74 65 6d nd cached statem
08e0: 65 6e 74 73 20 74 6f 67 65 74 68 65 72 0a 28 64 ents together.(d
08f0: 65 66 73 74 72 75 63 74 20 64 62 72 3a 64 62 64 efstruct dbr:dbd
0900: 61 74 0a 20 20 28 64 62 66 69 6c 65 20 20 20 20 at. (dbfile
0910: 20 20 23 66 29 0a 20 20 28 64 62 68 20 20 20 20 #f). (dbh
0920: 20 20 20 20 20 23 66 29 20 20 20 20 0a 20 20 28 #f) . (
0930: 73 74 6d 74 2d 63 61 63 68 65 20 20 28 6d 61 6b stmt-cache (mak
0940: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
0950: 20 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 23 66 (read-only #f
0960: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 ))..(define *dbs
0970: 74 72 75 63 74 2d 64 62 73 2a 20 23 66 29 0a 28 truct-dbs* #f).(
0980: 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 define *db-acces
0990: 73 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d s-mutex* (make-m
09a0: 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a utex)).(define *
09b0: 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 20 20 23 66 no-sync-db* #f
09c0: 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 79 ).(define *db-sy
09d0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 nc-in-progress*
09e0: 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d #f).(define *db-
09f0: 77 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 20 20 with-db-mutex*
0a00: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
0a10: 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 61 70 69 (define *max-api
0a20: 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 -process-request
0a30: 73 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 61 s* 0).(define *a
0a40: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
0a50: 73 74 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 65 st-count* 0).(de
0a60: 66 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 fine *db-write-a
0a70: 63 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a 28 ccess* #t).(
0a80: 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d define *db-last-
0a90: 73 79 6e 63 2a 20 20 20 20 20 20 20 20 30 29 20 sync* 0)
0aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ab0: 3b 3b 20 6c 61 73 74 20 74 69 6d 65 20 74 68 65 ;; last time the
0ac0: 20 73 79 6e 63 20 74 6f 20 6d 65 67 61 74 65 73 sync to megates
0ad0: 74 2e 64 62 20 68 61 70 70 65 6e 65 64 0a 28 64 t.db happened.(d
0ae0: 65 66 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 69 2d efine *db-multi-
0af0: 73 79 6e 63 2d 6d 75 74 65 78 2a 20 28 6d 61 6b sync-mutex* (mak
0b00: 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 20 3b e-mutex)) ;
0b10: 3b 20 70 72 6f 74 65 63 74 20 61 63 63 65 73 73 ; protect access
0b20: 20 74 6f 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d to *db-sync-in-
0b30: 70 72 6f 67 72 65 73 73 2a 2c 20 2a 64 62 2d 6c progress*, *db-l
0b40: 61 73 74 2d 73 79 6e 63 2a 0a 0a 28 64 65 66 69 ast-sync*..(defi
0b50: 6e 65 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 ne (db:generic-e
0b60: 72 72 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 rror-printout ex
0b70: 6e 20 2e 20 6d 65 73 73 61 67 65 29 0a 20 20 28 n . message). (
0b80: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
0b90: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
0ba0: 70 6f 72 74 29 29 0a 20 20 28 61 70 70 6c 79 20 port)). (apply
0bb0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
0bc0: 20 6d 65 73 73 61 67 65 29 0a 20 20 28 64 62 66 message). (dbf
0bd0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 0a 20 20 ile:print-err.
0be0: 20 20 22 2c 20 65 72 72 6f 72 3a 20 22 20 20 20 ", error: "
0bf0: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
0c00: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
0c10: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 20 'exn 'message)
0c20: 20 65 78 6e 29 0a 20 20 20 20 22 2c 20 61 72 67 exn). ", arg
0c30: 75 6d 65 6e 74 73 3a 20 22 20 28 28 63 6f 6e 64 uments: " ((cond
0c40: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0c50: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 61 72 ccessor 'exn 'ar
0c60: 67 75 6d 65 6e 74 73 29 20 65 78 6e 29 0a 20 20 guments) exn).
0c70: 20 20 22 2c 20 6c 6f 63 61 74 69 6f 6e 3a 20 22 ", location: "
0c80: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
0c90: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
0ca0: 27 65 78 6e 20 27 6c 6f 63 61 74 69 6f 6e 29 20 'exn 'location)
0cb0: 20 65 78 6e 29 0a 20 20 20 20 29 29 0a 0a 28 64 exn). ))..(d
0cc0: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 72 75 efine (dbfile:ru
0cd0: 6e 2d 69 64 2d 3e 6b 65 79 20 72 75 6e 2d 69 64 n-id->key run-id
0ce0: 29 0a 20 20 28 6f 72 20 72 75 6e 2d 69 64 20 27 ). (or run-id '
0cf0: 6d 61 69 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 main))..(define
0d00: 28 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 (db:safely-close
0d10: 2d 73 71 6c 69 74 65 33 2d 64 62 20 64 62 20 73 -sqlite3-db db s
0d20: 74 6d 74 2d 63 61 63 68 65 20 23 21 6b 65 79 20 tmt-cache #!key
0d30: 28 74 72 79 2d 6e 75 6d 20 33 29 29 0a 20 20 28 (try-num 3)). (
0d40: 69 66 20 28 3c 3d 20 74 72 79 2d 6e 75 6d 20 30 if (<= try-num 0
0d50: 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 ). #f.
0d60: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0d70: 6f 6e 73 0a 09 20 20 65 78 6e 0a 09 28 62 65 67 ons.. exn..(beg
0d80: 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 41 74 in.. (print "At
0d90: 74 65 6d 70 74 20 74 6f 20 73 61 66 65 6c 79 20 tempt to safely
0da0: 63 6c 6f 73 65 20 73 71 6c 69 74 65 33 20 64 62 close sqlite3 db
0db0: 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 failed. Trying
0dc0: 61 67 61 69 6e 2e 20 65 78 6e 3d 22 20 65 78 6e again. exn=" exn
0dd0: 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ).. (thread-sle
0de0: 65 70 21 20 33 29 0a 09 20 20 28 73 71 6c 69 74 ep! 3).. (sqlit
0df0: 65 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 e3:interrupt! db
0e00: 29 0a 09 20 20 28 64 62 3a 73 61 66 65 6c 79 2d ).. (db:safely-
0e10: 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 close-sqlite3-db
0e20: 20 64 62 20 73 74 6d 74 2d 63 61 63 68 65 20 74 db stmt-cache t
0e30: 72 79 2d 6e 75 6d 3a 20 28 2d 20 74 72 79 2d 6e ry-num: (- try-n
0e40: 75 6d 20 31 29 29 29 0a 09 28 69 66 20 28 73 71 um 1)))..(if (sq
0e50: 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 lite3:database?
0e60: 64 62 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 db).. (let* (
0e70: 28 73 74 6d 74 73 20 28 61 6e 64 20 73 74 6d 74 (stmts (and stmt
0e80: 2d 63 61 63 68 65 20 28 68 61 73 68 2d 74 61 62 -cache (hash-tab
0e90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
0ea0: 74 6d 74 2d 63 61 63 68 65 20 64 62 20 23 66 29 tmt-cache db #f)
0eb0: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 73 ))).. (if s
0ec0: 74 6d 74 73 20 28 6d 61 70 20 73 71 6c 69 74 65 tmts (map sqlite
0ed0: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 28 68 61 73 3:finalize! (has
0ee0: 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 73 h-table-values s
0ef0: 74 6d 74 73 29 29 29 0a 09 20 20 20 20 20 20 28 tmts))).. (
0f00: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
0f10: 21 20 64 62 29 0a 09 20 20 20 20 20 20 23 74 29 ! db).. #t)
0f20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 . (be
0f30: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
0f40: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
0f50: 72 72 20 22 64 62 3a 73 61 66 65 6c 79 2d 63 6c rr "db:safely-cl
0f60: 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 3a 20 ose-sqlite3-db:
0f70: 22 20 64 62 20 22 20 69 73 20 6e 6f 74 20 61 6e " db " is not an
0f80: 20 73 71 6c 69 74 65 33 20 64 62 22 29 0a 09 20 sqlite3 db")..
0f90: 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 #f.
0fa0: 20 20 20 29 0a 20 20 20 20 20 20 20 20 29 29 29 ). )))
0fb0: 29 0a 0a 3b 3b 20 63 6c 6f 73 65 20 61 6c 6c 20 )..;; close all
0fc0: 6f 70 65 6e 65 64 20 72 75 6e 2d 69 64 20 64 62 opened run-id db
0fd0: 73 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 63 6c s.(define (db:cl
0fe0: 6f 73 65 2d 61 6c 6c 20 64 62 73 74 72 75 63 74 ose-all dbstruct
0ff0: 29 0a 20 20 28 69 66 20 28 64 62 72 3a 64 62 73 ). (if (dbr:dbs
1000: 74 72 75 63 74 3f 20 64 62 73 74 72 75 63 74 29 truct? dbstruct)
1010: 0a 3b 3b 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 .;; (handle-exce
1020: 70 74 69 6f 6e 73 0a 3b 3b 20 09 20 20 65 78 6e ptions.;; . exn
1030: 0a 3b 3b 20 09 20 20 28 62 65 67 69 6e 0a 3b 3b .;; . (begin.;;
1040: 20 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
1050: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1060: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1070: 3a 20 46 69 6e 61 6c 69 7a 69 6e 67 20 66 61 69 : Finalizing fai
1080: 6c 65 64 2c 20 22 20 20 28 28 63 6f 6e 64 69 74 led, " ((condit
1090: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
10a0: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
10b0: 61 67 65 29 20 65 78 6e 29 20 22 2c 20 6e 6f 74 age) exn) ", not
10c0: 65 20 2d 20 65 78 6e 3d 22 20 65 78 6e 29 0a 3b e - exn=" exn).;
10d0: 3b 20 09 20 20 20 20 28 70 72 69 6e 74 2d 63 61 ; . (print-ca
10e0: 6c 6c 2d 63 68 61 69 6e 20 2a 64 65 66 61 75 6c ll-chain *defaul
10f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 0a 09 3b t-log-port*))..;
1100: 3b 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 ; (db:sync-touch
1110: 65 64 20 64 62 73 74 72 75 63 74 20 30 20 66 6f ed dbstruct 0 fo
1120: 72 63 65 2d 73 79 6e 63 3a 20 23 74 29 20 3b 3b rce-sync: #t) ;;
1130: 20 4e 4f 2e 20 44 6f 20 6e 6f 74 20 64 6f 20 74 NO. Do not do t
1140: 68 69 73 20 68 65 72 65 2e 20 49 6e 73 74 65 61 his here. Instea
1150: 64 20 77 65 20 72 65 6c 79 20 6f 6e 20 61 20 73 d we rely on a s
1160: 65 72 76 65 72 20 74 6f 20 62 65 20 73 74 61 72 erver to be star
1170: 74 65 64 20 77 68 65 6e 20 74 68 65 72 65 20 61 ted when there a
1180: 72 65 20 77 72 69 74 65 73 2c 20 65 76 65 6e 20 re writes, even
1190: 69 66 20 74 68 65 20 73 65 72 76 65 72 20 69 74 if the server it
11a0: 73 65 6c 66 20 69 73 20 6e 6f 74 20 67 6f 69 6e self is not goin
11b0: 67 20 74 6f 20 62 65 20 75 73 65 64 20 61 73 20 g to be used as
11c0: 61 20 73 65 72 76 65 72 2e 0a 20 20 20 20 20 20 a server..
11d0: 20 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 73 (let* ((subdbs
11e0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
11f0: 2d 76 61 6c 75 65 73 20 28 64 62 72 3a 64 62 73 -values (dbr:dbs
1200: 74 72 75 63 74 2d 73 75 62 64 62 73 20 64 62 73 truct-subdbs dbs
1210: 74 72 75 63 74 29 29 29 29 0a 09 20 20 28 66 6f truct)))).. (fo
1220: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
1230: 64 61 20 28 73 75 62 64 62 29 0a 09 20 20 20 20 da (subdb)..
1240: 20 28 6c 65 74 2a 20 28 28 74 64 62 73 20 20 20 (let* ((tdbs
1250: 20 20 20 20 28 73 74 61 63 6b 2d 3e 6c 69 73 74 (stack->list
1260: 20 28 64 62 72 3a 73 75 62 64 62 2d 64 62 73 74 (dbr:subdb-dbst
1270: 61 63 6b 20 73 75 62 64 62 29 29 29 0a 09 09 20 ack subdb)))...
1280: 20 20 20 28 6d 74 64 62 64 61 74 20 20 20 20 28 (mtdbdat (
1290: 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 28 64 dbr:dbdat-dbh (d
12a0: 62 72 3a 73 75 62 64 62 2d 6d 74 64 62 64 61 74 br:subdb-mtdbdat
12b0: 20 73 75 62 64 62 29 29 29 0a 09 09 20 20 20 20 subdb)))...
12c0: 23 3b 28 72 64 62 20 20 20 20 20 20 20 20 28 64 #;(rdb (d
12d0: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 28 64 62 br:dbdat-dbh (db
12e0: 72 3a 73 75 62 64 62 2d 72 65 66 6e 64 62 20 73 r:subdb-refndb s
12f0: 75 62 64 62 29 29 29 29 0a 09 09 20 20 20 20 0a ubdb))))... .
1300: 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 . (map (la
1310: 6d 62 64 61 20 28 64 62 64 61 74 29 0a 09 09 20 mbda (dbdat)...
1320: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 6d (let* ((stm
1330: 74 2d 63 61 63 68 65 20 28 64 62 72 3a 64 62 64 t-cache (dbr:dbd
1340: 61 74 2d 73 74 6d 74 2d 63 61 63 68 65 20 64 62 at-stmt-cache db
1350: 64 61 74 29 29 0a 09 09 09 20 20 20 20 20 28 64 dat)).... (d
1360: 62 68 20 20 20 20 20 20 20 20 28 64 62 72 3a 64 bh (dbr:d
1370: 62 64 61 74 2d 64 62 68 20 20 20 20 20 20 20 20 bdat-dbh
1380: 64 62 64 61 74 29 29 29 0a 09 09 09 28 64 62 3a dbdat)))....(db:
1390: 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c safely-close-sql
13a0: 69 74 65 33 2d 64 62 20 64 62 68 20 73 74 6d 74 ite3-db dbh stmt
13b0: 2d 63 61 63 68 65 29 29 29 0a 09 09 20 20 20 20 -cache)))...
13c0: 74 64 62 73 29 0a 09 20 20 20 20 20 20 20 28 64 tdbs).. (d
13d0: 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 b:safely-close-s
13e0: 71 6c 69 74 65 33 2d 64 62 20 6d 74 64 62 64 61 qlite3-db mtdbda
13f0: 74 20 28 64 62 72 3a 64 62 64 61 74 2d 73 74 6d t (dbr:dbdat-stm
1400: 74 2d 63 61 63 68 65 20 20 28 64 62 72 3a 73 75 t-cache (dbr:su
1410: 62 64 62 2d 6d 74 64 62 64 61 74 20 73 75 62 64 bdb-mtdbdat subd
1420: 62 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 b))) .
1430: 20 20 20 20 20 3b 3b 20 28 69 66 20 28 73 71 6c ;; (if (sql
1440: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 6d ite3:database? m
1450: 64 62 29 20 28 73 71 6c 69 74 65 33 3a 66 69 6e db) (sqlite3:fin
1460: 61 6c 69 7a 65 21 20 6d 64 62 29 29 0a 09 20 20 alize! mdb))..
1470: 20 20 20 20 20 23 3b 28 64 62 3a 73 61 66 65 6c #;(db:safel
1480: 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d y-close-sqlite3-
1490: 64 62 20 72 64 62 20 23 66 29 29 29 20 3b 3b 20 db rdb #f))) ;;
14a0: 73 74 6d 74 2d 63 61 63 68 65 29 29 29 29 29 20 stmt-cache)))))
14b0: 3b 3b 20 28 69 66 20 28 73 71 6c 69 74 65 33 3a ;; (if (sqlite3:
14c0: 64 61 74 61 62 61 73 65 3f 20 72 64 62 29 20 28 database? rdb) (
14d0: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
14e0: 21 20 72 64 62 29 29 29 29 29 29 0a 09 20 20 20 ! rdb))))))..
14f0: 73 75 62 64 62 73 29 0a 20 20 20 20 20 20 20 20 subdbs).
1500: 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 #t.
1510: 29 0a 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 ). #f.
1520: 20 29 0a 29 0a 0a 3b 3b 20 3b 3b 20 73 65 74 20 ).)..;; ;; set
1530: 75 70 20 61 20 73 69 6e 67 6c 65 20 64 62 20 28 up a single db (
1540: 65 2e 67 2e 20 6d 61 69 6e 2e 64 62 2c 20 31 2e e.g. main.db, 1.
1550: 64 62 20 2e 2e 2e 20 65 74 63 2e 29 0a 3b 3b 20 db ... etc.).;;
1560: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 ;;.;; (define (d
1570: 62 3a 73 65 74 75 70 2d 64 62 20 64 62 73 74 72 b:setup-db dbstr
1580: 75 63 74 20 61 72 65 61 70 61 74 68 20 72 75 6e uct areapath run
1590: 2d 69 64 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 -id).;; (let*
15a0: 28 28 64 62 6e 61 6d 65 20 20 20 28 64 62 3a 72 ((dbname (db:r
15b0: 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 un-id->dbname ru
15c0: 6e 2d 69 64 29 29 0a 3b 3b 20 09 20 28 64 62 73 n-id)).;; . (dbs
15d0: 74 72 75 63 74 20 28 68 61 73 68 2d 74 61 62 6c truct (hash-tabl
15e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 64 62 e-ref/default db
15f0: 73 74 72 75 63 74 73 20 64 62 6e 61 6d 65 20 23 structs dbname #
1600: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 f))).;; (if
1610: 64 62 73 74 72 75 63 74 0a 3b 3b 20 09 64 62 73 dbstruct.;; .dbs
1620: 74 72 75 63 74 0a 3b 3b 20 09 28 6c 65 74 2a 20 truct.;; .(let*
1630: 28 28 64 62 73 74 72 75 63 74 2d 6e 65 77 20 28 ((dbstruct-new (
1640: 6d 61 6b 65 2d 64 62 72 3a 64 62 73 74 72 75 63 make-dbr:dbstruc
1650: 74 29 29 29 0a 3b 3b 20 09 20 20 28 64 62 3a 6f t))).;; . (db:o
1660: 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 2d pen-db dbstruct-
1670: 6e 65 77 20 72 75 6e 2d 69 64 20 61 72 65 61 70 new run-id areap
1680: 61 74 68 3a 20 61 72 65 61 70 61 74 68 20 64 6f ath: areapath do
1690: 2d 73 79 6e 63 3a 20 23 74 29 0a 3b 3b 20 09 20 -sync: #t).;; .
16a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
16b0: 21 20 64 62 73 74 72 75 63 74 73 20 64 62 6e 61 ! dbstructs dbna
16c0: 6d 65 20 64 62 73 74 72 75 63 74 2d 6e 65 77 29 me dbstruct-new)
16d0: 0a 3b 3b 20 09 20 20 64 62 73 74 72 75 63 74 2d .;; . dbstruct-
16e0: 6e 65 77 29 29 29 29 0a 20 20 20 20 0a 3b 3b 20 new)))). .;;
16f0: 3b 20 52 65 74 75 72 6e 73 20 74 68 65 20 64 62 ; Returns the db
1700: 64 61 74 20 66 6f 72 20 61 20 70 61 72 74 69 63 dat for a partic
1710: 75 6c 61 72 20 64 62 66 69 6c 65 20 69 6e 73 69 ular dbfile insi
1720: 64 65 20 74 68 65 20 61 72 65 61 0a 3b 3b 20 3b de the area.;; ;
1730: 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 ;.;; (define (db
1740: 72 3a 64 62 73 74 72 75 63 74 2d 67 65 74 2d 64 r:dbstruct-get-d
1750: 62 64 61 74 20 64 62 73 74 72 75 63 74 20 64 62 bdat dbstruct db
1760: 66 69 6c 65 29 0a 3b 3b 20 20 20 28 68 61 73 68 file).;; (hash
1770: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1780: 6c 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 lt (dbr:dbstruct
1790: 2d 64 62 64 61 74 73 20 64 62 73 74 72 75 63 74 -dbdats dbstruct
17a0: 29 20 64 62 66 69 6c 65 20 23 66 29 29 0a 3b 3b ) dbfile #f)).;;
17b0: 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 .;; (define (db
17c0: 72 3a 64 62 73 74 72 75 63 74 2d 64 62 64 61 74 r:dbstruct-dbdat
17d0: 2d 70 75 74 21 20 64 62 73 74 72 75 63 74 20 64 -put! dbstruct d
17e0: 62 66 69 6c 65 20 64 62 29 0a 3b 3b 20 20 20 28 bfile db).;; (
17f0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1800: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 64 62 (dbr:dbstruct-db
1810: 64 61 74 73 20 64 62 73 74 72 75 63 74 29 20 64 dats dbstruct) d
1820: 62 66 69 6c 65 20 64 62 29 29 0a 3b 3b 20 0a 3b bfile db)).;; .;
1830: 3b 20 28 64 65 66 69 6e 65 20 28 64 62 3a 72 75 ; (define (db:ru
1840: 6e 2d 69 64 2d 3e 66 69 72 73 74 2d 6e 75 6d 20 n-id->first-num
1850: 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 28 6c 65 run-id).;; (le
1860: 74 2a 20 28 28 73 20 28 6e 75 6d 62 65 72 2d 3e t* ((s (number->
1870: 73 74 72 69 6e 67 20 72 75 6e 2d 69 64 29 29 0a string run-id)).
1880: 3b 3b 20 09 20 28 6c 20 28 73 74 72 69 6e 67 2d ;; . (l (string-
1890: 6c 65 6e 67 74 68 20 73 29 29 29 0a 3b 3b 20 20 length s))).;;
18a0: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 73 20 (substring s
18b0: 28 2d 20 6c 20 31 29 20 6c 29 29 29 0a 0a 3b 3b (- l 1) l)))..;;
18c0: 20 31 32 33 34 20 3d 3e 20 34 2f 31 32 33 34 2e 1234 => 4/1234.
18d0: 64 62 0a 3b 3b 20 20 20 23 66 20 3d 3e 20 30 2f db.;; #f => 0/
18e0: 6d 61 69 6e 2e 64 62 0a 3b 3b 20 20 20 28 61 62 main.db.;; (ab
18f0: 61 6e 64 6f 6e 65 64 20 74 68 65 20 69 64 65 61 andoned the idea
1900: 20 6f 66 20 6e 75 6d 2f 64 62 29 0a 3b 3b 20 0a of num/db).;; .
1910: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
1920: 72 75 6e 2d 69 64 2d 3e 70 61 74 68 20 61 70 61 run-id->path apa
1930: 74 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 63 6f th run-id). (co
1940: 6e 63 20 61 70 61 74 68 22 2f 22 28 64 62 66 69 nc apath"/"(dbfi
1950: 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d le:run-id->dbnam
1960: 65 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 e run-id)))..(de
1970: 66 69 6e 65 20 28 64 62 3a 64 62 6e 61 6d 65 2d fine (db:dbname-
1980: 3e 70 61 74 68 20 61 70 61 74 68 20 64 62 6e 61 >path apath dbna
1990: 6d 65 29 0a 20 20 28 63 6f 6e 63 20 61 70 61 74 me). (conc apat
19a0: 68 22 2f 22 64 62 6e 61 6d 65 29 29 0a 0a 28 64 h"/"dbname))..(d
19b0: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 72 75 efine (dbfile:ru
19c0: 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e n-id->dbname run
19d0: 2d 69 64 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 -id). (cond.
19e0: 28 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 ((number? run-id
19f0: 29 20 28 63 6f 6e 63 20 22 2e 64 62 2f 22 20 28 ) (conc ".db/" (
1a00: 6d 6f 64 75 6c 6f 20 72 75 6e 2d 69 64 20 31 30 modulo run-id 10
1a10: 30 29 20 22 2e 64 62 22 29 29 0a 20 20 20 28 28 0) ".db")). ((
1a20: 6e 6f 74 20 72 75 6e 2d 69 64 29 20 20 20 20 20 not run-id)
1a30: 28 63 6f 6e 63 20 22 2e 64 62 2f 6d 61 69 6e 2e (conc ".db/main.
1a40: 64 62 22 29 29 0a 20 20 20 28 65 6c 73 65 20 20 db")). (else
1a50: 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 2d 69 run-i
1a60: 64 29 29 29 0a 0a 3b 3b 20 4d 61 6b 65 20 74 68 d)))..;; Make th
1a70: 65 20 64 62 73 74 72 75 63 74 2c 20 73 65 74 75 e dbstruct, setu
1a80: 70 20 75 70 20 61 75 78 69 6c 6c 61 72 79 20 64 p up auxillary d
1a90: 62 27 73 20 61 6e 64 20 63 61 6c 6c 20 66 6f 72 b's and call for
1aa0: 20 6d 61 69 6e 20 64 62 20 61 74 20 6c 65 61 73 main db at leas
1ab0: 74 20 6f 6e 63 65 0a 3b 3b 0a 3b 3b 20 63 61 6c t once.;;.;; cal
1ac0: 6c 65 64 20 69 6e 20 68 74 74 70 2d 74 72 61 6e led in http-tran
1ad0: 73 70 6f 72 74 20 61 6e 64 20 72 65 70 6c 69 63 sport and replic
1ae0: 61 74 65 64 20 69 6e 20 72 6d 74 2e 73 63 6d 20 ated in rmt.scm
1af0: 66 6f 72 20 2a 6c 6f 63 61 6c 2a 20 61 63 63 65 for *local* acce
1b00: 73 73 2e 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ss. .;;.(define
1b10: 28 64 62 66 69 6c 65 3a 73 65 74 75 70 20 64 6f (dbfile:setup do
1b20: 2d 73 79 6e 63 20 61 72 65 61 70 61 74 68 20 74 -sync areapath t
1b30: 6d 70 70 61 74 68 29 0a 20 20 28 63 6f 6e 64 0a mppath). (cond.
1b40: 20 20 20 28 2a 64 62 73 74 72 75 63 74 2d 64 62 (*dbstruct-db
1b50: 73 2a 0a 20 20 20 20 28 64 62 66 69 6c 65 3a 70 s*. (dbfile:p
1b60: 72 69 6e 74 2d 65 72 72 20 22 57 41 52 4e 49 4e rint-err "WARNIN
1b70: 47 3a 20 64 62 66 69 6c 65 3a 73 65 74 75 70 20 G: dbfile:setup
1b80: 63 61 6c 6c 65 64 20 77 68 65 6e 20 2a 64 62 73 called when *dbs
1b90: 74 72 75 63 74 2d 64 62 73 2a 20 69 73 20 61 6c truct-dbs* is al
1ba0: 72 65 61 64 79 20 69 6e 69 74 69 61 6c 69 7a 65 ready initialize
1bb0: 64 22 29 0a 20 20 20 20 2a 64 62 73 74 72 75 63 d"). *dbstruc
1bc0: 74 2d 64 62 73 2a 29 20 3b 3b 20 54 4f 44 4f 3a t-dbs*) ;; TODO:
1bd0: 20 77 68 65 6e 20 6d 75 6c 74 69 70 6c 65 20 61 when multiple a
1be0: 72 65 61 73 20 61 72 65 20 73 75 70 70 6f 72 74 reas are support
1bf0: 65 64 2c 20 74 68 69 73 20 6f 70 74 69 6d 69 7a ed, this optimiz
1c00: 61 74 69 6f 6e 20 77 69 6c 6c 20 62 65 20 61 20 ation will be a
1c10: 68 61 7a 61 72 64 0a 20 20 20 28 65 6c 73 65 0a hazard. (else.
1c20: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 62 73 74 (let* ((dbst
1c30: 72 75 63 74 20 28 6d 61 6b 65 2d 64 62 72 3a 64 ruct (make-dbr:d
1c40: 62 73 74 72 75 63 74 29 29 29 0a 20 20 20 20 20 bstruct))).
1c50: 20 28 73 65 74 21 20 2a 64 62 73 74 72 75 63 74 (set! *dbstruct
1c60: 2d 64 62 73 2a 20 64 62 73 74 72 75 63 74 29 0a -dbs* dbstruct).
1c70: 20 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 (dbr:dbstr
1c80: 75 63 74 2d 61 72 65 61 70 61 74 68 2d 73 65 74 uct-areapath-set
1c90: 21 20 64 62 73 74 72 75 63 74 20 61 72 65 61 70 ! dbstruct areap
1ca0: 61 74 68 29 0a 20 20 20 20 20 20 28 64 62 72 3a ath). (dbr:
1cb0: 64 62 73 74 72 75 63 74 2d 74 6d 70 70 61 74 68 dbstruct-tmppath
1cc0: 2d 73 65 74 21 20 20 64 62 73 74 72 75 63 74 20 -set! dbstruct
1cd0: 74 6d 70 70 61 74 68 29 0a 20 20 20 20 20 20 64 tmppath). d
1ce0: 62 73 74 72 75 63 74 29 29 29 29 0a 0a 28 64 65 bstruct))))..(de
1cf0: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 67 65 74 fine (dbfile:get
1d00: 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 -subdb dbstruct
1d10: 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 run-id). (let*
1d20: 28 28 64 62 66 6e 61 6d 65 20 28 64 62 66 69 6c ((dbfname (dbfil
1d30: 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 e:run-id->dbname
1d40: 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 run-id))). (
1d50: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1d60: 65 66 61 75 6c 74 20 28 64 62 72 3a 64 62 73 74 efault (dbr:dbst
1d70: 72 75 63 74 2d 73 75 62 64 62 73 20 64 62 73 74 ruct-subdbs dbst
1d80: 72 75 63 74 29 20 64 62 66 6e 61 6d 65 20 23 66 ruct) dbfname #f
1d90: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 )))..(define (db
1da0: 66 69 6c 65 3a 73 65 74 2d 73 75 62 64 62 20 64 file:set-subdb d
1db0: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 73 bstruct run-id s
1dc0: 75 62 64 62 29 0a 20 20 28 68 61 73 68 2d 74 61 ubdb). (hash-ta
1dd0: 62 6c 65 2d 73 65 74 21 20 28 64 62 72 3a 64 62 ble-set! (dbr:db
1de0: 73 74 72 75 63 74 2d 73 75 62 64 62 73 20 64 62 struct-subdbs db
1df0: 73 74 72 75 63 74 29 20 28 64 62 66 69 6c 65 3a struct) (dbfile:
1e00: 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 run-id->dbname r
1e10: 75 6e 2d 69 64 29 20 73 75 62 64 62 29 29 0a 0a un-id) subdb))..
1e20: 28 64 65 66 69 6e 65 20 2a 64 62 66 69 6c 65 3a (define *dbfile:
1e30: 6e 75 6d 2d 68 61 6e 64 6c 65 73 2d 69 6e 2d 75 num-handles-in-u
1e40: 73 65 2a 20 30 29 0a 0a 3b 3b 20 47 65 74 2f 6f se* 0)..;; Get/o
1e50: 70 65 6e 20 61 20 64 61 74 61 62 61 73 65 0a 3b pen a database.;
1e60: 3b 20 20 20 20 69 66 20 72 75 6e 2d 69 64 20 3d ; if run-id =
1e70: 3e 20 67 65 74 20 72 75 6e 20 73 70 65 63 69 66 > get run specif
1e80: 69 63 20 64 62 0a 3b 3b 20 20 20 20 69 66 20 23 ic db.;; if #
1e90: 66 20 20 20 20 20 3d 3e 20 67 65 74 20 6d 61 69 f => get mai
1ea0: 6e 20 64 62 0a 3b 3b 20 20 20 20 69 66 20 72 75 n db.;; if ru
1eb0: 6e 2d 69 64 20 69 73 20 61 20 73 74 72 69 6e 67 n-id is a string
1ec0: 20 74 72 65 61 74 20 69 74 20 61 73 20 61 20 66 treat it as a f
1ed0: 69 6c 65 6e 61 6d 65 0a 3b 3b 20 20 20 20 69 66 ilename.;; if
1ee0: 20 64 62 20 61 6c 72 65 61 64 79 20 6f 70 65 6e db already open
1ef0: 20 2d 20 72 65 74 75 72 6e 20 69 6e 6d 65 6d 0a - return inmem.
1f00: 3b 3b 20 20 20 20 69 66 20 64 62 20 6e 6f 74 20 ;; if db not
1f10: 6f 70 65 6e 2c 20 6f 70 65 6e 20 69 6e 6d 65 6d open, open inmem
1f20: 2c 20 72 75 6e 64 62 20 61 6e 64 20 73 79 6e 63 , rundb and sync
1f30: 20 74 68 65 6e 20 72 65 74 75 72 6e 20 69 6e 6d then return inm
1f40: 65 6d 0a 3b 3b 20 20 20 20 69 6e 75 73 65 20 67 em.;; inuse g
1f50: 65 74 73 20 73 65 74 20 61 75 74 6f 6d 61 74 69 ets set automati
1f60: 63 61 6c 6c 79 20 66 6f 72 20 72 75 6e 64 62 27 cally for rundb'
1f70: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 s.;;.(define (db
1f80: 66 69 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 64 file:get-dbdat d
1f90: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 0a bstruct run-id).
1fa0: 20 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 20 (let* ((subdb
1fb0: 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 (dbfile:get-subd
1fc0: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
1fd0: 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 d))). (if (st
1fe0: 61 63 6b 2d 65 6d 70 74 79 3f 20 28 64 62 72 3a ack-empty? (dbr:
1ff0: 73 75 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 subdb-dbstack su
2000: 62 64 62 29 29 0a 09 23 66 0a 09 28 62 65 67 69 bdb))..#f..(begi
2010: 6e 0a 09 20 20 28 73 65 74 21 20 2a 64 62 66 69 n.. (set! *dbfi
2020: 6c 65 3a 6e 75 6d 2d 68 61 6e 64 6c 65 73 2d 69 le:num-handles-i
2030: 6e 2d 75 73 65 2a 20 28 2b 20 2a 64 62 66 69 6c n-use* (+ *dbfil
2040: 65 3a 6e 75 6d 2d 68 61 6e 64 6c 65 73 2d 69 6e e:num-handles-in
2050: 2d 75 73 65 2a 20 31 29 29 0a 09 20 20 28 73 74 -use* 1)).. (st
2060: 61 63 6b 2d 70 6f 70 21 20 28 64 62 72 3a 73 75 ack-pop! (dbr:su
2070: 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 bdb-dbstack subd
2080: 62 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 b))))))..;; retu
2090: 72 6e 20 61 20 70 72 65 76 69 6f 75 73 6c 79 20 rn a previously
20a0: 6f 70 65 6e 65 64 20 64 62 20 68 61 6e 64 6c 65 opened db handle
20b0: 20 74 6f 20 74 68 65 20 73 74 61 63 6b 20 6f 66 to the stack of
20c0: 20 61 76 61 69 6c 61 62 6c 65 20 68 61 6e 64 6c available handl
20d0: 65 73 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 es.(define (dbfi
20e0: 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 62 73 le:add-dbdat dbs
20f0: 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 64 truct run-id dbd
2100: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 75 at). (let* ((su
2110: 62 64 62 20 28 64 62 66 69 6c 65 3a 67 65 74 2d bdb (dbfile:get-
2120: 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 subdb dbstruct r
2130: 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 73 65 un-id))). (se
2140: 74 21 20 2a 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 t! *dbfile:num-h
2150: 61 6e 64 6c 65 73 2d 69 6e 2d 75 73 65 2a 20 28 andles-in-use* (
2160: 2d 20 2a 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 61 - *dbfile:num-ha
2170: 6e 64 6c 65 73 2d 69 6e 2d 75 73 65 2a 20 31 29 ndles-in-use* 1)
2180: 29 0a 20 20 20 20 28 73 74 61 63 6b 2d 70 75 73 ). (stack-pus
2190: 68 21 20 28 64 62 72 3a 73 75 62 64 62 2d 64 62 h! (dbr:subdb-db
21a0: 73 74 61 63 6b 20 73 75 62 64 62 29 20 64 62 64 stack subdb) dbd
21b0: 61 74 29 29 29 0a 0a 3b 3b 20 73 65 74 20 75 70 at)))..;; set up
21c0: 20 61 20 73 75 62 64 62 0a 3b 3b 0a 28 64 65 66 a subdb.;;.(def
21d0: 69 6e 65 20 28 64 62 66 69 6c 65 3a 69 6e 69 74 ine (dbfile:init
21e0: 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 -subdb dbstruct
21f0: 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 run-id init-proc
2200: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 6e 61 ). (let* ((dbna
2210: 6d 65 20 20 20 20 28 64 62 66 69 6c 65 3a 72 75 me (dbfile:ru
2220: 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e n-id->dbname run
2230: 2d 69 64 29 29 0a 09 20 28 61 72 65 61 70 61 74 -id)).. (areapat
2240: 68 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 h (dbr:dbstruct
2250: 2d 61 72 65 61 70 61 74 68 20 64 62 73 74 72 75 -areapath dbstru
2260: 63 74 29 29 0a 09 20 28 74 6d 70 70 61 74 68 20 ct)).. (tmppath
2270: 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d (dbr:dbstruct-
2280: 74 6d 70 70 61 74 68 20 20 64 62 73 74 72 75 63 tmppath dbstruc
2290: 74 29 29 0a 09 20 28 6d 74 64 62 70 61 74 68 20 t)).. (mtdbpath
22a0: 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d (dbfile:run-id-
22b0: 3e 70 61 74 68 20 61 72 65 61 70 61 74 68 20 72 >path areapath r
22c0: 75 6e 2d 69 64 29 29 0a 09 20 28 74 6d 70 64 62 un-id)).. (tmpdb
22d0: 70 61 74 68 20 28 64 62 66 69 6c 65 3a 72 75 6e path (dbfile:run
22e0: 2d 69 64 2d 3e 70 61 74 68 20 74 6d 70 70 61 74 -id->path tmppat
22f0: 68 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 6d 74 h run-id)).. (mt
2300: 64 62 64 61 74 20 20 20 28 64 62 66 69 6c 65 3a dbdat (dbfile:
2310: 6f 70 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 open-sqlite3-db
2320: 6d 74 64 62 70 61 74 68 20 69 6e 69 74 2d 70 72 mtdbpath init-pr
2330: 6f 63 29 29 0a 09 20 28 6e 65 77 73 75 62 64 62 oc)).. (newsubdb
2340: 20 20 28 6d 61 6b 65 2d 64 62 72 3a 73 75 62 64 (make-dbr:subd
2350: 62 20 64 62 6e 61 6d 65 3a 20 20 20 20 64 62 6e b dbname: dbn
2360: 61 6d 65 0a 09 09 09 09 20 20 20 20 6d 74 64 62 ame..... mtdb
2370: 66 69 6c 65 3a 20 20 6d 74 64 62 70 61 74 68 0a file: mtdbpath.
2380: 09 09 09 09 20 20 20 20 74 6d 70 64 62 66 69 6c .... tmpdbfil
2390: 65 3a 20 74 6d 70 64 62 70 61 74 68 0a 09 09 09 e: tmpdbpath....
23a0: 09 20 20 20 20 6d 74 64 62 64 61 74 3a 20 20 20 . mtdbdat:
23b0: 6d 74 64 62 64 61 74 29 29 29 0a 20 20 20 20 28 mtdbdat))). (
23c0: 64 62 66 69 6c 65 3a 73 65 74 2d 73 75 62 64 62 dbfile:set-subdb
23d0: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
23e0: 20 6e 65 77 73 75 62 64 62 29 0a 20 20 20 20 6e newsubdb). n
23f0: 65 77 73 75 62 64 62 29 29 20 3b 3b 20 72 65 74 ewsubdb)) ;; ret
2400: 75 72 6e 20 74 68 65 20 6e 65 77 20 73 75 62 64 urn the new subd
2410: 62 20 2d 20 62 75 74 20 73 68 6f 75 6c 64 6e 27 b - but shouldn'
2420: 74 20 72 65 61 6c 6c 79 20 75 73 65 20 69 74 0a t really use it.
2430: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 64 62 64 61 .;; returns dbda
2440: 74 20 77 69 74 68 20 64 62 68 20 61 6e 64 20 64 t with dbh and d
2450: 62 66 69 6c 65 70 61 74 68 0a 3b 3b 0a 3b 3b 20 bfilepath.;;.;;
2460: 4e 4f 54 45 3a 20 74 68 65 20 68 61 6e 64 6c 65 NOTE: the handle
2470: 20 69 73 20 6f 6e 20 2f 74 6d 70 20 64 62 20 66 is on /tmp db f
2480: 69 6c 65 21 0a 3b 3b 0a 3b 3b 20 20 31 2e 20 69 ile!.;;.;; 1. i
2490: 66 20 6e 65 65 64 65 64 20 73 65 74 75 70 20 74 f needed setup t
24a0: 68 65 20 73 75 62 64 62 20 66 6f 72 20 74 68 65 he subdb for the
24b0: 20 67 69 76 65 6e 20 72 75 6e 2d 69 64 0a 3b 3b given run-id.;;
24c0: 20 20 32 2e 20 69 66 20 74 68 65 72 65 20 69 73 2. if there is
24d0: 20 6e 6f 20 65 78 69 73 74 69 6e 67 20 64 62 20 no existing db
24e0: 68 61 6e 64 6c 65 20 69 6e 20 74 68 65 20 73 74 handle in the st
24f0: 61 63 6b 0a 3b 3b 20 20 20 20 20 63 72 65 61 74 ack.;; creat
2500: 65 20 61 20 6e 65 77 20 68 61 6e 64 6c 65 20 61 e a new handle a
2510: 6e 64 20 72 65 74 75 72 6e 20 69 74 20 28 64 6f nd return it (do
2520: 20 4e 4f 54 20 61 64 64 0a 3b 3b 20 20 20 20 20 NOT add.;;
2530: 69 74 20 74 6f 20 74 68 65 20 73 74 61 63 6b 29 it to the stack)
2540: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 ..;;.(define (db
2550: 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 64 62 73 file:open-db dbs
2560: 74 72 75 63 74 20 72 75 6e 2d 69 64 20 69 6e 69 truct run-id ini
2570: 74 2d 70 72 6f 63 29 0a 20 20 28 69 66 20 28 3e t-proc). (if (>
2580: 20 2a 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 61 6e *dbfile:num-han
2590: 64 6c 65 73 2d 69 6e 2d 75 73 65 2a 20 31 30 29 dles-in-use* 10)
25a0: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 77 . (let* ((w
25b0: 61 69 74 2d 64 65 6c 61 79 20 28 2d 20 2a 64 62 ait-delay (- *db
25c0: 66 69 6c 65 3a 6e 75 6d 2d 68 61 6e 64 6c 65 73 file:num-handles
25d0: 2d 69 6e 2d 75 73 65 2a 20 39 29 29 29 0a 09 28 -in-use* 9)))..(
25e0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
25f0: 20 22 49 4e 46 4f 3a 20 6f 76 65 72 20 74 65 6e "INFO: over ten
2600: 20 64 62 66 69 6c 65 20 68 61 6e 64 6c 65 20 74 dbfile handle t
2610: 68 72 65 61 64 73 20 69 6e 20 75 73 65 20 28 22 hreads in use ("
2620: 2a 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 61 6e 64 *dbfile:num-hand
2630: 6c 65 73 2d 69 6e 2d 75 73 65 2a 22 29 20 64 65 les-in-use*") de
2640: 6c 61 79 69 6e 67 20 22 77 61 69 74 2d 64 65 6c laying "wait-del
2650: 61 79 22 20 73 65 63 6f 6e 64 22 29 0a 09 28 74 ay" second")..(t
2660: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 hread-sleep! wai
2670: 74 2d 64 65 6c 61 79 29 29 29 0a 20 20 28 6c 65 t-delay))). (le
2680: 74 2a 20 28 28 73 75 62 64 62 20 28 64 62 66 69 t* ((subdb (dbfi
2690: 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 le:get-subdb dbs
26a0: 74 72 75 63 74 20 72 75 6e 2d 69 64 29 29 29 0a truct run-id))).
26b0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 75 62 (if (not sub
26c0: 64 62 29 20 3b 3b 20 6e 6f 74 20 79 65 74 20 64 db) ;; not yet d
26d0: 65 66 69 6e 65 64 0a 09 28 62 65 67 69 6e 0a 09 efined..(begin..
26e0: 20 20 28 64 62 66 69 6c 65 3a 69 6e 69 74 2d 73 (dbfile:init-s
26f0: 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 ubdb dbstruct ru
2700: 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a n-id init-proc).
2710: 09 20 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d . (dbfile:open-
2720: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
2730: 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 29 0a 09 id init-proc))..
2740: 28 6c 65 74 2a 20 28 28 64 62 64 61 74 20 28 64 (let* ((dbdat (d
2750: 62 66 69 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 bfile:get-dbdat
2760: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 dbstruct run-id)
2770: 29 29 0a 09 20 20 28 69 66 20 64 62 64 61 74 0a )).. (if dbdat.
2780: 09 20 20 20 20 20 20 64 62 64 61 74 0a 09 20 20 . dbdat..
2790: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 6d 70 70 (let* ((tmpp
27a0: 61 74 68 20 20 20 28 64 62 72 3a 64 62 73 74 72 ath (dbr:dbstr
27b0: 75 63 74 2d 74 6d 70 70 61 74 68 20 20 64 62 73 uct-tmppath dbs
27c0: 74 72 75 63 74 29 29 0a 09 09 20 20 20 20 20 28 truct))... (
27d0: 74 6d 70 64 62 70 61 74 68 20 28 64 62 66 69 6c tmpdbpath (dbfil
27e0: 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 74 68 20 74 e:run-id->path t
27f0: 6d 70 70 61 74 68 20 72 75 6e 2d 69 64 29 29 29 mppath run-id)))
2800: 0a 09 09 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d ...(dbfile:open-
2810: 73 71 6c 69 74 65 33 2d 64 62 20 74 6d 70 64 62 sqlite3-db tmpdb
2820: 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 29 29 path init-proc))
2830: 29 29 29 29 29 0a 0a 3b 3b 20 43 4f 4d 42 49 4e )))))..;; COMBIN
2840: 45 20 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 E dbfile:open-sq
2850: 6c 69 74 65 2d 64 62 20 61 6e 64 20 64 62 66 69 lite-db and dbfi
2860: 6c 65 3a 6c 6f 63 6b 2d 63 72 65 61 74 65 2d 6f le:lock-create-o
2870: 70 65 6e 0a 3b 3b 0a 0a 3b 3b 20 74 68 69 73 20 pen.;;..;; this
2880: 73 74 75 66 66 20 69 73 20 66 6f 72 20 69 6e 69 stuff is for ini
2890: 74 69 61 6c 20 64 65 62 75 67 67 69 6e 67 2c 20 tial debugging,
28a0: 70 6c 65 61 73 65 20 72 65 6d 6f 76 65 20 69 74 please remove it
28b0: 20 77 68 65 6e 0a 3b 3b 20 74 68 69 73 20 63 6f when.;; this co
28c0: 64 65 20 73 74 61 62 69 6c 69 7a 65 73 0a 28 64 de stabilizes.(d
28d0: 65 66 69 6e 65 20 2a 64 62 6f 70 65 6e 73 2a 20 efine *dbopens*
28e0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
28f0: 29 29 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 )).(define (dbfi
2900: 6c 65 3a 69 6e 63 2d 64 62 2d 6f 70 65 6e 20 64 le:inc-db-open d
2910: 62 66 69 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 bfile). (let* (
2920: 28 63 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e (curr-opens-coun
2930: 74 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 t (+ (hash-table
2940: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 -ref/default *db
2950: 6f 70 65 6e 73 2a 20 64 62 66 69 6c 65 20 30 29 opens* dbfile 0)
2960: 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e 1))). (if (>
2970: 20 63 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e curr-opens-coun
2980: 74 20 31 29 20 3b 3b 20 74 68 69 73 20 73 68 6f t 1) ;; this sho
2990: 75 6c 64 20 4e 4f 54 20 62 65 20 68 61 70 70 65 uld NOT be happe
29a0: 6e 69 6e 67 0a 09 28 64 62 66 69 6c 65 3a 70 72 ning..(dbfile:pr
29b0: 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 int-err "INFO: d
29c0: 62 20 22 64 62 66 69 6c 65 22 20 68 61 73 20 62 b "dbfile" has b
29d0: 65 65 6e 20 6f 70 65 6e 65 64 20 22 63 75 72 72 een opened "curr
29e0: 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 22 20 74 69 -opens-count" ti
29f0: 6d 65 73 21 22 29 29 0a 20 20 20 20 28 68 61 73 mes!")). (has
2a00: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 h-table-set! *db
2a10: 6f 70 65 6e 73 2a 20 64 62 66 69 6c 65 20 63 75 opens* dbfile cu
2a20: 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 29 0a rr-opens-count).
2a30: 20 20 20 20 63 75 72 72 2d 6f 70 65 6e 73 2d 63 curr-opens-c
2a40: 6f 75 6e 74 29 29 0a 0a 3b 3b 20 4f 70 65 6e 20 ount))..;; Open
2a50: 74 68 65 20 63 6c 61 73 73 69 63 20 6d 65 67 61 the classic mega
2a60: 74 65 73 74 2e 64 62 20 66 69 6c 65 20 28 64 65 test.db file (de
2a70: 66 61 75 6c 74 73 20 74 6f 20 6f 70 65 6e 20 69 faults to open i
2a80: 6e 20 74 6f 70 70 61 74 68 29 0a 3b 3b 0a 3b 3b n toppath).;;.;;
2a90: 20 20 20 4e 4f 54 45 3a 20 72 65 74 75 72 6e 73 NOTE: returns
2aa0: 20 61 20 64 62 64 61 74 20 6e 6f 74 20 61 20 64 a dbdat not a d
2ab0: 62 73 74 72 75 63 74 21 0a 3b 3b 0a 28 64 65 66 bstruct!.;;.(def
2ac0: 69 6e 65 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e ine (dbfile:open
2ad0: 2d 73 71 6c 69 74 65 33 2d 64 62 20 64 62 70 61 -sqlite3-db dbpa
2ae0: 74 68 20 69 6e 69 74 2d 70 72 6f 63 29 0a 20 20 th init-proc).
2af0: 28 6c 65 74 2a 20 28 28 64 62 65 78 69 73 74 73 (let* ((dbexists
2b00: 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 (file-exist
2b10: 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 28 77 s? dbpath)).. (w
2b20: 72 69 74 65 2d 61 63 63 65 73 73 20 28 66 69 6c rite-access (fil
2b30: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
2b40: 64 62 70 61 74 68 29 29 0a 09 20 28 64 62 20 20 dbpath)).. (db
2b50: 20 20 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 (dbfile
2b60: 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 :cautious-open-d
2b70: 61 74 61 62 61 73 65 20 64 62 70 61 74 68 20 69 atabase dbpath i
2b80: 6e 69 74 2d 70 72 6f 63 29 29 29 20 23 3b 28 73 nit-proc))) #;(s
2b90: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
2ba0: 62 61 73 65 20 64 62 70 61 74 68 29 0a 20 20 20 base dbpath).
2bb0: 20 28 64 62 66 69 6c 65 3a 69 6e 63 2d 64 62 2d (dbfile:inc-db-
2bc0: 6f 70 65 6e 20 64 62 70 61 74 68 29 0a 20 20 20 open dbpath).
2bd0: 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 (sqlite3:set-bu
2be0: 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 sy-handler! db (
2bf0: 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 sqlite3:make-bus
2c00: 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 y-timeout 10000)
2c10: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 ). (sqlite3:e
2c20: 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 xecute db (conc
2c30: 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e "PRAGMA synchron
2c40: 6f 75 73 20 3d 20 30 3b 22 29 29 0a 20 20 20 20 ous = 0;")).
2c50: 3b 3b 20 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 ;; (init-proc db
2c60: 29 0a 20 20 20 20 28 6d 61 6b 65 2d 64 62 72 3a ). (make-dbr:
2c70: 64 62 64 61 74 20 64 62 66 69 6c 65 3a 20 64 62 dbdat dbfile: db
2c80: 70 61 74 68 20 64 62 68 3a 20 64 62 20 72 65 61 path dbh: db rea
2c90: 64 2d 6f 6e 6c 79 3a 20 28 6e 6f 74 20 77 72 69 d-only: (not wri
2ca0: 74 65 2d 61 63 63 65 73 73 29 29 29 29 0a 0a 28 te-access))))..(
2cb0: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 70 define (dbfile:p
2cc0: 72 69 6e 74 2d 61 6e 64 2d 65 78 69 74 20 2e 20 rint-and-exit .
2cd0: 70 61 72 61 6d 73 29 0a 20 20 28 77 69 74 68 2d params). (with-
2ce0: 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 0a 20 output-to-port.
2cf0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 65 72 (current-er
2d00: 72 6f 72 2d 70 6f 72 74 29 0a 20 20 20 20 28 6c ror-port). (l
2d10: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 ambda (). (
2d20: 61 70 70 6c 79 20 70 72 69 6e 74 20 70 61 72 61 apply print para
2d30: 6d 73 29 29 29 0a 20 20 28 65 78 69 74 20 31 29 ms))). (exit 1)
2d40: 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 ). .(define (
2d50: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
2d60: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 77 69 . params). (wi
2d70: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
2d80: 74 0a 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 t. (current
2d90: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 20 20 20 -error-port).
2da0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
2db0: 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 70 (apply print p
2dc0: 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 0a 3b arams)))). .;
2dd0: 3b 20 6f 70 65 6e 20 61 6e 20 73 71 6c 20 64 61 ; open an sql da
2de0: 74 61 62 61 73 65 20 69 6e 73 69 64 65 20 61 20 tabase inside a
2df0: 66 69 6c 65 20 6c 6f 63 6b 0a 3b 3b 20 72 65 74 file lock.;; ret
2e00: 75 72 6e 73 3a 20 64 62 20 65 78 69 73 74 65 64 urns: db existed
2e10: 2d 70 72 69 6f 72 2d 74 6f 2d 6f 70 65 6e 69 6e -prior-to-openin
2e20: 67 0a 3b 3b 20 52 41 20 3d 3e 20 52 65 74 75 72 g.;; RA => Retur
2e30: 6e 73 20 61 20 64 62 20 68 61 6e 64 6c 65 72 3b ns a db handler;
2e40: 20 73 65 74 73 20 74 68 65 20 6c 6f 63 6b 20 69 sets the lock i
2e50: 66 20 6f 70 65 6e 65 64 20 69 6e 20 77 72 69 74 f opened in writ
2e60: 61 62 6c 65 20 6d 6f 64 65 0a 3b 3b 0a 3b 3b 20 able mode.;;.;;
2e70: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6f 70 65 6e (define *db-open
2e80: 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 -mutex* (make-mu
2e90: 74 65 78 29 29 0a 3b 3b 0a 23 3b 28 64 65 66 69 tex)).;;.#;(defi
2ea0: 6e 65 20 28 64 62 66 69 6c 65 3a 6c 6f 63 6b 2d ne (dbfile:lock-
2eb0: 63 72 65 61 74 65 2d 6f 70 65 6e 20 66 6e 61 6d create-open fnam
2ec0: 65 20 69 6e 69 74 70 72 6f 63 29 0a 20 20 28 6c e initproc). (l
2ed0: 65 74 2a 20 28 28 70 61 72 65 6e 74 2d 64 69 72 et* ((parent-dir
2ee0: 20 20 20 28 6f 72 20 28 70 61 74 68 6e 61 6d 65 (or (pathname
2ef0: 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 -directory fname
2f00: 29 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 )(current-direct
2f10: 6f 72 79 29 29 29 20 3b 3b 20 6e 6f 20 70 61 72 ory))) ;; no par
2f20: 65 6e 74 3f 20 67 6f 20 6c 6f 63 61 6c 0a 20 20 ent? go local.
2f30: 20 20 20 20 20 20 20 28 72 61 77 2d 66 6e 61 6d (raw-fnam
2f40: 65 20 20 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 e (pathname-f
2f50: 69 6c 65 20 66 6e 61 6d 65 29 29 0a 09 20 28 64 ile fname)).. (d
2f60: 69 72 2d 77 72 69 74 61 62 6c 65 20 28 66 69 6c ir-writable (fil
2f70: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
2f80: 70 61 72 65 6e 74 2d 64 69 72 29 29 0a 09 20 28 parent-dir)).. (
2f90: 66 69 6c 65 2d 65 78 69 73 74 73 20 20 28 66 69 file-exists (fi
2fa0: 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 le-exists? fname
2fb0: 29 29 0a 09 20 28 66 69 6c 65 2d 77 72 69 74 65 )).. (file-write
2fc0: 20 20 20 28 69 66 20 66 69 6c 65 2d 65 78 69 73 (if file-exis
2fd0: 74 73 0a 09 09 09 20 20 20 28 66 69 6c 65 2d 77 ts.... (file-w
2fe0: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 6e 61 rite-access? fna
2ff0: 6d 65 29 0a 09 09 09 20 20 20 64 69 72 2d 77 72 me).... dir-wr
3000: 69 74 61 62 6c 65 20 29 29 29 0a 20 20 20 20 3b itable ))). ;
3010: 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a ; (mutex-lock! *
3020: 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 20 db-open-mutex*)
3030: 3b 3b 20 74 72 69 65 64 20 74 68 69 73 20 6d 75 ;; tried this mu
3040: 74 65 78 2c 20 6e 6f 74 20 63 6c 65 61 72 20 69 tex, not clear i
3050: 74 20 68 65 6c 70 65 64 2e 0a 20 20 20 20 28 69 t helped.. (i
3060: 66 20 66 69 6c 65 2d 77 72 69 74 65 20 3b 3b 20 f file-write ;;
3070: 64 69 72 2d 77 72 69 74 61 62 6c 65 0a 09 28 63 dir-writable..(c
3080: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 20 20 ondition-case.
3090: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c (let* ((l
30a0: 6f 63 6b 66 6e 61 6d 65 20 20 20 28 63 6f 6e 63 ockfname (conc
30b0: 20 66 6e 61 6d 65 20 22 2e 6c 6f 63 6b 22 29 29 fname ".lock"))
30c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
30d0: 20 28 72 65 61 64 79 66 6e 61 6d 65 20 20 28 63 (readyfname (c
30e0: 6f 6e 63 20 70 61 72 65 6e 74 2d 64 69 72 20 22 onc parent-dir "
30f0: 2f 2e 72 65 61 64 79 2d 22 20 72 61 77 2d 66 6e /.ready-" raw-fn
3100: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ame)).
3110: 20 20 20 20 20 20 28 72 65 61 64 79 65 78 69 73 (readyexis
3120: 74 73 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d ts (common:file-
3130: 65 78 69 73 74 73 3f 20 72 65 61 64 79 66 6e 61 exists? readyfna
3140: 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 me))).
3150: 20 28 69 66 20 28 6e 6f 74 20 72 65 61 64 79 65 (if (not readye
3160: 78 69 73 74 73 29 0a 20 20 20 20 20 20 20 20 20 xists).
3170: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (common:si
3180: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 mple-file-lock-a
3190: 6e 64 2d 77 61 69 74 20 6c 6f 63 6b 66 6e 61 6d nd-wait lockfnam
31a0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 e)). (
31b0: 6c 65 74 20 28 28 64 62 20 20 20 20 20 20 28 73 let ((db (s
31c0: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
31d0: 62 61 73 65 20 66 6e 61 6d 65 29 29 29 0a 20 20 base fname))).
31e0: 20 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 (sqli
31f0: 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e te3:set-busy-han
3200: 64 6c 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 dler! db (sqlite
3210: 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 3:make-busy-time
3220: 6f 75 74 20 31 33 36 30 30 30 29 29 0a 20 20 20 out 136000)).
3230: 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 74 (sqlit
3240: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 50 e3:execute db "P
3250: 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 RAGMA synchronou
3260: 73 20 3d 20 30 3b 22 29 0a 20 20 20 20 20 20 20 s = 0;").
3270: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 66 (if (not f
3280: 69 6c 65 2d 65 78 69 73 74 73 29 0a 20 20 20 20 ile-exists).
3290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 6e (in
32a0: 69 74 70 72 6f 63 20 64 62 29 29 0a 20 20 20 20 itproc db)).
32b0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
32c0: 74 20 72 65 61 64 79 65 78 69 73 74 73 29 0a 20 t readyexists).
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32e0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
32f0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f (commo
3300: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
3310: 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 lease-lock lockf
3320: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 name).
3330: 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 6f (with-o
3340: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 0a 20 20 utput-to-file.
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 20 20 20 20 20 72 65 61 64 79 66 6e 61 6d 65 0a readyfname.
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3380: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
3390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33a0: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 (print "R
33b0: 65 61 64 79 20 61 74 20 22 20 0a 20 20 20 20 20 eady at " .
33c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33d0: 20 20 20 20 20 20 20 20 20 28 73 65 63 6f 6e 64 (second
33e0: 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 s->year-work-wee
33f0: 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 20 20 20 20 k/day-time .
3400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3410: 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 (curr
3420: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 29 ent-seconds)))))
3430: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3440: 64 62 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 db)). (e
3450: 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 20 20 28 xn (io-error) (
3460: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 dbfile:print-and
3470: 2d 65 78 69 74 20 22 45 52 52 4f 52 3a 20 69 2f -exit "ERROR: i/
3480: 6f 20 65 72 72 6f 72 20 77 69 74 68 20 22 20 66 o error with " f
3490: 6e 61 6d 65 20 22 2e 20 43 68 65 63 6b 20 70 65 name ". Check pe
34a0: 72 6d 69 73 73 69 6f 6e 73 2c 20 64 69 73 6b 20 rmissions, disk
34b0: 73 70 61 63 65 20 65 74 63 2e 20 61 6e 64 20 74 space etc. and t
34c0: 72 79 20 61 67 61 69 6e 2e 22 29 29 0a 20 20 20 ry again.")).
34d0: 20 20 20 20 20 20 28 65 78 6e 20 28 63 6f 72 72 (exn (corr
34e0: 75 70 74 29 20 20 20 28 64 62 66 69 6c 65 3a 70 upt) (dbfile:p
34f0: 72 69 6e 74 2d 61 6e 64 2d 65 78 69 74 20 22 45 rint-and-exit "E
3500: 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 RROR: database "
3510: 20 66 6e 61 6d 65 20 22 20 69 73 20 63 6f 72 72 fname " is corr
3520: 75 70 74 2e 20 52 65 70 61 69 72 20 69 74 20 74 upt. Repair it t
3530: 6f 20 70 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 o proceed.")).
3540: 20 20 20 20 20 20 20 28 65 78 6e 20 28 62 75 73 (exn (bus
3550: 79 29 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a y) (dbfile:
3560: 70 72 69 6e 74 2d 61 6e 64 2d 65 78 69 74 20 22 print-and-exit "
3570: 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 ERROR: database
3580: 22 20 66 6e 61 6d 65 20 22 20 69 73 20 6c 6f 63 " fname " is loc
3590: 6b 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 ked. Try copying
35a0: 20 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 to another loca
35b0: 74 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 tion, remove ori
35c0: 67 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 ginal and copy b
35d0: 61 63 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 20 ack.")).
35e0: 20 28 65 78 6e 20 28 70 65 72 6d 69 73 73 69 6f (exn (permissio
35f0: 6e 29 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d n)(dbfile:print-
3600: 61 6e 64 2d 65 78 69 74 20 22 45 52 52 4f 52 3a and-exit "ERROR:
3610: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
3620: 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 e " has some per
3630: 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d missions problem
3640: 2e 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 .")). (e
3650: 78 6e 20 28 29 20 28 64 62 66 69 6c 65 3a 70 72 xn () (dbfile:pr
3660: 69 6e 74 2d 61 6e 64 2d 65 78 69 74 20 22 45 52 int-and-exit "ER
3670: 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 ROR: Unknown err
3680: 6f 72 20 77 69 74 68 20 64 61 74 61 62 61 73 65 or with database
3690: 20 22 20 66 6e 61 6d 65 20 22 20 6d 65 73 73 61 " fname " messa
36a0: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
36b0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
36c0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
36d0: 65 29 20 65 78 6e 29 29 29 29 0a 20 20 20 20 20 e) exn)))).
36e0: 20 20 20 0a 09 28 63 6f 6e 64 69 74 69 6f 6e 2d ..(condition-
36f0: 63 61 73 65 0a 20 20 20 20 20 20 20 20 20 28 62 case. (b
3700: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
3710: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
3720: 72 20 22 57 41 52 4e 49 4e 47 3a 20 6f 70 65 6e r "WARNING: open
3730: 69 6e 67 20 64 62 20 69 6e 20 6e 6f 6e 2d 77 72 ing db in non-wr
3740: 69 74 61 62 6c 65 20 64 69 72 20 22 20 66 6e 61 itable dir " fna
3750: 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 me). (
3760: 6c 65 74 20 28 28 64 62 20 28 73 71 6c 69 74 65 let ((db (sqlite
3770: 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 3:open-database
3780: 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 fname))).
3790: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 73 (sqlite3:s
37a0: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
37b0: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b db (sqlite3:mak
37c0: 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 e-busy-timeout 1
37d0: 33 36 30 30 30 29 29 0a 20 20 20 20 20 20 20 20 36000)).
37e0: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
37f0: 65 63 75 74 65 20 64 62 20 22 50 52 41 47 4d 41 ecute db "PRAGMA
3800: 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 30 synchronous = 0
3810: 3b 22 29 0a 09 20 20 20 20 20 3b 3b 20 28 6d 75 ;").. ;; (mu
3820: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
3830: 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 0a 20 20 20 open-mutex*).
3840: 20 20 20 20 20 20 20 20 20 20 64 62 29 29 0a 20 db)).
3850: 20 20 20 20 20 20 20 20 28 65 78 6e 20 28 69 6f (exn (io
3860: 2d 65 72 72 6f 72 29 0a 09 20 20 20 20 20 20 28 -error).. (
3870: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 dbfile:print-and
3880: 2d 65 78 69 74 0a 09 20 20 20 20 20 20 20 22 45 -exit.. "E
3890: 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 RROR: i/o error
38a0: 77 69 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 with " fname ".
38b0: 43 68 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e Check permission
38c0: 73 2c 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 s, disk space et
38d0: 63 2e 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e c. and try again
38e0: 2e 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 .")). (e
38f0: 78 6e 20 28 63 6f 72 72 75 70 74 29 0a 09 20 20 xn (corrupt)..
3900: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
3910: 74 2d 61 6e 64 2d 65 78 69 74 0a 09 20 20 20 20 t-and-exit..
3920: 20 20 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 "ERROR: datab
3930: 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 69 73 ase " fname " is
3940: 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 corrupt. Repair
3950: 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 it to proceed."
3960: 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 78 6e )). (exn
3970: 20 28 62 75 73 79 29 0a 09 20 20 20 20 20 20 28 (busy).. (
3980: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 dbfile:print-and
3990: 2d 65 78 69 74 0a 09 20 20 20 20 20 20 20 22 45 -exit.. "E
39a0: 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 RROR: database "
39b0: 20 66 6e 61 6d 65 20 22 20 69 73 20 6c 6f 63 6b fname " is lock
39c0: 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 ed. Try copying
39d0: 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 to another locat
39e0: 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 ion, remove orig
39f0: 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 inal and copy ba
3a00: 63 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 20 20 ck.")).
3a10: 28 65 78 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e (exn (permission
3a20: 29 0a 09 20 20 20 20 20 20 28 64 62 66 69 6c 65 ).. (dbfile
3a30: 3a 70 72 69 6e 74 2d 61 6e 64 2d 65 78 69 74 0a :print-and-exit.
3a40: 09 20 20 20 20 20 20 20 22 45 52 52 4f 52 3a 20 . "ERROR:
3a50: 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 database " fname
3a60: 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 6d " has some perm
3a70: 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d 2e issions problem.
3a80: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 65 78 ")). (ex
3a90: 6e 20 28 29 0a 09 20 20 20 20 20 20 28 64 62 66 n ().. (dbf
3aa0: 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 2d 65 78 ile:print-and-ex
3ab0: 69 74 0a 09 20 20 20 20 20 20 20 22 45 52 52 4f it.. "ERRO
3ac0: 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 R: Unknown error
3ad0: 20 77 69 74 68 20 64 61 74 61 62 61 73 65 20 22 with database "
3ae0: 20 66 6e 61 6d 65 20 22 20 6d 65 73 73 61 67 65 fname " message
3af0: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
3b00: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
3b10: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
3b20: 20 65 78 6e 29 29 29 29 0a 09 29 29 29 0a 0a 0a exn))))..)))...
3b30: 09 09 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ...;;===========
3b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6e ===========.;; n
3b80: 6f 2d 73 79 6e 63 2e 64 62 20 2d 20 73 6d 61 6c o-sync.db - smal
3b90: 6c 20 62 69 74 73 20 6f 66 20 64 61 74 61 20 74 l bits of data t
3ba0: 6f 20 62 65 20 73 68 61 72 65 64 20 62 65 74 77 o be shared betw
3bb0: 65 65 6e 20 73 65 72 76 65 72 73 0a 3b 3b 3d 3d een servers.;;==
3bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c00: 3d 3d 3d 3d 0a 0a 3b 3b 20 69 66 20 77 65 20 61 ====..;; if we a
3c10: 72 65 20 6e 6f 74 20 61 20 73 65 72 76 65 72 20 re not a server
3c20: 63 72 65 61 74 65 20 61 20 64 62 20 68 61 6e 64 create a db hand
3c30: 6c 65 2e 20 74 68 69 73 20 69 73 20 6e 6f 74 20 le. this is not
3c40: 66 69 6e 61 6c 69 7a 65 64 0a 3b 3b 20 73 6f 20 finalized.;; so
3c50: 77 61 74 63 68 20 66 6f 72 20 70 72 6f 62 6c 65 watch for proble
3c60: 6d 73 2e 20 49 27 6d 20 73 74 69 6c 6c 20 6e 6f ms. I'm still no
3c70: 74 20 63 6c 65 61 72 20 69 66 20 69 74 20 69 73 t clear if it is
3c80: 20 6e 65 65 64 65 64 20 74 6f 20 6d 61 6e 75 61 needed to manua
3c90: 6c 6c 79 0a 3b 3b 20 66 69 6e 61 6c 69 7a 65 20 lly.;; finalize
3ca0: 73 71 6c 69 74 65 33 20 64 62 73 20 77 69 74 68 sqlite3 dbs with
3cb0: 20 74 68 65 20 73 71 6c 69 74 65 33 20 65 67 67 the sqlite3 egg
3cc0: 2e 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 64 ..;;..(define (d
3cd0: 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f bfile:cautious-o
3ce0: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 pen-database fna
3cf0: 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 23 21 6f me init-proc #!o
3d00: 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 73 2d 6c ptional (tries-l
3d10: 65 66 74 20 35 30 29 29 0a 20 20 28 6c 65 74 2a eft 50)). (let*
3d20: 20 28 28 62 75 73 79 2d 66 69 6c 65 20 20 28 63 ((busy-file (c
3d30: 6f 6e 63 20 66 6e 61 6d 65 22 2d 6a 6f 75 72 6e onc fname"-journ
3d40: 61 6c 22 29 29 0a 09 20 28 64 65 6c 61 79 2d 74 al")).. (delay-t
3d50: 69 6d 65 20 28 2a 20 28 2d 20 35 31 20 74 72 69 ime (* (- 51 tri
3d60: 65 73 2d 6c 65 66 74 29 20 31 2e 31 29 29 0a 09 es-left) 1.1))..
3d70: 20 28 72 65 74 72 79 20 20 20 20 20 20 28 6c 61 (retry (la
3d80: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
3d90: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
3da0: 64 65 6c 61 79 2d 74 69 6d 65 29 0a 09 09 20 20 delay-time)...
3db0: 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 69 65 (if (> trie
3dc0: 73 2d 6c 65 66 74 20 30 29 0a 09 09 09 20 20 20 s-left 0)....
3dd0: 28 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 (dbfile:cautious
3de0: 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 -open-database f
3df0: 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 28 name init-proc (
3e00: 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 31 29 29 - tries-left 1))
3e10: 29 29 29 29 0a 20 20 20 20 28 61 73 73 65 72 74 )))). (assert
3e20: 20 28 3e 3d 20 74 72 69 65 73 2d 6c 65 66 74 20 (>= tries-left
3e30: 30 29 20 28 63 6f 6e 63 20 22 46 41 54 41 4c 3a 0) (conc "FATAL:
3e40: 20 74 6f 6f 20 6d 61 6e 79 20 61 74 74 65 6d 70 too many attemp
3e50: 74 73 20 69 6e 20 64 62 66 69 6c 65 3a 63 61 75 ts in dbfile:cau
3e60: 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 tious-open-datab
3e70: 61 73 65 20 6f 66 20 22 66 6e 61 6d 65 22 2c 20 ase of "fname",
3e80: 67 69 76 69 6e 67 20 75 70 2e 22 29 29 0a 20 20 giving up.")).
3e90: 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 (if (and (file
3ea0: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 -write-access? f
3eb0: 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 66 69 6c name).. (fil
3ec0: 65 2d 65 78 69 73 74 73 3f 20 62 75 73 79 2d 66 e-exists? busy-f
3ed0: 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 ile))..(begin..
3ee0: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
3ef0: 72 72 20 22 49 4e 46 4f 3a 20 64 62 66 69 6c 65 rr "INFO: dbfile
3f00: 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 :cautious-open-d
3f10: 61 74 61 62 61 73 65 3a 20 6a 6f 75 72 6e 61 6c atabase: journal
3f20: 20 66 69 6c 65 20 22 20 62 75 73 79 2d 66 69 6c file " busy-fil
3f30: 65 20 22 20 65 78 69 73 74 73 2c 20 74 72 79 69 e " exists, tryi
3f40: 6e 67 20 61 67 61 69 6e 20 69 6e 20 66 65 77 20 ng again in few
3f50: 73 65 63 6f 6e 64 73 2e 22 29 0a 09 20 20 28 74 seconds.").. (t
3f60: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
3f70: 09 20 20 28 69 66 20 28 65 71 3f 20 74 72 69 65 . (if (eq? trie
3f80: 73 2d 6c 65 66 74 20 32 29 0a 09 20 20 20 20 20 s-left 2)..
3f90: 20 28 62 65 67 69 6e 0a 09 09 28 64 62 66 69 6c (begin...(dbfil
3fa0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 e:print-err "INF
3fb0: 4f 3a 20 66 6f 72 63 69 6e 67 20 6a 6f 75 72 6e O: forcing journ
3fc0: 61 6c 20 72 6f 6c 6c 75 70 20 22 62 75 73 79 2d al rollup "busy-
3fd0: 66 69 6c 65 29 0a 09 09 28 64 62 66 69 6c 65 3a file)...(dbfile:
3fe0: 62 72 75 74 65 2d 66 6f 72 63 65 2d 73 61 6c 76 brute-force-salv
3ff0: 61 67 65 2d 64 62 20 66 6e 61 6d 65 29 29 29 0a age-db fname))).
4000: 09 20 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 . (dbfile:cauti
4010: 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 ous-open-databas
4020: 65 20 66 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f e fname init-pro
4030: 63 20 28 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 c (- tries-left
4040: 31 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 1)))..(let* ((db
4050: 2d 65 78 69 73 74 73 20 28 66 69 6c 65 2d 65 78 -exists (file-ex
4060: 69 73 74 73 3f 20 66 6e 61 6d 65 29 29 0a 09 20 ists? fname))..
4070: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 28 63 (result (c
4080: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 09 ondition-case...
4090: 09 20 20 20 28 6c 65 74 2a 20 28 28 64 62 20 28 . (let* ((db (
40a0: 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 sqlite3:open-dat
40b0: 61 62 61 73 65 20 66 6e 61 6d 65 29 29 29 0a 09 abase fname)))..
40c0: 09 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 .. (if (and
40d0: 69 6e 69 74 2d 70 72 6f 63 20 28 6e 6f 74 20 64 init-proc (not d
40e0: 62 2d 65 78 69 73 74 73 29 29 0a 09 09 09 09 20 b-exists)).....
40f0: 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 29 29 0a (init-proc db)).
4100: 09 09 09 20 20 20 20 20 64 62 29 0a 09 09 09 28 ... db)....(
4110: 65 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 0a 09 exn (io-error)..
4120: 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 .. (dbfile:p
4130: 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 rint-err exn "ER
4140: 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 ROR: i/o error w
4150: 69 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 ith " fname ". C
4160: 68 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 heck permissions
4170: 2c 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 , disk space etc
4180: 2e 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e . and try again.
4190: 22 29 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 ").... (retr
41a0: 79 29 29 0a 09 09 09 28 65 78 6e 20 28 63 6f 72 y))....(exn (cor
41b0: 72 75 70 74 29 0a 09 09 09 20 20 20 20 20 28 64 rupt).... (d
41c0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
41d0: 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 61 exn "ERROR: data
41e0: 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 69 base " fname " i
41f0: 73 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 s corrupt. Repai
4200: 72 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e r it to proceed.
4210: 22 29 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 ").... (retr
4220: 79 29 29 0a 09 09 09 28 65 78 6e 20 28 62 75 73 y))....(exn (bus
4230: 79 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 y).... (dbfi
4240: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e le:print-err exn
4250: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
4260: 65 20 22 20 66 6e 61 6d 65 0a 09 09 09 09 09 20 e " fname......
4270: 20 20 20 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 " is locke
4280: 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 74 d. Try copying t
4290: 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 o another locati
42a0: 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 on, remove origi
42b0: 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 63 nal and copy bac
42c0: 6b 2e 22 29 0a 09 09 09 20 20 20 20 20 28 72 65 k.").... (re
42d0: 74 72 79 29 29 0a 09 09 09 28 65 78 6e 20 28 70 try))....(exn (p
42e0: 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 66 69 6c ermission)(dbfil
42f0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 e:print-err exn
4300: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
4310: 20 22 20 66 6e 61 6d 65 20 22 20 68 61 73 20 73 " fname " has s
4320: 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 ome permissions
4330: 70 72 6f 62 6c 65 6d 2e 22 29 0a 09 09 09 20 20 problem.")....
4340: 20 20 20 28 72 65 74 72 79 29 29 0a 09 09 09 28 (retry))....(
4350: 65 78 6e 20 28 29 0a 09 09 09 20 20 20 20 20 28 exn ().... (
4360: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
4370: 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e 6b exn "ERROR: Unk
4380: 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 20 nown error with
4390: 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 database " fname
43a0: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 09 " message: "...
43b0: 09 09 09 20 20 20 20 20 20 20 28 28 63 6f 6e 64 ... ((cond
43c0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
43d0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
43e0: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 ssage) exn))....
43f0: 20 20 20 20 20 28 72 65 74 72 79 29 29 29 29 29 (retry)))))
4400: 0a 20 20 20 20 20 20 20 20 20 20 23 3b 28 69 66 . #;(if
4410: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
4420: 65 73 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 20 ess? fname)..
4430: 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d (dbfile:simple-
4440: 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 file-release-loc
4450: 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 29 0a 09 20 k lock-file))..
4460: 20 72 65 73 75 6c 74 29 29 29 29 0a 0a 28 64 65 result))))..(de
4470: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 62 72 75 fine (dbfile:bru
4480: 74 65 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 65 te-force-salvage
4490: 2d 64 62 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 -db fname). (le
44a0: 74 2a 20 28 28 62 61 63 6b 75 70 66 6e 61 6d 65 t* ((backupfname
44b0: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 22 28 (conc fname"-"(
44c0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
44d0: 69 64 29 22 2e 62 61 6b 22 29 29 0a 09 20 28 63 id)".bak")).. (c
44e0: 6d 64 20 28 63 6f 6e 63 20 22 63 70 20 22 66 6e md (conc "cp "fn
44f0: 61 6d 65 22 20 22 62 61 63 6b 75 70 66 6e 61 6d ame" "backupfnam
4500: 65 22 3b 6d 76 20 22 66 6e 61 6d 65 22 20 22 28 e";mv "fname" "(
4510: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 64 65 6c conc fname ".del
4520: 6d 65 3b 22 29 0a 09 09 20 20 20 20 22 63 70 20 me;")... "cp
4530: 22 62 61 63 6b 75 70 66 6e 61 6d 65 22 20 22 66 "backupfname" "f
4540: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 64 62 66 name))). (dbf
4550: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 57 ile:print-err "W
4560: 41 52 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 69 ARNING: attempti
4570: 6e 67 20 72 65 63 6f 76 65 72 79 20 6f 66 20 66 ng recovery of f
4580: 69 6c 65 20 22 66 6e 61 6d 65 22 20 62 79 20 72 ile "fname" by r
4590: 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 73 3a unning commands:
45a0: 5c 6e 22 0a 09 09 20 20 20 20 20 20 22 20 20 22 \n"... " "
45b0: 63 6d 64 29 0a 20 20 20 20 28 73 79 73 74 65 6d cmd). (system
45c0: 20 63 6d 64 29 29 29 0a 0a 23 3b 28 64 65 66 69 cmd)))..#;(defi
45d0: 6e 65 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 ne (dbfile:cauti
45e0: 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 ous-open-databas
45f0: 65 2d 6f 72 69 67 20 66 6e 61 6d 65 20 69 6e 69 e-orig fname ini
4600: 74 2d 70 72 6f 63 20 23 21 6f 70 74 69 6f 6e 61 t-proc #!optiona
4610: 6c 20 28 74 72 69 65 73 2d 6c 65 66 74 20 35 30 l (tries-left 50
4620: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 )). (let* ((loc
4630: 6b 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 6e k-file (conc fn
4640: 61 6d 65 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 ame".lock")).. (
4650: 64 65 6c 61 79 2d 74 69 6d 65 20 28 2a 20 28 2d delay-time (* (-
4660: 20 35 31 20 74 72 69 65 73 2d 6c 65 66 74 29 20 51 tries-left)
4670: 31 2e 31 29 29 0a 09 20 28 72 65 74 72 79 20 20 1.1)).. (retry
4680: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
4690: 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d . (thread-
46a0: 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 74 69 6d sleep! delay-tim
46b0: 65 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 e)... (if
46c0: 28 3e 20 74 72 69 65 73 2d 6c 65 66 74 20 30 29 (> tries-left 0)
46d0: 0a 09 09 09 20 20 20 28 64 62 66 69 6c 65 3a 63 .... (dbfile:c
46e0: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
46f0: 61 62 61 73 65 20 66 6e 61 6d 65 20 69 6e 69 74 abase fname init
4700: 2d 70 72 6f 63 20 28 2d 20 74 72 69 65 73 2d 6c -proc (- tries-l
4710: 65 66 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 eft 1)))))).
4720: 28 61 73 73 65 72 74 20 28 3e 3d 20 74 72 69 65 (assert (>= trie
4730: 73 2d 6c 65 66 74 20 30 29 20 28 63 6f 6e 63 20 s-left 0) (conc
4740: 22 46 41 54 41 4c 3a 20 74 6f 6f 20 6d 61 6e 79 "FATAL: too many
4750: 20 61 74 74 65 6d 70 74 73 20 69 6e 20 64 62 66 attempts in dbf
4760: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
4770: 6e 2d 64 61 74 61 62 61 73 65 20 6f 66 20 22 66 n-database of "f
4780: 6e 61 6d 65 22 2c 20 67 69 76 69 6e 67 20 75 70 name", giving up
4790: 2e 22 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e .")). (if (an
47a0: 64 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 d (file-write-ac
47b0: 63 65 73 73 3f 20 66 6e 61 6d 65 29 20 28 6e 6f cess? fname) (no
47c0: 74 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 t (dbfile:simple
47d0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d -file-lock lock-
47e0: 66 69 6c 65 20 65 78 70 69 72 65 2d 74 69 6d 65 file expire-time
47f0: 3a 20 33 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 : 3)))..(begin..
4800: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
4810: 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 66 69 6c err "INFO: dbfil
4820: 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d e:cautious-open-
4830: 64 61 74 61 62 61 73 65 3a 20 6c 6f 63 6b 20 66 database: lock f
4840: 69 6c 65 20 22 20 6c 6f 63 6b 2d 66 69 6c 65 20 ile " lock-file
4850: 22 20 65 78 69 73 74 73 2c 20 74 72 79 69 6e 67 " exists, trying
4860: 20 61 67 61 69 6e 20 69 6e 20 66 65 77 20 73 65 again in few se
4870: 63 6f 6e 64 73 2e 22 29 0a 09 20 20 28 74 68 72 conds.").. (thr
4880: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 ead-sleep! 1)..
4890: 20 28 69 66 20 28 65 71 3f 20 74 72 69 65 73 2d (if (eq? tries-
48a0: 6c 65 66 74 20 32 29 0a 09 20 20 20 20 20 20 28 left 2).. (
48b0: 62 65 67 69 6e 0a 09 09 28 64 62 66 69 6c 65 3a begin...(dbfile:
48c0: 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a print-err "INFO:
48d0: 20 73 74 65 61 6c 69 6e 67 20 74 68 65 20 6c 6f stealing the lo
48e0: 63 6b 20 22 6c 6f 63 6b 2d 66 69 6c 65 29 0a 09 ck "lock-file)..
48f0: 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 6c .(delete-file* l
4900: 6f 63 6b 2d 66 69 6c 65 29 29 29 0a 09 20 20 28 ock-file))).. (
4910: 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d dbfile:cautious-
4920: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e open-database fn
4930: 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 28 2d ame init-proc (-
4940: 20 74 72 69 65 73 2d 6c 65 66 74 20 31 29 29 29 tries-left 1)))
4950: 0a 09 28 6c 65 74 2a 20 28 28 64 62 2d 65 78 69 ..(let* ((db-exi
4960: 73 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 73 sts (file-exists
4970: 3f 20 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 ? fname))..
4980: 20 20 28 72 65 73 75 6c 74 20 28 63 6f 6e 64 69 (result (condi
4990: 74 69 6f 6e 2d 63 61 73 65 0a 09 09 09 20 20 20 tion-case....
49a0: 28 6c 65 74 2a 20 28 28 64 62 20 28 73 71 6c 69 (let* ((db (sqli
49b0: 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 te3:open-databas
49c0: 65 20 66 6e 61 6d 65 29 29 29 0a 09 09 09 20 20 e fname)))....
49d0: 20 20 20 28 69 66 20 28 61 6e 64 20 69 6e 69 74 (if (and init
49e0: 2d 70 72 6f 63 20 28 6e 6f 74 20 64 62 2d 65 78 -proc (not db-ex
49f0: 69 73 74 73 29 29 0a 09 09 09 09 20 28 69 6e 69 ists))..... (ini
4a00: 74 2d 70 72 6f 63 20 64 62 29 29 0a 09 09 09 20 t-proc db))....
4a10: 20 20 20 20 64 62 29 0a 09 09 09 28 65 78 6e 20 db)....(exn
4a20: 28 69 6f 2d 65 72 72 6f 72 29 0a 09 09 09 20 20 (io-error)....
4a30: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
4a40: 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f 52 3a -err exn "ERROR:
4a50: 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 20 i/o error with
4a60: 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 65 63 6b " fname ". Check
4a70: 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 69 permissions, di
4a80: 73 6b 20 73 70 61 63 65 20 65 74 63 2e 20 61 6e sk space etc. an
4a90: 64 20 74 72 79 20 61 67 61 69 6e 2e 22 29 0a 09 d try again.")..
4aa0: 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 0a .. (retry)).
4ab0: 09 09 09 28 65 78 6e 20 28 63 6f 72 72 75 70 74 ...(exn (corrupt
4ac0: 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 6c ).... (dbfil
4ad0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 e:print-err exn
4ae0: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
4af0: 20 22 20 66 6e 61 6d 65 20 22 20 69 73 20 63 6f " fname " is co
4b00: 72 72 75 70 74 2e 20 52 65 70 61 69 72 20 69 74 rrupt. Repair it
4b10: 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 29 0a 09 to proceed.")..
4b20: 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 0a .. (retry)).
4b30: 09 09 09 28 65 78 6e 20 28 62 75 73 79 29 0a 09 ...(exn (busy)..
4b40: 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 .. (dbfile:p
4b50: 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 rint-err exn "ER
4b60: 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 ROR: database "
4b70: 66 6e 61 6d 65 0a 09 09 09 09 09 20 20 20 20 20 fname......
4b80: 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 54 " is locked. T
4b90: 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 6e ry copying to an
4ba0: 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c 20 other location,
4bb0: 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c 20 remove original
4bc0: 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 29 and copy back.")
4bd0: 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 .... (retry)
4be0: 29 0a 09 09 09 28 65 78 6e 20 28 70 65 72 6d 69 )....(exn (permi
4bf0: 73 73 69 6f 6e 29 28 64 62 66 69 6c 65 3a 70 72 ssion)(dbfile:pr
4c00: 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 int-err exn "ERR
4c10: 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 OR: database " f
4c20: 6e 61 6d 65 20 22 20 68 61 73 20 73 6f 6d 65 20 name " has some
4c30: 70 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 permissions prob
4c40: 6c 65 6d 2e 22 29 0a 09 09 09 20 20 20 20 20 28 lem.").... (
4c50: 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e 20 retry))....(exn
4c60: 28 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 ().... (dbfi
4c70: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e le:print-err exn
4c80: 20 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e "ERROR: Unknown
4c90: 20 65 72 72 6f 72 20 77 69 74 68 20 64 61 74 61 error with data
4ca0: 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 6d base " fname " m
4cb0: 65 73 73 61 67 65 3a 20 22 0a 09 09 09 09 09 20 essage: "......
4cc0: 20 20 20 20 20 20 28 28 63 6f 6e 64 69 74 69 6f ((conditio
4cd0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
4ce0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
4cf0: 65 29 20 65 78 6e 29 29 0a 09 09 09 20 20 20 20 e) exn))....
4d00: 20 28 72 65 74 72 79 29 29 29 29 29 0a 20 20 20 (retry))))).
4d10: 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 (if (file
4d20: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 -write-access? f
4d30: 6e 61 6d 65 29 0a 09 20 20 20 20 28 64 62 66 69 name).. (dbfi
4d40: 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 le:simple-file-r
4d50: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
4d60: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 -file).
4d70: 20 29 0a 09 20 20 72 65 73 75 6c 74 29 29 29 29 ).. result))))
4d80: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 ...(define (dbfi
4d90: 6c 65 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d le:open-no-sync-
4da0: 64 62 20 64 62 70 61 74 68 29 0a 20 20 28 69 66 db dbpath). (if
4db0: 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 0a 20 20 *no-sync-db*.
4dc0: 20 20 20 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a *no-sync-db*
4dd0: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
4de0: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
4df0: 69 73 74 73 3f 20 64 62 70 61 74 68 29 29 0a 09 ists? dbpath))..
4e00: 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 (create-dire
4e10: 63 74 6f 72 79 20 64 62 70 61 74 68 20 23 74 29 ctory dbpath #t)
4e20: 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d )..(let* ((dbnam
4e30: 65 20 20 20 20 28 63 6f 6e 63 20 64 62 70 61 74 e (conc dbpat
4e40: 68 20 22 2f 6e 6f 2d 73 79 6e 63 2e 64 62 22 29 h "/no-sync.db")
4e50: 29 0a 09 20 20 20 20 20 20 20 28 64 62 2d 65 78 ).. (db-ex
4e60: 69 73 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 ists (file-exist
4e70: 73 3f 20 64 62 6e 61 6d 65 29 29 0a 09 20 20 20 s? dbname))..
4e80: 20 20 20 20 28 69 6e 69 74 2d 70 72 6f 63 20 28 (init-proc (
4e90: 6c 61 6d 62 64 61 20 28 64 62 29 0a 09 09 09 20 lambda (db)....
4ea0: 20 20 20 28 69 66 20 28 6e 6f 74 20 64 62 2d 65 (if (not db-e
4eb0: 78 69 73 74 73 29 0a 09 09 09 09 28 62 65 67 69 xists).....(begi
4ec0: 6e 0a 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 n..... (sqlite3
4ed0: 3a 65 78 65 63 75 74 65 20 64 62 20 22 50 52 41 :execute db "PRA
4ee0: 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 GMA synchronous
4ef0: 3d 20 30 3b 22 29 0a 09 09 09 09 20 20 28 73 71 = 0;")..... (sq
4f00: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
4f10: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
4f20: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 6e 6f 5f F NOT EXISTS no_
4f30: 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 sync_metadat (va
4f40: 72 20 54 45 58 54 2c 76 61 6c 20 54 45 58 54 2c r TEXT,val TEXT,
4f50: 20 43 4f 4e 53 54 52 41 49 4e 54 20 6e 6f 5f 73 CONSTRAINT no_s
4f60: 79 6e 63 5f 6d 65 74 61 64 61 74 5f 63 6f 6e 73 ync_metadat_cons
4f70: 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 76 traint UNIQUE (v
4f80: 61 72 29 29 3b 22 29 29 0a 09 09 09 09 29 29 29 ar));")).....)))
4f90: 0a 09 20 20 20 20 20 20 20 28 64 62 20 20 20 20 .. (db
4fa0: 20 20 20 20 28 64 62 66 69 6c 65 3a 63 61 75 74 (dbfile:caut
4fb0: 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 ious-open-databa
4fc0: 73 65 20 64 62 6e 61 6d 65 20 69 6e 69 74 2d 70 se dbname init-p
4fd0: 72 6f 63 29 29 29 20 3b 3b 20 28 73 71 6c 69 74 roc))) ;; (sqlit
4fe0: 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 e3:open-database
4ff0: 20 64 62 6e 61 6d 65 29 29 29 0a 09 20 20 28 73 dbname))).. (s
5000: 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d qlite3:set-busy-
5010: 68 61 6e 64 6c 65 72 21 20 64 62 20 28 73 71 6c handler! db (sql
5020: 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 ite3:make-busy-t
5030: 69 6d 65 6f 75 74 20 31 33 36 30 30 30 29 29 0a imeout 136000)).
5040: 09 20 20 3b 3b 28 73 71 6c 69 74 65 33 3a 65 78 . ;;(sqlite3:ex
5050: 65 63 75 74 65 20 64 62 20 22 50 52 41 47 4d 41 ecute db "PRAGMA
5060: 20 6a 6f 75 72 6e 61 6c 5f 6d 6f 64 65 3d 57 41 journal_mode=WA
5070: 4c 3b 22 29 0a 09 20 20 28 73 65 74 21 20 2a 6e L;").. (set! *n
5080: 6f 2d 73 79 6e 63 2d 64 62 2a 20 64 62 29 0a 09 o-sync-db* db)..
5090: 20 20 64 62 29 29 29 29 0a 0a 28 64 65 66 69 6e db))))..(defin
50a0: 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 73 65 e (db:no-sync-se
50b0: 74 20 64 62 20 76 61 72 20 76 61 6c 29 0a 20 20 t db var val).
50c0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
50d0: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
50e0: 45 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 EPLACE INTO no_s
50f0: 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 ync_metadat (var
5100: 2c 76 61 6c 29 20 56 41 4c 55 45 53 20 28 3f 2c ,val) VALUES (?,
5110: 3f 29 3b 22 20 76 61 72 20 76 61 6c 29 29 0a 0a ?);" var val))..
5120: 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 (define (db:no-s
5130: 79 6e 63 2d 64 65 6c 21 20 64 62 20 76 61 72 29 ync-del! db var)
5140: 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
5150: 75 74 65 20 64 62 20 22 44 45 4c 45 54 45 20 46 ute db "DELETE F
5160: 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 ROM no_sync_meta
5170: 64 61 74 20 57 48 45 52 45 20 76 61 72 3d 3f 3b dat WHERE var=?;
5180: 22 20 76 61 72 29 29 0a 0a 28 64 65 66 69 6e 65 " var))..(define
5190: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
51a0: 2f 64 65 66 61 75 6c 74 20 64 62 20 76 61 72 20 /default db var
51b0: 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 default). (let
51c0: 28 28 72 65 73 20 64 65 66 61 75 6c 74 29 29 0a ((res default)).
51d0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
51e0: 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 -each-row. (
51f0: 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 20 20 20 lambda (val).
5200: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 76 61 (set! res va
5210: 6c 29 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 l)). db.
5220: 20 22 53 45 4c 45 43 54 20 76 61 6c 20 46 52 4f "SELECT val FRO
5230: 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 M no_sync_metada
5240: 74 20 57 48 45 52 45 20 76 61 72 3d 3f 3b 22 0a t WHERE var=?;".
5250: 20 20 20 20 20 76 61 72 29 0a 20 20 20 20 28 69 var). (i
5260: 66 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c f res. (l
5270: 65 74 20 28 28 6e 65 77 72 65 73 20 28 69 66 20 et ((newres (if
5280: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
5290: 09 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 . (string->numb
52a0: 65 72 20 72 65 73 29 0a 09 09 09 20 20 23 66 29 er res).... #f)
52b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
52c0: 20 6e 65 77 72 65 73 0a 20 20 20 20 20 20 20 20 newres.
52d0: 20 20 20 20 20 20 6e 65 77 72 65 73 0a 20 20 20 newres.
52e0: 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 res))
52f0: 0a 20 20 20 20 20 20 20 20 72 65 73 29 29 29 0a . res))).
5300: 0a 3b 3b 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 .;; transaction
5310: 70 72 6f 74 65 63 74 65 64 20 6c 6f 63 6b 20 61 protected lock a
5320: 71 75 69 73 69 74 69 6f 6e 0a 3b 3b 20 65 69 74 quisition.;; eit
5330: 68 65 72 3a 0a 3b 3b 20 20 20 20 66 61 69 6c 73 her:.;; fails
5340: 20 20 20 20 72 65 74 75 72 6e 73 20 20 28 23 66 returns (#f
5350: 20 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 6f 6e . lock-creation
5360: 2d 74 69 6d 65 29 0a 3b 3b 20 20 20 20 73 75 63 -time).;; suc
5370: 63 65 65 64 73 20 28 72 65 74 75 72 6e 73 20 28 ceeds (returns (
5380: 23 74 20 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 #t . lock-creati
5390: 6f 6e 2d 74 69 6d 65 29 0a 3b 3b 20 75 73 65 20 on-time).;; use
53a0: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 (db:no-sync-del!
53b0: 20 64 62 20 6b 65 79 6e 61 6d 65 29 20 74 6f 20 db keyname) to
53c0: 72 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b release the lock
53d0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a .;;.(define (db:
53e0: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
53f0: 20 64 62 20 6b 65 79 6e 61 6d 65 29 0a 20 20 28 db keyname). (
5400: 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 sqlite3:with-tra
5410: 6e 73 61 63 74 69 6f 6e 0a 20 20 20 64 62 0a 20 nsaction. db.
5420: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
5430: 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 (condition-cas
5440: 65 0a 09 20 60 28 23 66 20 2e 20 2c 28 73 71 6c e.. `(#f . ,(sql
5450: 69 74 65 33 3a 66 69 72 73 74 2d 72 65 73 75 6c ite3:first-resul
5460: 74 20 64 62 20 22 53 45 4c 45 43 54 20 76 61 6c t db "SELECT val
5470: 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 FROM no_sync_me
5480: 74 61 64 61 74 20 57 48 45 52 45 20 76 61 72 3d tadat WHERE var=
5490: 3f 3b 22 20 6b 65 79 6e 61 6d 65 29 29 0a 20 20 ?;" keyname)).
54a0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 28 65 78 . (ex
54b0: 6e 20 28 69 6f 2d 65 72 72 6f 72 29 20 20 28 64 n (io-error) (d
54c0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
54d0: 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f "ERROR: i/o erro
54e0: 72 20 77 69 74 68 20 6e 6f 2d 73 79 6e 63 20 64 r with no-sync d
54f0: 62 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 73 73 b. Check permiss
5500: 69 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 63 65 ions, disk space
5510: 20 65 74 63 2e 20 61 6e 64 20 74 72 79 20 61 67 etc. and try ag
5520: 61 69 6e 2e 22 29 29 0a 20 20 20 20 20 20 20 28 ain.")). (
5530: 65 78 6e 20 28 63 6f 72 72 75 70 74 29 20 20 20 exn (corrupt)
5540: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
5550: 72 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 r "ERROR: databa
5560: 73 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 69 73 se no-sync db is
5570: 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 corrupt. Repair
5580: 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 it to proceed."
5590: 29 29 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 )). (exn (
55a0: 62 75 73 79 29 20 20 20 20 20 20 28 64 62 66 69 busy) (dbfi
55b0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 le:print-err "ER
55c0: 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f ROR: database no
55d0: 2d 73 79 6e 63 20 64 62 20 69 73 20 6c 6f 63 6b -sync db is lock
55e0: 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 ed. Try copying
55f0: 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 to another locat
5600: 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 ion, remove orig
5610: 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 inal and copy ba
5620: 63 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 ck.")). (e
5630: 78 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e 29 28 xn (permission)(
5640: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
5650: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
5660: 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 68 61 73 e no-sync db has
5670: 20 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f 6e some permission
5680: 73 20 70 72 6f 62 6c 65 6d 2e 22 29 29 0a 20 20 s problem.")).
5690: 20 20 20 20 20 28 65 78 6e 20 28 64 6f 6e 65 29 (exn (done)
56a0: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6c 6f 63 .. (let ((loc
56b0: 6b 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d k-time (current-
56c0: 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 seconds)))..
56d0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
56e0: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
56f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 3a t-log-port* "db:
5700: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
5710: 20 6b 65 79 6e 61 6d 65 3d 22 20 6b 65 79 6e 61 keyname=" keyna
5720: 6d 65 20 22 2c 20 6c 6f 63 6b 2d 74 69 6d 65 3d me ", lock-time=
5730: 22 20 6c 6f 63 6b 2d 74 69 6d 65 20 22 2c 20 65 " lock-time ", e
5740: 78 6e 3d 22 20 65 78 6e 29 0a 09 20 20 20 20 20 xn=" exn)..
5750: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
5760: 65 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 e db "INSERT OR
5770: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f REPLACE INTO no_
5780: 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 sync_metadat (va
5790: 72 2c 76 61 6c 29 20 56 41 4c 55 45 53 28 3f 2c r,val) VALUES(?,
57a0: 3f 29 3b 22 20 6b 65 79 6e 61 6d 65 20 6c 6f 63 ?);" keyname loc
57b0: 6b 2d 74 69 6d 65 29 0a 09 20 20 20 20 20 20 60 k-time).. `
57c0: 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d 74 69 6d 65 (#t . ,lock-time
57d0: 29 29 29 0a 20 20 20 20 20 20 20 28 65 78 6e 20 ))). (exn
57e0: 28 29 0a 09 20 20 20 20 28 64 62 66 69 6c 65 3a ().. (dbfile:
57f0: 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 print-err "ERROR
5800: 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 : Unknown error
5810: 77 69 74 68 20 64 61 74 61 62 61 73 65 20 6e 6f with database no
5820: 2d 73 79 6e 63 20 64 62 20 6d 65 73 73 61 67 65 -sync db message
5830: 3a 20 65 78 6e 3d 22 28 63 6f 6e 64 69 74 69 6f : exn="(conditio
5840: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 22 2c 20 5c n->list exn)", \
5850: 6e 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 n" ((condition-p
5860: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
5870: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
5880: 65 78 6e 29 29 0a 09 20 20 20 20 60 28 23 66 20 exn)).. `(#f
5890: 2e 20 2c 28 63 75 72 72 65 6e 74 2d 73 65 63 6f . ,(current-seco
58a0: 6e 64 73 29 29 29 29 29 29 29 0a 0a 28 64 65 66 nds)))))))..(def
58b0: 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d ine (db:no-sync-
58c0: 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 6f 75 74 get-lock-timeout
58d0: 20 64 62 20 6b 65 79 6e 61 6d 65 20 74 69 6d 65 db keyname time
58e0: 6f 75 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c out). (let* ((l
58f0: 6f 63 6b 64 61 74 20 28 64 62 3a 6e 6f 2d 73 79 ockdat (db:no-sy
5900: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 64 62 20 6b nc-get-lock db k
5910: 65 79 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 6d eyname))). (m
5920: 61 74 63 68 20 6c 6f 63 6b 64 61 74 0a 20 20 20 atch lockdat.
5930: 20 20 20 28 28 23 66 20 2e 20 6c 6f 63 6b 2d 74 ((#f . lock-t
5940: 69 6d 65 29 0a 20 20 20 20 20 20 20 28 69 66 20 ime). (if
5950: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
5960: 65 63 6f 6e 64 73 29 20 28 69 66 20 28 73 74 72 econds) (if (str
5970: 69 6e 67 3f 20 6c 6f 63 6b 2d 74 69 6d 65 29 28 ing? lock-time)(
5980: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6c string->number l
5990: 6f 63 6b 2d 74 69 6d 65 29 6c 6f 63 6b 2d 74 69 ock-time)lock-ti
59a0: 6d 65 29 29 20 74 69 6d 65 6f 75 74 29 0a 09 20 me)) timeout)..
59b0: 20 20 28 6c 65 74 20 28 28 6c 6f 63 6b 2d 74 69 (let ((lock-ti
59c0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
59d0: 6e 64 73 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 nds))).. ;;
59e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
59f0: 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 2 *default-log
5a00: 2d 70 6f 72 74 2a 20 22 64 62 3a 6e 6f 2d 73 79 -port* "db:no-sy
5a10: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e nc-get-lock keyn
5a20: 61 6d 65 3d 22 20 6b 65 79 6e 61 6d 65 20 22 2c ame=" keyname ",
5a30: 20 6c 6f 63 6b 2d 74 69 6d 65 3d 22 20 6c 6f 63 lock-time=" loc
5a40: 6b 2d 74 69 6d 65 20 22 2c 20 65 78 6e 3d 22 20 k-time ", exn="
5a50: 65 78 6e 29 0a 09 20 20 20 20 20 28 73 71 6c 69 exn).. (sqli
5a60: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
5a70: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
5a80: 45 20 49 4e 54 4f 20 6e 6f 5f 73 79 6e 63 5f 6d E INTO no_sync_m
5a90: 65 74 61 64 61 74 20 28 76 61 72 2c 76 61 6c 29 etadat (var,val)
5aa0: 20 56 41 4c 55 45 53 28 3f 2c 3f 29 3b 22 20 6b VALUES(?,?);" k
5ab0: 65 79 6e 61 6d 65 20 6c 6f 63 6b 2d 74 69 6d 65 eyname lock-time
5ac0: 29 0a 09 20 20 20 20 20 60 28 23 74 20 2e 20 2c ).. `(#t . ,
5ad0: 6c 6f 63 6b 2d 74 69 6d 65 29 29 0a 09 20 20 20 lock-time))..
5ae0: 6c 6f 63 6b 64 61 74 29 29 0a 20 20 20 20 20 20 lockdat)).
5af0: 28 65 6c 73 65 20 6c 6f 63 6b 64 61 74 29 29 29 (else lockdat)))
5b00: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
5b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 73 ===========.;; s
5b50: 79 6e 63 20 62 61 63 6b 20 66 75 6e 63 74 69 6f ync back functio
5b60: 6e 73 20 70 75 6c 6c 65 64 20 66 72 6f 6d 20 64 ns pulled from d
5b70: 62 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d b.scm.;;========
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
5bc0: 3b 3b 20 47 65 74 20 61 20 6c 6f 63 6b 20 66 72 ;; Get a lock fr
5bd0: 6f 6d 20 74 68 65 20 6e 6f 2d 73 79 6e 63 2d 64 om the no-sync-d
5be0: 62 20 66 6f 72 20 74 68 65 20 66 72 6f 6d 2d 64 b for the from-d
5bf0: 62 2c 20 74 68 65 6e 20 64 65 6c 74 61 20 73 79 b, then delta sy
5c00: 6e 63 20 74 68 65 20 66 72 6f 6d 2d 64 62 20 74 nc the from-db t
5c10: 6f 20 74 68 65 20 74 6f 2d 64 62 2c 20 6f 74 68 o the to-db, oth
5c20: 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
5c30: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a .;;.(define (db:
5c40: 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 lock-and-delta-s
5c50: 79 6e 63 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 64 ync no-sync-db d
5c60: 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 62 2d bstruct from-db-
5c70: 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 73 20 file runid keys
5c80: 64 62 69 6e 69 74 29 0a 20 20 28 61 73 73 65 72 dbinit). (asser
5c90: 74 20 28 6e 6f 74 20 2a 64 62 2d 73 79 6e 63 2d t (not *db-sync-
5ca0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 20 22 46 in-progress*) "F
5cb0: 41 54 41 4c 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e ATAL: db:lock-an
5cc0: 64 2d 73 79 6e 63 20 63 61 6c 6c 65 64 20 77 68 d-sync called wh
5cd0: 69 6c 65 20 61 20 73 79 6e 63 20 69 73 20 69 6e ile a sync is in
5ce0: 20 70 72 6f 67 72 65 73 73 2e 22 29 0a 20 20 3b progress."). ;
5cf0: 3b 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d ; (dbfile:print-
5d00: 65 72 72 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 err *default-log
5d10: 2d 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d -port* "db:lock-
5d20: 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 22 29 and-delta-sync")
5d30: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 2d . (let* ((lock-
5d40: 66 69 6c 65 20 28 63 6f 6e 63 20 66 72 6f 6d 2d file (conc from-
5d50: 64 62 2d 66 69 6c 65 20 22 2e 6c 6f 63 6b 22 29 db-file ".lock")
5d60: 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
5d70: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
5d80: 6f 63 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 0a 09 ock lock-file)..
5d90: 28 62 65 67 69 6e 0a 09 20 20 28 64 62 66 69 6c (begin.. (dbfil
5da0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 e:print-err "INF
5db0: 4f 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 O: db:lock-and-d
5dc0: 65 6c 74 61 2d 73 79 6e 63 20 63 6f 70 79 69 6e elta-sync copyin
5dd0: 67 20 64 62 20 22 72 75 6e 69 64 22 20 61 74 20 g db "runid" at
5de0: 22 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 "(current-second
5df0: 73 29 29 0a 09 20 20 28 73 65 74 21 20 2a 64 62 s)).. (set! *db
5e00: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5e10: 73 2a 20 23 74 29 0a 09 20 20 28 64 62 3a 73 79 s* #t).. (db:sy
5e20: 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 74 72 nc-touched dbstr
5e30: 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 20 64 uct runid keys d
5e40: 62 69 6e 69 74 29 0a 09 20 20 28 73 65 74 21 20 binit).. (set!
5e50: 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 *db-sync-in-prog
5e60: 72 65 73 73 2a 20 23 66 29 0a 09 20 20 28 64 65 ress* #f).. (de
5e70: 6c 65 74 65 2d 66 69 6c 65 2a 20 6c 6f 63 6b 2d lete-file* lock-
5e80: 66 69 6c 65 29 0a 09 20 20 23 74 29 0a 20 20 20 file).. #t).
5e90: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
5ea0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 (dbfile:pr
5eb0: 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 63 int-err "INFO: c
5ec0: 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 6c 6f 63 ould not get loc
5ed0: 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d 64 62 2d k for " from-db-
5ee0: 66 69 6c 65 20 22 2c 20 73 79 6e 63 20 6c 69 6b file ", sync lik
5ef0: 65 6c 79 20 69 6e 20 70 72 6f 67 72 65 73 73 2e ely in progress.
5f00: 22 29 0a 09 20 20 23 66 0a 09 20 20 29 29 29 29 ").. #f.. ))))
5f10: 0a 0a 3b 3b 20 3b 3b 20 47 65 74 20 61 20 6c 6f ..;; ;; Get a lo
5f20: 63 6b 20 66 72 6f 6d 20 74 68 65 20 6e 6f 2d 73 ck from the no-s
5f30: 79 6e 63 2d 64 62 20 66 6f 72 20 74 68 65 20 66 ync-db for the f
5f40: 72 6f 6d 2d 64 62 2c 20 74 68 65 6e 20 64 65 6c rom-db, then del
5f50: 74 61 20 73 79 6e 63 20 74 68 65 20 66 72 6f 6d ta sync the from
5f60: 2d 64 62 20 74 6f 20 74 68 65 20 74 6f 2d 64 62 -db to the to-db
5f70: 2c 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 , otherwise retu
5f80: 72 6e 20 23 66 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 rn #f.;; ;;.;; (
5f90: 64 65 66 69 6e 65 20 28 64 62 3a 6c 6f 63 6b 2d define (db:lock-
5fa0: 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 2d 6f and-delta-sync-o
5fb0: 72 69 67 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 64 rig no-sync-db d
5fc0: 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 62 2d bstruct from-db-
5fd0: 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 73 20 file runid keys
5fe0: 64 62 69 6e 69 74 29 0a 3b 3b 20 20 20 28 61 73 dbinit).;; (as
5ff0: 73 65 72 74 20 28 6e 6f 74 20 2a 64 62 2d 73 79 sert (not *db-sy
6000: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 nc-in-progress*)
6010: 20 22 46 41 54 41 4c 3a 20 64 62 3a 6c 6f 63 6b "FATAL: db:lock
6020: 2d 61 6e 64 2d 73 79 6e 63 20 63 61 6c 6c 65 64 -and-sync called
6030: 20 77 68 69 6c 65 20 61 20 73 79 6e 63 20 69 73 while a sync is
6040: 20 69 6e 20 70 72 6f 67 72 65 73 73 2e 22 29 0a in progress.").
6050: 3b 3b 20 20 20 3b 3b 20 28 64 62 66 69 6c 65 3a ;; ;; (dbfile:
6060: 70 72 69 6e 74 2d 65 72 72 20 2a 64 65 66 61 75 print-err *defau
6070: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 lt-log-port* "db
6080: 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d :lock-and-delta-
6090: 73 79 6e 63 22 29 0a 3b 3b 20 20 20 28 6c 65 74 sync").;; (let
60a0: 2a 20 28 28 6c 6f 63 6b 64 61 74 20 20 28 64 62 * ((lockdat (db
60b0: 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 :no-sync-get-loc
60c0: 6b 2d 74 69 6d 65 6f 75 74 20 6e 6f 2d 73 79 6e k-timeout no-syn
60d0: 63 2d 64 62 20 66 72 6f 6d 2d 64 62 2d 66 69 6c c-db from-db-fil
60e0: 65 20 36 30 29 29 0a 3b 3b 20 09 20 28 67 6f 74 e 60)).;; . (got
60f0: 6c 6f 63 6b 20 20 28 63 61 72 20 6c 6f 63 6b 64 lock (car lockd
6100: 61 74 29 29 0a 3b 3b 20 09 20 28 6c 6f 63 6b 74 at)).;; . (lockt
6110: 69 6d 65 20 28 63 64 72 20 6c 6f 63 6b 64 61 74 ime (cdr lockdat
6120: 29 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 28 64 ))).;; ;; (d
6130: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6140: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
6150: 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d 61 6e ort* "db:lock-an
6160: 64 2d 64 65 6c 74 61 2d 73 79 6e 63 3a 20 67 6f d-delta-sync: go
6170: 74 20 6c 6f 63 6b 3f 22 29 0a 3b 3b 20 20 20 20 t lock?").;;
6180: 20 0a 3b 3b 20 20 20 20 20 28 69 66 20 67 6f 74 .;; (if got
6190: 6c 6f 63 6b 0a 3b 3b 20 09 28 62 65 67 69 6e 0a lock.;; .(begin.
61a0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 64 62 ;; (db
61b0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
61c0: 49 4e 46 4f 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e INFO: db:lock-an
61d0: 64 2d 64 65 6c 74 61 2d 73 79 6e 63 20 63 6f 70 d-delta-sync cop
61e0: 79 69 6e 67 20 64 62 20 22 72 75 6e 69 64 22 20 ying db "runid"
61f0: 61 74 20 22 28 63 75 72 72 65 6e 74 2d 73 65 63 at "(current-sec
6200: 6f 6e 64 73 29 29 0a 3b 3b 20 09 20 20 28 73 65 onds)).;; . (se
6210: 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 t! *db-sync-in-p
6220: 72 6f 67 72 65 73 73 2a 20 23 74 29 0a 3b 3b 20 rogress* #t).;;
6230: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 73 79 (db:sy
6240: 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 74 72 nc-touched dbstr
6250: 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 20 64 uct runid keys d
6260: 62 69 6e 69 74 29 0a 3b 3b 20 09 20 20 28 73 65 binit).;; . (se
6270: 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 t! *db-sync-in-p
6280: 72 6f 67 72 65 73 73 2a 20 23 66 29 0a 3b 3b 20 rogress* #f).;;
6290: 09 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 . (db:no-sync-d
62a0: 65 6c 21 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 el! no-sync-db f
62b0: 72 6f 6d 2d 64 62 2d 66 69 6c 65 29 0a 3b 3b 20 rom-db-file).;;
62c0: 09 20 20 23 74 29 0a 3b 3b 20 20 20 20 20 20 20 . #t).;;
62d0: 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 (begin.;;
62e0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 (dbfile:pr
62f0: 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 3a 20 int-err "ERROR:
6300: 63 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 6c 6f could not get lo
6310: 63 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d 64 62 ck for " from-db
6320: 2d 66 69 6c 65 20 22 20 66 72 6f 6d 20 6e 6f 2d -file " from no-
6330: 73 79 6e 63 2d 64 62 22 29 0a 3b 3b 20 09 20 20 sync-db").;; .
6340: 23 66 0a 3b 3b 20 20 20 20 20 20 20 20 20 29 29 #f.;; ))
6350: 29 29 0a 0a 3b 3b 20 73 79 6e 63 20 72 75 6e 20 ))..;; sync run
6360: 66 72 6f 6d 20 74 6d 70 20 64 69 73 6b 20 74 6f from tmp disk to
6370: 20 6e 66 73 20 64 69 73 6b 20 69 66 20 74 6f 75 nfs disk if tou
6380: 63 68 65 64 0a 3b 3b 0a 3b 3b 20 63 61 6c 6c 20 ched.;;.;; call
6390: 77 69 74 68 20 64 62 69 6e 69 74 3d 64 62 3a 69 with dbinit=db:i
63a0: 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 69 6e 2d 64 nitialize-main-d
63b0: 62 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 b.;;.(define (db
63c0: 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 :sync-touched db
63d0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 6b 65 struct run-id ke
63e0: 79 73 20 23 21 6b 65 79 20 64 62 69 6e 69 74 20 ys #!key dbinit
63f0: 28 66 6f 72 63 65 2d 73 79 6e 63 20 23 66 29 29 (force-sync #f))
6400: 0a 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 . (dbfile:print
6410: 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d 74 6f -err "db:sync-to
6420: 75 63 68 65 64 20 53 79 6e 63 69 6e 67 3a 20 22 uched Syncing: "
6430: 20 28 63 6f 6e 63 20 28 69 66 20 72 75 6e 2d 69 (conc (if run-i
6440: 64 20 72 75 6e 2d 69 64 20 22 6d 61 69 6e 22 29 d run-id "main")
6450: 20 22 2e 64 62 22 29 29 0a 20 20 28 6c 65 74 2a ".db")). (let*
6460: 20 28 3b 3b 20 74 68 65 20 73 75 62 64 62 20 69 (;; the subdb i
6470: 73 20 6e 65 65 64 65 64 20 74 6f 20 61 63 63 65 s needed to acce
6480: 73 73 20 74 68 65 20 6d 74 64 62 64 61 74 0a 09 ss the mtdbdat..
6490: 20 28 73 75 62 64 62 20 20 20 20 20 28 6f 72 20 (subdb (or
64a0: 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 (dbfile:get-subd
64b0: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
64c0: 64 29 0a 09 09 09 28 64 62 66 69 6c 65 3a 69 6e d)....(dbfile:in
64d0: 69 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 it-subdb dbstruc
64e0: 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 t run-id dbinit)
64f0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6d 70 )). (tmp
6500: 64 62 66 69 6c 65 20 28 64 62 72 3a 73 75 62 64 dbfile (dbr:subd
6510: 62 2d 74 6d 70 64 62 66 69 6c 65 20 73 75 62 64 b-tmpdbfile subd
6520: 62 29 29 0a 09 20 28 6d 74 64 62 20 20 20 20 20 b)).. (mtdb
6530: 20 28 64 62 72 3a 73 75 62 64 62 2d 6d 74 64 62 (dbr:subdb-mtdb
6540: 64 61 74 20 73 75 62 64 62 29 29 0a 20 20 20 20 dat subdb)).
6550: 20 20 20 20 20 28 74 6d 70 64 62 20 20 20 20 20 (tmpdb
6560: 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 (dbfile:open-db
6570: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
6580: 64 62 69 6e 69 74 29 29 20 3b 3b 20 73 71 6c 69 dbinit)) ;; sqli
6590: 74 65 33 2d 64 62 20 74 6d 70 64 62 66 69 6c 65 te3-db tmpdbfile
65a0: 20 23 66 29 29 0a 09 20 28 73 74 61 72 74 2d 74 #f)).. (start-t
65b0: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
65c0: 6e 64 73 29 29 29 0a 20 20 20 20 28 6d 75 74 65 nds))). (mute
65d0: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 x-lock! *db-mult
65e0: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 i-sync-mutex*).
65f0: 20 20 20 28 6c 65 74 20 28 28 75 70 64 61 74 65 (let ((update
6600: 5f 69 6e 66 6f 20 28 63 6f 6e 73 20 22 6c 61 73 _info (cons "las
6610: 74 5f 75 70 64 61 74 65 22 20 28 69 66 20 66 6f t_update" (if fo
6620: 72 63 65 2d 73 79 6e 63 20 30 20 2a 64 62 2d 6c rce-sync 0 *db-l
6630: 61 73 74 2d 73 79 6e 63 2a 29 20 29 29 29 0a 20 ast-sync*) ))).
6640: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
6650: 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 ck! *db-multi-sy
6660: 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 nc-mutex*).
6670: 20 28 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 (db:sync-tables
6680: 20 28 64 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 (db:sync-all-ta
6690: 62 6c 65 73 2d 6c 69 73 74 20 64 62 73 74 72 75 bles-list dbstru
66a0: 63 74 20 6b 65 79 73 29 20 75 70 64 61 74 65 5f ct keys) update_
66b0: 69 6e 66 6f 20 74 6d 70 64 62 20 6d 74 64 62 29 info tmpdb mtdb)
66c0: 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 ). (mutex-loc
66d0: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
66e0: 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 73 c-mutex*). (s
66f0: 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e et! *db-last-syn
6700: 63 2a 20 73 74 61 72 74 2d 74 29 0a 20 20 20 20 c* start-t).
6710: 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 (set! *db-last-a
6720: 63 63 65 73 73 2a 20 73 74 61 72 74 2d 74 29 0a ccess* start-t).
6730: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
6740: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
6750: 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 64 c-mutex*). (d
6760: 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 bfile:add-dbdat
6770: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
6780: 74 6d 70 64 62 29 0a 20 20 23 74 29 29 0a 0a 3b tmpdb). #t))..;
6790: 3b 20 6a 75 73 74 20 74 65 73 74 73 2c 20 74 65 ; just tests, te
67a0: 73 74 5f 73 74 65 70 73 20 61 6e 64 20 74 65 73 st_steps and tes
67b0: 74 5f 64 61 74 61 20 74 61 62 6c 65 73 0a 28 64 t_data tables.(d
67c0: 65 66 69 6e 65 20 64 62 3a 73 79 6e 63 2d 74 65 efine db:sync-te
67d0: 73 74 73 2d 6f 6e 6c 79 0a 20 20 28 6c 69 73 74 sts-only. (list
67e0: 0a 20 20 20 3b 3b 20 28 6c 69 73 74 20 22 73 74 . ;; (list "st
67f0: 72 73 22 0a 20 20 20 3b 3b 20 20 20 20 20 20 20 rs". ;;
6800: 27 28 22 69 64 22 20 20 20 20 20 20 20 20 20 20 '("id"
6810: 20 20 20 23 66 29 0a 20 20 20 3b 3b 20 20 20 20 #f). ;;
6820: 20 20 20 27 28 22 73 74 72 22 20 20 20 20 20 20 '("str"
6830: 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 28 6c #f)). (l
6840: 69 73 74 20 22 74 65 73 74 73 22 20 0a 09 20 27 ist "tests" .. '
6850: 28 22 69 64 22 20 20 20 20 20 20 20 20 20 20 20 ("id"
6860: 20 20 23 66 29 0a 09 20 27 28 22 72 75 6e 5f 69 #f).. '("run_i
6870: 64 22 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 d" #f)..
6880: 20 27 28 22 74 65 73 74 6e 61 6d 65 22 20 20 20 '("testname"
6890: 20 20 20 20 23 66 29 0a 09 20 27 28 22 68 6f 73 #f).. '("hos
68a0: 74 22 20 20 20 20 20 20 20 20 20 20 20 23 66 29 t" #f)
68b0: 0a 09 20 27 28 22 63 70 75 6c 6f 61 64 22 20 20 .. '("cpuload"
68c0: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 64 #f).. '("d
68d0: 69 73 6b 66 72 65 65 22 20 20 20 20 20 20 20 23 iskfree" #
68e0: 66 29 0a 09 20 27 28 22 75 6e 61 6d 65 22 20 20 f).. '("uname"
68f0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
6900: 22 72 75 6e 64 69 72 22 20 20 20 20 20 20 20 20 "rundir"
6910: 20 23 66 29 0a 09 20 27 28 22 73 68 6f 72 74 64 #f).. '("shortd
6920: 69 72 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 ir" #f)..
6930: 27 28 22 69 74 65 6d 5f 70 61 74 68 22 20 20 20 '("item_path"
6940: 20 20 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 #f).. '("stat
6950: 65 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a e" #f).
6960: 09 20 27 28 22 73 74 61 74 75 73 22 20 20 20 20 . '("status"
6970: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 61 74 #f).. '("at
6980: 74 65 6d 70 74 6e 75 6d 22 20 20 20 20 20 23 66 temptnum" #f
6990: 29 0a 09 20 27 28 22 66 69 6e 61 6c 5f 6c 6f 67 ).. '("final_log
69a0: 66 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 f" #f).. '("
69b0: 6c 6f 67 64 61 74 22 20 20 20 20 20 20 20 20 20 logdat"
69c0: 23 66 29 0a 09 20 27 28 22 72 75 6e 5f 64 75 72 #f).. '("run_dur
69d0: 61 74 69 6f 6e 22 20 20 20 23 66 29 0a 09 20 27 ation" #f).. '
69e0: 28 22 63 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 ("comment"
69f0: 20 20 23 66 29 0a 09 20 27 28 22 65 76 65 6e 74 #f).. '("event
6a00: 5f 74 69 6d 65 22 20 20 20 20 20 23 66 29 0a 09 _time" #f)..
6a10: 20 27 28 22 66 61 69 6c 5f 63 6f 75 6e 74 22 20 '("fail_count"
6a20: 20 20 20 20 23 66 29 0a 09 20 27 28 22 70 61 73 #f).. '("pas
6a30: 73 5f 63 6f 75 6e 74 22 20 20 20 20 20 23 66 29 s_count" #f)
6a40: 0a 09 20 27 28 22 61 72 63 68 69 76 65 64 22 20 .. '("archived"
6a50: 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 #f).
6a60: 20 20 20 27 28 22 6c 61 73 74 5f 75 70 64 61 74 '("last_updat
6a70: 65 22 20 20 20 20 23 66 29 29 0a 20 20 28 6c 69 e" #f)). (li
6a80: 73 74 20 22 74 65 73 74 5f 73 74 65 70 73 22 0a st "test_steps".
6a90: 09 20 27 28 22 69 64 22 20 20 20 20 20 20 20 20 . '("id"
6aa0: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 65 #f).. '("te
6ab0: 73 74 5f 69 64 22 20 20 20 20 20 20 20 20 23 66 st_id" #f
6ac0: 29 0a 09 20 27 28 22 73 74 65 70 6e 61 6d 65 22 ).. '("stepname"
6ad0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
6ae0: 73 74 61 74 65 22 20 20 20 20 20 20 20 20 20 20 state"
6af0: 23 66 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 #f).. '("status"
6b00: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
6b10: 28 22 65 76 65 6e 74 5f 74 69 6d 65 22 20 20 20 ("event_time"
6b20: 20 20 23 66 29 0a 09 20 27 28 22 63 6f 6d 6d 65 #f).. '("comme
6b30: 6e 74 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 nt" #f)..
6b40: 20 27 28 22 6c 6f 67 66 69 6c 65 22 20 20 20 20 '("logfile"
6b50: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
6b60: 20 27 28 22 6c 61 73 74 5f 75 70 64 61 74 65 22 '("last_update"
6b70: 20 20 20 20 23 66 29 29 0a 20 20 20 28 6c 69 73 #f)). (lis
6b80: 74 20 22 74 65 73 74 5f 64 61 74 61 22 0a 09 20 t "test_data"..
6b90: 27 28 22 69 64 22 20 20 20 20 20 20 20 20 20 20 '("id"
6ba0: 20 20 20 23 66 29 0a 09 20 27 28 22 74 65 73 74 #f).. '("test
6bb0: 5f 69 64 22 20 20 20 20 20 20 20 20 23 66 29 0a _id" #f).
6bc0: 09 20 27 28 22 63 61 74 65 67 6f 72 79 22 20 20 . '("category"
6bd0: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 76 61 #f).. '("va
6be0: 72 69 61 62 6c 65 22 20 20 20 20 20 20 20 23 66 riable" #f
6bf0: 29 0a 09 20 27 28 22 76 61 6c 75 65 22 20 20 20 ).. '("value"
6c00: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
6c10: 65 78 70 65 63 74 65 64 22 20 20 20 20 20 20 20 expected"
6c20: 23 66 29 0a 09 20 27 28 22 74 6f 6c 22 20 20 20 #f).. '("tol"
6c30: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
6c40: 28 22 75 6e 69 74 73 22 20 20 20 20 20 20 20 20 ("units"
6c50: 20 20 23 66 29 0a 09 20 27 28 22 63 6f 6d 6d 65 #f).. '("comme
6c60: 6e 74 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 nt" #f)..
6c70: 20 27 28 22 73 74 61 74 75 73 22 20 20 20 20 20 '("status"
6c80: 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 79 70 #f).. '("typ
6c90: 65 22 20 20 20 20 20 20 20 20 20 20 20 23 66 29 e" #f)
6ca0: 0a 20 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 . '("las
6cb0: 74 5f 75 70 64 61 74 65 22 20 20 20 20 23 66 29 t_update" #f)
6cc0: 29 29 29 0a 0a 3b 3b 20 6e 65 65 64 73 20 64 62 )))..;; needs db
6cd0: 20 74 6f 20 67 65 74 20 6b 65 79 73 2c 20 74 68 to get keys, th
6ce0: 69 73 20 69 73 20 66 6f 72 20 73 79 6e 63 69 6e is is for syncin
6cf0: 67 20 61 6c 6c 20 74 61 62 6c 65 73 0a 3b 3b 0a g all tables.;;.
6d00: 28 64 65 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 (define (db:sync
6d10: 2d 6d 61 69 6e 2d 6c 69 73 74 20 64 62 73 74 72 -main-list dbstr
6d20: 75 63 74 20 6b 65 79 73 29 0a 20 20 28 6c 65 74 uct keys). (let
6d30: 20 28 28 6b 65 79 73 20 20 6b 65 79 73 29 29 20 ((keys keys))
6d40: 3b 3b 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 20 ;; (db:get-keys
6d50: 64 62 73 74 72 75 63 74 29 29 29 0a 20 20 20 20 dbstruct))).
6d60: 28 6c 69 73 74 0a 20 20 20 20 20 28 6c 69 73 74 (list. (list
6d70: 20 22 6b 65 79 73 22 0a 09 20 20 20 27 28 22 69 "keys".. '("i
6d80: 64 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 d" #f)..
6d90: 20 20 27 28 22 66 69 65 6c 64 6e 61 6d 65 22 20 '("fieldname"
6da0: 23 66 29 0a 09 20 20 20 27 28 22 66 69 65 6c 64 #f).. '("field
6db0: 74 79 70 65 22 20 23 66 29 29 0a 20 20 20 20 20 type" #f)).
6dc0: 28 6c 69 73 74 20 22 6d 65 74 61 64 61 74 22 20 (list "metadat"
6dd0: 27 28 22 76 61 72 22 20 23 66 29 20 27 28 22 76 '("var" #f) '("v
6de0: 61 6c 22 20 23 66 29 29 0a 20 20 20 20 20 28 61 al" #f)). (a
6df0: 70 70 65 6e 64 20 28 6c 69 73 74 20 22 72 75 6e ppend (list "run
6e00: 73 22 20 0a 09 09 20 20 20 27 28 22 69 64 22 20 s" ... '("id"
6e10: 20 23 66 29 29 0a 09 20 20 20 20 20 28 6d 61 70 #f)).. (map
6e20: 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 6c 69 73 (lambda (k)(lis
6e30: 74 20 6b 20 23 66 29 29 0a 09 09 20 20 28 61 70 t k #f))... (ap
6e40: 70 65 6e 64 20 6b 65 79 73 0a 09 09 09 20 20 28 pend keys.... (
6e50: 6c 69 73 74 20 22 72 75 6e 6e 61 6d 65 22 20 22 list "runname" "
6e60: 73 74 61 74 65 22 20 22 73 74 61 74 75 73 22 20 state" "status"
6e70: 22 6f 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 "owner" "event_t
6e80: 69 6d 65 22 20 22 63 6f 6d 6d 65 6e 74 22 20 22 ime" "comment" "
6e90: 66 61 69 6c 5f 63 6f 75 6e 74 22 20 22 70 61 73 fail_count" "pas
6ea0: 73 5f 63 6f 75 6e 74 22 20 22 63 6f 6e 74 6f 75 s_count" "contou
6eb0: 72 22 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 r" "last_update"
6ec0: 29 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 )))). (list
6ed0: 22 61 72 63 68 69 76 65 5f 64 69 73 6b 73 22 0a "archive_disks".
6ee0: 20 20 20 20 20 20 20 20 20 20 20 27 28 22 69 64 '("id
6ef0: 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 " #f).
6f00: 20 27 28 22 61 72 63 68 69 76 65 5f 61 72 65 61 '("archive_area
6f10: 5f 6e 61 6d 65 22 20 23 66 29 20 0a 20 20 20 20 _name" #f) .
6f20: 20 20 20 20 20 20 20 27 28 22 64 69 73 6b 5f 70 '("disk_p
6f30: 61 74 68 22 20 23 66 29 0a 20 20 20 20 20 20 20 ath" #f).
6f40: 20 20 20 20 27 28 22 6c 61 73 74 5f 64 66 22 20 '("last_df"
6f50: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
6f60: 28 22 6c 61 73 74 5f 64 66 5f 74 69 6d 65 22 20 ("last_df_time"
6f70: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
6f80: 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 22 ("creation_time"
6f90: 20 23 66 29 29 20 0a 0a 20 20 20 20 20 28 6c 69 #f)) .. (li
6fa0: 73 74 20 22 61 72 63 68 69 76 65 5f 62 6c 6f 63 st "archive_bloc
6fb0: 6b 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 27 ks". '
6fc0: 28 22 69 64 22 20 23 66 29 0a 20 20 20 20 20 20 ("id" #f).
6fd0: 20 20 20 20 20 27 28 22 61 72 63 68 69 76 65 5f '("archive_
6fe0: 64 69 73 6b 5f 69 64 22 20 23 66 29 20 0a 20 20 disk_id" #f) .
6ff0: 20 20 20 20 20 20 20 20 20 27 28 22 64 69 73 6b '("disk
7000: 5f 70 61 74 68 22 20 23 66 29 0a 20 20 20 20 20 _path" #f).
7010: 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 75 '("last_du
7020: 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 " #f).
7030: 20 27 28 22 6c 61 73 74 5f 64 75 5f 74 69 6d 65 '("last_du_time
7040: 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 " #f).
7050: 20 27 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d '("creation_tim
7060: 65 22 20 23 66 29 29 20 0a 0a 20 20 20 20 20 28 e" #f)) .. (
7070: 6c 69 73 74 20 22 74 65 73 74 5f 6d 65 74 61 22 list "test_meta"
7080: 0a 09 20 20 20 27 28 22 69 64 22 20 20 20 20 20 .. '("id"
7090: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 #f)..
70a0: 27 28 22 74 65 73 74 6e 61 6d 65 22 20 20 20 20 '("testname"
70b0: 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 6f 77 #f).. '("ow
70c0: 6e 65 72 22 20 20 20 20 20 20 20 20 20 20 23 66 ner" #f
70d0: 29 0a 09 20 20 20 27 28 22 64 65 73 63 72 69 70 ).. '("descrip
70e0: 74 69 6f 6e 22 20 20 20 20 23 66 29 0a 09 20 20 tion" #f)..
70f0: 20 27 28 22 72 65 76 69 65 77 65 64 22 20 20 20 '("reviewed"
7100: 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 69 #f).. '("i
7110: 74 65 72 61 74 65 64 22 20 20 20 20 20 20 20 23 terated" #
7120: 66 29 0a 09 20 20 20 27 28 22 61 76 67 5f 72 75 f).. '("avg_ru
7130: 6e 74 69 6d 65 22 20 20 20 20 23 66 29 0a 09 20 ntime" #f)..
7140: 20 20 27 28 22 61 76 67 5f 64 69 73 6b 22 20 20 '("avg_disk"
7150: 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 #f).. '("
7160: 74 61 67 73 22 20 20 20 20 20 20 20 20 20 20 20 tags"
7170: 23 66 29 0a 09 20 20 20 27 28 22 6a 6f 62 67 72 #f).. '("jobgr
7180: 6f 75 70 22 20 20 20 20 20 20 20 23 66 29 29 29 oup" #f)))
7190: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a ))..(define (db:
71a0: 73 79 6e 63 2d 61 6c 6c 2d 74 61 62 6c 65 73 2d sync-all-tables-
71b0: 6c 69 73 74 20 64 62 73 74 72 75 63 74 20 6b 65 list dbstruct ke
71c0: 79 73 29 0a 20 20 28 61 70 70 65 6e 64 20 28 64 ys). (append (d
71d0: 62 3a 73 79 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 b:sync-main-list
71e0: 20 64 62 73 74 72 75 63 74 20 6b 65 79 73 29 0a dbstruct keys).
71f0: 09 20 20 64 62 3a 73 79 6e 63 2d 74 65 73 74 73 . db:sync-tests
7200: 2d 6f 6e 6c 79 29 29 0a 0a 3b 3b 20 74 62 6c 73 -only))..;; tbls
7210: 20 69 73 20 28 20 28 22 74 61 62 6c 65 6e 61 6d is ( ("tablenam
7220: 65 22 20 28 20 22 66 69 65 6c 64 31 22 20 5b 23 e" ( "field1" [#
7230: 66 7c 70 72 6f 63 31 5d 20 29 20 28 20 22 66 69 f|proc1] ) ( "fi
7240: 65 6c 64 32 22 20 5b 23 66 7c 70 72 6f 63 32 5d eld2" [#f|proc2]
7250: 20 29 20 2e 2e 2e 2e 20 29 20 29 0a 3b 3b 20 64 ) .... ) ).;; d
7260: 62 27 73 20 61 72 65 20 64 62 64 61 74 27 73 0a b's are dbdat's.
7270: 3b 3b 0a 3b 3b 20 69 66 20 6c 61 73 74 2d 75 70 ;;.;; if last-up
7280: 64 61 74 65 20 73 70 65 63 69 66 69 65 64 20 28 date specified (
7290: 22 66 69 65 6c 64 2d 6e 61 6d 65 22 20 2e 20 74 "field-name" . t
72a0: 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 29 0a ime-in-seconds).
72b0: 3b 3b 20 20 20 20 74 68 65 6e 20 73 79 6e 63 20 ;; then sync
72c0: 6f 6e 6c 79 20 72 65 63 6f 72 64 73 20 77 68 65 only records whe
72d0: 72 65 20 66 69 65 6c 64 2d 6e 61 6d 65 20 3e 3d re field-name >=
72e0: 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 time-in-seconds
72f0: 0a 3b 3b 20 20 20 20 49 46 46 20 66 69 65 6c 64 .;; IFF field
7300: 2d 6e 61 6d 65 20 65 78 69 73 74 73 0a 3b 3b 0a -name exists.;;.
7310: 28 64 65 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 (define (db:sync
7320: 2d 74 61 62 6c 65 73 20 74 62 6c 73 20 6c 61 73 -tables tbls las
7330: 74 2d 75 70 64 61 74 65 20 66 72 6f 6d 64 62 20 t-update fromdb
7340: 74 6f 64 62 20 2e 20 73 6c 61 76 65 2d 64 62 73 todb . slave-dbs
7350: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
7360: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
7370: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 64 62 (begin. (db
7380: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 file:print-err
7390: 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 "EXCEPTION: data
73a0: 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 base probably ov
73b0: 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 erloaded or unre
73c0: 61 64 61 62 6c 65 20 69 6e 20 64 62 3a 73 79 6e adable in db:syn
73d0: 63 2d 74 61 62 6c 65 73 2e 22 29 0a 20 20 20 20 c-tables.").
73e0: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
73f0: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
7400: 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 28 64 r-port)). (d
7410: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
7420: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
7430: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
7440: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
7450: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
7460: 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 . (dbfile:pr
7470: 69 6e 74 2d 65 72 72 20 20 22 65 78 6e 3d 22 20 int-err "exn="
7480: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
7490: 20 65 78 6e 29 29 0a 20 20 20 20 20 28 64 62 66 exn)). (dbf
74a0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 ile:print-err "
74b0: 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 63 6f status: " ((co
74c0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
74d0: 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 -accessor 'sqlit
74e0: 65 33 20 27 73 74 61 74 75 73 29 20 65 78 6e 29 e3 'status) exn)
74f0: 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 ). (dbfile:p
7500: 72 69 6e 74 2d 65 72 72 20 20 22 20 73 72 63 20 rint-err " src
7510: 64 62 3a 20 20 22 20 28 64 62 72 3a 64 62 64 61 db: " (dbr:dbda
7520: 74 2d 64 62 66 69 6c 65 20 66 72 6f 6d 64 62 29 t-dbfile fromdb)
7530: 29 0a 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ). (for-each
7540: 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 74 29 (lambda (dbdat)
7550: 0a 09 09 20 28 6c 65 74 20 28 28 64 62 70 61 74 ... (let ((dbpat
7560: 68 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 66 h (dbr:dbdat-dbf
7570: 69 6c 65 20 64 62 64 61 74 29 29 29 0a 09 09 20 ile dbdat)))...
7580: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
7590: 65 72 72 20 20 22 20 64 62 70 61 74 68 3a 20 20 err " dbpath:
75a0: 22 20 64 62 70 61 74 68 29 0a 09 09 20 20 20 28 " dbpath)... (
75b0: 69 66 20 23 74 20 3b 3b 20 28 6e 6f 74 20 28 64 if #t ;; (not (d
75c0: 62 3a 72 65 70 61 69 72 2d 64 62 20 64 62 64 61 b:repair-db dbda
75d0: 74 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 t))... (be
75e0: 67 69 6e 0a 09 09 09 20 28 64 62 66 69 6c 65 3a gin.... (dbfile:
75f0: 70 72 69 6e 74 2d 65 72 72 20 22 46 61 69 6c 65 print-err "Faile
7600: 64 20 74 6f 20 72 65 62 75 69 6c 64 20 28 72 65 d to rebuild (re
7610: 70 61 69 72 20 69 73 20 74 75 72 6e 65 64 20 6f pair is turned o
7620: 66 66 29 20 22 20 64 62 70 61 74 68 20 22 2c 20 ff) " dbpath ",
7630: 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 exiting now.")..
7640: 09 09 20 28 65 78 69 74 29 29 29 29 29 0a 09 20 .. (exit)))))..
7650: 20 20 20 20 20 20 28 63 6f 6e 73 20 74 6f 64 62 (cons todb
7660: 20 73 6c 61 76 65 2d 64 62 73 29 29 0a 20 20 20 slave-dbs)).
7670: 20 20 0a 20 20 20 20 20 30 29 0a 0a 20 20 20 3b . 0).. ;
7680: 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 77 6f ; this is the wo
7690: 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 22 29 0a rk to be done").
76a0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 28 28 6e (cond. ((n
76b0: 6f 74 20 66 72 6f 6d 64 62 29 20 28 64 62 66 69 ot fromdb) (dbfi
76c0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 57 le:print-err "W
76d0: 41 52 4e 49 4e 47 3a 20 64 62 3a 73 79 6e 63 2d ARNING: db:sync-
76e0: 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 tables called wi
76f0: 74 68 20 66 72 6f 6d 64 62 20 6d 69 73 73 69 6e th fromdb missin
7700: 67 22 29 0a 20 20 20 20 20 2d 31 29 0a 20 20 20 g"). -1).
7710: 20 28 28 6e 6f 74 20 74 6f 64 62 29 20 20 20 28 ((not todb) (
7720: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
7730: 20 20 22 57 41 52 4e 49 4e 47 3a 20 64 62 3a 73 "WARNING: db:s
7740: 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 ync-tables calle
7750: 64 20 77 69 74 68 20 74 6f 64 62 20 6d 69 73 73 d with todb miss
7760: 69 6e 67 22 29 0a 20 20 20 20 20 2d 32 29 0a 20 ing"). -2).
7770: 20 20 20 28 28 6e 6f 74 20 28 73 71 6c 69 74 65 ((not (sqlite
7780: 33 3a 64 61 74 61 62 61 73 65 3f 20 28 64 62 72 3:database? (dbr
7790: 3a 64 62 64 61 74 2d 64 62 68 20 66 72 6f 6d 64 :dbdat-dbh fromd
77a0: 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c b))). (dbfil
77b0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a e:print-err "db:
77c0: 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c sync-tables call
77d0: 65 64 20 77 69 74 68 20 66 72 6f 6d 64 62 20 6e ed with fromdb n
77e0: 6f 74 20 61 20 64 61 74 61 62 61 73 65 20 22 20 ot a database "
77f0: 66 72 6f 6d 64 62 29 0a 20 20 20 2d 33 29 0a 20 fromdb). -3).
7800: 20 20 20 28 28 6e 6f 74 20 28 73 71 6c 69 74 65 ((not (sqlite
7810: 33 3a 64 61 74 61 62 61 73 65 3f 20 28 64 62 72 3:database? (dbr
7820: 3a 64 62 64 61 74 2d 64 62 68 20 74 6f 64 62 29 :dbdat-dbh todb)
7830: 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a )). (dbfile:
7840: 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 print-err "db:sy
7850: 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 nc-tables called
7860: 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 with todb not a
7870: 20 64 61 74 61 62 61 73 65 20 22 20 74 6f 64 62 database " todb
7880: 29 0a 20 20 20 2d 34 29 0a 0a 20 20 20 20 28 28 ). -4).. ((
7890: 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d not (file-write-
78a0: 61 63 63 65 73 73 3f 20 28 64 62 72 3a 64 62 64 access? (dbr:dbd
78b0: 61 74 2d 64 62 66 69 6c 65 20 74 6f 64 62 29 29 at-dbfile todb))
78c0: 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 ). (dbfile:p
78d0: 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e rint-err "db:syn
78e0: 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 c-tables called
78f0: 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 with todb not a
7900: 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 read-only databa
7910: 73 65 20 22 20 74 6f 64 62 29 0a 20 20 20 20 20 se " todb).
7920: 2d 35 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 6e -5). ((not (n
7930: 75 6c 6c 3f 20 28 6c 65 74 20 28 28 72 65 61 64 ull? (let ((read
7940: 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 73 0a 20 only-slave-dbs.
7950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7960: 20 20 20 20 20 20 20 28 66 69 6c 74 65 72 0a 20 (filter.
7970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7980: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
7990: 28 64 62 64 61 74 29 0a 20 20 20 20 20 20 20 20 (dbdat).
79a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79b0: 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 (not (file-wr
79c0: 69 74 65 2d 61 63 63 65 73 73 3f 20 28 64 62 72 ite-access? (dbr
79d0: 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 74 6f :dbdat-dbfile to
79e0: 64 62 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 db)))).
79f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a00: 73 6c 61 76 65 2d 64 62 73 29 29 29 0a 20 20 20 slave-dbs))).
7a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a20: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 (for-each.
7a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
7a40: 61 6d 62 64 61 20 28 62 61 64 2d 64 62 64 61 74 ambda (bad-dbdat
7a50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7a60: 20 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a (dbfile:
7a70: 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 print-err "db:sy
7a80: 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 nc-tables called
7a90: 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 with todb not a
7aa0: 20 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 read-only datab
7ab0: 61 73 65 20 22 20 62 61 64 2d 64 62 64 61 74 29 ase " bad-dbdat)
7ac0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7ad0: 20 20 20 20 20 20 72 65 61 64 6f 6e 6c 79 2d 73 readonly-s
7ae0: 6c 61 76 65 2d 64 62 73 29 0a 20 20 20 20 20 20 lave-dbs).
7af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 rea
7b00: 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 73 29 donly-slave-dbs)
7b10: 29 29 20 2d 36 29 0a 20 20 20 20 28 65 6c 73 65 )) -6). (else
7b20: 0a 20 20 20 20 3b 3b 20 28 64 62 66 69 6c 65 3a . ;; (dbfile:
7b30: 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 print-err "db:sy
7b40: 6e 63 2d 74 61 62 6c 65 73 3a 20 61 72 67 73 20 nc-tables: args
7b50: 61 72 65 20 67 6f 6f 64 22 29 0a 0a 20 20 20 20 are good")..
7b60: 20 28 6c 65 74 20 28 28 73 74 6d 74 73 20 20 20 (let ((stmts
7b70: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
7b80: 61 62 6c 65 29 29 20 3b 3b 20 74 61 62 6c 65 2d able)) ;; table-
7b90: 66 69 65 6c 64 20 3d 3e 20 73 74 6d 74 0a 09 20 field => stmt..
7ba0: 20 20 28 61 6c 6c 2d 73 74 6d 74 73 20 20 20 27 (all-stmts '
7bb0: 28 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ())
7bc0: 20 3b 3b 20 28 20 28 20 73 74 6d 74 31 20 76 61 ;; ( ( stmt1 va
7bd0: 6c 75 65 31 20 29 20 28 20 73 74 6d 6c 32 20 76 lue1 ) ( stml2 v
7be0: 61 6c 75 65 32 20 29 29 0a 09 20 20 20 28 6e 75 alue2 )).. (nu
7bf0: 6d 72 65 63 73 20 20 20 20 20 28 6d 61 6b 65 2d mrecs (make-
7c00: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 hash-table))..
7c10: 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 28 63 (start-time (c
7c20: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
7c30: 6e 64 73 29 29 0a 09 20 20 20 28 74 6f 74 2d 63 nds)).. (tot-c
7c40: 6f 75 6e 74 20 20 20 30 29 29 0a 20 20 20 20 20 ount 0)).
7c50: 20 20 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 74 (for-each ;; t
7c60: 61 62 6c 65 0a 09 28 6c 61 6d 62 64 61 20 28 74 able..(lambda (t
7c70: 61 62 6c 65 64 61 74 29 0a 09 20 20 28 6c 65 74 abledat).. (let
7c80: 2a 20 28 28 74 61 62 6c 65 6e 61 6d 65 20 20 20 * ((tablename
7c90: 20 20 20 20 20 28 63 61 72 20 74 61 62 6c 65 64 (car tabled
7ca0: 61 74 29 29 0a 09 09 20 28 66 69 65 6c 64 73 20 at))... (fields
7cb0: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 (cdr t
7cc0: 61 62 6c 65 64 61 74 29 29 0a 09 09 20 28 68 61 abledat))... (ha
7cd0: 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 20 28 s-last-update (
7ce0: 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 member "last_upd
7cf0: 61 74 65 22 20 66 69 65 6c 64 73 29 29 0a 09 09 ate" fields))...
7d00: 20 28 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 (use-last-updat
7d10: 65 20 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 e (cond.....
7d20: 20 28 28 61 6e 64 20 68 61 73 2d 6c 61 73 74 2d ((and has-last-
7d30: 75 70 64 61 74 65 0a 09 09 09 09 09 20 20 28 6d update...... (m
7d40: 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 ember "last_upda
7d50: 74 65 22 20 66 69 65 6c 64 73 29 29 0a 09 09 09 te" fields))....
7d60: 09 20 20 20 20 20 23 74 29 20 3b 3b 20 69 66 20 . #t) ;; if
7d70: 67 69 76 65 6e 20 61 20 6e 75 6d 62 65 72 2c 20 given a number,
7d80: 6a 75 73 74 20 75 73 65 20 69 74 20 66 6f 72 20 just use it for
7d90: 61 6c 6c 20 66 69 65 6c 64 73 0a 09 09 09 09 20 all fields.....
7da0: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 6c 61 73 ((number? las
7db0: 74 2d 75 70 64 61 74 65 29 20 23 66 29 20 3b 3b t-update) #f) ;;
7dc0: 20 69 66 20 6e 6f 74 20 6d 61 74 63 68 65 64 20 if not matched
7dd0: 66 69 72 73 74 20 65 6e 74 72 79 20 74 68 65 6e first entry then
7de0: 20 69 67 6e 6f 72 65 20 6c 61 73 74 2d 75 70 64 ignore last-upd
7df0: 61 74 65 20 66 6f 72 20 74 68 69 73 20 74 61 62 ate for this tab
7e00: 6c 65 0a 09 09 09 09 20 20 20 20 28 28 61 6e 64 le..... ((and
7e10: 20 28 70 61 69 72 3f 20 6c 61 73 74 2d 75 70 64 (pair? last-upd
7e20: 61 74 65 29 0a 09 09 09 09 09 20 20 28 6d 65 6d ate)...... (mem
7e30: 62 65 72 20 28 63 61 72 20 6c 61 73 74 2d 75 70 ber (car last-up
7e40: 64 61 74 65 29 20 20 20 20 3b 3b 20 6c 61 73 74 date) ;; last
7e50: 2d 75 70 64 61 74 65 20 66 69 65 6c 64 20 6e 61 -update field na
7e60: 6d 65 0a 09 09 09 09 09 09 20 20 28 6d 61 70 20 me....... (map
7e70: 63 61 72 20 66 69 65 6c 64 73 29 29 29 0a 20 20 car fields))).
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ea0: 20 20 20 20 20 20 23 74 29 0a 09 09 09 09 20 20 #t).....
7eb0: 20 20 28 28 61 6e 64 20 6c 61 73 74 2d 75 70 64 ((and last-upd
7ec0: 61 74 65 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 ate (not (pair?
7ed0: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 20 28 6e last-update)) (n
7ee0: 6f 74 20 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 ot (number? last
7ef0: 2d 75 70 64 61 74 65 29 29 29 0a 09 09 09 09 20 -update))).....
7f00: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
7f10: 74 2d 65 72 72 20 20 22 45 52 52 4f 52 3a 20 70 t-err "ERROR: p
7f20: 61 72 61 6d 65 74 65 72 20 6c 61 73 74 2d 75 70 arameter last-up
7f30: 64 61 74 65 20 66 6f 72 20 64 62 3a 73 79 6e 63 date for db:sync
7f40: 2d 74 61 62 6c 65 73 20 6d 75 73 74 20 62 65 20 -tables must be
7f50: 61 20 70 61 69 72 20 6f 72 20 61 20 6e 75 6d 62 a pair or a numb
7f60: 65 72 2c 20 72 65 63 65 69 76 65 64 3a 20 22 20 er, received: "
7f70: 6c 61 73 74 2d 75 70 64 61 74 65 29 3b 3b 20 66 last-update);; f
7f80: 6f 75 6e 64 20 69 6e 20 66 69 65 6c 64 73 0a 09 ound in fields..
7f90: 09 09 09 20 20 20 20 20 23 66 29 0a 09 09 09 09 ... #f).....
7fa0: 20 20 20 20 28 65 6c 73 65 0a 09 09 09 09 20 20 (else.....
7fb0: 20 20 20 23 66 29 29 29 0a 09 09 20 28 6c 61 73 #f)))... (las
7fc0: 74 2d 75 70 64 61 74 65 2d 76 61 6c 75 65 20 28 t-update-value (
7fd0: 69 66 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 if use-last-upda
7fe0: 74 65 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f te ;; no need to
7ff0: 20 63 68 65 63 6b 20 66 6f 72 20 68 61 73 2d 6c check for has-l
8000: 61 73 74 2d 75 70 64 61 74 65 20 2d 20 69 74 20 ast-update - it
8010: 69 73 20 61 6c 72 65 61 64 79 20 61 63 63 6f 75 is already accou
8020: 6e 74 65 64 20 66 6f 72 0a 09 09 09 09 09 28 69 nted for......(i
8030: 66 20 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d f (number? last-
8040: 75 70 64 61 74 65 29 0a 09 09 09 09 09 20 20 20 update)......
8050: 20 6c 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 last-update....
8060: 09 09 20 20 20 20 28 63 64 72 20 6c 61 73 74 2d .. (cdr last-
8070: 75 70 64 61 74 65 29 29 0a 09 09 09 09 09 23 66 update))......#f
8080: 29 29 0a 09 09 20 28 6c 61 73 74 2d 75 70 64 61 ))... (last-upda
8090: 74 65 2d 66 69 65 6c 64 20 28 69 66 20 75 73 65 te-field (if use
80a0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 -last-update....
80b0: 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6c ..(if (number? l
80c0: 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 09 09 ast-update).....
80d0: 09 20 20 20 20 22 6c 61 73 74 5f 75 70 64 61 74 . "last_updat
80e0: 65 22 0a 09 09 09 09 09 20 20 20 20 28 63 61 72 e"...... (car
80f0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 09 last-update))..
8100: 09 09 09 09 23 66 29 29 0a 09 09 20 28 6e 75 6d ....#f))... (num
8110: 2d 66 69 65 6c 64 73 20 28 6c 65 6e 67 74 68 20 -fields (length
8120: 66 69 65 6c 64 73 29 29 0a 09 09 20 28 66 69 65 fields))... (fie
8130: 6c 64 2d 3e 6e 75 6d 20 28 6d 61 6b 65 2d 68 61 ld->num (make-ha
8140: 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 20 28 6e sh-table))... (n
8150: 75 6d 2d 3e 66 69 65 6c 64 20 28 61 70 70 6c 79 um->field (apply
8160: 20 76 65 63 74 6f 72 20 28 6d 61 70 20 63 61 72 vector (map car
8170: 20 66 69 65 6c 64 73 29 29 29 20 3b 3b 20 42 42 fields))) ;; BB
8180: 48 45 52 45 0a 09 09 20 28 66 75 6c 6c 2d 73 65 HERE... (full-se
8190: 6c 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 l (conc "SELEC
81a0: 54 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 T " (string-inte
81b0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 72 rsperse (map car
81c0: 20 66 69 65 6c 64 73 29 20 22 2c 22 29 20 0a 09 fields) ",") ..
81d0: 09 09 09 20 20 20 22 20 46 52 4f 4d 20 22 20 74 ... " FROM " t
81e0: 61 62 6c 65 6e 61 6d 65 20 28 69 66 20 75 73 65 ablename (if use
81f0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 3b 3b 20 -last-update ;;
8200: 61 70 70 6c 79 20 6c 61 73 74 2d 75 70 64 61 74 apply last-updat
8210: 65 20 63 72 69 74 65 72 69 61 0a 09 09 09 09 09 e criteria......
8220: 09 09 20 20 28 63 6f 6e 63 20 22 20 57 48 45 52 .. (conc " WHER
8230: 45 20 22 20 6c 61 73 74 2d 75 70 64 61 74 65 2d E " last-update-
8240: 66 69 65 6c 64 20 22 20 3e 3d 20 22 20 6c 61 73 field " >= " las
8250: 74 2d 75 70 64 61 74 65 2d 76 61 6c 75 65 29 0a t-update-value).
8260: 09 09 09 09 09 09 09 20 20 22 22 29 0a 09 09 09 ....... "")....
8270: 09 20 20 20 22 3b 22 29 29 0a 09 09 20 28 66 75 . ";"))... (fu
8280: 6c 6c 2d 69 6e 73 20 20 20 28 63 6f 6e 63 20 22 ll-ins (conc "
8290: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
82a0: 45 20 49 4e 54 4f 20 22 20 74 61 62 6c 65 6e 61 E INTO " tablena
82b0: 6d 65 20 22 20 28 20 22 20 28 73 74 72 69 6e 67 me " ( " (string
82c0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
82d0: 70 20 63 61 72 20 66 69 65 6c 64 73 29 20 22 2c p car fields) ",
82e0: 22 29 20 22 20 29 20 22 0a 09 09 09 09 20 20 20 ") " ) ".....
82f0: 22 20 56 41 4c 55 45 53 20 28 20 22 20 28 73 74 " VALUES ( " (st
8300: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
8310: 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 6d 2d (make-list num-
8320: 66 69 65 6c 64 73 20 22 3f 22 29 20 22 2c 22 29 fields "?") ",")
8330: 20 22 20 29 3b 22 29 29 0a 09 09 20 28 66 72 6f " );"))... (fro
8340: 6d 64 61 74 20 20 20 20 27 28 29 29 0a 09 09 20 mdat '())...
8350: 28 66 72 6f 6d 64 61 74 73 20 20 20 27 28 29 29 (fromdats '())
8360: 0a 09 09 20 28 74 6f 74 72 65 63 6f 72 64 73 20 ... (totrecords
8370: 30 29 0a 09 09 20 28 62 61 74 63 68 2d 6c 65 6e 0)... (batch-len
8380: 20 20 31 30 30 29 20 3b 3b 20 28 73 74 72 69 6e 100) ;; (strin
8390: 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 g->number (or (c
83a0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
83b0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 79 6e 63 22 onfigdat* "sync"
83c0: 20 22 62 61 74 63 68 73 69 7a 65 22 29 20 22 31 "batchsize") "1
83d0: 30 30 22 29 29 29 0a 09 09 20 28 74 6f 64 61 74 00")))... (todat
83e0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
83f0: 2d 74 61 62 6c 65 29 29 0a 09 09 20 28 63 6f 75 -table))... (cou
8400: 6e 74 20 20 20 20 20 20 30 29 0a 20 20 20 20 20 nt 0).
8410: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 65 (fie
8420: 6c 64 2d 6e 61 6d 65 73 20 28 6d 61 70 20 63 61 ld-names (map ca
8430: 72 20 66 69 65 6c 64 73 29 29 0a 20 20 20 20 20 r fields)).
8440: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c (del
8450: 61 79 2d 68 61 6e 64 69 63 61 70 20 20 30 29 20 ay-handicap 0)
8460: 3b 3b 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ;; (string->numb
8470: 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a er (or (configf:
8480: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
8490: 74 2a 20 22 73 79 6e 63 22 20 22 64 65 6c 61 79 t* "sync" "delay
84a0: 2d 68 61 6e 64 69 63 61 70 22 29 20 22 30 22 29 -handicap") "0")
84b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
84c0: 20 20 20 20 29 0a 0a 09 20 20 20 20 3b 3b 20 73 )... ;; s
84d0: 65 74 20 75 70 20 74 68 65 20 66 69 65 6c 64 2d et up the field-
84e0: 3e 6e 75 6d 20 74 61 62 6c 65 0a 09 20 20 20 20 >num table..
84f0: 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 (for-each..
8500: 28 6c 61 6d 62 64 61 20 28 66 69 65 6c 64 29 0a (lambda (field).
8510: 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 . (hash-ta
8520: 62 6c 65 2d 73 65 74 21 20 66 69 65 6c 64 2d 3e ble-set! field->
8530: 6e 75 6d 20 66 69 65 6c 64 20 63 6f 75 6e 74 29 num field count)
8540: 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 63 .. (set! c
8550: 6f 75 6e 74 20 28 2b 20 63 6f 75 6e 74 20 31 29 ount (+ count 1)
8560: 29 29 0a 09 20 20 20 20 20 66 69 65 6c 64 73 29 )).. fields)
8570: 0a 0a 09 20 20 20 20 3b 3b 20 72 65 61 64 20 74 ... ;; read t
8580: 68 65 20 73 6f 75 72 63 65 20 74 61 62 6c 65 0a he source table.
8590: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 73 ;; s
85a0: 74 6f 72 65 20 61 20 6c 69 73 74 20 6f 66 20 61 tore a list of a
85b0: 6c 6c 20 72 6f 77 73 20 69 6e 20 74 68 65 20 74 ll rows in the t
85c0: 61 62 6c 65 20 69 6e 20 66 72 6f 6d 64 61 74 2c able in fromdat,
85d0: 20 75 70 20 74 6f 20 62 61 74 63 68 2d 6c 65 6e up to batch-len
85e0: 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b .. ;;
85f0: 20 54 68 65 6e 20 61 64 64 20 66 72 6f 6d 64 61 Then add fromda
8600: 74 20 74 6f 20 74 68 65 20 66 72 6f 6d 64 61 74 t to the fromdat
8610: 73 20 6c 69 73 74 2c 20 63 6c 65 61 72 20 66 72 s list, clear fr
8620: 6f 6d 64 61 74 20 61 6e 64 20 72 65 70 65 61 74 omdat and repeat
8630: 2e 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ... (sqlite3:
8640: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 for-each-row..
8650: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 (lambda (a .
8660: 62 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 b).. (set!
8670: 20 66 72 6f 6d 64 61 74 20 28 63 6f 6e 73 20 28 fromdat (cons (
8680: 61 70 70 6c 79 20 76 65 63 74 6f 72 20 61 20 62 apply vector a b
8690: 29 20 66 72 6f 6d 64 61 74 29 29 0a 09 20 20 20 ) fromdat))..
86a0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
86b0: 74 68 20 66 72 6f 6d 64 61 74 29 20 62 61 74 63 th fromdat) batc
86c0: 68 2d 6c 65 6e 29 0a 09 09 20 20 20 28 62 65 67 h-len)... (beg
86d0: 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 in... (set!
86e0: 66 72 6f 6d 64 61 74 73 20 28 63 6f 6e 73 20 66 fromdats (cons f
86f0: 72 6f 6d 64 61 74 20 66 72 6f 6d 64 61 74 73 29 romdat fromdats)
8700: 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 66 )... (set! f
8710: 72 6f 6d 64 61 74 20 20 27 28 29 29 0a 09 09 20 romdat '())...
8720: 20 20 20 20 28 73 65 74 21 20 74 6f 74 72 65 63 (set! totrec
8730: 6f 72 64 73 20 28 2b 20 74 6f 74 72 65 63 6f 72 ords (+ totrecor
8740: 64 73 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 ds 1))).
8750: 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
8760: 20 20 20 20 20 20 29 0a 09 20 20 20 20 20 28 64 ).. (d
8770: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 66 72 6f br:dbdat-dbh fro
8780: 6d 64 62 29 0a 09 20 20 20 20 20 66 75 6c 6c 2d mdb).. full-
8790: 73 65 6c 29 0a 0a 20 20 20 20 20 20 20 20 20 20 sel)..
87a0: 20 20 20 3b 3b 20 43 6f 75 6e 74 20 6c 65 73 73 ;; Count less
87b0: 20 74 68 61 6e 20 62 61 74 63 68 2d 6c 65 6e 20 than batch-len
87c0: 61 73 20 61 20 72 65 63 6f 72 64 0a 20 20 20 20 as a record.
87d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 (if (>
87e0: 28 6c 65 6e 67 74 68 20 66 72 6f 6d 64 61 74 29 (length fromdat)
87f0: 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0).
8800: 20 20 20 20 20 28 73 65 74 21 20 74 6f 74 72 65 (set! totre
8810: 63 6f 72 64 73 20 28 2b 20 74 6f 74 72 65 63 6f cords (+ totreco
8820: 72 64 73 20 31 29 29 29 0a 0a 09 20 20 20 20 3b rds 1)))... ;
8830: 3b 20 74 61 63 6b 20 6f 6e 20 72 65 6d 61 69 6e ; tack on remain
8840: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 66 ing records in f
8850: 72 6f 6d 64 61 74 0a 09 20 20 20 20 28 69 66 20 romdat.. (if
8860: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 72 6f 6d (not (null? from
8870: 64 61 74 29 29 0a 09 09 28 73 65 74 21 20 66 72 dat))...(set! fr
8880: 6f 6d 64 61 74 73 20 28 63 6f 6e 73 20 66 72 6f omdats (cons fro
8890: 6d 64 61 74 20 66 72 6f 6d 64 61 74 73 29 29 29 mdat fromdats)))
88a0: 0a 0a 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d ... (if (comm
88b0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
88c0: 6e 74 20 31 32 30 20 22 73 79 6e 63 2d 72 65 63 nt 120 "sync-rec
88d0: 6f 72 64 73 22 29 0a 09 09 28 64 62 66 69 6c 65 ords")...(dbfile
88e0: 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 66 6f 75 :print-err "fou
88f0: 6e 64 20 22 20 74 6f 74 72 65 63 6f 72 64 73 20 nd " totrecords
8900: 22 20 72 65 63 6f 72 64 73 20 74 6f 20 73 79 6e " records to syn
8910: 63 22 29 29 0a 0a 09 20 20 20 20 28 73 71 6c 69 c"))... (sqli
8920: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
8930: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
8940: 61 20 2e 20 62 29 0a 09 20 20 20 20 20 20 20 28 a . b).. (
8950: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8960: 74 6f 64 61 74 20 61 20 28 61 70 70 6c 79 20 76 todat a (apply v
8970: 65 63 74 6f 72 20 61 20 62 29 29 29 0a 09 20 20 ector a b)))..
8980: 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 (dbr:dbdat-db
8990: 68 20 74 6f 64 62 29 0a 09 20 20 20 20 20 66 75 h todb).. fu
89a0: 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 20 20 ll-sel)..
89b0: 20 20 20 20 20 28 77 68 65 6e 20 28 61 6e 64 20 (when (and
89c0: 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 28 delay-handicap (
89d0: 3e 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 > delay-handicap
89e0: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
89f0: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
8a00: 2d 65 72 72 20 22 69 6d 70 6f 73 69 6e 67 20 73 -err "imposing s
8a10: 79 6e 74 68 65 74 69 63 20 73 79 6e 63 20 64 65 ynthetic sync de
8a20: 6c 61 79 20 6f 66 20 22 64 65 6c 61 79 2d 68 61 lay of "delay-ha
8a30: 6e 64 69 63 61 70 22 20 73 65 63 6f 6e 64 73 20 ndicap" seconds
8a40: 73 69 6e 63 65 20 73 79 6e 63 2f 64 65 6c 61 79 since sync/delay
8a50: 2d 68 61 6e 64 69 63 61 70 20 69 73 20 63 6f 6e -handicap is con
8a60: 66 69 67 75 72 65 64 22 29 0a 20 20 20 20 20 20 figured").
8a70: 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
8a80: 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 68 61 6e sleep! delay-han
8a90: 64 69 63 61 70 29 0a 20 20 20 20 20 20 20 20 20 dicap).
8aa0: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
8ab0: 6e 74 2d 65 72 72 20 22 73 79 6e 74 68 65 74 69 nt-err "syntheti
8ac0: 63 20 73 79 6e 63 20 64 65 6c 61 79 20 6f 66 20 c sync delay of
8ad0: 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 "delay-handicap"
8ae0: 20 73 65 63 6f 6e 64 73 20 63 6f 6d 70 6c 65 74 seconds complet
8af0: 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ed").
8b00: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 ).
8b10: 20 0a 09 20 20 20 20 3b 3b 20 66 69 72 73 74 20 .. ;; first
8b20: 70 61 73 73 20 69 6d 70 6c 65 6d 65 6e 74 61 74 pass implementat
8b30: 69 6f 6e 2c 20 6a 75 73 74 20 69 6e 73 65 72 74 ion, just insert
8b40: 20 61 6c 6c 20 63 68 61 6e 67 65 64 20 72 6f 77 all changed row
8b50: 73 0a 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 s... (for-eac
8b60: 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 h .. (lambda
8b70: 20 28 74 61 72 67 64 62 29 0a 09 20 20 20 20 20 (targdb)..
8b80: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
8b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
8ba0: 72 3a 64 62 64 61 74 2d 64 62 68 20 74 61 72 67 r:dbdat-dbh targ
8bb0: 64 62 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 db)).
8bc0: 20 20 20 20 20 20 20 20 20 20 20 28 64 72 70 2d (drp-
8bd0: 74 72 69 67 67 65 72 20 20 20 20 20 20 20 20 28 trigger (
8be0: 69 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 if (member "last
8bf0: 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e _update" field-n
8c00: 61 6d 65 73 29 0a 09 09 09 09 09 20 20 20 20 20 ames)......
8c10: 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 (db:drop-trigge
8c20: 72 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 20 r db tablename)
8c30: 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 ...... #f))
8c40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8c50: 20 20 20 20 20 20 20 28 69 73 2d 74 72 69 67 67 (is-trigg
8c60: 65 72 2d 64 72 6f 70 70 65 64 20 28 69 66 20 28 er-dropped (if (
8c70: 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 member "last_upd
8c80: 61 74 65 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 ate" field-names
8c90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cc0: 28 64 62 3a 69 73 2d 74 72 69 67 67 65 72 2d 64 (db:is-trigger-d
8cd0: 72 6f 70 70 65 64 20 64 62 20 74 61 62 6c 65 6e ropped db tablen
8ce0: 61 6d 65 29 0a 09 09 09 09 09 20 20 20 20 20 20 ame)......
8cf0: 23 66 29 29 20 0a 09 09 20 20 20 20 20 20 28 73 #f)) ... (s
8d00: 74 6d 74 68 20 20 28 73 71 6c 69 74 65 33 3a 70 tmth (sqlite3:p
8d10: 72 65 70 61 72 65 20 64 62 20 66 75 6c 6c 2d 69 repare db full-i
8d20: 6e 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ns)).
8d30: 20 20 20 20 20 20 20 20 20 20 20 28 63 68 61 6e (chan
8d40: 67 65 64 2d 72 6f 77 73 20 30 29 29 0a 09 09 20 ged-rows 0))...
8d50: 3b 3b 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d ;; (db:delay-if-
8d60: 62 75 73 79 20 74 61 72 67 64 62 29 20 3b 3b 20 busy targdb) ;;
8d70: 4e 4f 20 57 41 49 54 49 4e 47 0a 20 20 20 20 20 NO WAITING.
8d80: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
8d90: 69 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 if (member "last
8da0: 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e _update" field-n
8db0: 61 6d 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 ames).
8dc0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 64 62 ;; (db
8dd0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
8de0: 69 73 2d 74 72 69 67 67 65 72 2d 64 72 6f 70 70 is-trigger-dropp
8df0: 65 64 3a 20 22 20 69 73 2d 74 72 69 67 67 65 72 ed: " is-trigger
8e00: 2d 64 72 6f 70 70 65 64 29 29 20 0a 0a 09 09 20 -dropped)) ....
8e10: 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c (for-each... (l
8e20: 61 6d 62 64 61 20 28 66 72 6f 6d 64 61 74 2d 6c ambda (fromdat-l
8e30: 73 74 29 0a 09 09 20 20 20 20 28 73 71 6c 69 74 st)... (sqlit
8e40: 65 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 63 74 e3:with-transact
8e50: 69 6f 6e 0a 09 09 20 20 20 20 20 64 62 0a 09 09 ion... db...
8e60: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
8e70: 09 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 .. (for-ea
8e80: 63 68 20 3b 3b 20 0a 09 09 09 28 6c 61 6d 62 64 ch ;; ....(lambd
8e90: 61 20 28 66 72 6f 6d 72 6f 77 29 0a 09 09 09 20 a (fromrow)....
8ea0: 20 28 6c 65 74 2a 20 28 28 61 20 20 20 20 28 76 (let* ((a (v
8eb0: 65 63 74 6f 72 2d 72 65 66 20 66 72 6f 6d 72 6f ector-ref fromro
8ec0: 77 20 30 29 29 0a 09 09 09 09 20 28 63 75 72 72 w 0))..... (curr
8ed0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8ee0: 2f 64 65 66 61 75 6c 74 20 74 6f 64 61 74 20 61 /default todat a
8ef0: 20 23 66 29 29 0a 09 09 09 09 20 28 73 61 6d 65 #f))..... (same
8f00: 20 23 74 29 29 0a 09 09 09 20 20 20 20 28 6c 65 #t)).... (le
8f10: 74 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 09 t loop ((i 0))..
8f20: 09 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 .. (if (or
8f30: 28 6e 6f 74 20 63 75 72 72 29 0a 09 09 09 09 20 (not curr).....
8f40: 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c (not (equal
8f50: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 72 ? (vector-ref fr
8f60: 6f 6d 72 6f 77 20 69 29 28 76 65 63 74 6f 72 2d omrow i)(vector-
8f70: 72 65 66 20 63 75 72 72 20 69 29 29 29 29 0a 09 ref curr i))))..
8f80: 09 09 09 20 20 28 73 65 74 21 20 73 61 6d 65 20 ... (set! same
8f90: 23 66 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 #f)).... (i
8fa0: 66 20 28 61 6e 64 20 73 61 6d 65 0a 09 09 09 09 f (and same.....
8fb0: 20 20 20 20 20 20 20 28 3c 20 69 20 28 2d 20 6e (< i (- n
8fc0: 75 6d 2d 66 69 65 6c 64 73 20 31 29 29 29 0a 09 um-fields 1)))..
8fd0: 09 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 69 20 ... (loop (+ i
8fe0: 31 29 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 1)))).... (if
8ff0: 20 28 6e 6f 74 20 73 61 6d 65 29 0a 09 09 09 09 (not same).....
9000: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 61 70 (begin..... (ap
9010: 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 ply sqlite3:exec
9020: 75 74 65 20 73 74 6d 74 68 20 28 76 65 63 74 6f ute stmth (vecto
9030: 72 2d 3e 6c 69 73 74 20 66 72 6f 6d 72 6f 77 29 r->list fromrow)
9040: 29 0a 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 )..... (hash-ta
9050: 62 6c 65 2d 73 65 74 21 20 6e 75 6d 72 65 63 73 ble-set! numrecs
9060: 20 74 61 62 6c 65 6e 61 6d 65 20 28 2b 20 31 20 tablename (+ 1
9070: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
9080: 64 65 66 61 75 6c 74 20 6e 75 6d 72 65 63 73 20 default numrecs
9090: 74 61 62 6c 65 6e 61 6d 65 20 30 29 29 29 0a 20 tablename 0))).
90a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90c0: 20 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 72 (set! changed-r
90d0: 6f 77 73 20 28 2b 20 63 68 61 6e 67 65 64 2d 72 ows (+ changed-r
90e0: 6f 77 73 20 31 29 29 0a 20 20 20 20 20 20 20 20 ows 1)).
90f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9100: 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
9130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9140: 20 20 20 20 29 29 0a 09 09 09 66 72 6f 6d 64 61 ))....fromda
9150: 74 2d 6c 73 74 29 29 29 29 0a 09 09 20 20 66 72 t-lst))))... fr
9160: 6f 6d 64 61 74 73 29 0a 0a 0a 20 20 20 20 20 20 omdats)...
9170: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
9180: 3e 20 63 68 61 6e 67 65 64 2d 72 6f 77 73 20 30 > changed-rows 0
9190: 29 0a 09 20 20 20 20 20 20 20 20 20 20 20 28 64 ).. (d
91a0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
91b0: 20 22 74 61 62 6c 65 20 22 20 74 61 62 6c 65 6e "table " tablen
91c0: 61 6d 65 20 22 20 63 68 61 6e 67 65 64 20 72 6f ame " changed ro
91d0: 77 73 3a 20 22 20 63 68 61 6e 67 65 64 2d 72 6f ws: " changed-ro
91e0: 77 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ws).
91f0: 20 20 20 20 20 29 0a 0a 0a 09 09 20 28 73 71 6c )..... (sql
9200: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 73 ite3:finalize! s
9210: 74 6d 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 tmth).
9220: 20 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 (if (memb
9230: 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 er "last_update"
9240: 20 66 69 65 6c 64 2d 6e 61 6d 65 73 29 0a 20 20 field-names).
9250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9260: 20 20 28 64 62 3a 63 72 65 61 74 65 2d 74 72 69 (db:create-tri
9270: 67 67 65 72 20 64 62 20 74 61 62 6c 65 6e 61 6d gger db tablenam
9280: 65 29 29 29 29 0a 09 20 20 20 20 20 28 61 70 70 e)))).. (app
9290: 65 6e 64 20 28 6c 69 73 74 20 74 6f 64 62 29 20 end (list todb)
92a0: 73 6c 61 76 65 2d 64 62 73 29 0a 20 20 20 20 20 slave-dbs).
92b0: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
92c0: 20 20 29 0a 20 20 20 20 20 20 20 20 29 0a 09 74 ). )..t
92d0: 62 6c 73 29 0a 20 20 20 20 20 20 20 28 6c 65 74 bls). (let
92e0: 2a 20 28 28 72 75 6e 74 69 6d 65 20 20 20 20 20 * ((runtime
92f0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (- (current-mil
9300: 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 liseconds) start
9310: 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 20 20 28 -time)).. (
9320: 73 68 6f 75 6c 64 2d 70 72 69 6e 74 20 28 6f 72 should-print (or
9330: 20 3b 3b 20 28 64 65 62 75 67 3a 64 65 62 75 67 ;; (debug:debug
9340: 2d 6d 6f 64 65 20 31 32 29 0a 09 09 09 09 28 63 -mode 12).....(c
9350: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
9360: 70 72 69 6e 74 20 31 32 30 20 22 64 62 20 73 79 print 120 "db sy
9370: 6e 63 22 20 28 3e 20 72 75 6e 74 69 6d 65 20 35 nc" (> runtime 5
9380: 30 30 29 29 29 29 29 20 3b 3b 20 6c 6f 77 20 61 00))))) ;; low a
9390: 6e 64 20 68 69 67 68 20 73 79 6e 63 20 74 69 6d nd high sync tim
93a0: 65 73 20 74 72 65 61 74 65 64 20 61 73 20 73 65 es treated as se
93b0: 70 61 72 61 74 65 2e 0a 09 20 28 69 66 20 73 68 parate... (if sh
93c0: 6f 75 6c 64 2d 70 72 69 6e 74 20 28 64 62 66 69 ould-print (dbfi
93d0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 49 le:print-err "I
93e0: 4e 46 4f 3a 20 64 62 20 73 79 6e 63 2c 20 74 6f NFO: db sync, to
93f0: 74 61 6c 20 72 75 6e 20 74 69 6d 65 20 22 20 72 tal run time " r
9400: 75 6e 74 69 6d 65 20 22 20 6d 73 22 29 29 0a 09 untime " ms"))..
9410: 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 28 (for-each .. (
9420: 6c 61 6d 62 64 61 20 28 64 61 74 29 0a 09 20 20 lambda (dat)..
9430: 20 20 28 6c 65 74 20 28 28 74 62 6c 6e 61 6d 65 (let ((tblname
9440: 20 28 63 61 72 20 64 61 74 29 29 0a 09 09 20 20 (car dat))...
9450: 28 63 6f 75 6e 74 20 20 20 28 63 64 72 20 64 61 (count (cdr da
9460: 74 29 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 t))).. (set
9470: 21 20 74 6f 74 2d 63 6f 75 6e 74 20 28 2b 20 74 ! tot-count (+ t
9480: 6f 74 2d 63 6f 75 6e 74 20 63 6f 75 6e 74 29 29 ot-count count))
9490: 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 63 .. (if (> c
94a0: 6f 75 6e 74 20 30 29 0a 09 09 20 20 28 69 66 20 ount 0)... (if
94b0: 73 68 6f 75 6c 64 2d 70 72 69 6e 74 20 28 64 62 should-print (db
94c0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
94d0: 46 49 58 4d 45 3a 20 74 62 6c 6e 61 6d 65 3a 20 FIXME: tblname:
94e0: 22 20 74 62 6c 6e 61 6d 65 22 2c 20 63 6f 75 6e " tblname", coun
94f0: 74 3a 20 22 63 6f 75 6e 74 22 20 22 29 29 29 29 t: "count" "))))
9500: 29 20 3b 3b 20 28 66 6f 72 6d 61 74 20 23 66 20 ) ;; (format #f
9510: 22 20 20 20 20 7e 31 30 61 20 7e 35 61 22 20 74 " ~10a ~5a" t
9520: 62 6c 6e 61 6d 65 20 63 6f 75 6e 74 29 29 29 29 blname count))))
9530: 29 29 0a 09 20 20 28 73 6f 72 74 20 28 68 61 73 )).. (sort (has
9540: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 6e h-table->alist n
9550: 75 6d 72 65 63 73 29 28 6c 61 6d 62 64 61 20 28 umrecs)(lambda (
9560: 61 20 62 29 28 3e 20 28 63 64 72 20 61 29 28 63 a b)(> (cdr a)(c
9570: 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 20 dr b)))))).
9580: 20 20 74 6f 74 2d 63 6f 75 6e 74 29 29 29 29 29 tot-count)))))
9590: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
95a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 72 ==========.;; tr
95e0: 69 67 67 65 72 20 73 65 74 75 70 2f 74 61 6b 65 igger setup/take
95f0: 64 6f 77 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d down.;;=========
9600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
9640: 64 65 66 69 6e 65 20 64 62 3a 74 72 69 67 67 65 define db:trigge
9650: 72 2d 6c 69 73 74 20 0a 20 20 20 20 20 28 6c 69 r-list . (li
9660: 73 74 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 st (list "update
9670: 5f 72 75 6e 73 5f 74 72 69 67 67 65 72 22 20 20 _runs_trigger"
9680: 22 43 52 45 41 54 45 20 54 52 49 47 47 45 52 20 "CREATE TRIGGER
9690: 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 70 IF NOT EXISTS up
96a0: 64 61 74 65 5f 72 75 6e 73 5f 74 72 69 67 67 65 date_runs_trigge
96b0: 72 20 41 46 54 45 52 20 55 50 44 41 54 45 20 4f r AFTER UPDATE O
96c0: 4e 20 72 75 6e 73 0a 20 20 20 20 20 20 20 20 20 N runs.
96d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96e0: 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f 57 FOR EACH ROW
96f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9710: 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 20 BEGIN .
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9730: 20 20 20 20 20 20 20 20 55 50 44 41 54 45 20 72 UPDATE r
9740: 75 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 70 64 uns SET last_upd
9750: 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 27 25 ate=(strftime('%
9760: 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 s','now')).
9770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 57 48 WH
9790: 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 ERE id=old.id;.
97a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45 4e EN
97c0: 44 3b 22 20 29 20 0a 09 20 20 20 28 6c 69 73 74 D;" ) .. (list
97d0: 20 22 75 70 64 61 74 65 5f 72 75 6e 5f 73 74 61 "update_run_sta
97e0: 74 73 5f 74 72 69 67 67 65 72 22 20 20 22 43 52 ts_trigger" "CR
97f0: 45 41 54 45 20 54 52 49 47 47 45 52 20 20 49 46 EATE TRIGGER IF
9800: 20 4e 4f 54 20 45 58 49 53 54 53 20 75 70 64 61 NOT EXISTS upda
9810: 74 65 5f 72 75 6e 5f 73 74 61 74 73 5f 74 72 69 te_run_stats_tri
9820: 67 67 65 72 20 41 46 54 45 52 20 55 50 44 41 54 gger AFTER UPDAT
9830: 45 20 4f 4e 20 72 75 6e 5f 73 74 61 74 73 0a 20 E ON run_stats.
9840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9850: 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 FOR
9860: 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 EACH ROW.
9870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9880: 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a 20 BEGIN .
9890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98b0: 55 50 44 41 54 45 20 72 75 6e 5f 73 74 61 74 73 UPDATE run_stats
98c0: 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 SET last_update
98d0: 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c =(strftime('%s',
98e0: 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 'now')).
98f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9900: 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 45 WHERE
9910: 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 id=old.id;.
9920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9930: 20 20 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 END;"
9940: 20 29 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 ).. (list "up
9950: 64 61 74 65 5f 74 65 73 74 73 5f 74 72 69 67 67 date_tests_trigg
9960: 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 er" "CREATE TRI
9970: 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 GGER IF NOT EXI
9980: 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 73 STS update_tests
9990: 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 55 _trigger AFTER U
99a0: 50 44 41 54 45 20 4f 4e 20 74 65 73 74 73 0a 20 PDATE ON tests.
99b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99c0: 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 FOR
99d0: 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 EACH ROW.
99e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99f0: 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a 20 BEGIN .
9a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a20: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
9a30: 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 last_update=(st
9a40: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
9a50: 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ')).
9a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a70: 20 20 20 20 20 20 20 57 48 45 52 45 20 69 64 3d WHERE id=
9a80: 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 old.id;.
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9aa0: 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 0a 09 END;" )..
9ab0: 20 20 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 (list "update
9ac0: 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 _teststeps_trigg
9ad0: 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 er" "CREATE TRI
9ae0: 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 GGER IF NOT EXI
9af0: 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 73 STS update_tests
9b00: 74 65 70 73 5f 74 72 69 67 67 65 72 20 41 46 54 teps_trigger AFT
9b10: 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 ER UPDATE ON tes
9b20: 74 5f 73 74 65 70 73 0a 20 20 20 20 20 20 20 20 t_steps.
9b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b40: 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f FOR EACH RO
9b50: 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 W.
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b70: 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 BEGIN .
9b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b90: 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 20 UPDATE
9ba0: 74 65 73 74 5f 73 74 65 70 73 20 53 45 54 20 6c test_steps SET l
9bb0: 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 ast_update=(strf
9bc0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
9bd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bf0: 20 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c WHERE id=ol
9c00: 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 d.id;.
9c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c20: 20 20 20 20 20 45 4e 44 3b 22 20 29 0a 09 20 20 END;" )..
9c30: 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 5f 74 (list "update_t
9c40: 65 73 74 5f 64 61 74 61 5f 74 72 69 67 67 65 72 est_data_trigger
9c50: 22 20 20 22 43 52 45 41 54 45 20 54 52 49 47 47 " "CREATE TRIGG
9c60: 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 53 54 ER IF NOT EXIST
9c70: 53 20 75 70 64 61 74 65 5f 74 65 73 74 5f 64 61 S update_test_da
9c80: 74 61 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 ta_trigger AFTER
9c90: 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 74 5f UPDATE ON test_
9ca0: 64 61 74 61 0a 20 20 20 20 20 20 20 20 20 20 20 data.
9cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cc0: 20 20 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 FOR EACH ROW.
9cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42 45 BE
9cf0: 47 49 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 GIN .
9d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d10: 20 20 20 20 20 20 55 50 44 41 54 45 20 74 65 73 UPDATE tes
9d20: 74 5f 64 61 74 61 20 53 45 54 20 6c 61 73 74 5f t_data SET last_
9d30: 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 update=(strftime
9d40: 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 ('%s','now')).
9d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d70: 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 WHERE id=old.id
9d80: 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;.
9d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9da0: 20 45 4e 44 3b 22 20 29 29 29 0a 3b 3b 0a 3b 3b END;" ))).;;.;;
9db0: 20 41 44 44 20 72 75 6e 2d 69 64 20 53 55 50 50 ADD run-id SUPP
9dc0: 4f 52 54 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ORT.;;.(define (
9dd0: 64 62 3a 63 72 65 61 74 65 2d 61 6c 6c 2d 74 72 db:create-all-tr
9de0: 69 67 67 65 72 73 20 64 62 73 74 72 75 63 74 29 iggers dbstruct)
9df0: 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 . (db:with-db.
9e00: 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 66 dbstruct #f #f
9e10: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 64 . (lambda (dbd
9e20: 61 74 20 64 62 29 0a 20 20 20 20 20 28 64 62 3a at db). (db:
9e30: 63 72 65 61 74 65 2d 74 72 69 67 67 65 72 73 20 create-triggers
9e40: 64 62 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 db))))..(define
9e50: 28 64 62 3a 63 72 65 61 74 65 2d 74 72 69 67 67 (db:create-trigg
9e60: 65 72 73 20 64 62 29 0a 20 20 20 20 28 66 6f 72 ers db). (for
9e70: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
9e80: 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ey).
9e90: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
9ea0: 74 65 20 64 62 20 28 63 61 64 72 20 6b 65 79 29 te db (cadr key)
9eb0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 64 62 3a )). db:
9ec0: 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 0a 0a trigger-list))..
9ed0: 28 64 65 66 69 6e 65 20 28 64 62 3a 64 72 6f 70 (define (db:drop
9ee0: 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 20 64 62 -all-triggers db
9ef0: 73 74 72 75 63 74 29 0a 20 20 28 64 62 3a 77 69 struct). (db:wi
9f00: 74 68 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 th-db. dbstruc
9f10: 74 20 23 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 t #f #f. (lamb
9f20: 64 61 20 28 64 62 64 61 74 20 64 62 29 0a 20 20 da (dbdat db).
9f30: 20 20 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 (db:drop-trig
9f40: 67 65 72 73 20 64 62 29 29 29 29 0a 0a 28 64 65 gers db))))..(de
9f50: 66 69 6e 65 20 28 64 62 3a 69 73 2d 74 72 69 67 fine (db:is-trig
9f60: 67 65 72 2d 64 72 6f 70 70 65 64 20 64 62 20 74 ger-dropped db t
9f70: 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a bl-name). (let*
9f80: 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 ((trigger-name
9f90: 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d (if (equal? tbl-
9fa0: 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 name "test_steps
9fb0: 22 29 0a 09 09 09 20 20 20 22 75 70 64 61 74 65 ").... "update
9fc0: 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 _teststeps_trigg
9fd0: 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 er" .
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ff0: 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 (conc "update_"
a000: 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 tbl-name "_trigg
a010: 65 72 22 29 29 29 0a 09 20 28 72 65 73 20 20 20 er"))).. (res
a020: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
a030: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
a040: 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 h-row. (lamb
a050: 64 61 20 28 6e 61 6d 65 29 0a 20 20 20 20 20 20 da (name).
a060: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 6e 61 6d (if (equal? nam
a070: 65 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 0a e trigger-name).
a080: 09 20 20 20 28 73 65 74 21 20 72 65 73 20 23 74 . (set! res #t
a090: 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 20 ))). db .
a0a0: 20 20 22 53 45 4c 45 43 54 20 6e 61 6d 65 20 46 "SELECT name F
a0b0: 52 4f 4d 20 73 71 6c 69 74 65 5f 6d 61 73 74 65 ROM sqlite_maste
a0c0: 72 20 57 48 45 52 45 20 74 79 70 65 20 3d 20 27 r WHERE type = '
a0d0: 74 72 69 67 67 65 72 27 20 3b 22 20 0a 20 20 20 trigger' ;" .
a0e0: 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))..(define (
a0f0: 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 72 73 db:drop-triggers
a100: 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 db). (for-each
a110: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 . (lambda (key
a120: 29 20 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 ) . (sqlite3
a130: 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e :execute db (con
a140: 63 20 22 64 72 6f 70 20 74 72 69 67 67 65 72 20 c "drop trigger
a150: 69 66 20 65 78 69 73 74 73 20 22 20 28 63 61 72 if exists " (car
a160: 20 6b 65 79 29 29 29 29 0a 20 20 20 64 62 3a 74 key)))). db:t
a170: 72 69 67 67 65 72 2d 6c 69 73 74 29 29 0a 0a 28 rigger-list))..(
a180: 64 65 66 69 6e 65 20 20 28 64 62 3a 64 72 6f 70 define (db:drop
a190: 2d 74 72 69 67 67 65 72 20 64 62 20 74 62 6c 2d -trigger db tbl-
a1a0: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 name). (let* ((
a1b0: 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 28 69 66 trigger-name (if
a1c0: 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d 6e 61 6d (equal? tbl-nam
a1d0: 65 20 22 74 65 73 74 5f 73 74 65 70 73 22 29 0a e "test_steps").
a1e0: 09 09 09 20 20 20 22 75 70 64 61 74 65 5f 74 65 ... "update_te
a1f0: 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 72 22 ststeps_trigger"
a200: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a210: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
a220: 6e 63 20 22 75 70 64 61 74 65 5f 22 20 74 62 6c nc "update_" tbl
a230: 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 65 72 22 -name "_trigger"
a240: 29 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 )))). (for-ea
a250: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
a260: 28 6b 65 79 29 20 0a 20 20 20 20 20 20 20 28 69 (key) . (i
a270: 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 20 6b f (equal? (car k
a280: 65 79 29 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 ey) trigger-name
a290: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 71 ). (sq
a2a0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
a2b0: 20 28 63 6f 6e 63 20 22 64 72 6f 70 20 74 72 69 (conc "drop tri
a2c0: 67 67 65 72 20 69 66 20 65 78 69 73 74 73 20 22 gger if exists "
a2d0: 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 29 29 trigger-name)))
a2e0: 29 0a 20 20 20 20 20 64 62 3a 74 72 69 67 67 65 ). db:trigge
a2f0: 72 2d 6c 69 73 74 29 29 29 0a 0a 28 64 65 66 69 r-list)))..(defi
a300: 6e 65 20 20 28 64 62 3a 63 72 65 61 74 65 2d 74 ne (db:create-t
a310: 72 69 67 67 65 72 20 64 62 20 74 62 6c 2d 6e 61 rigger db tbl-na
a320: 6d 65 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 me). (let*
a330: 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 28 ((trigger-name (
a340: 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d 6e if (equal? tbl-n
a350: 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 22 ame "test_steps"
a360: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a380: 22 75 70 64 61 74 65 5f 74 65 73 74 73 74 65 70 "update_teststep
a390: 73 5f 74 72 69 67 67 65 72 22 20 0a 20 20 20 20 s_trigger" .
a3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3b0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
a3c0: 22 75 70 64 61 74 65 5f 22 20 74 62 6c 2d 6e 61 "update_" tbl-na
a3d0: 6d 65 20 22 5f 74 72 69 67 67 65 72 22 29 29 29 me "_trigger")))
a3e0: 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ). (for-ea
a3f0: 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 ch (lambda (key)
a400: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
a410: 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 20 if (equal? (car
a420: 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e 61 6d key) trigger-nam
a430: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
a440: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
a450: 20 64 62 20 28 63 61 64 72 20 6b 65 79 29 29 29 db (cadr key)))
a460: 29 0a 20 20 20 20 20 20 64 62 3a 74 72 69 67 67 ). db:trigg
a470: 65 72 2d 6c 69 73 74 29 29 29 20 0a 0a 3b 3b 3d er-list))) ..;;=
a480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4c0: 3d 3d 3d 3d 3d 0a 3b 3b 20 64 62 20 61 63 63 65 =====.;; db acce
a4d0: 73 73 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d 3d ss stuff.;;=====
a4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a520: 3d 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 20 =..;; call with
a530: 64 62 69 6e 69 74 3d 64 62 3a 69 6e 69 74 69 61 dbinit=db:initia
a540: 6c 69 7a 65 2d 6d 61 69 6e 2d 64 62 0a 3b 3b 0a lize-main-db.;;.
a550: 28 64 65 66 69 6e 65 20 28 64 62 3a 6f 70 65 6e (define (db:open
a560: 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e -db dbstruct run
a570: 2d 69 64 20 64 62 69 6e 69 74 29 0a 20 20 28 6c -id dbinit). (l
a580: 65 74 2a 20 28 28 64 62 64 61 74 20 28 64 62 66 et* ((dbdat (dbf
a590: 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 ile:open-db dbst
a5a0: 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 69 6e ruct run-id dbin
a5b0: 69 74 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 it))). (set!
a5c0: 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 65 73 73 *db-write-access
a5d0: 2a 20 28 6e 6f 74 20 28 64 62 72 3a 64 62 64 61 * (not (dbr:dbda
a5e0: 74 2d 72 65 61 64 2d 6f 6e 6c 79 20 64 62 64 61 t-read-only dbda
a5f0: 74 29 29 29 0a 20 20 20 20 64 62 64 61 74 29 29 t))). dbdat))
a600: 0a 0a 28 64 65 66 69 6e 65 20 64 62 66 69 6c 65 ..(define dbfile
a610: 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 20 28 6d :db-init-proc (m
a620: 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 23 66 ake-parameter #f
a630: 29 29 0a 0a 3b 3b 20 28 64 62 3a 77 69 74 68 2d ))..;; (db:with-
a640: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
a650: 69 64 20 73 71 6c 69 74 65 33 3a 65 78 65 63 20 id sqlite3:exec
a660: 22 73 65 6c 65 63 74 20 62 6c 61 68 20 66 67 72 "select blah fgr
a670: 6f 6d 20 62 6c 61 7a 3b 22 29 0a 3b 3b 20 72 2f om blaz;").;; r/
a680: 77 20 69 73 20 61 20 66 6c 61 67 20 74 6f 20 69 w is a flag to i
a690: 6e 64 69 63 61 74 65 20 69 66 20 74 68 65 20 64 ndicate if the d
a6a0: 62 20 69 73 20 6d 6f 64 69 66 69 65 64 20 62 79 b is modified by
a6b0: 20 74 68 69 73 20 71 75 65 72 79 20 23 74 20 3d this query #t =
a6c0: 20 79 65 73 2c 20 23 66 20 3d 20 6e 6f 0a 3b 3b yes, #f = no.;;
a6d0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 77 69 74 .(define (db:wit
a6e0: 68 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 h-db dbstruct ru
a6f0: 6e 2d 69 64 20 72 2f 77 20 70 72 6f 63 20 2e 20 n-id r/w proc .
a700: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
a710: 28 28 68 61 76 65 2d 73 74 72 75 63 74 20 28 64 ((have-struct (d
a720: 62 72 3a 64 62 73 74 72 75 63 74 3f 20 64 62 73 br:dbstruct? dbs
a730: 74 72 75 63 74 29 29 0a 20 20 20 20 20 20 20 20 truct)).
a740: 20 28 64 62 64 61 74 20 20 20 20 20 28 69 66 20 (dbdat (if
a750: 68 61 76 65 2d 73 74 72 75 63 74 20 20 20 20 20 have-struct
a760: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 ;; th
a770: 69 73 20 73 74 75 66 66 20 6a 75 73 74 20 61 6c is stuff just al
a780: 6c 6f 77 73 20 75 73 20 74 6f 20 63 61 6c 6c 20 lows us to call
a790: 77 69 74 68 20 61 20 64 62 20 68 61 6e 64 6c 65 with a db handle
a7a0: 20 64 69 72 65 63 74 6c 79 0a 09 09 09 28 64 62 directly....(db
a7b0: 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 :open-db dbstruc
a7c0: 74 20 72 75 6e 2d 69 64 20 28 64 62 66 69 6c 65 t run-id (dbfile
a7d0: 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 29 29 20 :db-init-proc))
a7e0: 3b 3b 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 ;; (dbfile:get-s
a7f0: 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 ubdb dbstruct ru
a800: 6e 2d 69 64 29 0a 09 09 09 23 66 29 29 0a 09 20 n-id)....#f))..
a810: 28 64 62 20 20 20 20 20 20 20 20 28 69 66 20 68 (db (if h
a820: 61 76 65 2d 73 74 72 75 63 74 20 20 20 20 20 20 ave-struct
a830: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 69 ;; thi
a840: 73 20 73 74 75 66 66 20 6a 75 73 74 20 61 6c 6c s stuff just all
a850: 6f 77 73 20 75 73 20 74 6f 20 63 61 6c 6c 20 77 ows us to call w
a860: 69 74 68 20 61 20 64 62 20 68 61 6e 64 6c 65 20 ith a db handle
a870: 64 69 72 65 63 74 6c 79 0a 09 09 09 28 64 62 72 directly....(dbr
a880: 3a 64 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 :dbdat-dbh dbdat
a890: 29 0a 09 09 09 64 62 73 74 72 75 63 74 29 29 0a )....dbstruct)).
a8a0: 09 20 28 66 6e 61 6d 65 20 20 20 20 20 28 69 66 . (fname (if
a8b0: 20 64 62 64 61 74 0a 09 09 09 28 64 62 72 3a 64 dbdat....(dbr:d
a8c0: 62 64 61 74 2d 64 62 66 69 6c 65 20 64 62 64 61 bdat-dbfile dbda
a8d0: 74 29 0a 09 09 09 22 6e 6f 66 69 6c 65 6e 61 6d t)...."nofilenam
a8e0: 65 61 76 61 69 6c 61 62 6c 65 22 29 29 0a 09 20 eavailable"))..
a8f0: 23 3b 28 73 75 62 64 62 20 20 20 20 20 28 69 66 #;(subdb (if
a900: 20 68 61 76 65 2d 73 74 72 75 63 74 0a 09 09 09 have-struct....
a910: 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 (dbfile:get-subd
a920: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
a930: 64 29 0a 09 09 09 23 66 29 29 0a 09 20 28 75 73 d)....#f)).. (us
a940: 65 2d 6d 75 74 65 78 20 28 3e 20 2a 61 70 69 2d e-mutex (> *api-
a950: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d process-request-
a960: 63 6f 75 6e 74 2a 20 32 35 29 29 29 20 3b 3b 20 count* 25))) ;;
a970: 77 61 73 20 32 35 0a 20 20 20 20 28 69 66 20 28 was 25. (if (
a980: 61 6e 64 20 75 73 65 2d 6d 75 74 65 78 0a 09 20 and use-mutex..
a990: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (common:low-
a9a0: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 noise-print 120
a9b0: 22 6f 76 65 72 2d 35 30 2d 70 61 72 61 6c 6c 65 "over-50-paralle
a9c0: 6c 2d 61 70 69 2d 72 65 71 75 65 73 74 73 22 29 l-api-requests")
a9d0: 29 0a 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 )..(dbfile:print
a9e0: 2d 65 72 72 20 2a 61 70 69 2d 70 72 6f 63 65 73 -err *api-proces
a9f0: 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a s-request-count*
aa00: 20 22 20 70 61 72 61 6c 6c 65 6c 20 61 70 69 20 " parallel api
aa10: 72 65 71 75 65 73 74 73 20 62 65 69 6e 67 20 70 requests being p
aa20: 72 6f 63 65 73 73 65 64 20 69 6e 20 70 72 6f 63 rocessed in proc
aa30: 65 73 73 20 22 20 28 63 75 72 72 65 6e 74 2d 70 ess " (current-p
aa40: 72 6f 63 65 73 73 2d 69 64 29 20 22 2c 20 74 68 rocess-id) ", th
aa50: 72 6f 74 74 6c 69 6e 67 20 61 63 63 65 73 73 22 rottling access"
aa60: 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
aa70: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
aa80: 6e 74 20 36 30 30 20 28 63 6f 6e 63 20 22 70 61 nt 600 (conc "pa
aa90: 72 61 6c 6c 65 6c 2d 61 70 69 2d 72 65 71 75 65 rallel-api-reque
aaa0: 73 74 73 22 20 2a 6d 61 78 2d 61 70 69 2d 70 72 sts" *max-api-pr
aab0: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 73 2a 29 ocess-requests*)
aac0: 29 0a 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 )..(dbfile:print
aad0: 2d 65 72 72 20 22 50 61 72 61 6c 6c 65 6c 20 61 -err "Parallel a
aae0: 70 69 20 72 65 71 75 65 73 74 20 63 6f 75 6e 74 pi request count
aaf0: 3a 20 22 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 : " *api-process
ab00: 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 -request-count*
ab10: 22 20 6d 61 78 20 70 61 72 61 6c 6c 65 6c 20 72 " max parallel r
ab20: 65 71 75 65 73 74 73 3a 20 22 20 2a 6d 61 78 2d equests: " *max-
ab30: 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 api-process-requ
ab40: 65 73 74 73 2a 29 29 0a 20 20 20 20 28 63 6f 6e ests*)). (con
ab50: 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 28 62 65 dition-case..(be
ab60: 67 69 6e 0a 09 20 20 28 69 66 20 75 73 65 2d 6d gin.. (if use-m
ab70: 75 74 65 78 20 28 6d 75 74 65 78 2d 6c 6f 63 6b utex (mutex-lock
ab80: 21 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d 6d 75 ! *db-with-db-mu
ab90: 74 65 78 2a 29 29 0a 09 20 20 28 6c 65 74 20 28 tex*)).. (let (
aba0: 28 72 65 73 20 28 61 70 70 6c 79 20 70 72 6f 63 (res (apply proc
abb0: 20 64 62 64 61 74 20 64 62 20 70 61 72 61 6d 73 dbdat db params
abc0: 29 29 29 0a 09 20 20 20 20 28 69 66 20 75 73 65 ))).. (if use
abd0: 2d 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 75 6e -mutex (mutex-un
abe0: 6c 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 lock! *db-with-d
abf0: 62 2d 6d 75 74 65 78 2a 29 29 0a 09 20 20 20 20 b-mutex*))..
ac00: 3b 3b 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 ;; (if (vector?
ac10: 64 62 73 74 72 75 63 74 29 28 64 62 3a 64 6f 6e dbstruct)(db:don
ac20: 65 2d 77 69 74 68 20 64 62 73 74 72 75 63 74 20 e-with dbstruct
ac30: 72 75 6e 2d 69 64 20 72 2f 77 29 29 0a 09 20 20 run-id r/w))..
ac40: 20 20 28 69 66 20 64 62 64 61 74 0a 09 09 28 64 (if dbdat...(d
ac50: 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 bfile:add-dbdat
ac60: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
ac70: 64 62 64 61 74 29 29 0a 09 20 20 20 20 72 65 73 dbdat)).. res
ac80: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 69 )). (exn (i
ac90: 6f 2d 65 72 72 6f 72 29 0a 09 20 20 20 28 64 62 o-error).. (db
aca0: 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 :generic-error-p
acb0: 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 rintout exn "ERR
acc0: 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 OR: i/o error wi
acd0: 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 th " fname ". Ch
ace0: 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c eck permissions,
acf0: 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e disk space etc.
ad00: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 and try again."
ad10: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 63 )). (exn (c
ad20: 6f 72 72 75 70 74 29 0a 09 20 20 20 28 64 62 3a orrupt).. (db:
ad30: 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 generic-error-pr
ad40: 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f intout exn "ERRO
ad50: 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e R: database " fn
ad60: 61 6d 65 20 22 20 69 73 20 63 6f 72 72 75 70 74 ame " is corrupt
ad70: 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 70 . Repair it to p
ad80: 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 20 20 20 roceed.")).
ad90: 20 28 65 78 6e 20 28 62 75 73 79 29 0a 09 20 20 (exn (busy)..
ada0: 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 (db:generic-err
adb0: 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 or-printout exn
adc0: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
add0: 20 22 20 66 6e 61 6d 65 0a 09 09 09 09 20 20 20 " fname.....
ade0: 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 " is locked.
adf0: 54 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 Try copying to a
ae00: 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c nother location,
ae10: 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c remove original
ae20: 20 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 and copy back."
ae30: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 70 )). (exn (p
ae40: 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 3a 67 65 ermission)(db:ge
ae50: 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e neric-error-prin
ae60: 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a tout exn "ERROR:
ae70: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
ae80: 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 e " has some per
ae90: 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d missions problem
aea0: 2e 22 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 .")). (exn
aeb0: 28 29 0a 09 20 20 20 28 64 62 3a 67 65 6e 65 72 ().. (db:gener
aec0: 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 ic-error-printou
aed0: 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e t exn "ERROR: Un
aee0: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 known error with
aef0: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
af00: 65 20 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 e " message: "..
af10: 09 09 09 20 20 20 20 20 20 28 28 63 6f 6e 64 69 ... ((condi
af20: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
af30: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
af40: 73 61 67 65 29 20 65 78 6e 29 29 29 29 29 29 0a sage) exn)))))).
af50: 20 20 20 20 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ..;;======
af60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
afa0: 0a 3b 3b 20 66 69 6c 65 20 75 74 69 6c 73 0a 3b .;; file utils.;
afb0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
afc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
afd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
afe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aff0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
b000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b040: 3d 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 =.;; lazy-safe g
b050: 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 et file mod time
b060: 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 . on any error (
b070: 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e file not existin
b080: 67 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 g etc.) return 0
b090: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 .;;.(define (dbf
b0a0: 69 6c 65 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 ile:lazy-modific
b0b0: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
b0c0: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
b0d0: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e ptions. exn
b0e0: 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 . (begin.
b0f0: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
b100: 65 72 72 20 22 46 61 69 6c 65 64 20 74 6f 20 67 err "Failed to g
b110: 65 74 20 6d 6f 64 69 66 69 63 61 74 69 6f 6e 20 et modification
b120: 74 69 6d 65 20 66 6f 72 20 22 20 66 70 61 74 68 time for " fpath
b130: 20 22 2c 20 74 72 65 61 74 69 6e 67 20 69 74 20 ", treating it
b140: 61 73 20 7a 65 72 6f 2e 20 65 78 6e 3d 22 20 65 as zero. exn=" e
b150: 78 6e 29 0a 20 20 20 20 20 20 30 29 0a 20 20 20 xn). 0).
b160: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
b170: 73 3f 20 66 70 61 74 68 29 0a 09 28 66 69 6c 65 s? fpath)..(file
b180: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
b190: 6d 65 20 66 70 61 74 68 29 0a 09 30 29 29 29 0a me fpath)..0))).
b1a0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
b1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 69 6e =========.;; fin
b1f0: 64 20 74 69 6d 65 73 74 61 6d 70 20 6f 66 20 6e d timestamp of n
b200: 65 77 65 73 74 20 66 69 6c 65 20 61 73 73 6f 63 ewest file assoc
b210: 69 61 74 65 64 20 77 69 74 68 20 61 20 73 71 6c iated with a sql
b220: 69 74 65 20 64 62 20 66 69 6c 65 0a 28 64 65 66 ite db file.(def
b230: 69 6e 65 20 28 64 62 66 69 6c 65 3a 6c 61 7a 79 ine (dbfile:lazy
b240: 2d 73 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 69 66 -sqlite-db-modif
b250: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 ication-time fpa
b260: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 67 6c th). (let* ((gl
b270: 6f 62 2d 6c 69 73 74 20 28 68 61 6e 64 6c 65 2d ob-list (handle-
b280: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 65 78 exceptions....ex
b290: 6e 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e n... (begin
b2a0: 0a 09 09 09 28 64 62 66 69 6c 65 3a 70 72 69 6e ....(dbfile:prin
b2b0: 74 2d 65 72 72 20 22 46 61 69 6c 65 64 20 74 6f t-err "Failed to
b2c0: 20 67 6c 6f 62 20 22 20 66 70 61 74 68 20 22 2a glob " fpath "*
b2d0: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
b2e0: 60 28 2c 28 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 `(,(conc "/no/su
b2f0: 63 68 2f 66 69 6c 65 2c 20 6d 65 73 73 61 67 65 ch/file, message
b300: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
b310: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
b320: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
b330: 20 65 78 6e 29 29 29 29 0a 09 09 20 20 20 20 20 exn))))...
b340: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 66 70 61 (glob (conc fpa
b350: 74 68 20 22 2a 22 29 29 29 29 0a 20 20 20 20 20 th "*")))).
b360: 20 20 20 20 28 66 69 6c 65 2d 6c 69 73 74 20 28 (file-list (
b370: 69 66 20 28 65 71 3f 20 30 20 28 6c 65 6e 67 74 if (eq? 0 (lengt
b380: 68 20 67 6c 6f 62 2d 6c 69 73 74 29 29 0a 09 09 h glob-list))...
b390: 09 27 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c .'("/no/such/fil
b3a0: 65 22 29 0a 09 09 09 67 6c 6f 62 2d 6c 69 73 74 e")....glob-list
b3b0: 29 29 29 0a 20 20 28 61 70 70 6c 79 20 6d 61 78 ))). (apply max
b3c0: 0a 09 20 28 6d 61 70 0a 09 20 20 64 62 66 69 6c .. (map.. dbfil
b3d0: 65 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 e:lazy-modificat
b3e0: 69 6f 6e 2d 74 69 6d 65 20 0a 09 20 20 66 69 6c ion-time .. fil
b3f0: 65 2d 6c 69 73 74 29 29 29 29 0a 0a 3b 3b 20 64 e-list))))..;; d
b400: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 ot-locking egg s
b410: 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b eems not to work
b420: 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 , using this for
b430: 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 now.;; if lock
b440: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 is older than ex
b450: 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 pire-time then r
b460: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 emove it and try
b470: 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 again.;; to get
b480: 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 the lock.;;.(de
b490: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 69 6d fine (dbfile:sim
b4a0: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e ple-file-lock fn
b4b0: 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 ame #!key (expir
b4c0: 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 e-time 300)). (
b4d0: 6c 65 74 20 28 28 66 6d 6f 64 2d 74 69 6d 65 20 let ((fmod-time
b4e0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
b4f0: 6e 73 0a 09 09 20 20 20 20 20 20 20 65 78 74 0a ns... ext.
b500: 09 09 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d .. (current-
b510: 73 65 63 6f 6e 64 73 29 0a 09 09 20 20 20 20 20 seconds)...
b520: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
b530: 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 29 on-time fname)))
b540: 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d ). (if (file-
b550: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
b560: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
b570: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 66 6d 6f 64 nt-seconds) fmod
b580: 2d 74 69 6d 65 29 20 65 78 70 69 72 65 2d 74 69 -time) expire-ti
b590: 6d 65 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a me).. (begin.
b5a0: 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 . (handle-e
b5b0: 78 63 65 70 74 69 6f 6e 73 20 65 78 6e 20 23 66 xceptions exn #f
b5c0: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 (delete-file* f
b5d0: 6e 61 6d 65 29 29 09 0a 09 20 20 20 20 20 20 28 name))... (
b5e0: 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 dbfile:simple-fi
b5f0: 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 le-lock fname ex
b600: 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 pire-time: expir
b610: 65 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 23 66 e-time)).. #f
b620: 29 0a 09 28 6c 65 74 20 28 28 6b 65 79 2d 73 74 )..(let ((key-st
b630: 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 74 2d ring (conc (get-
b640: 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 28 host-name) "-" (
b650: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
b660: 69 64 29 29 29 0a 09 20 20 20 20 20 20 28 6f 75 id))).. (ou
b670: 70 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f p (open-o
b680: 75 74 70 75 74 2d 66 69 6c 65 20 66 6e 61 6d 65 utput-file fname
b690: 29 29 29 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 ))).. (with-out
b6a0: 70 75 74 2d 74 6f 2d 70 6f 72 74 0a 09 20 20 20 put-to-port..
b6b0: 20 20 20 6f 75 70 0a 09 20 20 20 20 28 6c 61 6d oup.. (lam
b6c0: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 70 bda ().. (p
b6d0: 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 rint key-string)
b6e0: 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 74 )).. (close-out
b6f0: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 20 put-port oup)..
b700: 20 23 3b 28 77 69 74 68 2d 6f 75 74 70 75 74 2d #;(with-output-
b710: 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 20 3b 3b to-file fname ;;
b720: 20 62 69 7a 61 72 72 65 2e 20 77 69 74 68 2d 6f bizarre. with-o
b730: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 64 6f utput-to-file do
b740: 65 73 20 6e 6f 74 20 73 65 65 6d 20 74 6f 20 62 es not seem to b
b750: 65 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 61 66 e cleaning up af
b760: 74 65 72 20 69 74 73 65 6c 66 2e 0a 09 20 20 20 ter itself...
b770: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 (lambda ().. (
b780: 70 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 print key-string
b790: 29 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 ))).. (thread-s
b7a0: 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 leep! 0.25).. (
b7b0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
b7c0: 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 fname).. (
b7d0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
b7e0: 73 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 s exn.
b7f0: 20 20 20 20 20 20 23 66 20 0a 20 20 20 20 20 20 #f .
b800: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d (with-
b810: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
b820: 66 6e 61 6d 65 0a 09 20 20 09 20 20 28 6c 61 6d fname.. . (lam
b830: 62 64 61 20 28 29 0a 09 09 20 20 20 20 28 65 71 bda ()... (eq
b840: 75 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 20 ual? key-string
b850: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
b860: 09 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 . #f).
b870: 20 20 29 0a 20 20 20 20 29 0a 20 20 29 0a 29 0a ). ). ).).
b880: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
b890: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
b8a0: 6b 2d 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 k-and-wait fname
b8b0: 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 #!key (expire-t
b8c0: 69 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 ime 300)). (let
b8d0: 20 28 28 65 6e 64 2d 74 69 6d 65 20 28 2b 20 65 ((end-time (+ e
b8e0: 78 70 69 72 65 2d 74 69 6d 65 20 28 63 75 72 72 xpire-time (curr
b8f0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
b900: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
b910: 67 6f 74 2d 6c 6f 63 6b 20 28 64 62 66 69 6c 65 got-lock (dbfile
b920: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
b930: 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 k fname expire-t
b940: 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 ime: expire-time
b950: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 67 6f ))). (if go
b960: 74 2d 6c 6f 63 6b 0a 09 20 20 23 74 0a 09 20 20 t-lock.. #t..
b970: 28 69 66 20 28 3e 20 65 6e 64 2d 74 69 6d 65 20 (if (> end-time
b980: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
b990: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
b9a0: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
b9b0: 21 20 33 29 0a 09 09 28 6c 6f 6f 70 20 28 64 62 ! 3)...(loop (db
b9c0: 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 file:simple-file
b9d0: 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 -lock fname expi
b9e0: 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d re-time: expire-
b9f0: 74 69 6d 65 29 29 29 0a 09 20 20 20 20 20 20 23 time))).. #
ba00: 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 f)))))..(define
ba10: 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 (dbfile:simple-f
ba20: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
ba30: 20 66 6e 61 6d 65 29 0a 20 20 28 68 61 6e 64 6c fname). (handl
ba40: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
ba50: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 20 exn. #f
ba60: 3b 3b 20 49 20 64 6f 6e 27 74 20 72 65 61 6c 6c ;; I don't reall
ba70: 79 20 63 61 72 65 20 77 68 79 20 74 68 69 73 20 y care why this
ba80: 66 61 69 6c 65 64 20 28 61 74 20 6c 65 61 73 74 failed (at least
ba90: 20 66 6f 72 20 6e 6f 77 29 0a 20 20 20 20 28 64 for now). (d
baa0: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d elete-file* fnam
bab0: 65 29 29 29 0a 0a 0a 29 0a e)))...).