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 6d 65 67 61 74 65 73 74 2f f) ;; .megatest/
06a0: 31 2e 64 62 0a 20 20 28 6d 74 64 62 66 69 6c 65 1.db. (mtdbfile
06b0: 20 20 20 20 23 66 29 20 3b 3b 20 6d 74 72 61 68 #f) ;; mtrah
06c0: 2f 2e 6d 65 67 61 74 65 73 74 2f 31 2e 64 62 0a /.megatest/1.db.
06d0: 20 20 28 6d 74 64 62 64 61 74 20 20 20 20 20 23 (mtdbdat #
06e0: 66 29 20 3b 3b 20 6f 6e 6c 79 20 6e 65 65 64 20 f) ;; only need
06f0: 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 66 6f 72 one of these for
0700: 20 73 79 6e 63 69 6e 67 0a 20 20 3b 3b 20 28 64 syncing. ;; (d
0710: 62 64 61 74 73 20 20 20 20 20 20 28 6d 61 6b 65 bdats (make
0720: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 20 3b -hash-table)) ;
0730: 3b 20 69 64 20 3d 3e 20 64 62 64 61 74 20 0a 20 ; id => dbdat .
0740: 20 28 74 6d 70 64 62 66 69 6c 65 20 20 20 23 66 (tmpdbfile #f
0750: 29 20 3b 3b 20 2f 74 6d 70 2f 2e 2e 2e 2f 2e 6d ) ;; /tmp/.../.m
0760: 65 67 61 74 65 73 74 2f 31 2e 64 62 0a 20 20 3b egatest/1.db. ;
0770: 3b 20 28 72 65 66 6e 64 62 66 69 6c 65 20 20 23 ; (refndbfile #
0780: 66 29 20 3b 3b 20 2f 74 6d 70 2f 2e 2e 2e 2f 2e f) ;; /tmp/.../.
0790: 6d 65 67 61 74 65 73 74 2f 31 2e 64 62 5f 72 65 megatest/1.db_re
07a0: 66 0a 20 20 28 64 62 73 74 61 63 6b 20 20 20 20 f. (dbstack
07b0: 20 28 6d 61 6b 65 2d 73 74 61 63 6b 29 29 20 3b (make-stack)) ;
07c0: 3b 20 73 74 61 63 6b 20 66 6f 72 20 74 6d 70 20 ; stack for tmp
07d0: 64 62 72 3a 64 62 64 61 74 2c 0a 20 20 28 68 6f dbr:dbdat,. (ho
07e0: 6d 65 68 6f 73 74 20 20 20 20 23 66 29 20 3b 3b mehost #f) ;;
07f0: 20 6e 6f 74 20 75 73 65 64 20 79 65 74 0a 20 20 not used yet.
0800: 28 6f 6e 2d 68 6f 6d 65 68 6f 73 74 20 23 66 29 (on-homehost #f)
0810: 20 3b 3b 20 6e 6f 74 20 75 73 65 64 20 79 65 74 ;; not used yet
0820: 0a 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 . (read-only
0830: 23 66 29 0a 20 20 28 6c 61 73 74 2d 73 79 6e 63 #f). (last-sync
0840: 20 20 20 30 29 0a 20 20 28 6c 61 73 74 2d 77 72 0). (last-wr
0850: 69 74 65 20 20 28 63 75 72 72 65 6e 74 2d 73 65 ite (current-se
0860: 63 6f 6e 64 73 29 29 0a 20 20 29 20 20 20 20 20 conds)). )
0870: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 67 6f ;; go
0880: 61 6c 20 69 73 20 74 6f 20 63 6f 6e 76 65 72 67 al is to converg
0890: 65 20 6f 6e 20 6f 6e 65 20 73 74 72 75 63 74 20 e on one struct
08a0: 66 6f 72 20 61 6e 20 61 72 65 61 20 62 75 74 20 for an area but
08b0: 66 6f 72 20 6e 6f 77 20 69 74 20 69 73 20 74 6f for now it is to
08c0: 6f 20 63 6f 6e 66 75 73 69 6e 67 0a 0a 3b 3b 20 o confusing..;;
08d0: 6e 65 65 64 20 74 6f 20 6b 65 65 70 20 64 62 68 need to keep dbh
08e0: 61 6e 64 6c 65 73 20 61 6e 64 20 63 61 63 68 65 andles and cache
08f0: 64 20 73 74 61 74 65 6d 65 6e 74 73 20 74 6f 67 d statements tog
0900: 65 74 68 65 72 0a 28 64 65 66 73 74 72 75 63 74 ether.(defstruct
0910: 20 64 62 72 3a 64 62 64 61 74 0a 20 20 28 64 62 dbr:dbdat. (db
0920: 66 69 6c 65 20 20 20 20 20 20 23 66 29 0a 20 20 file #f).
0930: 28 64 62 68 20 20 20 20 20 20 20 20 20 23 66 29 (dbh #f)
0940: 20 20 20 20 0a 20 20 28 73 74 6d 74 2d 63 61 63 . (stmt-cac
0950: 68 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 he (make-hash-t
0960: 61 62 6c 65 29 29 0a 20 20 28 72 65 61 64 2d 6f able)). (read-o
0970: 6e 6c 79 20 20 20 23 66 29 0a 20 20 28 62 69 72 nly #f). (bir
0980: 74 68 2d 73 65 63 20 20 20 28 63 75 72 72 65 6e th-sec (curren
0990: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 0a 28 64 t-seconds)))..(d
09a0: 65 66 69 6e 65 20 2a 64 62 73 74 72 75 63 74 2d efine *dbstruct-
09b0: 64 62 73 2a 20 23 66 29 0a 28 64 65 66 69 6e 65 dbs* #f).(define
09c0: 20 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a *db-open-mutex*
09d0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
09e0: 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 define *db-acces
09f0: 73 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d s-mutex* (make-m
0a00: 75 74 65 78 29 29 20 3b 3b 20 75 73 65 64 20 69 utex)) ;; used i
0a10: 6e 20 63 6f 6d 6d 6f 6e 2e 73 63 6d 0a 28 64 65 n common.scm.(de
0a20: 66 69 6e 65 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 fine *no-sync-db
0a30: 2a 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 * #f).(define
0a40: 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 *db-sync-in-prog
0a50: 72 65 73 73 2a 20 23 66 29 0a 28 64 65 66 69 6e ress* #f).(defin
0a60: 65 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d 6d 75 e *db-with-db-mu
0a70: 74 65 78 2a 20 20 20 20 28 6d 61 6b 65 2d 6d 75 tex* (make-mu
0a80: 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 6d tex)).(define *m
0a90: 61 78 2d 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 ax-api-process-r
0aa0: 65 71 75 65 73 74 73 2a 20 30 29 0a 28 64 65 66 equests* 0).(def
0ab0: 69 6e 65 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 ine *api-process
0ac0: 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 -request-count*
0ad0: 30 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 0).(define *db-w
0ae0: 72 69 74 65 2d 61 63 63 65 73 73 2a 20 20 20 20 rite-access*
0af0: 20 23 74 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 #t).(define *db
0b00: 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 20 20 -last-sync*
0b10: 20 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 0)
0b20: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 74 69 ;; last ti
0b30: 6d 65 20 74 68 65 20 73 79 6e 63 20 74 6f 20 6d me the sync to m
0b40: 65 67 61 74 65 73 74 2e 64 62 20 68 61 70 70 65 egatest.db happe
0b50: 6e 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d ned.(define *db-
0b60: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
0b70: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 * (make-mutex))
0b80: 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 63 74 20 ;; protect
0b90: 61 63 63 65 73 73 20 74 6f 20 2a 64 62 2d 73 79 access to *db-sy
0ba0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 2c nc-in-progress*,
0bb0: 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 0a *db-last-sync*.
0bc0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 67 65 6e .(define (db:gen
0bd0: 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 eric-error-print
0be0: 6f 75 74 20 65 78 6e 20 2e 20 6d 65 73 73 61 67 out exn . messag
0bf0: 65 29 0a 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c e). (print-call
0c00: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
0c10: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 28 error-port)). (
0c20: 61 70 70 6c 79 20 64 62 66 69 6c 65 3a 70 72 69 apply dbfile:pri
0c30: 6e 74 2d 65 72 72 20 6d 65 73 73 61 67 65 29 0a nt-err message).
0c40: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
0c50: 65 72 72 0a 20 20 20 20 22 2c 20 65 72 72 6f 72 err. ", error
0c60: 3a 20 22 20 20 20 20 20 28 28 63 6f 6e 64 69 74 : " ((condit
0c70: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
0c80: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
0c90: 61 67 65 29 20 20 20 65 78 6e 29 0a 20 20 20 20 age) exn).
0ca0: 22 2c 20 61 72 67 75 6d 65 6e 74 73 3a 20 22 20 ", arguments: "
0cb0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0cc0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
0cd0: 78 6e 20 27 61 72 67 75 6d 65 6e 74 73 29 20 65 xn 'arguments) e
0ce0: 78 6e 29 0a 20 20 20 20 22 2c 20 6c 6f 63 61 74 xn). ", locat
0cf0: 69 6f 6e 3a 20 22 20 20 28 28 63 6f 6e 64 69 74 ion: " ((condit
0d00: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
0d10: 65 73 73 6f 72 20 27 65 78 6e 20 27 6c 6f 63 61 essor 'exn 'loca
0d20: 74 69 6f 6e 29 20 20 65 78 6e 29 0a 20 20 20 20 tion) exn).
0d30: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 ))..(define (dbf
0d40: 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 6b 65 79 20 ile:run-id->key
0d50: 72 75 6e 2d 69 64 29 0a 20 20 28 6f 72 20 72 75 run-id). (or ru
0d60: 6e 2d 69 64 20 27 6d 61 69 6e 29 29 0a 0a 28 64 n-id 'main))..(d
0d70: 65 66 69 6e 65 20 28 64 62 3a 73 61 66 65 6c 79 efine (db:safely
0d80: 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 -close-sqlite3-d
0d90: 62 20 64 62 20 73 74 6d 74 2d 63 61 63 68 65 20 b db stmt-cache
0da0: 23 21 6b 65 79 20 28 74 72 79 2d 6e 75 6d 20 33 #!key (try-num 3
0db0: 29 29 0a 20 20 28 69 66 20 28 3c 3d 20 74 72 79 )). (if (<= try
0dc0: 2d 6e 75 6d 20 30 29 0a 20 20 20 20 20 20 23 66 -num 0). #f
0dd0: 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 . (handle-e
0de0: 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 65 78 6e xceptions.. exn
0df0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 ..(begin.. (pri
0e00: 6e 74 20 22 41 74 74 65 6d 70 74 20 74 6f 20 73 nt "Attempt to s
0e10: 61 66 65 6c 79 20 63 6c 6f 73 65 20 73 71 6c 69 afely close sqli
0e20: 74 65 33 20 64 62 20 66 61 69 6c 65 64 2e 20 54 te3 db failed. T
0e30: 72 79 69 6e 67 20 61 67 61 69 6e 2e 20 65 78 6e rying again. exn
0e40: 3d 22 20 65 78 6e 29 0a 09 20 20 28 74 68 72 65 =" exn).. (thre
0e50: 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 20 20 ad-sleep! 3)..
0e60: 28 73 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 (sqlite3:interru
0e70: 70 74 21 20 64 62 29 0a 09 20 20 28 64 62 3a 73 pt! db).. (db:s
0e80: 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 afely-close-sqli
0e90: 74 65 33 2d 64 62 20 64 62 20 73 74 6d 74 2d 63 te3-db db stmt-c
0ea0: 61 63 68 65 20 74 72 79 2d 6e 75 6d 3a 20 28 2d ache try-num: (-
0eb0: 20 74 72 79 2d 6e 75 6d 20 31 29 29 29 0a 09 28 try-num 1)))..(
0ec0: 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 if (sqlite3:data
0ed0: 62 61 73 65 3f 20 64 62 29 0a 09 20 20 20 20 28 base? db).. (
0ee0: 6c 65 74 2a 20 28 28 73 74 6d 74 73 20 28 61 6e let* ((stmts (an
0ef0: 64 20 73 74 6d 74 2d 63 61 63 68 65 20 28 68 61 d stmt-cache (ha
0f00: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0f10: 61 75 6c 74 20 73 74 6d 74 2d 63 61 63 68 65 20 ault stmt-cache
0f20: 64 62 20 23 66 29 29 29 29 0a 09 20 20 20 20 20 db #f))))..
0f30: 20 28 69 66 20 73 74 6d 74 73 20 28 6d 61 70 20 (if stmts (map
0f40: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
0f50: 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 ! (hash-table-va
0f60: 6c 75 65 73 20 73 74 6d 74 73 29 29 29 0a 09 20 lues stmts)))..
0f70: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 (sqlite3:fi
0f80: 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 20 20 20 nalize! db)..
0f90: 20 20 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 #t).
0fa0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
0fb0: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 (dbfile:p
0fc0: 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 61 66 rint-err "db:saf
0fd0: 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 ely-close-sqlite
0fe0: 33 2d 64 62 3a 20 22 20 64 62 20 22 20 69 73 20 3-db: " db " is
0ff0: 6e 6f 74 20 61 6e 20 73 71 6c 69 74 65 33 20 64 not an sqlite3 d
1000: 62 22 29 0a 09 20 20 20 20 20 23 66 0a 20 20 20 b").. #f.
1010: 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ).
1020: 20 20 20 29 29 29 29 0a 0a 3b 3b 20 63 6c 6f 73 ))))..;; clos
1030: 65 20 61 6c 6c 20 6f 70 65 6e 65 64 20 72 75 6e e all opened run
1040: 2d 69 64 20 64 62 73 0a 28 64 65 66 69 6e 65 20 -id dbs.(define
1050: 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 64 62 (db:close-all db
1060: 73 74 72 75 63 74 29 0a 20 20 28 69 66 20 28 64 struct). (if (d
1070: 62 72 3a 64 62 73 74 72 75 63 74 3f 20 64 62 73 br:dbstruct? dbs
1080: 74 72 75 63 74 29 0a 3b 3b 20 28 68 61 6e 64 6c truct).;; (handl
1090: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 e-exceptions.;;
10a0: 09 20 20 65 78 6e 0a 3b 3b 20 09 20 20 28 62 65 . exn.;; . (be
10b0: 67 69 6e 0a 3b 3b 20 09 20 20 20 20 28 64 65 62 gin.;; . (deb
10c0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
10d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
10e0: 41 52 4e 49 4e 47 3a 20 46 69 6e 61 6c 69 7a 69 ARNING: Finalizi
10f0: 6e 67 20 66 61 69 6c 65 64 2c 20 22 20 20 28 28 ng failed, " ((
1100: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
1110: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
1120: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 'message) exn)
1130: 22 2c 20 6e 6f 74 65 20 2d 20 65 78 6e 3d 22 20 ", note - exn="
1140: 65 78 6e 29 0a 3b 3b 20 09 20 20 20 20 28 70 72 exn).;; . (pr
1150: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 2a int-call-chain *
1160: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1170: 2a 29 29 0a 09 3b 3b 20 28 64 62 3a 73 79 6e 63 *))..;; (db:sync
1180: 2d 74 6f 75 63 68 65 64 20 64 62 73 74 72 75 63 -touched dbstruc
1190: 74 20 30 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 t 0 force-sync:
11a0: 23 74 29 20 3b 3b 20 4e 4f 2e 20 44 6f 20 6e 6f #t) ;; NO. Do no
11b0: 74 20 64 6f 20 74 68 69 73 20 68 65 72 65 2e 20 t do this here.
11c0: 49 6e 73 74 65 61 64 20 77 65 20 72 65 6c 79 20 Instead we rely
11d0: 6f 6e 20 61 20 73 65 72 76 65 72 20 74 6f 20 62 on a server to b
11e0: 65 20 73 74 61 72 74 65 64 20 77 68 65 6e 20 74 e started when t
11f0: 68 65 72 65 20 61 72 65 20 77 72 69 74 65 73 2c here are writes,
1200: 20 65 76 65 6e 20 69 66 20 74 68 65 20 73 65 72 even if the ser
1210: 76 65 72 20 69 74 73 65 6c 66 20 69 73 20 6e 6f ver itself is no
1220: 74 20 67 6f 69 6e 67 20 74 6f 20 62 65 20 75 73 t going to be us
1230: 65 64 20 61 73 20 61 20 73 65 72 76 65 72 2e 0a ed as a server..
1240: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
1250: 73 75 62 64 62 73 20 20 20 20 20 28 68 61 73 68 subdbs (hash
1260: 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 28 64 -table-values (d
1270: 62 72 3a 64 62 73 74 72 75 63 74 2d 73 75 62 64 br:dbstruct-subd
1280: 62 73 20 64 62 73 74 72 75 63 74 29 29 29 29 0a bs dbstruct)))).
1290: 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 . (for-each..
12a0: 20 28 6c 61 6d 62 64 61 20 28 73 75 62 64 62 29 (lambda (subdb)
12b0: 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 .. (let* ((t
12c0: 64 62 73 20 20 20 20 20 20 20 28 73 74 61 63 6b dbs (stack
12d0: 2d 3e 6c 69 73 74 20 28 64 62 72 3a 73 75 62 64 ->list (dbr:subd
12e0: 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 62 29 b-dbstack subdb)
12f0: 29 29 0a 09 09 20 20 20 20 28 6d 74 64 62 64 61 ))... (mtdbda
1300: 74 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d t (dbr:dbdat-
1310: 64 62 68 20 28 64 62 72 3a 73 75 62 64 62 2d 6d dbh (dbr:subdb-m
1320: 74 64 62 64 61 74 20 73 75 62 64 62 29 29 29 0a tdbdat subdb))).
1330: 09 09 20 20 20 20 23 3b 28 72 64 62 20 20 20 20 .. #;(rdb
1340: 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 (dbr:dbdat-d
1350: 62 68 20 28 64 62 72 3a 73 75 62 64 62 2d 72 65 bh (dbr:subdb-re
1360: 66 6e 64 62 20 73 75 62 64 62 29 29 29 29 0a 09 fndb subdb))))..
1370: 09 20 20 20 20 0a 09 20 20 20 20 20 20 20 28 6d . .. (m
1380: 61 70 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 ap (lambda (dbda
1390: 74 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a t)... (let*
13a0: 20 28 28 73 74 6d 74 2d 63 61 63 68 65 20 28 64 ((stmt-cache (d
13b0: 62 72 3a 64 62 64 61 74 2d 73 74 6d 74 2d 63 61 br:dbdat-stmt-ca
13c0: 63 68 65 20 64 62 64 61 74 29 29 0a 09 09 09 20 che dbdat))....
13d0: 20 20 20 20 28 64 62 68 20 20 20 20 20 20 20 20 (dbh
13e0: 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 20 (dbr:dbdat-dbh
13f0: 20 20 20 20 20 20 64 62 64 61 74 29 29 29 0a 09 dbdat)))..
1400: 09 09 28 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f ..(db:safely-clo
1410: 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 64 62 se-sqlite3-db db
1420: 68 20 73 74 6d 74 2d 63 61 63 68 65 29 29 29 0a h stmt-cache))).
1430: 09 09 20 20 20 20 74 64 62 73 29 0a 09 20 20 20 .. tdbs)..
1440: 20 20 20 20 28 64 62 3a 73 61 66 65 6c 79 2d 63 (db:safely-c
1450: 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 lose-sqlite3-db
1460: 6d 74 64 62 64 61 74 20 28 64 62 72 3a 64 62 64 mtdbdat (dbr:dbd
1470: 61 74 2d 73 74 6d 74 2d 63 61 63 68 65 20 20 28 at-stmt-cache (
1480: 64 62 72 3a 73 75 62 64 62 2d 6d 74 64 62 64 61 dbr:subdb-mtdbda
1490: 74 20 73 75 62 64 62 29 29 29 20 0a 20 20 20 20 t subdb))) .
14a0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 69 ;; (i
14b0: 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 f (sqlite3:datab
14c0: 61 73 65 3f 20 6d 64 62 29 20 28 73 71 6c 69 74 ase? mdb) (sqlit
14d0: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6d 64 62 e3:finalize! mdb
14e0: 29 29 0a 09 20 20 20 20 20 20 20 23 3b 28 64 62 )).. #;(db
14f0: 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 :safely-close-sq
1500: 6c 69 74 65 33 2d 64 62 20 72 64 62 20 23 66 29 lite3-db rdb #f)
1510: 29 29 20 3b 3b 20 73 74 6d 74 2d 63 61 63 68 65 )) ;; stmt-cache
1520: 29 29 29 29 29 20 3b 3b 20 28 69 66 20 28 73 71 ))))) ;; (if (sq
1530: 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 lite3:database?
1540: 72 64 62 29 20 28 73 71 6c 69 74 65 33 3a 66 69 rdb) (sqlite3:fi
1550: 6e 61 6c 69 7a 65 21 20 72 64 62 29 29 29 29 29 nalize! rdb)))))
1560: 29 0a 09 20 20 20 73 75 62 64 62 73 29 0a 20 20 ).. subdbs).
1570: 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 #t.
1580: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
1590: 20 20 23 66 0a 20 20 29 0a 29 0a 0a 3b 3b 20 3b #f. ).)..;; ;
15a0: 3b 20 73 65 74 20 75 70 20 61 20 73 69 6e 67 6c ; set up a singl
15b0: 65 20 64 62 20 28 65 2e 67 2e 20 6d 61 69 6e 2e e db (e.g. main.
15c0: 64 62 2c 20 31 2e 64 62 20 2e 2e 2e 20 65 74 63 db, 1.db ... etc
15d0: 2e 29 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 .).;; ;;.;; (def
15e0: 69 6e 65 20 28 64 62 3a 73 65 74 75 70 2d 64 62 ine (db:setup-db
15f0: 20 64 62 73 74 72 75 63 74 20 61 72 65 61 70 61 dbstruct areapa
1600: 74 68 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 th run-id).;;
1610: 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 20 20 (let* ((dbname
1620: 20 28 64 62 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e (db:run-id->dbn
1630: 61 6d 65 20 72 75 6e 2d 69 64 29 29 0a 3b 3b 20 ame run-id)).;;
1640: 09 20 28 64 62 73 74 72 75 63 74 20 28 68 61 73 . (dbstruct (has
1650: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1660: 75 6c 74 20 64 62 73 74 72 75 63 74 73 20 64 62 ult dbstructs db
1670: 6e 61 6d 65 20 23 66 29 29 29 0a 3b 3b 20 20 20 name #f))).;;
1680: 20 20 28 69 66 20 64 62 73 74 72 75 63 74 0a 3b (if dbstruct.;
1690: 3b 20 09 64 62 73 74 72 75 63 74 0a 3b 3b 20 09 ; .dbstruct.;; .
16a0: 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 63 74 (let* ((dbstruct
16b0: 2d 6e 65 77 20 28 6d 61 6b 65 2d 64 62 72 3a 64 -new (make-dbr:d
16c0: 62 73 74 72 75 63 74 29 29 29 0a 3b 3b 20 09 20 bstruct))).;; .
16d0: 20 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 73 (db:open-db dbs
16e0: 74 72 75 63 74 2d 6e 65 77 20 72 75 6e 2d 69 64 truct-new run-id
16f0: 20 61 72 65 61 70 61 74 68 3a 20 61 72 65 61 70 areapath: areap
1700: 61 74 68 20 64 6f 2d 73 79 6e 63 3a 20 23 74 29 ath do-sync: #t)
1710: 0a 3b 3b 20 09 20 20 28 68 61 73 68 2d 74 61 62 .;; . (hash-tab
1720: 6c 65 2d 73 65 74 21 20 64 62 73 74 72 75 63 74 le-set! dbstruct
1730: 73 20 64 62 6e 61 6d 65 20 64 62 73 74 72 75 63 s dbname dbstruc
1740: 74 2d 6e 65 77 29 0a 3b 3b 20 09 20 20 64 62 73 t-new).;; . dbs
1750: 74 72 75 63 74 2d 6e 65 77 29 29 29 29 0a 20 20 truct-new)))).
1760: 20 20 0a 3b 3b 20 3b 20 52 65 74 75 72 6e 73 20 .;; ; Returns
1770: 74 68 65 20 64 62 64 61 74 20 66 6f 72 20 61 20 the dbdat for a
1780: 70 61 72 74 69 63 75 6c 61 72 20 64 62 66 69 6c particular dbfil
1790: 65 20 69 6e 73 69 64 65 20 74 68 65 20 61 72 65 e inside the are
17a0: 61 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 a.;; ;;.;; (defi
17b0: 6e 65 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 ne (dbr:dbstruct
17c0: 2d 67 65 74 2d 64 62 64 61 74 20 64 62 73 74 72 -get-dbdat dbstr
17d0: 75 63 74 20 64 62 66 69 6c 65 29 0a 3b 3b 20 20 uct dbfile).;;
17e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
17f0: 2f 64 65 66 61 75 6c 74 20 28 64 62 72 3a 64 62 /default (dbr:db
1800: 73 74 72 75 63 74 2d 64 62 64 61 74 73 20 64 62 struct-dbdats db
1810: 73 74 72 75 63 74 29 20 64 62 66 69 6c 65 20 23 struct) dbfile #
1820: 66 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 f)).;; .;; (defi
1830: 6e 65 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 ne (dbr:dbstruct
1840: 2d 64 62 64 61 74 2d 70 75 74 21 20 64 62 73 74 -dbdat-put! dbst
1850: 72 75 63 74 20 64 62 66 69 6c 65 20 64 62 29 0a ruct dbfile db).
1860: 3b 3b 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ;; (hash-table
1870: 2d 73 65 74 21 20 28 64 62 72 3a 64 62 73 74 72 -set! (dbr:dbstr
1880: 75 63 74 2d 64 62 64 61 74 73 20 64 62 73 74 72 uct-dbdats dbstr
1890: 75 63 74 29 20 64 62 66 69 6c 65 20 64 62 29 29 uct) dbfile db))
18a0: 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;; .;; (define
18b0: 28 64 62 3a 72 75 6e 2d 69 64 2d 3e 66 69 72 73 (db:run-id->firs
18c0: 74 2d 6e 75 6d 20 72 75 6e 2d 69 64 29 0a 3b 3b t-num run-id).;;
18d0: 20 20 20 28 6c 65 74 2a 20 28 28 73 20 28 6e 75 (let* ((s (nu
18e0: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 72 75 6e mber->string run
18f0: 2d 69 64 29 29 0a 3b 3b 20 09 20 28 6c 20 28 73 -id)).;; . (l (s
1900: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 29 tring-length s))
1910: 29 0a 3b 3b 20 20 20 20 20 28 73 75 62 73 74 72 ).;; (substr
1920: 69 6e 67 20 73 20 28 2d 20 6c 20 31 29 20 6c 29 ing s (- l 1) l)
1930: 29 29 0a 0a 3b 3b 20 31 32 33 34 20 3d 3e 20 34 ))..;; 1234 => 4
1940: 2f 31 32 33 34 2e 64 62 0a 3b 3b 20 20 20 23 66 /1234.db.;; #f
1950: 20 3d 3e 20 30 2f 6d 61 69 6e 2e 64 62 0a 3b 3b => 0/main.db.;;
1960: 20 20 20 28 61 62 61 6e 64 6f 6e 65 64 20 74 68 (abandoned th
1970: 65 20 69 64 65 61 20 6f 66 20 6e 75 6d 2f 64 62 e idea of num/db
1980: 29 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 64 ).;; .(define (d
1990: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 bfile:run-id->pa
19a0: 74 68 20 61 70 61 74 68 20 72 75 6e 2d 69 64 29 th apath run-id)
19b0: 0a 20 20 28 63 6f 6e 63 20 61 70 61 74 68 22 2f . (conc apath"/
19c0: 22 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d "(dbfile:run-id-
19d0: 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 >dbname run-id))
19e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 64 )..(define (db:d
19f0: 62 6e 61 6d 65 2d 3e 70 61 74 68 20 61 70 61 74 bname->path apat
1a00: 68 20 64 62 6e 61 6d 65 29 0a 20 20 28 63 6f 6e h dbname). (con
1a10: 63 20 61 70 61 74 68 22 2f 22 64 62 6e 61 6d 65 c apath"/"dbname
1a20: 29 29 0a 0a 3b 3b 20 50 4f 54 45 4e 54 49 41 4c ))..;; POTENTIAL
1a30: 20 42 55 47 3a 20 74 68 69 73 20 69 6d 70 6c 65 BUG: this imple
1a40: 6d 65 6e 74 61 74 69 6f 6e 20 63 6f 75 6c 64 20 mentation could
1a50: 70 72 6f 64 75 63 65 20 61 20 64 62 20 66 69 6c produce a db fil
1a60: 65 20 69 66 20 72 75 6e 2d 69 64 20 69 73 20 6e e if run-id is n
1a70: 65 69 74 68 65 72 20 23 66 20 6f 72 20 61 20 6e either #f or a n
1a80: 75 6d 62 65 72 0a 28 64 65 66 69 6e 65 20 28 64 umber.(define (d
1a90: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 bfile:run-id->db
1aa0: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 name run-id). (
1ab0: 63 6f 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 cond. ((number
1ac0: 3f 20 72 75 6e 2d 69 64 29 20 28 63 6f 6e 63 20 ? run-id) (conc
1ad0: 22 2e 6d 65 67 61 74 65 73 74 2f 22 20 28 6d 6f ".megatest/" (mo
1ae0: 64 75 6c 6f 20 72 75 6e 2d 69 64 20 31 30 30 29 dulo run-id 100)
1af0: 20 22 2e 64 62 22 29 29 0a 20 20 20 28 28 6e 6f ".db")). ((no
1b00: 74 20 72 75 6e 2d 69 64 29 20 20 20 20 20 28 63 t run-id) (c
1b10: 6f 6e 63 20 22 2e 6d 65 67 61 74 65 73 74 2f 6d onc ".megatest/m
1b20: 61 69 6e 2e 64 62 22 29 29 0a 20 20 20 28 65 6c ain.db")). (el
1b30: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 72 se r
1b40: 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 20 4d 61 6b un-id)))..;; Mak
1b50: 65 20 74 68 65 20 64 62 73 74 72 75 63 74 2c 20 e the dbstruct,
1b60: 73 65 74 75 70 20 75 70 20 61 75 78 69 6c 6c 61 setup up auxilla
1b70: 72 79 20 64 62 27 73 20 61 6e 64 20 63 61 6c 6c ry db's and call
1b80: 20 66 6f 72 20 6d 61 69 6e 20 64 62 20 61 74 20 for main db at
1b90: 6c 65 61 73 74 20 6f 6e 63 65 0a 3b 3b 0a 3b 3b least once.;;.;;
1ba0: 20 63 61 6c 6c 65 64 20 69 6e 20 68 74 74 70 2d called in http-
1bb0: 74 72 61 6e 73 70 6f 72 74 20 61 6e 64 20 72 65 transport and re
1bc0: 70 6c 69 63 61 74 65 64 20 69 6e 20 72 6d 74 2e plicated in rmt.
1bd0: 73 63 6d 20 66 6f 72 20 2a 6c 6f 63 61 6c 2a 20 scm for *local*
1be0: 61 63 63 65 73 73 2e 20 0a 3b 3b 0a 28 64 65 66 access. .;;.(def
1bf0: 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 65 74 75 ine (dbfile:setu
1c00: 70 20 64 6f 2d 73 79 6e 63 20 61 72 65 61 70 61 p do-sync areapa
1c10: 74 68 20 74 6d 70 70 61 74 68 29 0a 20 20 28 63 th tmppath). (c
1c20: 6f 6e 64 0a 20 20 20 28 2a 64 62 73 74 72 75 63 ond. (*dbstruc
1c30: 74 2d 64 62 73 2a 0a 20 20 20 20 28 64 62 66 69 t-dbs*. (dbfi
1c40: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 57 41 le:print-err "WA
1c50: 52 4e 49 4e 47 3a 20 64 62 66 69 6c 65 3a 73 65 RNING: dbfile:se
1c60: 74 75 70 20 63 61 6c 6c 65 64 20 77 68 65 6e 20 tup called when
1c70: 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a 20 69 *dbstruct-dbs* i
1c80: 73 20 61 6c 72 65 61 64 79 20 69 6e 69 74 69 61 s already initia
1c90: 6c 69 7a 65 64 22 29 0a 20 20 20 20 2a 64 62 73 lized"). *dbs
1ca0: 74 72 75 63 74 2d 64 62 73 2a 29 20 3b 3b 20 54 truct-dbs*) ;; T
1cb0: 4f 44 4f 3a 20 77 68 65 6e 20 6d 75 6c 74 69 70 ODO: when multip
1cc0: 6c 65 20 61 72 65 61 73 20 61 72 65 20 73 75 70 le areas are sup
1cd0: 70 6f 72 74 65 64 2c 20 74 68 69 73 20 6f 70 74 ported, this opt
1ce0: 69 6d 69 7a 61 74 69 6f 6e 20 77 69 6c 6c 20 62 imization will b
1cf0: 65 20 61 20 68 61 7a 61 72 64 0a 20 20 20 28 65 e a hazard. (e
1d00: 6c 73 65 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 lse. (let* ((
1d10: 64 62 73 74 72 75 63 74 20 28 6d 61 6b 65 2d 64 dbstruct (make-d
1d20: 62 72 3a 64 62 73 74 72 75 63 74 29 29 29 0a 20 br:dbstruct))).
1d30: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 73 74 (set! *dbst
1d40: 72 75 63 74 2d 64 62 73 2a 20 64 62 73 74 72 75 ruct-dbs* dbstru
1d50: 63 74 29 0a 20 20 20 20 20 20 28 64 62 72 3a 64 ct). (dbr:d
1d60: 62 73 74 72 75 63 74 2d 61 72 65 61 70 61 74 68 bstruct-areapath
1d70: 2d 73 65 74 21 20 64 62 73 74 72 75 63 74 20 61 -set! dbstruct a
1d80: 72 65 61 70 61 74 68 29 0a 20 20 20 20 20 20 28 reapath). (
1d90: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d 70 dbr:dbstruct-tmp
1da0: 70 61 74 68 2d 73 65 74 21 20 20 64 62 73 74 72 path-set! dbstr
1db0: 75 63 74 20 74 6d 70 70 61 74 68 29 0a 20 20 20 uct tmppath).
1dc0: 20 20 20 64 62 73 74 72 75 63 74 29 29 29 29 0a dbstruct)))).
1dd0: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
1de0: 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 :get-subdb dbstr
1df0: 75 63 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c uct run-id). (l
1e00: 65 74 2a 20 28 28 64 62 66 6e 61 6d 65 20 28 64 et* ((dbfname (d
1e10: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 bfile:run-id->db
1e20: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 0a 20 name run-id))).
1e30: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
1e40: 65 66 2f 64 65 66 61 75 6c 74 20 28 64 62 72 3a ef/default (dbr:
1e50: 64 62 73 74 72 75 63 74 2d 73 75 62 64 62 73 20 dbstruct-subdbs
1e60: 64 62 73 74 72 75 63 74 29 20 64 62 66 6e 61 6d dbstruct) dbfnam
1e70: 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 e #f)))..(define
1e80: 20 28 64 62 66 69 6c 65 3a 73 65 74 2d 73 75 62 (dbfile:set-sub
1e90: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
1ea0: 69 64 20 73 75 62 64 62 29 0a 20 20 28 68 61 73 id subdb). (has
1eb0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 64 62 h-table-set! (db
1ec0: 72 3a 64 62 73 74 72 75 63 74 2d 73 75 62 64 62 r:dbstruct-subdb
1ed0: 73 20 64 62 73 74 72 75 63 74 29 20 28 64 62 66 s dbstruct) (dbf
1ee0: 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 ile:run-id->dbna
1ef0: 6d 65 20 72 75 6e 2d 69 64 29 20 73 75 62 64 62 me run-id) subdb
1f00: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a ))..;; (define *
1f10: 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 61 6e 64 6c dbfile:num-handl
1f20: 65 73 2d 69 6e 2d 75 73 65 2a 20 30 29 0a 0a 3b es-in-use* 0)..;
1f30: 3b 20 47 65 74 2f 6f 70 65 6e 20 61 20 64 61 74 ; Get/open a dat
1f40: 61 62 61 73 65 0a 3b 3b 20 20 20 20 69 66 20 72 abase.;; if r
1f50: 75 6e 2d 69 64 20 3d 3e 20 67 65 74 20 72 75 6e un-id => get run
1f60: 20 73 70 65 63 69 66 69 63 20 64 62 0a 3b 3b 20 specific db.;;
1f70: 20 20 20 69 66 20 23 66 20 20 20 20 20 3d 3e 20 if #f =>
1f80: 67 65 74 20 6d 61 69 6e 20 64 62 0a 3b 3b 20 20 get main db.;;
1f90: 20 20 69 66 20 72 75 6e 2d 69 64 20 69 73 20 61 if run-id is a
1fa0: 20 73 74 72 69 6e 67 20 74 72 65 61 74 20 69 74 string treat it
1fb0: 20 61 73 20 61 20 66 69 6c 65 6e 61 6d 65 0a 3b as a filename.;
1fc0: 3b 20 20 20 20 69 66 20 64 62 20 61 6c 72 65 61 ; if db alrea
1fd0: 64 79 20 6f 70 65 6e 20 2d 20 72 65 74 75 72 6e dy open - return
1fe0: 20 69 6e 6d 65 6d 0a 3b 3b 20 20 20 20 69 66 20 inmem.;; if
1ff0: 64 62 20 6e 6f 74 20 6f 70 65 6e 2c 20 6f 70 65 db not open, ope
2000: 6e 20 69 6e 6d 65 6d 2c 20 72 75 6e 64 62 20 61 n inmem, rundb a
2010: 6e 64 20 73 79 6e 63 20 74 68 65 6e 20 72 65 74 nd sync then ret
2020: 75 72 6e 20 69 6e 6d 65 6d 0a 3b 3b 20 20 20 20 urn inmem.;;
2030: 69 6e 75 73 65 20 67 65 74 73 20 73 65 74 20 61 inuse gets set a
2040: 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 66 6f 72 utomatically for
2050: 20 72 75 6e 64 62 27 73 0a 3b 3b 0a 28 64 65 66 rundb's.;;.(def
2060: 69 6e 65 20 28 64 62 66 69 6c 65 3a 67 65 74 2d ine (dbfile:get-
2070: 64 62 64 61 74 20 64 62 73 74 72 75 63 74 20 72 dbdat dbstruct r
2080: 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 un-id). (let* (
2090: 28 73 75 62 64 62 20 28 64 62 66 69 6c 65 3a 67 (subdb (dbfile:g
20a0: 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 et-subdb dbstruc
20b0: 74 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 t run-id))).
20c0: 28 69 66 20 28 73 74 61 63 6b 2d 65 6d 70 74 79 (if (stack-empty
20d0: 3f 20 28 64 62 72 3a 73 75 62 64 62 2d 64 62 73 ? (dbr:subdb-dbs
20e0: 74 61 63 6b 20 73 75 62 64 62 29 29 0a 09 23 66 tack subdb))..#f
20f0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 74 61 ..(begin.. (sta
2100: 63 6b 2d 70 6f 70 21 20 28 64 62 72 3a 73 75 62 ck-pop! (dbr:sub
2110: 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 62 db-dbstack subdb
2120: 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 ))))))..;; retur
2130: 6e 20 61 20 70 72 65 76 69 6f 75 73 6c 79 20 6f n a previously o
2140: 70 65 6e 65 64 20 64 62 20 68 61 6e 64 6c 65 20 pened db handle
2150: 74 6f 20 74 68 65 20 73 74 61 63 6b 20 6f 66 20 to the stack of
2160: 61 76 61 69 6c 61 62 6c 65 20 68 61 6e 64 6c 65 available handle
2170: 73 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c s.(define (dbfil
2180: 65 3a 61 64 64 2d 64 62 64 61 74 20 64 62 73 74 e:add-dbdat dbst
2190: 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 64 61 ruct run-id dbda
21a0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 75 62 t). (let* ((sub
21b0: 64 62 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 db (dbfile:get-s
21c0: 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 ubdb dbstruct ru
21d0: 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 73 74 61 n-id))). (sta
21e0: 63 6b 2d 70 75 73 68 21 20 28 64 62 72 3a 73 75 ck-push! (dbr:su
21f0: 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 bdb-dbstack subd
2200: 62 29 20 64 62 64 61 74 29 0a 20 20 20 20 64 62 b) dbdat). db
2210: 64 61 74 29 29 0a 0a 3b 3b 20 73 65 74 20 75 70 dat))..;; set up
2220: 20 61 20 73 75 62 64 62 0a 3b 3b 0a 28 64 65 66 a subdb.;;.(def
2230: 69 6e 65 20 28 64 62 66 69 6c 65 3a 69 6e 69 74 ine (dbfile:init
2240: 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 -subdb dbstruct
2250: 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 run-id init-proc
2260: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 6e 61 ). (let* ((dbna
2270: 6d 65 20 20 20 20 28 64 62 66 69 6c 65 3a 72 75 me (dbfile:ru
2280: 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e n-id->dbname run
2290: 2d 69 64 29 29 0a 09 20 28 61 72 65 61 70 61 74 -id)).. (areapat
22a0: 68 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 h (dbr:dbstruct
22b0: 2d 61 72 65 61 70 61 74 68 20 64 62 73 74 72 75 -areapath dbstru
22c0: 63 74 29 29 0a 09 20 28 74 6d 70 70 61 74 68 20 ct)).. (tmppath
22d0: 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d (dbr:dbstruct-
22e0: 74 6d 70 70 61 74 68 20 20 64 62 73 74 72 75 63 tmppath dbstruc
22f0: 74 29 29 0a 09 20 28 6d 74 64 62 70 61 74 68 20 t)).. (mtdbpath
2300: 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d (dbfile:run-id-
2310: 3e 70 61 74 68 20 61 72 65 61 70 61 74 68 20 72 >path areapath r
2320: 75 6e 2d 69 64 29 29 0a 09 20 28 74 6d 70 64 62 un-id)).. (tmpdb
2330: 70 61 74 68 20 28 64 62 66 69 6c 65 3a 72 75 6e path (dbfile:run
2340: 2d 69 64 2d 3e 70 61 74 68 20 74 6d 70 70 61 74 -id->path tmppat
2350: 68 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 6d 74 h run-id)).. (mt
2360: 64 62 64 61 74 20 20 20 28 64 62 66 69 6c 65 3a dbdat (dbfile:
2370: 6f 70 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 open-sqlite3-db
2380: 6d 74 64 62 70 61 74 68 20 69 6e 69 74 2d 70 72 mtdbpath init-pr
2390: 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 3a 20 30 20 oc sync-mode: 0
23a0: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 3a 20 23 66 journal-mode: #f
23b0: 29 29 20 3b 3b 20 22 57 41 4c 22 29 29 0a 09 20 )) ;; "WAL"))..
23c0: 28 6e 65 77 73 75 62 64 62 20 20 28 6d 61 6b 65 (newsubdb (make
23d0: 2d 64 62 72 3a 73 75 62 64 62 20 64 62 6e 61 6d -dbr:subdb dbnam
23e0: 65 3a 20 20 20 20 64 62 6e 61 6d 65 0a 09 09 09 e: dbname....
23f0: 09 20 20 20 20 6d 74 64 62 66 69 6c 65 3a 20 20 . mtdbfile:
2400: 6d 74 64 62 70 61 74 68 0a 09 09 09 09 20 20 20 mtdbpath.....
2410: 20 74 6d 70 64 62 66 69 6c 65 3a 20 74 6d 70 64 tmpdbfile: tmpd
2420: 62 70 61 74 68 0a 09 09 09 09 20 20 20 20 6d 74 bpath..... mt
2430: 64 62 64 61 74 3a 20 20 20 6d 74 64 62 64 61 74 dbdat: mtdbdat
2440: 29 29 29 0a 20 20 20 20 28 64 62 66 69 6c 65 3a ))). (dbfile:
2450: 73 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 set-subdb dbstru
2460: 63 74 20 72 75 6e 2d 69 64 20 6e 65 77 73 75 62 ct run-id newsub
2470: 64 62 29 0a 20 20 20 20 6e 65 77 73 75 62 64 62 db). newsubdb
2480: 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 )) ;; return the
2490: 20 6e 65 77 20 73 75 62 64 62 20 2d 20 62 75 74 new subdb - but
24a0: 20 73 68 6f 75 6c 64 6e 27 74 20 72 65 61 6c 6c shouldn't reall
24b0: 79 20 75 73 65 20 69 74 0a 0a 3b 3b 20 72 65 74 y use it..;; ret
24c0: 75 72 6e 73 20 64 62 64 61 74 20 77 69 74 68 20 urns dbdat with
24d0: 64 62 68 20 61 6e 64 20 64 62 66 69 6c 65 70 61 dbh and dbfilepa
24e0: 74 68 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 74 th.;;.;; NOTE: t
24f0: 68 65 20 68 61 6e 64 6c 65 20 69 73 20 6f 6e 20 he handle is on
2500: 2f 74 6d 70 20 64 62 20 66 69 6c 65 21 0a 3b 3b /tmp db file!.;;
2510: 0a 3b 3b 20 20 31 2e 20 69 66 20 6e 65 65 64 65 .;; 1. if neede
2520: 64 20 73 65 74 75 70 20 74 68 65 20 73 75 62 64 d setup the subd
2530: 62 20 66 6f 72 20 74 68 65 20 67 69 76 65 6e 20 b for the given
2540: 72 75 6e 2d 69 64 0a 3b 3b 20 20 32 2e 20 69 66 run-id.;; 2. if
2550: 20 74 68 65 72 65 20 69 73 20 6e 6f 20 65 78 69 there is no exi
2560: 73 74 69 6e 67 20 64 62 20 68 61 6e 64 6c 65 20 sting db handle
2570: 69 6e 20 74 68 65 20 73 74 61 63 6b 0a 3b 3b 20 in the stack.;;
2580: 20 20 20 20 63 72 65 61 74 65 20 61 20 6e 65 77 create a new
2590: 20 68 61 6e 64 6c 65 20 61 6e 64 20 72 65 74 75 handle and retu
25a0: 72 6e 20 69 74 20 28 64 6f 20 4e 4f 54 20 61 64 rn it (do NOT ad
25b0: 64 0a 3b 3b 20 20 20 20 20 69 74 20 74 6f 20 74 d.;; it to t
25c0: 68 65 20 73 74 61 63 6b 29 2e 0a 3b 3b 0a 28 64 he stack)..;;.(d
25d0: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 6f 70 efine (dbfile:op
25e0: 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 en-db dbstruct r
25f0: 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 un-id init-proc)
2600: 0a 20 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 . (let* ((subdb
2610: 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 (dbfile:get-sub
2620: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
2630: 69 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e id))). (if (n
2640: 6f 74 20 73 75 62 64 62 29 20 3b 3b 20 6e 6f 74 ot subdb) ;; not
2650: 20 79 65 74 20 64 65 66 69 6e 65 64 0a 09 28 62 yet defined..(b
2660: 65 67 69 6e 0a 09 20 20 28 64 62 66 69 6c 65 3a egin.. (dbfile:
2670: 69 6e 69 74 2d 73 75 62 64 62 20 64 62 73 74 72 init-subdb dbstr
2680: 75 63 74 20 72 75 6e 2d 69 64 20 69 6e 69 74 2d uct run-id init-
2690: 70 72 6f 63 29 0a 09 20 20 28 64 62 66 69 6c 65 proc).. (dbfile
26a0: 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 :open-db dbstruc
26b0: 74 20 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 t run-id init-pr
26c0: 6f 63 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 oc))..(let* ((db
26d0: 64 61 74 20 28 64 62 66 69 6c 65 3a 67 65 74 2d dat (dbfile:get-
26e0: 64 62 64 61 74 20 64 62 73 74 72 75 63 74 20 72 dbdat dbstruct r
26f0: 75 6e 2d 69 64 29 29 29 0a 09 20 20 28 69 66 20 un-id))).. (if
2700: 64 62 64 61 74 0a 09 20 20 20 20 20 20 64 62 64 dbdat.. dbd
2710: 61 74 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 at.. (let*
2720: 28 28 74 6d 70 70 61 74 68 20 20 20 28 64 62 72 ((tmppath (dbr
2730: 3a 64 62 73 74 72 75 63 74 2d 74 6d 70 70 61 74 :dbstruct-tmppat
2740: 68 20 20 64 62 73 74 72 75 63 74 29 29 0a 09 09 h dbstruct))...
2750: 20 20 20 20 20 28 74 6d 70 64 62 70 61 74 68 20 (tmpdbpath
2760: 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e (dbfile:run-id->
2770: 70 61 74 68 20 74 6d 70 70 61 74 68 20 72 75 6e path tmppath run
2780: 2d 69 64 29 29 0a 09 09 20 20 20 20 20 28 64 62 -id))... (db
2790: 64 61 74 20 20 20 20 20 28 64 62 66 69 6c 65 3a dat (dbfile:
27a0: 6f 70 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 open-sqlite3-db
27b0: 74 6d 70 64 62 70 61 74 68 20 69 6e 69 74 2d 70 tmpdbpath init-p
27c0: 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 3a 20 30 roc sync-mode: 0
27d0: 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 3a 20 22 journal-mode: "
27e0: 57 41 4c 22 29 29 29 0a 09 09 3b 3b 20 74 68 65 WAL")))...;; the
27f0: 20 66 6f 6c 6c 6f 77 69 6e 67 20 6c 69 6e 65 20 following line
2800: 73 68 6f 72 74 2d 63 69 72 63 75 69 74 73 20 74 short-circuits t
2810: 68 65 20 22 6f 6e 65 20 64 62 20 68 61 6e 64 6c he "one db handl
2820: 65 20 70 65 72 20 74 68 72 65 61 64 22 20 6d 6f e per thread" mo
2830: 64 65 6c 0a 09 09 3b 3b 20 0a 09 09 3b 3b 20 28 del...;; ...;; (
2840: 64 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 dbfile:add-dbdat
2850: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
2860: 20 64 62 64 61 74 29 0a 09 09 3b 3b 0a 09 09 64 dbdat)...;;...d
2870: 62 64 61 74 29 29 29 29 29 29 0a 20 20 20 20 0a bdat)))))). .
2880: 3b 3b 20 43 4f 4d 42 49 4e 45 20 64 62 66 69 6c ;; COMBINE dbfil
2890: 65 3a 6f 70 65 6e 2d 73 71 6c 69 74 65 2d 64 62 e:open-sqlite-db
28a0: 20 61 6e 64 20 64 62 66 69 6c 65 3a 6c 6f 63 6b and dbfile:lock
28b0: 2d 63 72 65 61 74 65 2d 6f 70 65 6e 0a 3b 3b 0a -create-open.;;.
28c0: 0a 3b 3b 20 74 68 69 73 20 73 74 75 66 66 20 69 .;; this stuff i
28d0: 73 20 66 6f 72 20 69 6e 69 74 69 61 6c 20 64 65 s for initial de
28e0: 62 75 67 67 69 6e 67 2c 20 70 6c 65 61 73 65 20 bugging, please
28f0: 72 65 6d 6f 76 65 20 69 74 20 77 68 65 6e 0a 3b remove it when.;
2900: 3b 20 74 68 69 73 20 63 6f 64 65 20 73 74 61 62 ; this code stab
2910: 69 6c 69 7a 65 73 0a 28 64 65 66 69 6e 65 20 2a ilizes.(define *
2920: 64 62 6f 70 65 6e 73 2a 20 28 6d 61 6b 65 2d 68 dbopens* (make-h
2930: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
2940: 69 6e 65 20 28 64 62 66 69 6c 65 3a 69 6e 63 2d ine (dbfile:inc-
2950: 64 62 2d 6f 70 65 6e 20 64 62 66 69 6c 65 29 0a db-open dbfile).
2960: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 6f (let* ((curr-o
2970: 70 65 6e 73 2d 63 6f 75 6e 74 20 28 2b 20 28 68 pens-count (+ (h
2980: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2990: 66 61 75 6c 74 20 2a 64 62 6f 70 65 6e 73 2a 20 fault *dbopens*
29a0: 64 62 66 69 6c 65 20 30 29 20 31 29 29 29 0a 20 dbfile 0) 1))).
29b0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 63 (if (and (> c
29c0: 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 20 urr-opens-count
29d0: 31 29 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 6c 1) ;; this shoul
29e0: 64 20 4e 4f 54 20 62 65 20 68 61 70 70 65 6e 69 d NOT be happeni
29f0: 6e 67 0a 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e ng.. (common
2a00: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
2a10: 20 31 35 20 22 64 62 2d 6f 70 65 6e 73 22 29 29 15 "db-opens"))
2a20: 0a 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d ..(dbfile:print-
2a30: 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 20 22 64 err "INFO: db "d
2a40: 62 66 69 6c 65 22 20 68 61 73 20 62 65 65 6e 20 bfile" has been
2a50: 6f 70 65 6e 65 64 20 22 63 75 72 72 2d 6f 70 65 opened "curr-ope
2a60: 6e 73 2d 63 6f 75 6e 74 22 20 74 69 6d 65 73 21 ns-count" times!
2a70: 22 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ")). (hash-ta
2a80: 62 6c 65 2d 73 65 74 21 20 2a 64 62 6f 70 65 6e ble-set! *dbopen
2a90: 73 2a 20 64 62 66 69 6c 65 20 63 75 72 72 2d 6f s* dbfile curr-o
2aa0: 70 65 6e 73 2d 63 6f 75 6e 74 29 0a 20 20 20 20 pens-count).
2ab0: 63 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 curr-opens-count
2ac0: 29 29 0a 0a 3b 3b 20 4f 70 65 6e 20 74 68 65 20 ))..;; Open the
2ad0: 63 6c 61 73 73 69 63 20 6d 65 67 61 74 65 73 74 classic megatest
2ae0: 2e 64 62 20 66 69 6c 65 20 28 64 65 66 61 75 6c .db file (defaul
2af0: 74 73 20 74 6f 20 6f 70 65 6e 20 69 6e 20 74 6f ts to open in to
2b00: 70 70 61 74 68 29 0a 3b 3b 0a 3b 3b 20 20 20 4e ppath).;;.;; N
2b10: 4f 54 45 3a 20 72 65 74 75 72 6e 73 20 61 20 64 OTE: returns a d
2b20: 62 64 61 74 20 6e 6f 74 20 61 20 64 62 73 74 72 bdat not a dbstr
2b30: 75 63 74 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 uct!.;;.(define
2b40: 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 6c (dbfile:open-sql
2b50: 69 74 65 33 2d 64 62 20 64 62 70 61 74 68 20 69 ite3-db dbpath i
2b60: 6e 69 74 2d 70 72 6f 63 20 23 21 6b 65 79 20 28 nit-proc #!key (
2b70: 73 79 6e 63 2d 6d 6f 64 65 20 30 29 28 6a 6f 75 sync-mode 0)(jou
2b80: 72 6e 61 6c 2d 6d 6f 64 65 20 23 66 29 29 0a 20 rnal-mode #f)).
2b90: 20 28 6c 65 74 2a 20 28 28 64 62 65 78 69 73 74 (let* ((dbexist
2ba0: 73 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 s (file-exis
2bb0: 74 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 28 ts? dbpath)).. (
2bc0: 77 72 69 74 65 2d 61 63 63 65 73 73 20 28 66 69 write-access (fi
2bd0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
2be0: 20 64 62 70 61 74 68 29 29 0a 09 20 28 64 62 20 dbpath)).. (db
2bf0: 20 20 20 20 20 20 20 20 20 20 28 64 62 66 69 6c (dbfil
2c00: 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d e:cautious-open-
2c10: 64 61 74 61 62 61 73 65 20 64 62 70 61 74 68 20 database dbpath
2c20: 69 6e 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d 6d init-proc sync-m
2c30: 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 ode journal-mode
2c40: 29 29 29 0a 20 20 20 20 28 64 62 66 69 6c 65 3a ))). (dbfile:
2c50: 69 6e 63 2d 64 62 2d 6f 70 65 6e 20 64 62 70 61 inc-db-open dbpa
2c60: 74 68 29 0a 20 20 20 20 3b 3b 20 28 69 6e 69 74 th). ;; (init
2c70: 2d 70 72 6f 63 20 64 62 29 0a 20 20 20 20 28 6d -proc db). (m
2c80: 61 6b 65 2d 64 62 72 3a 64 62 64 61 74 20 64 62 ake-dbr:dbdat db
2c90: 66 69 6c 65 3a 20 64 62 70 61 74 68 20 64 62 68 file: dbpath dbh
2ca0: 3a 20 64 62 20 72 65 61 64 2d 6f 6e 6c 79 3a 20 : db read-only:
2cb0: 28 6e 6f 74 20 77 72 69 74 65 2d 61 63 63 65 73 (not write-acces
2cc0: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
2cd0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 dbfile:print-and
2ce0: 2d 65 78 69 74 20 2e 20 70 61 72 61 6d 73 29 0a -exit . params).
2cf0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
2d00: 6f 2d 70 6f 72 74 0a 20 20 20 20 20 20 28 63 75 o-port. (cu
2d10: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
2d20: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 ). (lambda ()
2d30: 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 . (apply pr
2d40: 69 6e 74 20 70 61 72 61 6d 73 29 29 29 0a 20 20 int params))).
2d50: 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 0a 28 (exit 1)). .(
2d60: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 70 define (dbfile:p
2d70: 72 69 6e 74 2d 65 72 72 20 2e 20 70 61 72 61 6d rint-err . param
2d80: 73 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 s). (with-outpu
2d90: 74 2d 74 6f 2d 70 6f 72 74 0a 20 20 20 20 20 20 t-to-port.
2da0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
2db0: 6f 72 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 ort). (lambda
2dc0: 20 28 29 0a 20 20 20 20 20 20 28 61 70 70 6c 79 (). (apply
2dd0: 20 70 72 69 6e 74 20 70 61 72 61 6d 73 29 29 29 print params)))
2de0: 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 ). .(define (
2df0: 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d dbfile:cautious-
2e00: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e open-database fn
2e10: 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 73 79 ame init-proc sy
2e20: 6e 63 2d 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d nc-mode journal-
2e30: 6d 6f 64 65 20 23 21 6f 70 74 69 6f 6e 61 6c 20 mode #!optional
2e40: 28 74 72 69 65 73 2d 6c 65 66 74 20 35 30 30 29 (tries-left 500)
2e50: 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 75 73 79 ). (let* ((busy
2e60: 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 6e 61 -file (conc fna
2e70: 6d 65 20 22 2d 6a 6f 75 72 6e 61 6c 22 29 29 0a me "-journal")).
2e80: 09 20 28 64 65 6c 61 79 2d 74 69 6d 65 20 28 2a . (delay-time (*
2e90: 20 28 2d 20 35 31 20 74 72 69 65 73 2d 6c 65 66 (- 51 tries-lef
2ea0: 74 29 20 31 2e 31 29 29 0a 20 20 20 20 20 20 09 t) 1.1)). .
2eb0: 20 28 77 72 69 74 65 2d 61 63 63 65 73 73 20 28 (write-access (
2ec0: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
2ed0: 73 3f 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 20 s? fname)).
2ee0: 20 20 20 20 28 64 69 72 2d 61 63 63 65 73 73 20 (dir-access
2ef0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
2f00: 73 73 3f 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 ss? (pathname-di
2f10: 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 29 29 29 rectory fname)))
2f20: 0a 20 20 20 20 20 20 20 20 20 28 72 65 74 72 79 . (retry
2f30: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
2f40: 0a 09 09 20 20 20 20 20 20 20 28 74 68 72 65 61 ... (threa
2f50: 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 74 d-sleep! delay-t
2f60: 69 6d 65 29 0a 09 09 20 20 20 20 20 20 20 28 69 ime)... (i
2f70: 66 20 28 3e 20 74 72 69 65 73 2d 6c 65 66 74 20 f (> tries-left
2f80: 30 29 0a 09 09 09 20 20 20 28 64 62 66 69 6c 65 0).... (dbfile
2f90: 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 :cautious-open-d
2fa0: 61 74 61 62 61 73 65 20 66 6e 61 6d 65 20 69 6e atabase fname in
2fb0: 69 74 2d 70 72 6f 63 0a 09 09 09 09 09 09 09 20 it-proc........
2fc0: 20 73 79 6e 63 2d 6d 6f 64 65 3a 20 73 79 6e 63 sync-mode: sync
2fd0: 2d 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f -mode journal-mo
2fe0: 64 65 0a 09 09 09 09 09 09 09 20 20 28 2d 20 74 de........ (- t
2ff0: 72 69 65 73 2d 6c 65 66 74 20 31 29 29 29 29 29 ries-left 1)))))
3000: 29 0a 20 20 20 20 28 61 73 73 65 72 74 20 28 3e ). (assert (>
3010: 3d 20 74 72 69 65 73 2d 6c 65 66 74 20 30 29 20 = tries-left 0)
3020: 28 63 6f 6e 63 20 22 46 41 54 41 4c 3a 20 74 6f (conc "FATAL: to
3030: 6f 20 6d 61 6e 79 20 61 74 74 65 6d 70 74 73 20 o many attempts
3040: 69 6e 20 64 62 66 69 6c 65 3a 63 61 75 74 69 6f in dbfile:cautio
3050: 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 us-open-database
3060: 20 6f 66 20 22 66 6e 61 6d 65 22 2c 20 67 69 76 of "fname", giv
3070: 69 6e 67 20 75 70 2e 22 29 29 0a 20 20 20 20 0a ing up.")). .
3080: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 (if (and (fi
3090: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
30a0: 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 66 fname).. (f
30b0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 62 75 73 79 ile-exists? busy
30c0: 2d 66 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a -file))..(begin.
30d0: 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c . (if (common:l
30e0: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 ow-noise-print 1
30f0: 32 30 20 62 75 73 79 2d 66 69 6c 65 29 0a 09 20 20 busy-file)..
3100: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
3110: 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 nt-err "INFO: db
3120: 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 file:cautious-op
3130: 65 6e 2d 64 61 74 61 62 61 73 65 3a 20 6a 6f 75 en-database: jou
3140: 72 6e 61 6c 20 66 69 6c 65 20 22 0a 09 09 09 09 rnal file ".....
3150: 62 75 73 79 2d 66 69 6c 65 22 20 65 78 69 73 74 busy-file" exist
3160: 73 2c 20 74 72 79 69 6e 67 20 61 67 61 69 6e 20 s, trying again
3170: 69 6e 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 22 in few seconds."
3180: 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c )).. (thread-sl
3190: 65 65 70 21 20 31 29 0a 09 20 20 28 69 66 20 28 eep! 1).. (if (
31a0: 65 71 3f 20 74 72 69 65 73 2d 6c 65 66 74 20 32 eq? tries-left 2
31b0: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
31c0: 09 20 20 09 28 64 62 66 69 6c 65 3a 70 72 69 6e . .(dbfile:prin
31d0: 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 66 6f 72 t-err "INFO: for
31e0: 63 69 6e 67 20 6a 6f 75 72 6e 61 6c 20 72 6f 6c cing journal rol
31f0: 6c 75 70 20 22 62 75 73 79 2d 66 69 6c 65 29 0a lup "busy-file).
3200: 09 20 20 09 28 64 62 66 69 6c 65 3a 62 72 75 74 . .(dbfile:brut
3210: 65 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 65 2d e-force-salvage-
3220: 64 62 20 66 6e 61 6d 65 29 29 29 0a 09 20 20 28 db fname))).. (
3230: 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d dbfile:cautious-
3240: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e open-database fn
3250: 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 73 79 ame init-proc sy
3260: 6e 63 2d 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d nc-mode journal-
3270: 6d 6f 64 65 20 28 2d 20 74 72 69 65 73 2d 6c 65 mode (- tries-le
3280: 66 74 20 31 29 29 29 0a 09 0a 09 28 6c 65 74 2a ft 1)))....(let*
3290: 20 28 28 72 65 73 75 6c 74 20 28 63 6f 6e 64 69 ((result (condi
32a0: 74 69 6f 6e 2d 63 61 73 65 0a 09 09 20 20 20 20 tion-case...
32b0: 20 20 20 20 28 69 66 20 64 69 72 2d 61 63 63 65 (if dir-acce
32c0: 73 73 0a 09 09 09 20 20 20 20 28 64 62 66 69 6c ss.... (dbfil
32d0: 65 3a 77 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 e:with-simple-fi
32e0: 6c 65 2d 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 le-lock....
32f0: 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 6c 6f (conc fname ".lo
3300: 63 6b 22 29 0a 09 09 09 20 20 20 20 20 28 6c 61 ck").... (la
3310: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
3320: 20 20 28 6c 65 74 2a 20 28 28 64 62 2d 65 78 69 (let* ((db-exi
3330: 73 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 73 sts (file-exists
3340: 3f 20 66 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 ? fname)).....
3350: 20 20 20 20 28 64 62 20 20 20 20 20 20 20 20 28 (db (
3360: 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 sqlite3:open-dat
3370: 61 62 61 73 65 20 66 6e 61 6d 65 29 29 29 20 3b abase fname))) ;
3380: 3b 20 63 72 65 61 74 65 73 20 61 6e 20 65 6d 70 ; creates an emp
3390: 74 79 20 64 62 20 69 66 20 69 74 20 64 69 64 20 ty db if it did
33a0: 6e 6f 74 20 61 6c 72 65 61 64 79 20 65 78 69 73 not already exis
33b0: 74 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t..
33c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33d0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 73 65 74 (sqlite3:set
33e0: 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 -busy-handler! d
33f0: 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d b (sqlite3:make-
3400: 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 30 30 busy-timeout 300
3410: 30 30 29 29 0a 09 09 09 09 20 28 69 66 20 73 79 00))..... (if sy
3420: 6e 63 2d 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 nc-mode.....
3430: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
3440: 65 20 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 e db (conc "PRAG
3450: 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d MA synchronous =
3460: 20 22 73 79 6e 63 2d 6d 6f 64 65 22 3b 22 29 29 "sync-mode";"))
3470: 29 0a 09 09 09 09 20 28 69 66 20 6a 6f 75 72 6e )..... (if journ
3480: 61 6c 2d 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 al-mode.....
3490: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
34a0: 65 20 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 e db (conc "PRAG
34b0: 4d 41 20 6a 6f 75 72 6e 61 6c 5f 6d 6f 64 65 20 MA journal_mode
34c0: 3d 20 22 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 22 = "journal-mode"
34d0: 3b 22 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 ;")))..... (if (
34e0: 61 6e 64 20 69 6e 69 74 2d 70 72 6f 63 20 28 6e and init-proc (n
34f0: 6f 74 20 64 62 2d 65 78 69 73 74 73 29 29 0a 09 ot db-exists))..
3500: 09 09 09 20 20 20 20 20 28 69 6e 69 74 2d 70 72 ... (init-pr
3510: 6f 63 20 64 62 29 29 0a 09 09 09 09 20 64 62 29 oc db))..... db)
3520: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3540: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 begin.... (
3550: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
3560: 20 66 6e 61 6d 65 20 29 0a 20 20 20 20 20 20 20 fname ).
3570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3580: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
3590: 28 28 64 62 20 28 73 71 6c 69 74 65 33 3a 6f 70 ((db (sqlite3:op
35a0: 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d en-database fnam
35b0: 65 29 29 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 e)))..... ;;
35c0: 70 72 61 67 6d 61 73 20 73 79 6e 63 68 72 6f 6e pragmas synchron
35d0: 6f 75 73 20 6e 6f 74 20 6e 65 65 64 65 64 20 62 ous not needed b
35e0: 65 63 61 75 73 65 20 74 68 69 73 20 64 62 20 69 ecause this db i
35f0: 73 20 75 73 65 64 20 72 65 61 64 2d 6f 6e 6c 79 s used read-only
3600: 0a 09 09 09 09 20 20 20 20 3b 3b 20 28 73 71 6c ..... ;; (sql
3610: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
3620: 28 63 6f 6e 63 20 22 50 52 41 47 4d 41 20 73 79 (conc "PRAGMA sy
3630: 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 22 6d 6f 64 nchronous = "mod
3640: 65 22 3b 22 29 0a 09 09 09 09 20 20 20 20 28 73 e";")..... (s
3650: 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d qlite3:set-busy-
3660: 68 61 6e 64 6c 65 72 21 20 64 62 20 28 73 71 6c handler! db (sql
3670: 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 ite3:make-busy-t
3680: 69 6d 65 6f 75 74 20 33 30 30 30 30 29 29 20 3b imeout 30000)) ;
3690: 3b 20 72 65 61 64 2d 6f 6e 6c 79 20 62 75 74 20 ; read-only but
36a0: 73 74 69 6c 6c 20 6e 65 65 64 20 74 69 6d 65 6f still need timeo
36b0: 75 74 0a 09 09 09 09 20 20 20 20 64 62 20 29 0a ut..... db ).
36c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36e0: 20 20 28 70 72 69 6e 74 20 22 66 69 6c 65 20 64 (print "file d
36f0: 6f 65 73 6e 27 74 20 65 78 69 73 74 3a 20 22 20 oesn't exist: "
3700: 66 6e 61 6d 65 29 29 29 29 0a 09 09 09 28 65 78 fname))))....(ex
3710: 6e 20 28 69 6f 2d 65 72 72 6f 72 29 0a 09 09 09 n (io-error)....
3720: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
3730: 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f nt-err exn "ERRO
3740: 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 R: i/o error wit
3750: 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 65 h " fname ". Che
3760: 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 ck permissions,
3770: 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e 20 disk space etc.
3780: 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 29 and try again.")
3790: 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 .... (retry)
37a0: 29 0a 09 09 09 28 65 78 6e 20 28 63 6f 72 72 75 )....(exn (corru
37b0: 70 74 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 pt).... (dbf
37c0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 ile:print-err ex
37d0: 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 n "ERROR: databa
37e0: 73 65 20 22 20 66 6e 61 6d 65 20 22 20 69 73 20 se " fname " is
37f0: 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 20 corrupt. Repair
3800: 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 29 it to proceed.")
3810: 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 .... (retry)
3820: 29 0a 09 09 09 28 65 78 6e 20 28 62 75 73 79 29 )....(exn (busy)
3830: 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 .... (dbfile
3840: 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 :print-err exn "
3850: 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 ERROR: database
3860: 22 20 66 6e 61 6d 65 0a 09 09 09 09 09 20 20 20 " fname......
3870: 20 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e " is locked.
3880: 20 54 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 Try copying to
3890: 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e another location
38a0: 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 , remove origina
38b0: 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e l and copy back.
38c0: 22 29 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 ").... (retr
38d0: 79 29 29 0a 09 09 09 28 65 78 6e 20 28 70 65 72 y))....(exn (per
38e0: 6d 69 73 73 69 6f 6e 29 28 64 62 66 69 6c 65 3a mission)(dbfile:
38f0: 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 print-err exn "E
3900: 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 RROR: database "
3910: 20 66 6e 61 6d 65 20 22 20 68 61 73 20 73 6f 6d fname " has som
3920: 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 e permissions pr
3930: 6f 62 6c 65 6d 2e 22 29 0a 09 09 09 20 20 20 20 oblem.")....
3940: 20 28 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 (retry))....(ex
3950: 6e 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 62 n ().... (db
3960: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 file:print-err e
3970: 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f xn "ERROR: Unkno
3980: 77 6e 20 65 72 72 6f 72 20 77 69 74 68 20 64 61 wn error with da
3990: 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 tabase " fname "
39a0: 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 09 09 09 message: ".....
39b0: 09 20 20 20 20 20 20 20 28 28 63 6f 6e 64 69 74 . ((condit
39c0: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
39d0: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
39e0: 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 20 20 age) exn))....
39f0: 20 20 20 28 72 65 74 72 79 29 29 29 29 29 0a 09 (retry)))))..
3a00: 20 20 72 65 73 75 6c 74 29 29 29 29 0a 0a 28 64 result))))..(d
3a10: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 62 72 efine (dbfile:br
3a20: 75 74 65 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 ute-force-salvag
3a30: 65 2d 64 62 20 66 6e 61 6d 65 29 0a 20 20 28 6c e-db fname). (l
3a40: 65 74 2a 20 28 28 62 61 63 6b 75 70 66 6e 61 6d et* ((backupfnam
3a50: 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 22 e (conc fname"-"
3a60: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
3a70: 2d 69 64 29 22 2e 62 61 6b 22 29 29 0a 09 20 28 -id)".bak")).. (
3a80: 63 6d 64 20 28 63 6f 6e 63 20 22 63 70 20 22 66 cmd (conc "cp "f
3a90: 6e 61 6d 65 22 20 22 62 61 63 6b 75 70 66 6e 61 name" "backupfna
3aa0: 6d 65 22 3b 6d 76 20 22 66 6e 61 6d 65 22 20 22 me";mv "fname" "
3ab0: 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 64 65 (conc fname ".de
3ac0: 6c 6d 65 3b 22 29 0a 09 09 20 20 20 20 22 63 70 lme;")... "cp
3ad0: 20 22 62 61 63 6b 75 70 66 6e 61 6d 65 22 20 22 "backupfname" "
3ae0: 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 64 62 fname))). (db
3af0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
3b00: 57 41 52 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 WARNING: attempt
3b10: 69 6e 67 20 72 65 63 6f 76 65 72 79 20 6f 66 20 ing recovery of
3b20: 66 69 6c 65 20 22 66 6e 61 6d 65 22 20 62 79 20 file "fname" by
3b30: 72 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 73 running commands
3b40: 3a 5c 6e 22 0a 09 09 20 20 20 20 20 20 22 20 20 :\n"... "
3b50: 22 63 6d 64 29 0a 20 20 20 20 28 73 79 73 74 65 "cmd). (syste
3b60: 6d 20 63 6d 64 29 29 29 0a 0a 0a 28 64 65 66 69 m cmd)))...(defi
3b70: 6e 65 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d ne (dbfile:open-
3b80: 6e 6f 2d 73 79 6e 63 2d 64 62 20 64 62 70 61 74 no-sync-db dbpat
3b90: 68 29 0a 20 20 28 69 66 20 2a 6e 6f 2d 73 79 6e h). (if *no-syn
3ba0: 63 2d 64 62 2a 0a 20 20 20 20 20 20 2a 6e 6f 2d c-db*. *no-
3bb0: 73 79 6e 63 2d 64 62 2a 0a 20 20 20 20 20 20 28 sync-db*. (
3bc0: 62 65 67 69 6e 0a 09 28 69 66 20 28 6e 6f 74 20 begin..(if (not
3bd0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 (file-exists? db
3be0: 70 61 74 68 29 29 0a 09 20 20 20 20 28 63 72 65 path)).. (cre
3bf0: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 64 62 ate-directory db
3c00: 70 61 74 68 20 23 74 29 29 0a 09 28 6c 65 74 2a path #t))..(let*
3c10: 20 28 28 64 62 6e 61 6d 65 20 20 20 20 28 63 6f ((dbname (co
3c20: 6e 63 20 64 62 70 61 74 68 20 22 2f 6e 6f 2d 73 nc dbpath "/no-s
3c30: 79 6e 63 2e 64 62 22 29 29 0a 09 20 20 20 20 20 ync.db"))..
3c40: 20 20 28 64 62 2d 65 78 69 73 74 73 20 28 66 69 (db-exists (fi
3c50: 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 6e 61 6d le-exists? dbnam
3c60: 65 29 29 0a 09 20 20 20 20 20 20 20 28 69 6e 69 e)).. (ini
3c70: 74 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 t-proc (lambda (
3c80: 64 62 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 db).... (if (
3c90: 6e 6f 74 20 64 62 2d 65 78 69 73 74 73 29 0a 09 not db-exists)..
3ca0: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 ...(begin.....
3cb0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3cc0: 20 64 62 20 22 43 52 45 41 54 45 20 54 41 42 4c db "CREATE TABL
3cd0: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
3ce0: 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 no_sync_metadat
3cf0: 28 76 61 72 20 54 45 58 54 2c 76 61 6c 20 54 45 (var TEXT,val TE
3d00: 58 54 2c 20 43 4f 4e 53 54 52 41 49 4e 54 20 6e XT, CONSTRAINT n
3d10: 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 5f 63 o_sync_metadat_c
3d20: 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 onstraint UNIQUE
3d30: 20 28 76 61 72 29 29 3b 22 29 29 0a 09 09 09 09 (var));")).....
3d40: 29 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 20 ))).. (db
3d50: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 63 (dbfile:c
3d60: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
3d70: 61 62 61 73 65 20 64 62 6e 61 6d 65 20 69 6e 69 abase dbname ini
3d80: 74 2d 70 72 6f 63 20 30 20 22 57 41 4c 22 29 29 t-proc 0 "WAL"))
3d90: 29 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 6f 70 ) ;; (sqlite3:op
3da0: 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 6e 61 en-database dbna
3db0: 6d 65 29 29 29 0a 09 20 20 3b 3b 20 28 73 71 6c me))).. ;; (sql
3dc0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
3dd0: 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e "PRAGMA synchron
3de0: 6f 75 73 20 3d 20 30 3b 22 29 0a 09 20 20 3b 3b ous = 0;").. ;;
3df0: 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 (sqlite3:set-bu
3e00: 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 sy-handler! db (
3e10: 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 sqlite3:make-bus
3e20: 79 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 30 30 y-timeout 136000
3e30: 29 29 20 3b 3b 20 64 6f 6e 65 20 69 6e 20 63 61 )) ;; done in ca
3e40: 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 utious-open-data
3e50: 62 61 73 65 0a 09 20 20 28 73 65 74 21 20 2a 6e base.. (set! *n
3e60: 6f 2d 73 79 6e 63 2d 64 62 2a 20 64 62 29 0a 09 o-sync-db* db)..
3e70: 20 20 64 62 29 29 29 29 0a 0a 28 64 65 66 69 6e db))))..(defin
3e80: 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 73 65 e (db:no-sync-se
3e90: 74 20 64 62 20 76 61 72 20 76 61 6c 29 0a 20 20 t db var val).
3ea0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3eb0: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
3ec0: 45 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 EPLACE INTO no_s
3ed0: 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 ync_metadat (var
3ee0: 2c 76 61 6c 29 20 56 41 4c 55 45 53 20 28 3f 2c ,val) VALUES (?,
3ef0: 3f 29 3b 22 20 76 61 72 20 76 61 6c 29 29 0a 0a ?);" var val))..
3f00: 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 (define (db:no-s
3f10: 79 6e 63 2d 64 65 6c 21 20 64 62 20 76 61 72 29 ync-del! db var)
3f20: 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
3f30: 75 74 65 20 64 62 20 22 44 45 4c 45 54 45 20 46 ute db "DELETE F
3f40: 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 ROM no_sync_meta
3f50: 64 61 74 20 57 48 45 52 45 20 76 61 72 3d 3f 3b dat WHERE var=?;
3f60: 22 20 76 61 72 29 29 0a 0a 28 64 65 66 69 6e 65 " var))..(define
3f70: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
3f80: 2f 64 65 66 61 75 6c 74 20 64 62 20 76 61 72 20 /default db var
3f90: 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 default). (let
3fa0: 28 28 72 65 73 20 64 65 66 61 75 6c 74 29 29 0a ((res default)).
3fb0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
3fc0: 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 -each-row. (
3fd0: 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 20 20 20 lambda (val).
3fe0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 76 61 (set! res va
3ff0: 6c 29 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 l)). db.
4000: 20 22 53 45 4c 45 43 54 20 76 61 6c 20 46 52 4f "SELECT val FRO
4010: 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 M no_sync_metada
4020: 74 20 57 48 45 52 45 20 76 61 72 3d 3f 3b 22 0a t WHERE var=?;".
4030: 20 20 20 20 20 76 61 72 29 0a 20 20 20 20 28 69 var). (i
4040: 66 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c f res. (l
4050: 65 74 20 28 28 6e 65 77 72 65 73 20 28 69 66 20 et ((newres (if
4060: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
4070: 09 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 . (string->numb
4080: 65 72 20 72 65 73 29 0a 09 09 09 20 20 23 66 29 er res).... #f)
4090: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
40a0: 20 6e 65 77 72 65 73 0a 20 20 20 20 20 20 20 20 newres.
40b0: 20 20 20 20 20 20 6e 65 77 72 65 73 0a 20 20 20 newres.
40c0: 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 res))
40d0: 0a 20 20 20 20 20 20 20 20 72 65 73 29 29 29 0a . res))).
40e0: 0a 3b 3b 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 .;; transaction
40f0: 70 72 6f 74 65 63 74 65 64 20 6c 6f 63 6b 20 61 protected lock a
4100: 71 75 69 73 69 74 69 6f 6e 0a 3b 3b 20 65 69 74 quisition.;; eit
4110: 68 65 72 3a 0a 3b 3b 20 20 20 20 66 61 69 6c 73 her:.;; fails
4120: 20 20 20 20 72 65 74 75 72 6e 73 20 20 28 23 66 returns (#f
4130: 20 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 6f 6e . lock-creation
4140: 2d 74 69 6d 65 29 0a 3b 3b 20 20 20 20 73 75 63 -time).;; suc
4150: 63 65 65 64 73 20 28 72 65 74 75 72 6e 73 20 28 ceeds (returns (
4160: 23 74 20 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 #t . lock-creati
4170: 6f 6e 2d 74 69 6d 65 29 0a 3b 3b 20 75 73 65 20 on-time).;; use
4180: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 (db:no-sync-del!
4190: 20 64 62 20 6b 65 79 6e 61 6d 65 29 20 74 6f 20 db keyname) to
41a0: 72 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b release the lock
41b0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a .;;.(define (db:
41c0: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
41d0: 20 64 62 20 6b 65 79 6e 61 6d 65 29 0a 20 20 28 db keyname). (
41e0: 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 sqlite3:with-tra
41f0: 6e 73 61 63 74 69 6f 6e 0a 20 20 20 64 62 0a 20 nsaction. db.
4200: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
4210: 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 (condition-cas
4220: 65 0a 09 20 28 6c 65 74 2a 20 28 28 63 75 72 72 e.. (let* ((curr
4230: 2d 76 61 6c 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 -val (db:no-sync
4240: 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 64 62 20 -get/default db
4250: 6b 65 79 6e 61 6d 65 20 23 66 29 29 29 0a 09 20 keyname #f)))..
4260: 20 20 28 69 66 20 63 75 72 72 2d 76 61 6c 0a 09 (if curr-val..
4270: 20 20 20 20 20 20 20 60 28 23 66 20 2e 20 2c 63 `(#f . ,c
4280: 75 72 72 2d 76 61 6c 29 20 20 20 3b 3b 20 28 73 urr-val) ;; (s
4290: 71 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 65 73 qlite3:first-res
42a0: 75 6c 74 20 64 62 20 22 53 45 4c 45 43 54 20 76 ult db "SELECT v
42b0: 61 6c 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f al FROM no_sync_
42c0: 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 76 61 metadat WHERE va
42d0: 72 3d 3f 3b 22 20 6b 65 79 6e 61 6d 65 29 29 0a r=?;" keyname)).
42e0: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6c . (let ((l
42f0: 6f 63 6b 2d 74 69 6d 65 20 28 63 75 72 72 65 6e ock-time (curren
4300: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 20 t-seconds)))...
4310: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
4320: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
4330: 45 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 EPLACE INTO no_s
4340: 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 ync_metadat (var
4350: 2c 76 61 6c 29 20 56 41 4c 55 45 53 28 3f 2c 3f ,val) VALUES(?,?
4360: 29 3b 22 20 6b 65 79 6e 61 6d 65 20 6c 6f 63 6b );" keyname lock
4370: 2d 74 69 6d 65 29 0a 09 09 20 60 28 23 74 20 2e -time)... `(#t .
4380: 20 2c 6c 6f 63 6b 2d 74 69 6d 65 29 29 29 29 0a ,lock-time)))).
4390: 20 20 20 20 20 20 20 28 65 78 6e 20 28 69 6f 2d (exn (io-
43a0: 65 72 72 6f 72 29 20 20 28 64 62 66 69 6c 65 3a error) (dbfile:
43b0: 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 print-err "ERROR
43c0: 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 : i/o error with
43d0: 20 6e 6f 2d 73 79 6e 63 20 64 62 2e 20 43 68 65 no-sync db. Che
43e0: 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 ck permissions,
43f0: 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e 20 disk space etc.
4400: 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 29 and try again.")
4410: 29 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 63 ). (exn (c
4420: 6f 72 72 75 70 74 29 20 20 20 28 64 62 66 69 6c orrupt) (dbfil
4430: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 e:print-err "ERR
4440: 4f 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f 2d OR: database no-
4450: 73 79 6e 63 20 64 62 20 69 73 20 63 6f 72 72 75 sync db is corru
4460: 70 74 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f pt. Repair it to
4470: 20 70 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 20 proceed.")).
4480: 20 20 20 20 28 65 78 6e 20 28 62 75 73 79 29 20 (exn (busy)
4490: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
44a0: 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 3a 20 64 nt-err "ERROR: d
44b0: 61 74 61 62 61 73 65 20 6e 6f 2d 73 79 6e 63 20 atabase no-sync
44c0: 64 62 20 69 73 20 6c 6f 63 6b 65 64 2e 20 54 72 db is locked. Tr
44d0: 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 6e 6f y copying to ano
44e0: 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c 20 72 ther location, r
44f0: 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c 20 61 emove original a
4500: 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 29 29 nd copy back."))
4510: 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 70 65 . (exn (pe
4520: 72 6d 69 73 73 69 6f 6e 29 28 64 62 66 69 6c 65 rmission)(dbfile
4530: 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f :print-err "ERRO
4540: 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f 2d 73 R: database no-s
4550: 79 6e 63 20 64 62 20 68 61 73 20 73 6f 6d 65 20 ync db has some
4560: 70 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 permissions prob
4570: 6c 65 6d 2e 22 29 29 0a 20 20 20 20 20 20 20 28 lem.")). (
4580: 65 78 6e 20 28 29 20 3b 3b 20 28 73 74 61 74 75 exn () ;; (statu
4590: 73 20 64 6f 6e 65 29 20 3b 3b 20 49 20 64 6f 6e s done) ;; I don
45a0: 27 74 20 6b 6e 6f 77 20 68 6f 77 20 74 6f 20 64 't know how to d
45b0: 65 74 65 63 74 20 73 74 61 74 75 73 20 64 6f 6e etect status don
45c0: 65 20 62 75 74 20 6e 6f 20 64 61 74 61 21 0a 09 e but no data!..
45d0: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
45e0: 74 2d 65 72 72 20 22 45 52 52 4f 52 3a 20 55 6e t-err "ERROR: Un
45f0: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 known error with
4600: 20 64 61 74 61 62 61 73 65 20 6e 6f 2d 73 79 6e database no-syn
4610: 63 20 64 62 20 6d 65 73 73 61 67 65 3a 20 65 78 c db message: ex
4620: 6e 3d 22 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c n="(condition->l
4630: 69 73 74 20 65 78 6e 29 22 2c 20 5c 6e 22 0a 09 ist exn)", \n"..
4640: 09 09 20 20 20 20 20 20 28 28 63 6f 6e 64 69 74 .. ((condit
4650: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
4660: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
4670: 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 age) exn))..
4680: 60 28 23 66 20 2e 20 2c 28 63 75 72 72 65 6e 74 `(#f . ,(current
4690: 2d 73 65 63 6f 6e 64 73 29 29 29 29 29 29 29 0a -seconds))))))).
46a0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d .(define (db:no-
46b0: 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 sync-get-lock-ti
46c0: 6d 65 6f 75 74 20 64 62 20 6b 65 79 6e 61 6d 65 meout db keyname
46d0: 20 74 69 6d 65 6f 75 74 29 0a 20 20 28 6c 65 74 timeout). (let
46e0: 2a 20 28 28 6c 6f 63 6b 64 61 74 20 28 64 62 3a * ((lockdat (db:
46f0: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
4700: 20 64 62 20 6b 65 79 6e 61 6d 65 29 29 29 0a 20 db keyname))).
4710: 20 20 20 28 6d 61 74 63 68 20 6c 6f 63 6b 64 61 (match lockda
4720: 74 0a 20 20 20 20 20 20 28 28 23 66 20 2e 20 6c t. ((#f . l
4730: 6f 63 6b 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 ock-time).
4740: 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
4750: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 69 66 ent-seconds) (if
4760: 20 28 73 74 72 69 6e 67 3f 20 6c 6f 63 6b 2d 74 (string? lock-t
4770: 69 6d 65 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ime)(string->num
4780: 62 65 72 20 6c 6f 63 6b 2d 74 69 6d 65 29 6c 6f ber lock-time)lo
4790: 63 6b 2d 74 69 6d 65 29 29 20 74 69 6d 65 6f 75 ck-time)) timeou
47a0: 74 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6c 6f t).. (let ((lo
47b0: 63 6b 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 ck-time (current
47c0: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 20 -seconds)))..
47d0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
47e0: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
47f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 3a t-log-port* "db:
4800: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
4810: 20 6b 65 79 6e 61 6d 65 3d 22 20 6b 65 79 6e 61 keyname=" keyna
4820: 6d 65 20 22 2c 20 6c 6f 63 6b 2d 74 69 6d 65 3d me ", lock-time=
4830: 22 20 6c 6f 63 6b 2d 74 69 6d 65 20 22 2c 20 65 " lock-time ", e
4840: 78 6e 3d 22 20 65 78 6e 29 0a 09 20 20 20 20 20 xn=" exn)..
4850: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
4860: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
4870: 45 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 EPLACE INTO no_s
4880: 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 ync_metadat (var
4890: 2c 76 61 6c 29 20 56 41 4c 55 45 53 28 3f 2c 3f ,val) VALUES(?,?
48a0: 29 3b 22 20 6b 65 79 6e 61 6d 65 20 6c 6f 63 6b );" keyname lock
48b0: 2d 74 69 6d 65 29 0a 09 20 20 20 20 20 60 28 23 -time).. `(#
48c0: 74 20 2e 20 2c 6c 6f 63 6b 2d 74 69 6d 65 29 29 t . ,lock-time))
48d0: 0a 09 20 20 20 6c 6f 63 6b 64 61 74 29 29 0a 20 .. lockdat)).
48e0: 20 20 20 20 20 28 65 6c 73 65 20 6c 6f 63 6b 64 (else lockd
48f0: 61 74 29 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a at))))..;; NOTE:
4900: 20 54 68 69 73 20 77 69 6c 6c 20 73 74 65 61 6c This will steal
4910: 20 74 68 65 20 6c 6f 63 6b 20 61 66 74 65 72 20 the lock after
4920: 74 69 6d 65 6f 75 74 20 6f 66 20 77 61 69 74 69 timeout of waiti
4930: 6e 67 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ng..;;.(define (
4940: 64 62 3a 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d db:with-no-sync-
4950: 6c 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d 65 20 lock db keyname
4960: 74 69 6d 65 6f 75 74 20 70 72 6f 63 29 0a 20 20 timeout proc).
4970: 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 64 61 74 20 (let* ((lockdat
4980: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
4990: 2d 6c 6f 63 6b 2d 74 69 6d 65 6f 75 74 20 64 62 -lock-timeout db
49a0: 20 6b 65 79 6e 61 6d 65 29 29 0a 09 20 28 67 6f keyname)).. (go
49b0: 74 6c 6f 63 6b 20 20 28 63 61 72 20 6c 6f 63 6b tlock (car lock
49c0: 64 61 74 29 29 0a 09 20 28 6c 6f 63 6b 74 69 6d dat)).. (locktim
49d0: 65 20 28 63 64 72 20 6c 6f 63 6b 64 61 74 29 29 e (cdr lockdat))
49e0: 29 0a 20 20 20 20 28 69 66 20 67 6f 74 6c 6f 63 ). (if gotloc
49f0: 6b 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 70 k..(let ((res (p
4a00: 72 6f 63 29 29 29 0a 09 20 20 28 64 62 3a 6e 6f roc))).. (db:no
4a10: 2d 73 79 6e 63 2d 64 65 6c 21 20 64 62 20 6b 65 -sync-del! db ke
4a20: 79 6e 61 6d 65 29 0a 09 20 20 72 65 73 29 29 29 yname).. res)))
4a30: 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ). .;;=========
4a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
4a80: 20 73 79 6e 63 20 62 61 63 6b 20 66 75 6e 63 74 sync back funct
4a90: 69 6f 6e 73 20 70 75 6c 6c 65 64 20 66 72 6f 6d ions pulled from
4aa0: 20 64 62 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d db.scm.;;======
4ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4af0: 0a 0a 3b 3b 20 47 65 74 20 61 20 6c 6f 63 6b 20 ..;; Get a lock
4b00: 66 72 6f 6d 20 74 68 65 20 6e 6f 2d 73 79 6e 63 from the no-sync
4b10: 2d 64 62 20 66 6f 72 20 74 68 65 20 66 72 6f 6d -db for the from
4b20: 2d 64 62 2c 20 74 68 65 6e 20 64 65 6c 74 61 20 -db, then delta
4b30: 73 79 6e 63 20 74 68 65 20 66 72 6f 6d 2d 64 62 sync the from-db
4b40: 20 74 6f 20 74 68 65 20 74 6f 2d 64 62 2c 20 6f to the to-db, o
4b50: 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 therwise return
4b60: 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 #f.;;.(define (d
4b70: 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 b:lock-and-delta
4b80: 2d 73 79 6e 63 20 6e 6f 2d 73 79 6e 63 2d 64 62 -sync no-sync-db
4b90: 20 64 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 dbstruct from-d
4ba0: 62 2d 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 b-file runid key
4bb0: 73 20 64 62 69 6e 69 74 29 0a 20 20 28 61 73 73 s dbinit). (ass
4bc0: 65 72 74 20 28 6e 6f 74 20 2a 64 62 2d 73 79 6e ert (not *db-syn
4bd0: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 20 c-in-progress*)
4be0: 22 46 41 54 41 4c 3a 20 64 62 3a 6c 6f 63 6b 2d "FATAL: db:lock-
4bf0: 61 6e 64 2d 73 79 6e 63 20 63 61 6c 6c 65 64 20 and-sync called
4c00: 77 68 69 6c 65 20 61 20 73 79 6e 63 20 69 73 20 while a sync is
4c10: 69 6e 20 70 72 6f 67 72 65 73 73 2e 22 29 0a 20 in progress.").
4c20: 20 3b 3b 20 28 64 62 66 69 6c 65 3a 70 72 69 6e ;; (dbfile:prin
4c30: 74 2d 65 72 72 20 2a 64 65 66 61 75 6c 74 2d 6c t-err *default-l
4c40: 6f 67 2d 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 og-port* "db:loc
4c50: 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 k-and-delta-sync
4c60: 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 "). (let* ((loc
4c70: 6b 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 72 6f k-file (conc fro
4c80: 6d 2d 64 62 2d 66 69 6c 65 20 22 2e 6c 6f 63 6b m-db-file ".lock
4c90: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f "))). (if (co
4ca0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
4cb0: 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 -lock lock-file)
4cc0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 62 66 ..(begin.. (dbf
4cd0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 ile:print-err "I
4ce0: 4e 46 4f 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e 64 NFO: db:lock-and
4cf0: 2d 64 65 6c 74 61 2d 73 79 6e 63 20 63 6f 70 79 -delta-sync copy
4d00: 69 6e 67 20 64 62 20 22 72 75 6e 69 64 22 20 61 ing db "runid" a
4d10: 74 20 22 28 63 75 72 72 65 6e 74 2d 73 65 63 6f t "(current-seco
4d20: 6e 64 73 29 29 0a 09 20 20 28 73 65 74 21 20 2a nds)).. (set! *
4d30: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
4d40: 65 73 73 2a 20 23 74 29 0a 09 20 20 28 64 62 3a ess* #t).. (db:
4d50: 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 sync-touched dbs
4d60: 74 72 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 truct runid keys
4d70: 20 64 62 69 6e 69 74 29 0a 09 20 20 28 73 65 74 dbinit).. (set
4d80: 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 ! *db-sync-in-pr
4d90: 6f 67 72 65 73 73 2a 20 23 66 29 0a 09 20 20 28 ogress* #f).. (
4da0: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 6c 6f 63 delete-file* loc
4db0: 6b 2d 66 69 6c 65 29 0a 09 20 20 23 74 29 0a 20 k-file).. #t).
4dc0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
4dd0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
4de0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 -noise-print 120
4df0: 20 28 63 6f 6e 63 20 22 6e 6f 20 6c 6f 63 6b 20 (conc "no lock
4e00: 22 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 29 29 0a "from-db-file)).
4e10: 09 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 . (dbfile:p
4e20: 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 rint-err "INFO:
4e30: 63 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 6c 6f could not get lo
4e40: 63 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d 64 62 ck for " from-db
4e50: 2d 66 69 6c 65 20 22 2c 20 73 79 6e 63 20 6c 69 -file ", sync li
4e60: 6b 65 6c 79 20 69 6e 20 70 72 6f 67 72 65 73 73 kely in progress
4e70: 2e 22 29 29 0a 09 20 20 23 66 0a 09 20 20 29 29 .")).. #f.. ))
4e80: 29 29 0a 0a 3b 3b 20 3b 3b 20 47 65 74 20 61 20 ))..;; ;; Get a
4e90: 6c 6f 63 6b 20 66 72 6f 6d 20 74 68 65 20 6e 6f lock from the no
4ea0: 2d 73 79 6e 63 2d 64 62 20 66 6f 72 20 74 68 65 -sync-db for the
4eb0: 20 66 72 6f 6d 2d 64 62 2c 20 74 68 65 6e 20 64 from-db, then d
4ec0: 65 6c 74 61 20 73 79 6e 63 20 74 68 65 20 66 72 elta sync the fr
4ed0: 6f 6d 2d 64 62 20 74 6f 20 74 68 65 20 74 6f 2d om-db to the to-
4ee0: 64 62 2c 20 6f 74 68 65 72 77 69 73 65 20 72 65 db, otherwise re
4ef0: 74 75 72 6e 20 23 66 0a 3b 3b 20 3b 3b 0a 3b 3b turn #f.;; ;;.;;
4f00: 20 28 64 65 66 69 6e 65 20 28 64 62 3a 6c 6f 63 (define (db:loc
4f10: 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 k-and-delta-sync
4f20: 2d 6f 72 69 67 20 6e 6f 2d 73 79 6e 63 2d 64 62 -orig no-sync-db
4f30: 20 64 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 dbstruct from-d
4f40: 62 2d 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 b-file runid key
4f50: 73 20 64 62 69 6e 69 74 29 0a 3b 3b 20 20 20 28 s dbinit).;; (
4f60: 61 73 73 65 72 74 20 28 6e 6f 74 20 2a 64 62 2d assert (not *db-
4f70: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
4f80: 2a 29 20 22 46 41 54 41 4c 3a 20 64 62 3a 6c 6f *) "FATAL: db:lo
4f90: 63 6b 2d 61 6e 64 2d 73 79 6e 63 20 63 61 6c 6c ck-and-sync call
4fa0: 65 64 20 77 68 69 6c 65 20 61 20 73 79 6e 63 20 ed while a sync
4fb0: 69 73 20 69 6e 20 70 72 6f 67 72 65 73 73 2e 22 is in progress."
4fc0: 29 0a 3b 3b 20 20 20 3b 3b 20 28 64 62 66 69 6c ).;; ;; (dbfil
4fd0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 2a 64 65 66 e:print-err *def
4fe0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4ff0: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 db:lock-and-delt
5000: 61 2d 73 79 6e 63 22 29 0a 3b 3b 20 20 20 28 6c a-sync").;; (l
5010: 65 74 2a 20 28 28 6c 6f 63 6b 64 61 74 20 20 28 et* ((lockdat (
5020: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c db:no-sync-get-l
5030: 6f 63 6b 2d 74 69 6d 65 6f 75 74 20 6e 6f 2d 73 ock-timeout no-s
5040: 79 6e 63 2d 64 62 20 66 72 6f 6d 2d 64 62 2d 66 ync-db from-db-f
5050: 69 6c 65 20 36 30 29 29 0a 3b 3b 20 09 20 28 67 ile 60)).;; . (g
5060: 6f 74 6c 6f 63 6b 20 20 28 63 61 72 20 6c 6f 63 otlock (car loc
5070: 6b 64 61 74 29 29 0a 3b 3b 20 09 20 28 6c 6f 63 kdat)).;; . (loc
5080: 6b 74 69 6d 65 20 28 63 64 72 20 6c 6f 63 6b 64 ktime (cdr lockd
5090: 61 74 29 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 at))).;; ;;
50a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
50b0: 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 3 *default-log
50c0: 2d 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d -port* "db:lock-
50d0: 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 3a 20 and-delta-sync:
50e0: 67 6f 74 20 6c 6f 63 6b 3f 22 29 0a 3b 3b 20 20 got lock?").;;
50f0: 20 20 20 0a 3b 3b 20 20 20 20 20 28 69 66 20 67 .;; (if g
5100: 6f 74 6c 6f 63 6b 0a 3b 3b 20 09 28 62 65 67 69 otlock.;; .(begi
5110: 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 n.;; (
5120: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
5130: 20 22 49 4e 46 4f 3a 20 64 62 3a 6c 6f 63 6b 2d "INFO: db:lock-
5140: 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 20 63 and-delta-sync c
5150: 6f 70 79 69 6e 67 20 64 62 20 22 72 75 6e 69 64 opying db "runid
5160: 22 20 61 74 20 22 28 63 75 72 72 65 6e 74 2d 73 " at "(current-s
5170: 65 63 6f 6e 64 73 29 29 0a 3b 3b 20 09 20 20 28 econds)).;; . (
5180: 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e set! *db-sync-in
5190: 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 0a 3b -progress* #t).;
51a0: 3b 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a ; (db:
51b0: 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 sync-touched dbs
51c0: 74 72 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 truct runid keys
51d0: 20 64 62 69 6e 69 74 29 0a 3b 3b 20 09 20 20 28 dbinit).;; . (
51e0: 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e set! *db-sync-in
51f0: 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a 3b -progress* #f).;
5200: 3b 20 09 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 ; . (db:no-sync
5210: 2d 64 65 6c 21 20 6e 6f 2d 73 79 6e 63 2d 64 62 -del! no-sync-db
5220: 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 29 0a 3b from-db-file).;
5230: 3b 20 09 20 20 23 74 29 0a 3b 3b 20 20 20 20 20 ; . #t).;;
5240: 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 (begin.;;
5250: 20 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a (dbfile:
5260: 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 print-err "ERROR
5270: 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 : could not get
5280: 6c 6f 63 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d lock for " from-
5290: 64 62 2d 66 69 6c 65 20 22 20 66 72 6f 6d 20 6e db-file " from n
52a0: 6f 2d 73 79 6e 63 2d 64 62 22 29 0a 3b 3b 20 09 o-sync-db").;; .
52b0: 20 20 23 66 0a 3b 3b 20 20 20 20 20 20 20 20 20 #f.;;
52c0: 29 29 29 29 0a 0a 3b 3b 20 73 79 6e 63 20 72 75 ))))..;; sync ru
52d0: 6e 20 66 72 6f 6d 20 74 6d 70 20 64 69 73 6b 20 n from tmp disk
52e0: 74 6f 20 6e 66 73 20 64 69 73 6b 20 69 66 20 74 to nfs disk if t
52f0: 6f 75 63 68 65 64 0a 3b 3b 0a 3b 3b 20 63 61 6c ouched.;;.;; cal
5300: 6c 20 77 69 74 68 20 64 62 69 6e 69 74 3d 64 62 l with dbinit=db
5310: 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 69 6e :initialize-main
5320: 2d 64 62 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 -db.;;.(define (
5330: 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 db:sync-touched
5340: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
5350: 6b 65 79 73 20 23 21 6b 65 79 20 64 62 69 6e 69 keys #!key dbini
5360: 74 20 28 66 6f 72 63 65 2d 73 79 6e 63 20 23 66 t (force-sync #f
5370: 29 29 0a 20 20 28 64 62 66 69 6c 65 3a 70 72 69 )). (dbfile:pri
5380: 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d nt-err "db:sync-
5390: 74 6f 75 63 68 65 64 20 53 79 6e 63 69 6e 67 3a touched Syncing:
53a0: 20 22 20 28 63 6f 6e 63 20 28 69 66 20 72 75 6e " (conc (if run
53b0: 2d 69 64 20 72 75 6e 2d 69 64 20 22 6d 61 69 6e -id run-id "main
53c0: 22 29 20 22 2e 64 62 22 29 29 0a 20 20 28 6c 65 ") ".db")). (le
53d0: 74 2a 20 28 3b 3b 20 74 68 65 20 73 75 62 64 62 t* (;; the subdb
53e0: 20 69 73 20 6e 65 65 64 65 64 20 74 6f 20 61 63 is needed to ac
53f0: 63 65 73 73 20 74 68 65 20 6d 74 64 62 64 61 74 cess the mtdbdat
5400: 0a 09 20 28 73 75 62 64 62 20 20 20 20 20 28 6f .. (subdb (o
5410: 72 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 r (dbfile:get-su
5420: 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e bdb dbstruct run
5430: 2d 69 64 29 0a 09 09 09 28 64 62 66 69 6c 65 3a -id)....(dbfile:
5440: 69 6e 69 74 2d 73 75 62 64 62 20 64 62 73 74 72 init-subdb dbstr
5450: 75 63 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 uct run-id dbini
5460: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 t))). (t
5470: 6d 70 64 62 66 69 6c 65 20 28 64 62 72 3a 73 75 mpdbfile (dbr:su
5480: 62 64 62 2d 74 6d 70 64 62 66 69 6c 65 20 73 75 bdb-tmpdbfile su
5490: 62 64 62 29 29 0a 09 20 28 6d 74 64 62 20 20 20 bdb)).. (mtdb
54a0: 20 20 20 28 64 62 72 3a 73 75 62 64 62 2d 6d 74 (dbr:subdb-mt
54b0: 64 62 64 61 74 20 73 75 62 64 62 29 29 0a 20 20 dbdat subdb)).
54c0: 20 20 20 20 20 20 20 28 74 6d 70 64 62 20 20 20 (tmpdb
54d0: 20 20 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 (db:open-db db
54e0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 struct run-id db
54f0: 69 6e 69 74 29 29 20 3b 3b 20 73 71 6c 69 74 65 init)) ;; sqlite
5500: 33 2d 64 62 20 74 6d 70 64 62 66 69 6c 65 20 23 3-db tmpdbfile #
5510: 66 29 29 0a 09 20 28 73 74 61 72 74 2d 74 20 20 f)).. (start-t
5520: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5530: 73 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d s))). (mutex-
5540: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5550: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 sync-mutex*).
5560: 20 28 6c 65 74 20 28 28 75 70 64 61 74 65 5f 69 (let ((update_i
5570: 6e 66 6f 20 28 63 6f 6e 73 20 22 6c 61 73 74 5f nfo (cons "last_
5580: 75 70 64 61 74 65 22 20 28 69 66 20 66 6f 72 63 update" (if forc
5590: 65 2d 73 79 6e 63 20 30 20 2a 64 62 2d 6c 61 73 e-sync 0 *db-las
55a0: 74 2d 73 79 6e 63 2a 29 20 29 29 29 0a 20 20 20 t-sync*) ))).
55b0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
55c0: 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 ! *db-multi-sync
55d0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
55e0: 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 28 db:sync-tables (
55f0: 64 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 62 6c db:sync-all-tabl
5600: 65 73 2d 6c 69 73 74 20 64 62 73 74 72 75 63 74 es-list dbstruct
5610: 20 6b 65 79 73 29 20 75 70 64 61 74 65 5f 69 6e keys) update_in
5620: 66 6f 20 74 6d 70 64 62 20 6d 74 64 62 29 29 0a fo tmpdb mtdb)).
5630: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
5640: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
5650: 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 73 65 74 mutex*). (set
5660: 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a ! *db-last-sync*
5670: 20 73 74 61 72 74 2d 74 29 0a 20 20 20 20 28 73 start-t). (s
5680: 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 et! *db-last-acc
5690: 65 73 73 2a 20 73 74 61 72 74 2d 74 29 0a 20 20 ess* start-t).
56a0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
56b0: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
56c0: 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 64 62 66 mutex*). (dbf
56d0: 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 62 ile:add-dbdat db
56e0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 74 6d struct run-id tm
56f0: 70 64 62 29 0a 20 20 23 74 29 29 0a 0a 3b 3b 20 pdb). #t))..;;
5700: 6a 75 73 74 20 74 65 73 74 73 2c 20 74 65 73 74 just tests, test
5710: 5f 73 74 65 70 73 20 61 6e 64 20 74 65 73 74 5f _steps and test_
5720: 64 61 74 61 20 74 61 62 6c 65 73 0a 28 64 65 66 data tables.(def
5730: 69 6e 65 20 64 62 3a 73 79 6e 63 2d 74 65 73 74 ine db:sync-test
5740: 73 2d 6f 6e 6c 79 0a 20 20 28 6c 69 73 74 0a 20 s-only. (list.
5750: 20 20 3b 3b 20 28 6c 69 73 74 20 22 73 74 72 73 ;; (list "strs
5760: 22 0a 20 20 20 3b 3b 20 20 20 20 20 20 20 27 28 ". ;; '(
5770: 22 69 64 22 20 20 20 20 20 20 20 20 20 20 20 20 "id"
5780: 20 23 66 29 0a 20 20 20 3b 3b 20 20 20 20 20 20 #f). ;;
5790: 20 27 28 22 73 74 72 22 20 20 20 20 20 20 20 20 '("str"
57a0: 20 20 20 20 23 66 29 29 0a 20 20 20 28 6c 69 73 #f)). (lis
57b0: 74 20 22 74 65 73 74 73 22 20 0a 09 20 27 28 22 t "tests" .. '("
57c0: 69 64 22 20 20 20 20 20 20 20 20 20 20 20 20 20 id"
57d0: 23 66 29 0a 09 20 27 28 22 72 75 6e 5f 69 64 22 #f).. '("run_id"
57e0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
57f0: 28 22 74 65 73 74 6e 61 6d 65 22 20 20 20 20 20 ("testname"
5800: 20 20 23 66 29 0a 09 20 27 28 22 68 6f 73 74 22 #f).. '("host"
5810: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
5820: 20 27 28 22 63 70 75 6c 6f 61 64 22 20 20 20 20 '("cpuload"
5830: 20 20 20 20 23 66 29 0a 09 20 27 28 22 64 69 73 #f).. '("dis
5840: 6b 66 72 65 65 22 20 20 20 20 20 20 20 23 66 29 kfree" #f)
5850: 0a 09 20 27 28 22 75 6e 61 6d 65 22 20 20 20 20 .. '("uname"
5860: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 72 #f).. '("r
5870: 75 6e 64 69 72 22 20 20 20 20 20 20 20 20 20 23 undir" #
5880: 66 29 0a 09 20 27 28 22 73 68 6f 72 74 64 69 72 f).. '("shortdir
5890: 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 " #f).. '(
58a0: 22 69 74 65 6d 5f 70 61 74 68 22 20 20 20 20 20 "item_path"
58b0: 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 65 22 #f).. '("state"
58c0: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
58d0: 27 28 22 73 74 61 74 75 73 22 20 20 20 20 20 20 '("status"
58e0: 20 20 20 23 66 29 0a 09 20 27 28 22 61 74 74 65 #f).. '("atte
58f0: 6d 70 74 6e 75 6d 22 20 20 20 20 20 23 66 29 0a mptnum" #f).
5900: 09 20 27 28 22 66 69 6e 61 6c 5f 6c 6f 67 66 22 . '("final_logf"
5910: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 6c 6f #f).. '("lo
5920: 67 64 61 74 22 20 20 20 20 20 20 20 20 20 23 66 gdat" #f
5930: 29 0a 09 20 27 28 22 72 75 6e 5f 64 75 72 61 74 ).. '("run_durat
5940: 69 6f 6e 22 20 20 20 23 66 29 0a 09 20 27 28 22 ion" #f).. '("
5950: 63 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 20 comment"
5960: 23 66 29 0a 09 20 27 28 22 65 76 65 6e 74 5f 74 #f).. '("event_t
5970: 69 6d 65 22 20 20 20 20 20 23 66 29 0a 09 20 27 ime" #f).. '
5980: 28 22 66 61 69 6c 5f 63 6f 75 6e 74 22 20 20 20 ("fail_count"
5990: 20 20 23 66 29 0a 09 20 27 28 22 70 61 73 73 5f #f).. '("pass_
59a0: 63 6f 75 6e 74 22 20 20 20 20 20 23 66 29 0a 09 count" #f)..
59b0: 20 27 28 22 61 72 63 68 69 76 65 64 22 20 20 20 '("archived"
59c0: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
59d0: 20 27 28 22 6c 61 73 74 5f 75 70 64 61 74 65 22 '("last_update"
59e0: 20 20 20 20 23 66 29 29 0a 20 20 28 6c 69 73 74 #f)). (list
59f0: 20 22 74 65 73 74 5f 73 74 65 70 73 22 0a 09 20 "test_steps"..
5a00: 27 28 22 69 64 22 20 20 20 20 20 20 20 20 20 20 '("id"
5a10: 20 20 20 23 66 29 0a 09 20 27 28 22 74 65 73 74 #f).. '("test
5a20: 5f 69 64 22 20 20 20 20 20 20 20 20 23 66 29 0a _id" #f).
5a30: 09 20 27 28 22 73 74 65 70 6e 61 6d 65 22 20 20 . '("stepname"
5a40: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 74 #f).. '("st
5a50: 61 74 65 22 20 20 20 20 20 20 20 20 20 20 23 66 ate" #f
5a60: 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 20 20 ).. '("status"
5a70: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5a80: 65 76 65 6e 74 5f 74 69 6d 65 22 20 20 20 20 20 event_time"
5a90: 23 66 29 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 #f).. '("comment
5aa0: 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 " #f).. '
5ab0: 28 22 6c 6f 67 66 69 6c 65 22 20 20 20 20 20 20 ("logfile"
5ac0: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 27 #f). '
5ad0: 28 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 20 ("last_update"
5ae0: 20 20 23 66 29 29 0a 20 20 20 28 6c 69 73 74 20 #f)). (list
5af0: 22 74 65 73 74 5f 64 61 74 61 22 0a 09 20 27 28 "test_data".. '(
5b00: 22 69 64 22 20 20 20 20 20 20 20 20 20 20 20 20 "id"
5b10: 20 23 66 29 0a 09 20 27 28 22 74 65 73 74 5f 69 #f).. '("test_i
5b20: 64 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 d" #f)..
5b30: 27 28 22 63 61 74 65 67 6f 72 79 22 20 20 20 20 '("category"
5b40: 20 20 20 23 66 29 0a 09 20 27 28 22 76 61 72 69 #f).. '("vari
5b50: 61 62 6c 65 22 20 20 20 20 20 20 20 23 66 29 0a able" #f).
5b60: 09 20 27 28 22 76 61 6c 75 65 22 20 20 20 20 20 . '("value"
5b70: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 65 78 #f).. '("ex
5b80: 70 65 63 74 65 64 22 20 20 20 20 20 20 20 23 66 pected" #f
5b90: 29 0a 09 20 27 28 22 74 6f 6c 22 20 20 20 20 20 ).. '("tol"
5ba0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5bb0: 75 6e 69 74 73 22 20 20 20 20 20 20 20 20 20 20 units"
5bc0: 23 66 29 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 #f).. '("comment
5bd0: 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 " #f).. '
5be0: 28 22 73 74 61 74 75 73 22 20 20 20 20 20 20 20 ("status"
5bf0: 20 20 23 66 29 0a 09 20 27 28 22 74 79 70 65 22 #f).. '("type"
5c00: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 #f).
5c10: 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f '("last_
5c20: 75 70 64 61 74 65 22 20 20 20 20 23 66 29 29 29 update" #f)))
5c30: 29 0a 0a 3b 3b 20 6e 65 65 64 73 20 64 62 20 74 )..;; needs db t
5c40: 6f 20 67 65 74 20 6b 65 79 73 2c 20 74 68 69 73 o get keys, this
5c50: 20 69 73 20 66 6f 72 20 73 79 6e 63 69 6e 67 20 is for syncing
5c60: 61 6c 6c 20 74 61 62 6c 65 73 0a 3b 3b 0a 28 64 all tables.;;.(d
5c70: 65 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d 6d efine (db:sync-m
5c80: 61 69 6e 2d 6c 69 73 74 20 64 62 73 74 72 75 63 ain-list dbstruc
5c90: 74 20 6b 65 79 73 29 0a 20 20 28 6c 65 74 20 28 t keys). (let (
5ca0: 28 6b 65 79 73 20 20 6b 65 79 73 29 29 20 3b 3b (keys keys)) ;;
5cb0: 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 (db:get-keys db
5cc0: 73 74 72 75 63 74 29 29 29 0a 20 20 20 20 28 6c struct))). (l
5cd0: 69 73 74 0a 20 20 20 20 20 28 6c 69 73 74 20 22 ist. (list "
5ce0: 6b 65 79 73 22 0a 09 20 20 20 27 28 22 69 64 22 keys".. '("id"
5cf0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 #f)..
5d00: 27 28 22 66 69 65 6c 64 6e 61 6d 65 22 20 23 66 '("fieldname" #f
5d10: 29 0a 09 20 20 20 27 28 22 66 69 65 6c 64 74 79 ).. '("fieldty
5d20: 70 65 22 20 23 66 29 29 0a 20 20 20 20 20 28 6c pe" #f)). (l
5d30: 69 73 74 20 22 6d 65 74 61 64 61 74 22 20 27 28 ist "metadat" '(
5d40: 22 76 61 72 22 20 23 66 29 20 27 28 22 76 61 6c "var" #f) '("val
5d50: 22 20 23 66 29 29 0a 20 20 20 20 20 28 61 70 70 " #f)). (app
5d60: 65 6e 64 20 28 6c 69 73 74 20 22 72 75 6e 73 22 end (list "runs"
5d70: 20 0a 09 09 20 20 20 27 28 22 69 64 22 20 20 23 ... '("id" #
5d80: 66 29 29 0a 09 20 20 20 20 20 28 6d 61 70 20 28 f)).. (map (
5d90: 6c 61 6d 62 64 61 20 28 6b 29 28 6c 69 73 74 20 lambda (k)(list
5da0: 6b 20 23 66 29 29 0a 09 09 20 20 28 61 70 70 65 k #f))... (appe
5db0: 6e 64 20 6b 65 79 73 0a 09 09 09 20 20 28 6c 69 nd keys.... (li
5dc0: 73 74 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 74 st "runname" "st
5dd0: 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 6f ate" "status" "o
5de0: 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 6d wner" "event_tim
5df0: 65 22 20 22 63 6f 6d 6d 65 6e 74 22 20 22 66 61 e" "comment" "fa
5e00: 69 6c 5f 63 6f 75 6e 74 22 20 22 70 61 73 73 5f il_count" "pass_
5e10: 63 6f 75 6e 74 22 20 22 63 6f 6e 74 6f 75 72 22 count" "contour"
5e20: 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 29 29 "last_update"))
5e30: 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 61 )). (list "a
5e40: 72 63 68 69 76 65 5f 64 69 73 6b 73 22 0a 20 20 rchive_disks".
5e50: 20 20 20 20 20 20 20 20 20 27 28 22 69 64 22 20 '("id"
5e60: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
5e70: 28 22 61 72 63 68 69 76 65 5f 61 72 65 61 5f 6e ("archive_area_n
5e80: 61 6d 65 22 20 23 66 29 20 0a 20 20 20 20 20 20 ame" #f) .
5e90: 20 20 20 20 20 27 28 22 64 69 73 6b 5f 70 61 74 '("disk_pat
5ea0: 68 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 h" #f).
5eb0: 20 20 27 28 22 6c 61 73 74 5f 64 66 22 20 23 66 '("last_df" #f
5ec0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ). '("
5ed0: 6c 61 73 74 5f 64 66 5f 74 69 6d 65 22 20 23 66 last_df_time" #f
5ee0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ). '("
5ef0: 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 22 20 23 creation_time" #
5f00: 66 29 29 20 0a 0a 20 20 20 20 20 28 6c 69 73 74 f)) .. (list
5f10: 20 22 61 72 63 68 69 76 65 5f 62 6c 6f 63 6b 73 "archive_blocks
5f20: 22 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ". '("
5f30: 69 64 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 id" #f).
5f40: 20 20 20 27 28 22 61 72 63 68 69 76 65 5f 64 69 '("archive_di
5f50: 73 6b 5f 69 64 22 20 23 66 29 20 0a 20 20 20 20 sk_id" #f) .
5f60: 20 20 20 20 20 20 20 27 28 22 64 69 73 6b 5f 70 '("disk_p
5f70: 61 74 68 22 20 23 66 29 0a 20 20 20 20 20 20 20 ath" #f).
5f80: 20 20 20 20 27 28 22 6c 61 73 74 5f 64 75 22 20 '("last_du"
5f90: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
5fa0: 28 22 6c 61 73 74 5f 64 75 5f 74 69 6d 65 22 20 ("last_du_time"
5fb0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
5fc0: 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 22 ("creation_time"
5fd0: 20 23 66 29 29 20 0a 0a 20 20 20 20 20 28 6c 69 #f)) .. (li
5fe0: 73 74 20 22 74 65 73 74 5f 6d 65 74 61 22 0a 09 st "test_meta"..
5ff0: 20 20 20 27 28 22 69 64 22 20 20 20 20 20 20 20 '("id"
6000: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 #f).. '(
6010: 22 74 65 73 74 6e 61 6d 65 22 20 20 20 20 20 20 "testname"
6020: 20 23 66 29 0a 09 20 20 20 27 28 22 6f 77 6e 65 #f).. '("owne
6030: 72 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a r" #f).
6040: 09 20 20 20 27 28 22 64 65 73 63 72 69 70 74 69 . '("descripti
6050: 6f 6e 22 20 20 20 20 23 66 29 0a 09 20 20 20 27 on" #f).. '
6060: 28 22 72 65 76 69 65 77 65 64 22 20 20 20 20 20 ("reviewed"
6070: 20 20 23 66 29 0a 09 20 20 20 27 28 22 69 74 65 #f).. '("ite
6080: 72 61 74 65 64 22 20 20 20 20 20 20 20 23 66 29 rated" #f)
6090: 0a 09 20 20 20 27 28 22 61 76 67 5f 72 75 6e 74 .. '("avg_runt
60a0: 69 6d 65 22 20 20 20 20 23 66 29 0a 09 20 20 20 ime" #f)..
60b0: 27 28 22 61 76 67 5f 64 69 73 6b 22 20 20 20 20 '("avg_disk"
60c0: 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 74 61 #f).. '("ta
60d0: 67 73 22 20 20 20 20 20 20 20 20 20 20 20 23 66 gs" #f
60e0: 29 0a 09 20 20 20 27 28 22 6a 6f 62 67 72 6f 75 ).. '("jobgrou
60f0: 70 22 20 20 20 20 20 20 20 23 66 29 29 29 29 29 p" #f)))))
6100: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 73 79 ..(define (db:sy
6110: 6e 63 2d 61 6c 6c 2d 74 61 62 6c 65 73 2d 6c 69 nc-all-tables-li
6120: 73 74 20 64 62 73 74 72 75 63 74 20 6b 65 79 73 st dbstruct keys
6130: 29 0a 20 20 28 61 70 70 65 6e 64 20 28 64 62 3a ). (append (db:
6140: 73 79 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 20 64 sync-main-list d
6150: 62 73 74 72 75 63 74 20 6b 65 79 73 29 0a 09 20 bstruct keys)..
6160: 20 64 62 3a 73 79 6e 63 2d 74 65 73 74 73 2d 6f db:sync-tests-o
6170: 6e 6c 79 29 29 0a 0a 3b 3b 20 74 62 6c 73 20 69 nly))..;; tbls i
6180: 73 20 28 20 28 22 74 61 62 6c 65 6e 61 6d 65 22 s ( ("tablename"
6190: 20 28 20 22 66 69 65 6c 64 31 22 20 5b 23 66 7c ( "field1" [#f|
61a0: 70 72 6f 63 31 5d 20 29 20 28 20 22 66 69 65 6c proc1] ) ( "fiel
61b0: 64 32 22 20 5b 23 66 7c 70 72 6f 63 32 5d 20 29 d2" [#f|proc2] )
61c0: 20 2e 2e 2e 2e 20 29 20 29 0a 3b 3b 20 64 62 27 .... ) ).;; db'
61d0: 73 20 61 72 65 20 64 62 64 61 74 27 73 0a 3b 3b s are dbdat's.;;
61e0: 0a 3b 3b 20 69 66 20 6c 61 73 74 2d 75 70 64 61 .;; if last-upda
61f0: 74 65 20 73 70 65 63 69 66 69 65 64 20 28 22 66 te specified ("f
6200: 69 65 6c 64 2d 6e 61 6d 65 22 20 2e 20 74 69 6d ield-name" . tim
6210: 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 29 0a 3b 3b e-in-seconds).;;
6220: 20 20 20 20 74 68 65 6e 20 73 79 6e 63 20 6f 6e then sync on
6230: 6c 79 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 ly records where
6240: 20 66 69 65 6c 64 2d 6e 61 6d 65 20 3e 3d 20 74 field-name >= t
6250: 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 0a 3b ime-in-seconds.;
6260: 3b 20 20 20 20 49 46 46 20 66 69 65 6c 64 2d 6e ; IFF field-n
6270: 61 6d 65 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 ame exists.;;.(d
6280: 65 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d 74 efine (db:sync-t
6290: 61 62 6c 65 73 20 74 62 6c 73 20 6c 61 73 74 2d ables tbls last-
62a0: 75 70 64 61 74 65 20 66 72 6f 6d 64 62 20 74 6f update fromdb to
62b0: 64 62 20 2e 20 73 6c 61 76 65 2d 64 62 73 29 0a db . slave-dbs).
62c0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
62d0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
62e0: 62 65 67 69 6e 0a 20 20 20 20 20 28 64 62 66 69 begin. (dbfi
62f0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 45 le:print-err "E
6300: 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 XCEPTION: databa
6310: 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 se probably over
6320: 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 loaded or unread
6330: 61 62 6c 65 20 69 6e 20 64 62 3a 73 79 6e 63 2d able in db:sync-
6340: 74 61 62 6c 65 73 2e 22 29 0a 20 20 20 20 20 28 tables."). (
6350: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
6360: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
6370: 70 6f 72 74 29 29 0a 20 20 20 20 20 28 64 62 66 port)). (dbf
6380: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 ile:print-err "
6390: 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f message: " ((co
63a0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
63b0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
63c0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 message) exn)).
63d0: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
63e0: 74 2d 65 72 72 20 20 22 65 78 6e 3d 22 20 28 63 t-err "exn=" (c
63f0: 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 ondition->list e
6400: 78 6e 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c xn)). (dbfil
6410: 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 20 73 e:print-err " s
6420: 74 61 74 75 73 3a 20 20 22 20 28 28 63 6f 6e 64 tatus: " ((cond
6430: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
6440: 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 65 33 ccessor 'sqlite3
6450: 20 27 73 74 61 74 75 73 29 20 65 78 6e 29 29 0a 'status) exn)).
6460: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
6470: 6e 74 2d 65 72 72 20 20 22 20 73 72 63 20 64 62 nt-err " src db
6480: 3a 20 20 22 20 28 64 62 72 3a 64 62 64 61 74 2d : " (dbr:dbdat-
6490: 64 62 66 69 6c 65 20 66 72 6f 6d 64 62 29 29 0a dbfile fromdb)).
64a0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
64b0: 6c 61 6d 62 64 61 20 28 64 62 64 61 74 29 0a 09 lambda (dbdat)..
64c0: 09 20 28 6c 65 74 20 28 28 64 62 70 61 74 68 20 . (let ((dbpath
64d0: 28 64 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c (dbr:dbdat-dbfil
64e0: 65 20 64 62 64 61 74 29 29 29 0a 09 09 20 20 20 e dbdat)))...
64f0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
6500: 72 20 20 22 20 64 62 70 61 74 68 3a 20 20 22 20 r " dbpath: "
6510: 64 62 70 61 74 68 29 0a 09 09 20 20 20 28 69 66 dbpath)... (if
6520: 20 23 74 20 3b 3b 20 28 6e 6f 74 20 28 64 62 3a #t ;; (not (db:
6530: 72 65 70 61 69 72 2d 64 62 20 64 62 64 61 74 29 repair-db dbdat)
6540: 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 )... (begi
6550: 6e 0a 09 09 09 20 28 64 62 66 69 6c 65 3a 70 72 n.... (dbfile:pr
6560: 69 6e 74 2d 65 72 72 20 22 46 61 69 6c 65 64 20 int-err "Failed
6570: 74 6f 20 72 65 62 75 69 6c 64 20 28 72 65 70 61 to rebuild (repa
6580: 69 72 20 69 73 20 74 75 72 6e 65 64 20 6f 66 66 ir is turned off
6590: 29 20 22 20 64 62 70 61 74 68 20 22 2c 20 65 78 ) " dbpath ", ex
65a0: 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 09 09 iting now.")....
65b0: 20 28 65 78 69 74 29 29 29 29 29 0a 09 20 20 20 (exit)))))..
65c0: 20 20 20 20 28 63 6f 6e 73 20 74 6f 64 62 20 73 (cons todb s
65d0: 6c 61 76 65 2d 64 62 73 29 29 0a 20 20 20 20 20 lave-dbs)).
65e0: 0a 20 20 20 20 20 30 29 0a 0a 20 20 20 3b 3b 20 . 0).. ;;
65f0: 74 68 69 73 20 69 73 20 74 68 65 20 77 6f 72 6b this is the work
6600: 20 74 6f 20 62 65 20 64 6f 6e 65 22 29 0a 20 20 to be done").
6610: 20 28 63 6f 6e 64 0a 20 20 20 20 28 28 6e 6f 74 (cond. ((not
6620: 20 66 72 6f 6d 64 62 29 20 28 64 62 66 69 6c 65 fromdb) (dbfile
6630: 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 57 41 52 :print-err "WAR
6640: 4e 49 4e 47 3a 20 64 62 3a 73 79 6e 63 2d 74 61 NING: db:sync-ta
6650: 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 74 68 bles called with
6660: 20 66 72 6f 6d 64 62 20 6d 69 73 73 69 6e 67 22 fromdb missing"
6670: 29 0a 20 20 20 20 20 2d 31 29 0a 20 20 20 20 28 ). -1). (
6680: 28 6e 6f 74 20 74 6f 64 62 29 20 20 20 28 64 62 (not todb) (db
6690: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 file:print-err
66a0: 22 57 41 52 4e 49 4e 47 3a 20 64 62 3a 73 79 6e "WARNING: db:syn
66b0: 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 c-tables called
66c0: 77 69 74 68 20 74 6f 64 62 20 6d 69 73 73 69 6e with todb missin
66d0: 67 22 29 0a 20 20 20 20 20 2d 32 29 0a 20 20 20 g"). -2).
66e0: 20 28 28 6e 6f 74 20 28 73 71 6c 69 74 65 33 3a ((not (sqlite3:
66f0: 64 61 74 61 62 61 73 65 3f 20 28 64 62 72 3a 64 database? (dbr:d
6700: 62 64 61 74 2d 64 62 68 20 66 72 6f 6d 64 62 29 bdat-dbh fromdb)
6710: 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a )). (dbfile:
6720: 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 print-err "db:sy
6730: 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 nc-tables called
6740: 20 77 69 74 68 20 66 72 6f 6d 64 62 20 6e 6f 74 with fromdb not
6750: 20 61 20 64 61 74 61 62 61 73 65 20 22 20 66 72 a database " fr
6760: 6f 6d 64 62 29 0a 20 20 20 2d 33 29 0a 20 20 20 omdb). -3).
6770: 20 28 28 6e 6f 74 20 28 73 71 6c 69 74 65 33 3a ((not (sqlite3:
6780: 64 61 74 61 62 61 73 65 3f 20 28 64 62 72 3a 64 database? (dbr:d
6790: 62 64 61 74 2d 64 62 68 20 74 6f 64 62 29 29 29 bdat-dbh todb)))
67a0: 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 . (dbfile:pr
67b0: 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 int-err "db:sync
67c0: 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 -tables called w
67d0: 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 64 ith todb not a d
67e0: 61 74 61 62 61 73 65 20 22 20 74 6f 64 62 29 0a atabase " todb).
67f0: 20 20 20 2d 34 29 0a 0a 20 20 20 20 28 28 6e 6f -4).. ((no
6800: 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 t (file-write-ac
6810: 63 65 73 73 3f 20 28 64 62 72 3a 64 62 64 61 74 cess? (dbr:dbdat
6820: 2d 64 62 66 69 6c 65 20 74 6f 64 62 29 29 29 0a -dbfile todb))).
6830: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
6840: 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d nt-err "db:sync-
6850: 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 tables called wi
6860: 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 72 65 th todb not a re
6870: 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 ad-only database
6880: 20 22 20 74 6f 64 62 29 0a 20 20 20 20 20 2d 35 " todb). -5
6890: 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c ). ((not (nul
68a0: 6c 3f 20 28 6c 65 74 20 28 28 72 65 61 64 6f 6e l? (let ((readon
68b0: 6c 79 2d 73 6c 61 76 65 2d 64 62 73 0a 20 20 20 ly-slave-dbs.
68c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68d0: 20 20 20 20 20 28 66 69 6c 74 65 72 0a 20 20 20 (filter.
68e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68f0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 (lambda (d
6900: 62 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 bdat).
6910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6920: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
6930: 65 2d 61 63 63 65 73 73 3f 20 28 64 62 72 3a 64 e-access? (dbr:d
6940: 62 64 61 74 2d 64 62 66 69 6c 65 20 74 6f 64 62 bdat-dbfile todb
6950: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
6960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 6c sl
6970: 61 76 65 2d 64 62 73 29 29 29 0a 20 20 20 20 20 ave-dbs))).
6980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
6990: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 or-each.
69a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
69b0: 62 64 61 20 28 62 61 64 2d 64 62 64 61 74 29 0a bda (bad-dbdat).
69c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69d0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 (dbfile:pr
69e0: 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 int-err "db:sync
69f0: 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 -tables called w
6a00: 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 72 ith todb not a r
6a10: 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 ead-only databas
6a20: 65 20 22 20 62 61 64 2d 64 62 64 61 74 29 29 0a e " bad-dbdat)).
6a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a40: 20 20 20 20 72 65 61 64 6f 6e 6c 79 2d 73 6c 61 readonly-sla
6a50: 76 65 2d 64 62 73 29 0a 20 20 20 20 20 20 20 20 ve-dbs).
6a60: 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 6f reado
6a70: 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 73 29 29 29 nly-slave-dbs)))
6a80: 20 2d 36 29 0a 20 20 20 20 28 65 6c 73 65 0a 20 -6). (else.
6a90: 20 20 20 20 3b 3b 20 28 64 62 66 69 6c 65 3a 70 ;; (dbfile:p
6aa0: 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e rint-err "db:syn
6ab0: 63 2d 74 61 62 6c 65 73 3a 20 61 72 67 73 20 61 c-tables: args a
6ac0: 72 65 20 67 6f 6f 64 22 29 0a 0a 20 20 20 20 20 re good")..
6ad0: 28 6c 65 74 20 28 28 73 74 6d 74 73 20 20 20 20 (let ((stmts
6ae0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
6af0: 62 6c 65 29 29 20 3b 3b 20 74 61 62 6c 65 2d 66 ble)) ;; table-f
6b00: 69 65 6c 64 20 3d 3e 20 73 74 6d 74 0a 09 20 20 ield => stmt..
6b10: 20 28 61 6c 6c 2d 73 74 6d 74 73 20 20 20 27 28 (all-stmts '(
6b20: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
6b30: 3b 3b 20 28 20 28 20 73 74 6d 74 31 20 76 61 6c ;; ( ( stmt1 val
6b40: 75 65 31 20 29 20 28 20 73 74 6d 6c 32 20 76 61 ue1 ) ( stml2 va
6b50: 6c 75 65 32 20 29 29 0a 09 20 20 20 28 6e 75 6d lue2 )).. (num
6b60: 72 65 63 73 20 20 20 20 20 28 6d 61 6b 65 2d 68 recs (make-h
6b70: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 ash-table))..
6b80: 28 73 74 61 72 74 2d 74 69 6d 65 20 20 28 63 75 (start-time (cu
6b90: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
6ba0: 64 73 29 29 0a 09 20 20 20 28 74 6f 74 2d 63 6f ds)).. (tot-co
6bb0: 75 6e 74 20 20 20 30 29 29 0a 20 20 20 20 20 20 unt 0)).
6bc0: 20 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 74 61 (for-each ;; ta
6bd0: 62 6c 65 0a 09 28 6c 61 6d 62 64 61 20 28 74 61 ble..(lambda (ta
6be0: 62 6c 65 64 61 74 29 0a 09 20 20 28 6c 65 74 2a bledat).. (let*
6bf0: 20 28 28 74 61 62 6c 65 6e 61 6d 65 20 20 20 20 ((tablename
6c00: 20 20 20 20 28 63 61 72 20 74 61 62 6c 65 64 61 (car tableda
6c10: 74 29 29 0a 09 09 20 28 66 69 65 6c 64 73 20 20 t))... (fields
6c20: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 74 61 (cdr ta
6c30: 62 6c 65 64 61 74 29 29 0a 09 09 20 28 68 61 73 bledat))... (has
6c40: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 20 28 6d -last-update (m
6c50: 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 ember "last_upda
6c60: 74 65 22 20 66 69 65 6c 64 73 29 29 0a 09 09 20 te" fields))...
6c70: 28 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 (use-last-update
6c80: 20 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 (cond.....
6c90: 28 28 61 6e 64 20 68 61 73 2d 6c 61 73 74 2d 75 ((and has-last-u
6ca0: 70 64 61 74 65 0a 09 09 09 09 09 20 20 28 6d 65 pdate...... (me
6cb0: 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 mber "last_updat
6cc0: 65 22 20 66 69 65 6c 64 73 29 29 0a 09 09 09 09 e" fields)).....
6cd0: 20 20 20 20 20 23 74 29 20 3b 3b 20 69 66 20 67 #t) ;; if g
6ce0: 69 76 65 6e 20 61 20 6e 75 6d 62 65 72 2c 20 6a iven a number, j
6cf0: 75 73 74 20 75 73 65 20 69 74 20 66 6f 72 20 61 ust use it for a
6d00: 6c 6c 20 66 69 65 6c 64 73 0a 09 09 09 09 20 20 ll fields.....
6d10: 20 20 28 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 ((number? last
6d20: 2d 75 70 64 61 74 65 29 20 23 66 29 20 3b 3b 20 -update) #f) ;;
6d30: 69 66 20 6e 6f 74 20 6d 61 74 63 68 65 64 20 66 if not matched f
6d40: 69 72 73 74 20 65 6e 74 72 79 20 74 68 65 6e 20 irst entry then
6d50: 69 67 6e 6f 72 65 20 6c 61 73 74 2d 75 70 64 61 ignore last-upda
6d60: 74 65 20 66 6f 72 20 74 68 69 73 20 74 61 62 6c te for this tabl
6d70: 65 0a 09 09 09 09 20 20 20 20 28 28 61 6e 64 20 e..... ((and
6d80: 28 70 61 69 72 3f 20 6c 61 73 74 2d 75 70 64 61 (pair? last-upda
6d90: 74 65 29 0a 09 09 09 09 09 20 20 28 6d 65 6d 62 te)...... (memb
6da0: 65 72 20 28 63 61 72 20 6c 61 73 74 2d 75 70 64 er (car last-upd
6db0: 61 74 65 29 20 20 20 20 3b 3b 20 6c 61 73 74 2d ate) ;; last-
6dc0: 75 70 64 61 74 65 20 66 69 65 6c 64 20 6e 61 6d update field nam
6dd0: 65 0a 09 09 09 09 09 09 20 20 28 6d 61 70 20 63 e....... (map c
6de0: 61 72 20 66 69 65 6c 64 73 29 29 29 0a 20 20 20 ar fields))).
6df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e10: 20 20 20 20 20 23 74 29 0a 09 09 09 09 20 20 20 #t).....
6e20: 20 28 28 61 6e 64 20 6c 61 73 74 2d 75 70 64 61 ((and last-upda
6e30: 74 65 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 6c te (not (pair? l
6e40: 61 73 74 2d 75 70 64 61 74 65 29 29 20 28 6e 6f ast-update)) (no
6e50: 74 20 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d t (number? last-
6e60: 75 70 64 61 74 65 29 29 29 0a 09 09 09 09 20 20 update))).....
6e70: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
6e80: 2d 65 72 72 20 20 22 45 52 52 4f 52 3a 20 70 61 -err "ERROR: pa
6e90: 72 61 6d 65 74 65 72 20 6c 61 73 74 2d 75 70 64 rameter last-upd
6ea0: 61 74 65 20 66 6f 72 20 64 62 3a 73 79 6e 63 2d ate for db:sync-
6eb0: 74 61 62 6c 65 73 20 6d 75 73 74 20 62 65 20 61 tables must be a
6ec0: 20 70 61 69 72 20 6f 72 20 61 20 6e 75 6d 62 65 pair or a numbe
6ed0: 72 2c 20 72 65 63 65 69 76 65 64 3a 20 22 20 6c r, received: " l
6ee0: 61 73 74 2d 75 70 64 61 74 65 29 3b 3b 20 66 6f ast-update);; fo
6ef0: 75 6e 64 20 69 6e 20 66 69 65 6c 64 73 0a 09 09 und in fields...
6f00: 09 09 20 20 20 20 20 23 66 29 0a 09 09 09 09 20 .. #f).....
6f10: 20 20 20 28 65 6c 73 65 0a 09 09 09 09 20 20 20 (else.....
6f20: 20 20 23 66 29 29 29 0a 09 09 20 28 6c 61 73 74 #f)))... (last
6f30: 2d 75 70 64 61 74 65 2d 76 61 6c 75 65 20 28 69 -update-value (i
6f40: 66 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 f use-last-updat
6f50: 65 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 20 e ;; no need to
6f60: 63 68 65 63 6b 20 66 6f 72 20 68 61 73 2d 6c 61 check for has-la
6f70: 73 74 2d 75 70 64 61 74 65 20 2d 20 69 74 20 69 st-update - it i
6f80: 73 20 61 6c 72 65 61 64 79 20 61 63 63 6f 75 6e s already accoun
6f90: 74 65 64 20 66 6f 72 0a 09 09 09 09 09 28 69 66 ted for......(if
6fa0: 20 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d 75 (number? last-u
6fb0: 70 64 61 74 65 29 0a 09 09 09 09 09 20 20 20 20 pdate)......
6fc0: 6c 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 last-update.....
6fd0: 09 20 20 20 20 28 63 64 72 20 6c 61 73 74 2d 75 . (cdr last-u
6fe0: 70 64 61 74 65 29 29 0a 09 09 09 09 09 23 66 29 pdate))......#f)
6ff0: 29 0a 09 09 20 28 6c 61 73 74 2d 75 70 64 61 74 )... (last-updat
7000: 65 2d 66 69 65 6c 64 20 28 69 66 20 75 73 65 2d e-field (if use-
7010: 6c 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 last-update.....
7020: 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6c 61 .(if (number? la
7030: 73 74 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 st-update)......
7040: 20 20 20 20 22 6c 61 73 74 5f 75 70 64 61 74 65 "last_update
7050: 22 0a 09 09 09 09 09 20 20 20 20 28 63 61 72 20 "...... (car
7060: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 09 09 last-update))...
7070: 09 09 09 23 66 29 29 0a 09 09 20 28 6e 75 6d 2d ...#f))... (num-
7080: 66 69 65 6c 64 73 20 28 6c 65 6e 67 74 68 20 66 fields (length f
7090: 69 65 6c 64 73 29 29 0a 09 09 20 28 66 69 65 6c ields))... (fiel
70a0: 64 2d 3e 6e 75 6d 20 28 6d 61 6b 65 2d 68 61 73 d->num (make-has
70b0: 68 2d 74 61 62 6c 65 29 29 0a 09 09 20 28 6e 75 h-table))... (nu
70c0: 6d 2d 3e 66 69 65 6c 64 20 28 61 70 70 6c 79 20 m->field (apply
70d0: 76 65 63 74 6f 72 20 28 6d 61 70 20 63 61 72 20 vector (map car
70e0: 66 69 65 6c 64 73 29 29 29 20 3b 3b 20 42 42 48 fields))) ;; BBH
70f0: 45 52 45 0a 09 09 20 28 66 75 6c 6c 2d 73 65 6c ERE... (full-sel
7100: 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 (conc "SELECT
7110: 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 " (string-inter
7120: 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 72 20 sperse (map car
7130: 66 69 65 6c 64 73 29 20 22 2c 22 29 20 0a 09 09 fields) ",") ...
7140: 09 09 20 20 20 22 20 46 52 4f 4d 20 22 20 74 61 .. " FROM " ta
7150: 62 6c 65 6e 61 6d 65 20 28 69 66 20 75 73 65 2d blename (if use-
7160: 6c 61 73 74 2d 75 70 64 61 74 65 20 3b 3b 20 61 last-update ;; a
7170: 70 70 6c 79 20 6c 61 73 74 2d 75 70 64 61 74 65 pply last-update
7180: 20 63 72 69 74 65 72 69 61 0a 09 09 09 09 09 09 criteria.......
7190: 09 20 20 28 63 6f 6e 63 20 22 20 57 48 45 52 45 . (conc " WHERE
71a0: 20 22 20 6c 61 73 74 2d 75 70 64 61 74 65 2d 66 " last-update-f
71b0: 69 65 6c 64 20 22 20 3e 3d 20 22 20 6c 61 73 74 ield " >= " last
71c0: 2d 75 70 64 61 74 65 2d 76 61 6c 75 65 29 0a 09 -update-value)..
71d0: 09 09 09 09 09 09 20 20 22 22 29 0a 09 09 09 09 ...... "").....
71e0: 20 20 20 22 3b 22 29 29 0a 09 09 20 28 66 75 6c ";"))... (ful
71f0: 6c 2d 69 6e 73 20 20 20 28 63 6f 6e 63 20 22 49 l-ins (conc "I
7200: 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
7210: 20 49 4e 54 4f 20 22 20 74 61 62 6c 65 6e 61 6d INTO " tablenam
7220: 65 20 22 20 28 20 22 20 28 73 74 72 69 6e 67 2d e " ( " (string-
7230: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
7240: 20 63 61 72 20 66 69 65 6c 64 73 29 20 22 2c 22 car fields) ","
7250: 29 20 22 20 29 20 22 0a 09 09 09 09 20 20 20 22 ) " ) "..... "
7260: 20 56 41 4c 55 45 53 20 28 20 22 20 28 73 74 72 VALUES ( " (str
7270: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
7280: 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 6d 2d 66 (make-list num-f
7290: 69 65 6c 64 73 20 22 3f 22 29 20 22 2c 22 29 20 ields "?") ",")
72a0: 22 20 29 3b 22 29 29 0a 09 09 20 28 66 72 6f 6d " );"))... (from
72b0: 64 61 74 20 20 20 20 27 28 29 29 0a 09 09 20 28 dat '())... (
72c0: 66 72 6f 6d 64 61 74 73 20 20 20 27 28 29 29 0a fromdats '()).
72d0: 09 09 20 28 74 6f 74 72 65 63 6f 72 64 73 20 30 .. (totrecords 0
72e0: 29 0a 09 09 20 28 62 61 74 63 68 2d 6c 65 6e 20 )... (batch-len
72f0: 20 31 30 30 29 20 3b 3b 20 28 73 74 72 69 6e 67 100) ;; (string
7300: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f ->number (or (co
7310: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
7320: 6e 66 69 67 64 61 74 2a 20 22 73 79 6e 63 22 20 nfigdat* "sync"
7330: 22 62 61 74 63 68 73 69 7a 65 22 29 20 22 31 30 "batchsize") "10
7340: 30 22 29 29 29 0a 09 09 20 28 74 6f 64 61 74 20 0")))... (todat
7350: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
7360: 74 61 62 6c 65 29 29 0a 09 09 20 28 63 6f 75 6e table))... (coun
7370: 74 20 20 20 20 20 20 30 29 0a 20 20 20 20 20 20 t 0).
7380: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 65 6c (fiel
7390: 64 2d 6e 61 6d 65 73 20 28 6d 61 70 20 63 61 72 d-names (map car
73a0: 20 66 69 65 6c 64 73 29 29 0a 20 20 20 20 20 20 fields)).
73b0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 61 (dela
73c0: 79 2d 68 61 6e 64 69 63 61 70 20 20 30 29 20 3b y-handicap 0) ;
73d0: 3b 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ; (string->numbe
73e0: 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c r (or (configf:l
73f0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
7400: 2a 20 22 73 79 6e 63 22 20 22 64 65 6c 61 79 2d * "sync" "delay-
7410: 68 61 6e 64 69 63 61 70 22 29 20 22 30 22 29 29 handicap") "0"))
7420: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7430: 20 20 20 29 0a 0a 09 20 20 20 20 3b 3b 20 73 65 )... ;; se
7440: 74 20 75 70 20 74 68 65 20 66 69 65 6c 64 2d 3e t up the field->
7450: 6e 75 6d 20 74 61 62 6c 65 0a 09 20 20 20 20 28 num table.. (
7460: 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 28 for-each.. (
7470: 6c 61 6d 62 64 61 20 28 66 69 65 6c 64 29 0a 09 lambda (field)..
7480: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
7490: 6c 65 2d 73 65 74 21 20 66 69 65 6c 64 2d 3e 6e le-set! field->n
74a0: 75 6d 20 66 69 65 6c 64 20 63 6f 75 6e 74 29 0a um field count).
74b0: 09 20 20 20 20 20 20 20 28 73 65 74 21 20 63 6f . (set! co
74c0: 75 6e 74 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 unt (+ count 1))
74d0: 29 0a 09 20 20 20 20 20 66 69 65 6c 64 73 29 0a ).. fields).
74e0: 0a 09 20 20 20 20 3b 3b 20 72 65 61 64 20 74 68 .. ;; read th
74f0: 65 20 73 6f 75 72 63 65 20 74 61 62 6c 65 0a 20 e source table.
7500: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 73 74 ;; st
7510: 6f 72 65 20 61 20 6c 69 73 74 20 6f 66 20 61 6c ore a list of al
7520: 6c 20 72 6f 77 73 20 69 6e 20 74 68 65 20 74 61 l rows in the ta
7530: 62 6c 65 20 69 6e 20 66 72 6f 6d 64 61 74 2c 20 ble in fromdat,
7540: 75 70 20 74 6f 20 62 61 74 63 68 2d 6c 65 6e 2e up to batch-len.
7550: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 . ;;
7560: 54 68 65 6e 20 61 64 64 20 66 72 6f 6d 64 61 74 Then add fromdat
7570: 20 74 6f 20 74 68 65 20 66 72 6f 6d 64 61 74 73 to the fromdats
7580: 20 6c 69 73 74 2c 20 63 6c 65 61 72 20 66 72 6f list, clear fro
7590: 6d 64 61 74 20 61 6e 64 20 72 65 70 65 61 74 2e mdat and repeat.
75a0: 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 .. (sqlite3:f
75b0: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 or-each-row..
75c0: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 (lambda (a . b
75d0: 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 ).. (set!
75e0: 66 72 6f 6d 64 61 74 20 28 63 6f 6e 73 20 28 61 fromdat (cons (a
75f0: 70 70 6c 79 20 76 65 63 74 6f 72 20 61 20 62 29 pply vector a b)
7600: 20 66 72 6f 6d 64 61 74 29 29 0a 09 20 20 20 20 fromdat))..
7610: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
7620: 68 20 66 72 6f 6d 64 61 74 29 20 62 61 74 63 68 h fromdat) batch
7630: 2d 6c 65 6e 29 0a 09 09 20 20 20 28 62 65 67 69 -len)... (begi
7640: 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 66 n... (set! f
7650: 72 6f 6d 64 61 74 73 20 28 63 6f 6e 73 20 66 72 romdats (cons fr
7660: 6f 6d 64 61 74 20 66 72 6f 6d 64 61 74 73 29 29 omdat fromdats))
7670: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 66 72 ... (set! fr
7680: 6f 6d 64 61 74 20 20 27 28 29 29 0a 09 09 20 20 omdat '())...
7690: 20 20 20 28 73 65 74 21 20 74 6f 74 72 65 63 6f (set! totreco
76a0: 72 64 73 20 28 2b 20 74 6f 74 72 65 63 6f 72 64 rds (+ totrecord
76b0: 73 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 s 1))).
76c0: 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
76d0: 20 20 20 20 20 29 0a 09 20 20 20 20 20 28 64 62 ).. (db
76e0: 72 3a 64 62 64 61 74 2d 64 62 68 20 66 72 6f 6d r:dbdat-dbh from
76f0: 64 62 29 0a 09 20 20 20 20 20 66 75 6c 6c 2d 73 db).. full-s
7700: 65 6c 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 el)..
7710: 20 20 3b 3b 20 43 6f 75 6e 74 20 6c 65 73 73 20 ;; Count less
7720: 74 68 61 6e 20 62 61 74 63 68 2d 6c 65 6e 20 61 than batch-len a
7730: 73 20 61 20 72 65 63 6f 72 64 0a 20 20 20 20 20 s a record.
7740: 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 (if (> (
7750: 6c 65 6e 67 74 68 20 66 72 6f 6d 64 61 74 29 20 length fromdat)
7760: 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0).
7770: 20 20 20 20 28 73 65 74 21 20 74 6f 74 72 65 63 (set! totrec
7780: 6f 72 64 73 20 28 2b 20 74 6f 74 72 65 63 6f 72 ords (+ totrecor
7790: 64 73 20 31 29 29 29 0a 0a 09 20 20 20 20 3b 3b ds 1)))... ;;
77a0: 20 74 61 63 6b 20 6f 6e 20 72 65 6d 61 69 6e 69 tack on remaini
77b0: 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 66 72 ng records in fr
77c0: 6f 6d 64 61 74 0a 09 20 20 20 20 28 69 66 20 28 omdat.. (if (
77d0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 72 6f 6d 64 not (null? fromd
77e0: 61 74 29 29 0a 09 09 28 73 65 74 21 20 66 72 6f at))...(set! fro
77f0: 6d 64 61 74 73 20 28 63 6f 6e 73 20 66 72 6f 6d mdats (cons from
7800: 64 61 74 20 66 72 6f 6d 64 61 74 73 29 29 29 0a dat fromdats))).
7810: 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 .. (sqlite3:f
7820: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 or-each-row..
7830: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 (lambda (a . b
7840: 29 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 2d ).. (hash-
7850: 74 61 62 6c 65 2d 73 65 74 21 20 74 6f 64 61 74 table-set! todat
7860: 20 61 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 a (apply vector
7870: 20 61 20 62 29 29 29 0a 09 20 20 20 20 20 28 64 a b))).. (d
7880: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 74 6f 64 br:dbdat-dbh tod
7890: 62 29 0a 09 20 20 20 20 20 66 75 6c 6c 2d 73 65 b).. full-se
78a0: 6c 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 l)..
78b0: 28 77 68 65 6e 20 28 61 6e 64 20 64 65 6c 61 79 (when (and delay
78c0: 2d 68 61 6e 64 69 63 61 70 20 28 3e 20 64 65 6c -handicap (> del
78d0: 61 79 2d 68 61 6e 64 69 63 61 70 20 30 29 29 0a ay-handicap 0)).
78e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
78f0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
7900: 22 69 6d 70 6f 73 69 6e 67 20 73 79 6e 74 68 65 "imposing synthe
7910: 74 69 63 20 73 79 6e 63 20 64 65 6c 61 79 20 6f tic sync delay o
7920: 66 20 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 f "delay-handica
7930: 70 22 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 p" seconds since
7940: 20 73 79 6e 63 2f 64 65 6c 61 79 2d 68 61 6e 64 sync/delay-hand
7950: 69 63 61 70 20 69 73 20 63 6f 6e 66 69 67 75 72 icap is configur
7960: 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ed").
7970: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
7980: 21 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 ! delay-handicap
7990: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
79a0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
79b0: 72 20 22 73 79 6e 74 68 65 74 69 63 20 73 79 6e r "synthetic syn
79c0: 63 20 64 65 6c 61 79 20 6f 66 20 22 64 65 6c 61 c delay of "dela
79d0: 79 2d 68 61 6e 64 69 63 61 70 22 20 73 65 63 6f y-handicap" seco
79e0: 6e 64 73 20 63 6f 6d 70 6c 65 74 65 64 22 29 0a nds completed").
79f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
7a00: 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 20 20 ..
7a10: 20 20 3b 3b 20 66 69 72 73 74 20 70 61 73 73 20 ;; first pass
7a20: 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 2c 20 implementation,
7a30: 6a 75 73 74 20 69 6e 73 65 72 74 20 61 6c 6c 20 just insert all
7a40: 63 68 61 6e 67 65 64 20 72 6f 77 73 0a 0a 09 20 changed rows...
7a50: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 (for-each ..
7a60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 61 72 (lambda (tar
7a70: 67 64 62 29 0a 09 20 20 20 20 20 20 20 28 6c 65 gdb).. (le
7a80: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
7a90: 20 20 20 20 20 20 20 20 28 64 62 72 3a 64 62 64 (dbr:dbd
7aa0: 61 74 2d 64 62 68 20 74 61 72 67 64 62 29 29 0a at-dbh targdb)).
7ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ac0: 20 20 20 20 20 20 28 64 72 70 2d 74 72 69 67 67 (drp-trigg
7ad0: 65 72 20 20 20 20 20 20 20 20 28 69 66 20 28 6d er (if (m
7ae0: 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 ember "last_upda
7af0: 74 65 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 29 te" field-names)
7b00: 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 62 3a ...... (db:
7b10: 64 72 6f 70 2d 74 72 69 67 67 65 72 20 64 62 20 drop-trigger db
7b20: 74 61 62 6c 65 6e 61 6d 65 29 20 0a 09 09 09 09 tablename) .....
7b30: 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 20 20 . #f))...
7b40: 20 20 20 20 28 68 61 73 2d 6c 61 73 74 2d 75 70 (has-last-up
7b50: 64 61 74 65 20 20 20 20 28 6d 65 6d 62 65 72 20 date (member
7b60: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 66 69 "last_update" fi
7b70: 65 6c 64 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 eld-names)).
7b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b90: 20 20 28 69 73 2d 74 72 69 67 67 65 72 2d 64 72 (is-trigger-dr
7ba0: 6f 70 70 65 64 20 28 69 66 20 68 61 73 2d 6c 61 opped (if has-la
7bb0: 73 74 2d 75 70 64 61 74 65 0a 20 20 20 20 20 20 st-update.
7bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7be0: 20 20 20 20 20 20 20 20 28 64 62 3a 69 73 2d 74 (db:is-t
7bf0: 72 69 67 67 65 72 2d 64 72 6f 70 70 65 64 20 64 rigger-dropped d
7c00: 62 20 74 61 62 6c 65 6e 61 6d 65 29 0a 09 09 09 b tablename)....
7c10: 09 09 20 20 20 20 20 20 23 66 29 29 20 0a 09 09 .. #f)) ...
7c20: 20 20 20 20 20 20 28 73 74 6d 74 68 20 20 28 73 (stmth (s
7c30: 71 6c 69 74 65 33 3a 70 72 65 70 61 72 65 20 64 qlite3:prepare d
7c40: 62 20 66 75 6c 6c 2d 69 6e 73 29 29 0a 20 20 20 b full-ins)).
7c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c60: 20 20 20 28 63 68 61 6e 67 65 64 2d 72 6f 77 73 (changed-rows
7c70: 20 30 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 0))... (for-eac
7c80: 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 66 h... (lambda (f
7c90: 72 6f 6d 64 61 74 2d 6c 73 74 29 0a 09 09 20 20 romdat-lst)...
7ca0: 20 20 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d (sqlite3:with-
7cb0: 74 72 61 6e 73 61 63 74 69 6f 6e 0a 09 09 20 20 transaction...
7cc0: 20 20 20 64 62 0a 09 09 20 20 20 20 20 28 6c 61 db... (la
7cd0: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
7ce0: 20 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 0a 09 (for-each ;; ..
7cf0: 09 09 28 6c 61 6d 62 64 61 20 28 66 72 6f 6d 72 ..(lambda (fromr
7d00: 6f 77 29 0a 09 09 09 20 20 28 6c 65 74 2a 20 28 ow).... (let* (
7d10: 28 61 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (a (vector-re
7d20: 66 20 66 72 6f 6d 72 6f 77 20 30 29 29 0a 09 09 f fromrow 0))...
7d30: 09 09 20 28 63 75 72 72 20 28 68 61 73 68 2d 74 .. (curr (hash-t
7d40: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7d50: 20 74 6f 64 61 74 20 61 20 23 66 29 29 0a 09 09 todat a #f))...
7d60: 09 09 20 28 73 61 6d 65 20 23 74 29 29 0a 09 09 .. (same #t))...
7d70: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
7d80: 28 69 20 30 29 29 0a 09 09 09 20 20 20 20 20 20 (i 0))....
7d90: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 75 72 (if (or (not cur
7da0: 72 29 0a 09 09 09 09 20 20 20 20 20 20 28 6e 6f r)..... (no
7db0: 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f t (equal? (vecto
7dc0: 72 2d 72 65 66 20 66 72 6f 6d 72 6f 77 20 69 29 r-ref fromrow i)
7dd0: 28 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 (vector-ref curr
7de0: 20 69 29 29 29 29 0a 09 09 09 09 20 20 28 73 65 i))))..... (se
7df0: 74 21 20 73 61 6d 65 20 23 66 29 29 0a 09 09 09 t! same #f))....
7e00: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 (if (and s
7e10: 61 6d 65 0a 09 09 09 09 20 20 20 20 20 20 20 28 ame..... (
7e20: 3c 20 69 20 28 2d 20 6e 75 6d 2d 66 69 65 6c 64 < i (- num-field
7e30: 73 20 31 29 29 29 0a 09 09 09 09 20 20 28 6c 6f s 1)))..... (lo
7e40: 6f 70 20 28 2b 20 69 20 31 29 29 29 29 0a 09 09 op (+ i 1))))...
7e50: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 61 . (if (not sa
7e60: 6d 65 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 me).....(begin..
7e70: 09 09 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 ... (apply sqli
7e80: 74 65 33 3a 65 78 65 63 75 74 65 20 73 74 6d 74 te3:execute stmt
7e90: 68 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 h (vector->list
7ea0: 66 72 6f 6d 72 6f 77 29 29 0a 09 09 09 09 20 20 fromrow)).....
7eb0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
7ec0: 20 6e 75 6d 72 65 63 73 20 74 61 62 6c 65 6e 61 numrecs tablena
7ed0: 6d 65 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 me (+ 1 (hash-ta
7ee0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7ef0: 6e 75 6d 72 65 63 73 20 74 61 62 6c 65 6e 61 6d numrecs tablenam
7f00: 65 20 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 e 0))).
7f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f20: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 63 (set! c
7f30: 68 61 6e 67 65 64 2d 72 6f 77 73 20 28 2b 20 63 hanged-rows (+ c
7f40: 68 61 6e 67 65 64 2d 72 6f 77 73 20 31 29 29 0a hanged-rows 1)).
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
7f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fa0: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a 09 ))..
7fb0: 09 09 66 72 6f 6d 64 61 74 2d 6c 73 74 29 29 29 ..fromdat-lst)))
7fc0: 29 0a 09 09 20 20 66 72 6f 6d 64 61 74 73 29 0a )... fromdats).
7fd0: 0a 09 09 20 28 73 71 6c 69 74 65 33 3a 66 69 6e ... (sqlite3:fin
7fe0: 61 6c 69 7a 65 21 20 73 74 6d 74 68 29 0a 20 20 alize! stmth).
7ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8000: 69 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 if (member "last
8010: 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e _update" field-n
8020: 61 6d 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 ames).
8030: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 63 72 (db:cr
8040: 65 61 74 65 2d 74 72 69 67 67 65 72 20 64 62 20 eate-trigger db
8050: 74 61 62 6c 65 6e 61 6d 65 29 29 29 29 0a 09 20 tablename))))..
8060: 20 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 (append (lis
8070: 74 20 74 6f 64 62 29 20 73 6c 61 76 65 2d 64 62 t todb) slave-db
8080: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 29 0a s). ).
8090: 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 ).
80a0: 20 20 20 20 29 0a 09 74 62 6c 73 29 0a 20 20 20 )..tbls).
80b0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 74 (let* ((runt
80c0: 69 6d 65 20 20 20 20 20 20 28 2d 20 28 63 75 72 ime (- (cur
80d0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
80e0: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a s) start-time)).
80f0: 09 20 20 20 20 20 20 28 73 68 6f 75 6c 64 2d 70 . (should-p
8100: 72 69 6e 74 20 28 6f 72 20 3b 3b 20 28 64 65 62 rint (or ;; (deb
8110: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 32 ug:debug-mode 12
8120: 29 0a 09 09 09 09 28 63 6f 6d 6d 6f 6e 3a 6c 6f ).....(common:lo
8130: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 w-noise-print 12
8140: 30 20 22 64 62 20 73 79 6e 63 22 20 28 3e 20 72 0 "db sync" (> r
8150: 75 6e 74 69 6d 65 20 35 30 30 29 29 29 29 29 20 untime 500)))))
8160: 3b 3b 20 6c 6f 77 20 61 6e 64 20 68 69 67 68 20 ;; low and high
8170: 73 79 6e 63 20 74 69 6d 65 73 20 74 72 65 61 74 sync times treat
8180: 65 64 20 61 73 20 73 65 70 61 72 61 74 65 2e 0a ed as separate..
8190: 09 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 . (for-each ..
81a0: 28 6c 61 6d 62 64 61 20 28 64 61 74 29 0a 09 20 (lambda (dat)..
81b0: 20 20 20 28 6c 65 74 20 28 28 74 62 6c 6e 61 6d (let ((tblnam
81c0: 65 20 28 63 61 72 20 64 61 74 29 29 0a 09 09 20 e (car dat))...
81d0: 20 28 63 6f 75 6e 74 20 20 20 28 63 64 72 20 64 (count (cdr d
81e0: 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 73 65 at))).. (se
81f0: 74 21 20 74 6f 74 2d 63 6f 75 6e 74 20 28 2b 20 t! tot-count (+
8200: 74 6f 74 2d 63 6f 75 6e 74 20 63 6f 75 6e 74 29 tot-count count)
8210: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8220: 29 29 20 0a 09 20 20 28 73 6f 72 74 20 28 68 61 )) .. (sort (ha
8230: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
8240: 6e 75 6d 72 65 63 73 29 28 6c 61 6d 62 64 61 20 numrecs)(lambda
8250: 28 61 20 62 29 28 3e 20 28 63 64 72 20 61 29 28 (a b)(> (cdr a)(
8260: 63 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 cdr b)))))).
8270: 20 20 20 74 6f 74 2d 63 6f 75 6e 74 29 29 29 29 tot-count))))
8280: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
8290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 ===========.;; t
82d0: 72 69 67 67 65 72 20 73 65 74 75 70 2f 74 61 6b rigger setup/tak
82e0: 65 64 6f 77 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d edown.;;========
82f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
8330: 28 64 65 66 69 6e 65 20 64 62 3a 74 72 69 67 67 (define db:trigg
8340: 65 72 2d 6c 69 73 74 20 0a 20 20 20 20 20 28 6c er-list . (l
8350: 69 73 74 20 28 6c 69 73 74 20 22 75 70 64 61 74 ist (list "updat
8360: 65 5f 72 75 6e 73 5f 74 72 69 67 67 65 72 22 20 e_runs_trigger"
8370: 20 22 43 52 45 41 54 45 20 54 52 49 47 47 45 52 "CREATE TRIGGER
8380: 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 IF NOT EXISTS u
8390: 70 64 61 74 65 5f 72 75 6e 73 5f 74 72 69 67 67 pdate_runs_trigg
83a0: 65 72 20 41 46 54 45 52 20 55 50 44 41 54 45 20 er AFTER UPDATE
83b0: 4f 4e 20 72 75 6e 73 0a 20 20 20 20 20 20 20 20 ON runs.
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f FOR EACH RO
83e0: 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 W.
83f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8400: 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 BEGIN .
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 20 UPDATE
8430: 72 75 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 70 runs SET last_up
8440: 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 27 date=(strftime('
8450: 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 %s','now')).
8460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 57 W
8480: 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a HERE id=old.id;.
8490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45 E
84b0: 4e 44 3b 22 20 29 20 0a 09 20 20 20 28 6c 69 73 ND;" ) .. (lis
84c0: 74 20 22 75 70 64 61 74 65 5f 72 75 6e 5f 73 74 t "update_run_st
84d0: 61 74 73 5f 74 72 69 67 67 65 72 22 20 20 22 43 ats_trigger" "C
84e0: 52 45 41 54 45 20 54 52 49 47 47 45 52 20 20 49 REATE TRIGGER I
84f0: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 70 64 F NOT EXISTS upd
8500: 61 74 65 5f 72 75 6e 5f 73 74 61 74 73 5f 74 72 ate_run_stats_tr
8510: 69 67 67 65 72 20 41 46 54 45 52 20 55 50 44 41 igger AFTER UPDA
8520: 54 45 20 4f 4e 20 72 75 6e 5f 73 74 61 74 73 0a TE ON run_stats.
8530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 FOR
8550: 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 EACH ROW.
8560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8570: 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a BEGIN .
8580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85a0: 20 55 50 44 41 54 45 20 72 75 6e 5f 73 74 61 74 UPDATE run_stat
85b0: 73 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 s SET last_updat
85c0: 65 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 e=(strftime('%s'
85d0: 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 ,'now')).
85e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85f0: 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 WHER
8600: 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 E id=old.id;.
8610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8620: 20 20 20 20 20 20 20 20 20 20 20 20 45 4e 44 3b END;
8630: 22 20 29 0a 09 20 20 20 28 6c 69 73 74 20 22 75 " ).. (list "u
8640: 70 64 61 74 65 5f 74 65 73 74 73 5f 74 72 69 67 pdate_tests_trig
8650: 67 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 ger" "CREATE TR
8660: 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 IGGER IF NOT EX
8670: 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 ISTS update_test
8680: 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 s_trigger AFTER
8690: 55 50 44 41 54 45 20 4f 4e 20 74 65 73 74 73 0a UPDATE ON tests.
86a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 FOR
86c0: 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 EACH ROW.
86d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86e0: 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a BEGIN .
86f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8710: 20 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 UPDATE tests SE
8720: 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 T last_update=(s
8730: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
8740: 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 w')).
8750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8760: 20 20 20 20 20 20 20 20 57 48 45 52 45 20 69 64 WHERE id
8770: 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 =old.id;.
8780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8790: 20 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 0a END;" ).
87a0: 09 20 20 20 28 6c 69 73 74 20 22 75 70 64 61 74 . (list "updat
87b0: 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 e_teststeps_trig
87c0: 67 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 ger" "CREATE TR
87d0: 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 IGGER IF NOT EX
87e0: 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 ISTS update_test
87f0: 73 74 65 70 73 5f 74 72 69 67 67 65 72 20 41 46 steps_trigger AF
8800: 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 TER UPDATE ON te
8810: 73 74 5f 73 74 65 70 73 0a 20 20 20 20 20 20 20 st_steps.
8820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8830: 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 FOR EACH R
8840: 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 OW.
8850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8860: 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 BEGIN .
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8880: 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 UPDATE
8890: 20 74 65 73 74 5f 73 74 65 70 73 20 53 45 54 20 test_steps SET
88a0: 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 last_update=(str
88b0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
88c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f WHERE id=o
88f0: 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 ld.id;.
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8910: 20 20 20 20 20 20 45 4e 44 3b 22 20 29 0a 09 20 END;" )..
8920: 20 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 5f (list "update_
8930: 74 65 73 74 5f 64 61 74 61 5f 74 72 69 67 67 65 test_data_trigge
8940: 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 47 r" "CREATE TRIG
8950: 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 53 GER IF NOT EXIS
8960: 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 5f 64 TS update_test_d
8970: 61 74 61 5f 74 72 69 67 67 65 72 20 41 46 54 45 ata_trigger AFTE
8980: 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 74 R UPDATE ON test
8990: 5f 64 61 74 61 0a 20 20 20 20 20 20 20 20 20 20 _data.
89a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89b0: 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f 57 0a FOR EACH ROW.
89c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42 B
89e0: 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 20 20 EGIN .
89f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a00: 20 20 20 20 20 20 20 55 50 44 41 54 45 20 74 65 UPDATE te
8a10: 73 74 5f 64 61 74 61 20 53 45 54 20 6c 61 73 74 st_data SET last
8a20: 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d _update=(strftim
8a30: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 e('%s','now')).
8a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a60: 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 WHERE id=old.i
8a70: 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d;.
8a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a90: 20 20 45 4e 44 3b 22 20 29 29 29 0a 3b 3b 0a 3b END;" ))).;;.;
8aa0: 3b 20 41 44 44 20 72 75 6e 2d 69 64 20 53 55 50 ; ADD run-id SUP
8ab0: 50 4f 52 54 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 PORT.;;.(define
8ac0: 28 64 62 3a 63 72 65 61 74 65 2d 61 6c 6c 2d 74 (db:create-all-t
8ad0: 72 69 67 67 65 72 73 20 64 62 73 74 72 75 63 74 riggers dbstruct
8ae0: 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a ). (db:with-db.
8af0: 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 dbstruct #f #
8b00: 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 f. (lambda (db
8b10: 64 61 74 20 64 62 29 0a 20 20 20 20 20 28 64 62 dat db). (db
8b20: 3a 63 72 65 61 74 65 2d 74 72 69 67 67 65 72 73 :create-triggers
8b30: 20 64 62 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 db))))..(define
8b40: 20 28 64 62 3a 63 72 65 61 74 65 2d 74 72 69 67 (db:create-trig
8b50: 67 65 72 73 20 64 62 29 0a 20 20 20 20 28 66 6f gers db). (fo
8b60: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
8b70: 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 key).
8b80: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
8b90: 75 74 65 20 64 62 20 28 63 61 64 72 20 6b 65 79 ute db (cadr key
8ba0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 64 62 ))). db
8bb0: 3a 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 0a :trigger-list)).
8bc0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 64 72 6f .(define (db:dro
8bd0: 70 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 20 64 p-all-triggers d
8be0: 62 73 74 72 75 63 74 29 0a 20 20 28 64 62 3a 77 bstruct). (db:w
8bf0: 69 74 68 2d 64 62 0a 20 20 20 64 62 73 74 72 75 ith-db. dbstru
8c00: 63 74 20 23 66 20 23 66 0a 20 20 20 28 6c 61 6d ct #f #f. (lam
8c10: 62 64 61 20 28 64 62 64 61 74 20 64 62 29 0a 20 bda (dbdat db).
8c20: 20 20 20 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 (db:drop-tri
8c30: 67 67 65 72 73 20 64 62 29 29 29 29 0a 0a 28 64 ggers db))))..(d
8c40: 65 66 69 6e 65 20 28 64 62 3a 69 73 2d 74 72 69 efine (db:is-tri
8c50: 67 67 65 72 2d 64 72 6f 70 70 65 64 20 64 62 20 gger-dropped db
8c60: 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 tbl-name). (let
8c70: 2a 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 * ((trigger-name
8c80: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c (if (equal? tbl
8c90: 2d 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 -name "test_step
8ca0: 73 22 29 0a 09 09 09 20 20 20 22 75 70 64 61 74 s").... "updat
8cb0: 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 e_teststeps_trig
8cc0: 67 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 ger" .
8cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ce0: 20 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 (conc "update_"
8cf0: 20 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 tbl-name "_trig
8d00: 67 65 72 22 29 29 29 0a 09 20 28 72 65 73 20 20 ger"))).. (res
8d10: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
8d20: 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 (sqlite3:for-ea
8d30: 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d ch-row. (lam
8d40: 62 64 61 20 28 6e 61 6d 65 29 0a 20 20 20 20 20 bda (name).
8d50: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 6e 61 (if (equal? na
8d60: 6d 65 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 me trigger-name)
8d70: 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 23 .. (set! res #
8d80: 74 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 t))). db .
8d90: 20 20 20 22 53 45 4c 45 43 54 20 6e 61 6d 65 20 "SELECT name
8da0: 46 52 4f 4d 20 73 71 6c 69 74 65 5f 6d 61 73 74 FROM sqlite_mast
8db0: 65 72 20 57 48 45 52 45 20 74 79 70 65 20 3d 20 er WHERE type =
8dc0: 27 74 72 69 67 67 65 72 27 20 3b 22 29 0a 20 20 'trigger' ;").
8dd0: 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 res))..(define
8de0: 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 (db:drop-trigge
8df0: 72 73 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 rs db). (for-ea
8e00: 63 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 6b ch. (lambda (k
8e10: 65 79 29 20 0a 20 20 20 20 20 28 73 71 6c 69 74 ey) . (sqlit
8e20: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 e3:execute db (c
8e30: 6f 6e 63 20 22 64 72 6f 70 20 74 72 69 67 67 65 onc "drop trigge
8e40: 72 20 69 66 20 65 78 69 73 74 73 20 22 20 28 63 r if exists " (c
8e50: 61 72 20 6b 65 79 29 29 29 29 0a 20 20 20 64 62 ar key)))). db
8e60: 3a 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 0a :trigger-list)).
8e70: 0a 28 64 65 66 69 6e 65 20 20 28 64 62 3a 64 72 .(define (db:dr
8e80: 6f 70 2d 74 72 69 67 67 65 72 20 64 62 20 74 62 op-trigger db tb
8e90: 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 l-name). (let*
8ea0: 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 28 ((trigger-name (
8eb0: 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d 6e if (equal? tbl-n
8ec0: 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 22 ame "test_steps"
8ed0: 29 0a 09 09 09 20 20 20 22 75 70 64 61 74 65 5f ).... "update_
8ee0: 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 teststeps_trigge
8ef0: 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 r" .
8f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8f10: 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 74 conc "update_" t
8f20: 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 65 bl-name "_trigge
8f30: 72 22 29 29 29 29 0a 20 20 20 20 28 66 6f 72 2d r")))). (for-
8f40: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
8f50: 61 20 28 6b 65 79 29 20 0a 20 20 20 20 20 20 20 a (key) .
8f60: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 (if (equal? (car
8f70: 20 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e 61 key) trigger-na
8f80: 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 me). (
8f90: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
8fa0: 64 62 20 28 63 6f 6e 63 20 22 64 72 6f 70 20 74 db (conc "drop t
8fb0: 72 69 67 67 65 72 20 69 66 20 65 78 69 73 74 73 rigger if exists
8fc0: 20 22 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 " trigger-name)
8fd0: 29 29 29 0a 20 20 20 20 20 64 62 3a 74 72 69 67 ))). db:trig
8fe0: 67 65 72 2d 6c 69 73 74 29 29 29 0a 0a 28 64 65 ger-list)))..(de
8ff0: 66 69 6e 65 20 20 28 64 62 3a 63 72 65 61 74 65 fine (db:create
9000: 2d 74 72 69 67 67 65 72 20 64 62 20 74 62 6c 2d -trigger db tbl-
9010: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 6c 65 74 name). (let
9020: 2a 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 * ((trigger-name
9030: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c (if (equal? tbl
9040: 2d 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 -name "test_step
9050: 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s").
9060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9070: 20 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 74 "update_testst
9080: 65 70 73 5f 74 72 69 67 67 65 72 22 20 0a 20 20 eps_trigger" .
9090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
90b0: 63 20 22 75 70 64 61 74 65 5f 22 20 74 62 6c 2d c "update_" tbl-
90c0: 6e 61 6d 65 20 22 5f 74 72 69 67 67 65 72 22 29 name "_trigger")
90d0: 29 29 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d ))). (for-
90e0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
90f0: 79 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 y) .
9100: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 (if (equal? (ca
9110: 72 20 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e r key) trigger-n
9120: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
9130: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
9140: 74 65 20 64 62 20 28 63 61 64 72 20 6b 65 79 29 te db (cadr key)
9150: 29 29 29 0a 20 20 20 20 20 20 64 62 3a 74 72 69 ))). db:tri
9160: 67 67 65 72 2d 6c 69 73 74 29 29 29 20 0a 0a 3b gger-list))) ..;
9170: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
9180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91b0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 64 62 20 61 63 =======.;; db ac
91c0: 63 65 73 73 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d cess stuff.;;===
91d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9210: 3d 3d 3d 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 ===..;; call wit
9220: 68 20 64 62 69 6e 69 74 3d 64 62 3a 69 6e 69 74 h dbinit=db:init
9230: 69 61 6c 69 7a 65 2d 6d 61 69 6e 2d 64 62 0a 3b ialize-main-db.;
9240: 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6f 70 ;.(define (db:op
9250: 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 en-db dbstruct r
9260: 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 0a 20 20 un-id dbinit).
9270: 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 ;; (mutex-lock!
9280: 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 *db-open-mutex*)
9290: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 64 61 74 . (let* ((dbdat
92a0: 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 (dbfile:open-db
92b0: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
92c0: 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 28 dbinit))). (
92d0: 73 65 74 21 20 2a 64 62 2d 77 72 69 74 65 2d 61 set! *db-write-a
92e0: 63 63 65 73 73 2a 20 28 6e 6f 74 20 28 64 62 72 ccess* (not (dbr
92f0: 3a 64 62 64 61 74 2d 72 65 61 64 2d 6f 6e 6c 79 :dbdat-read-only
9300: 20 64 62 64 61 74 29 29 29 0a 20 20 20 20 3b 3b dbdat))). ;;
9310: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
9320: 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 *db-open-mutex*)
9330: 0a 20 20 20 20 64 62 64 61 74 29 29 0a 0a 28 64 . dbdat))..(d
9340: 65 66 69 6e 65 20 64 62 66 69 6c 65 3a 64 62 2d efine dbfile:db-
9350: 69 6e 69 74 2d 70 72 6f 63 20 28 6d 61 6b 65 2d init-proc (make-
9360: 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 0a 0a parameter #f))..
9370: 3b 3b 20 28 64 62 3a 77 69 74 68 2d 64 62 20 64 ;; (db:with-db d
9380: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 73 bstruct run-id s
9390: 71 6c 69 74 65 33 3a 65 78 65 63 20 22 73 65 6c qlite3:exec "sel
93a0: 65 63 74 20 62 6c 61 68 20 66 67 72 6f 6d 20 62 ect blah fgrom b
93b0: 6c 61 7a 3b 22 29 0a 3b 3b 20 72 2f 77 20 69 73 laz;").;; r/w is
93c0: 20 61 20 66 6c 61 67 20 74 6f 20 69 6e 64 69 63 a flag to indic
93d0: 61 74 65 20 69 66 20 74 68 65 20 64 62 20 69 73 ate if the db is
93e0: 20 6d 6f 64 69 66 69 65 64 20 62 79 20 74 68 69 modified by thi
93f0: 73 20 71 75 65 72 79 20 23 74 20 3d 20 79 65 73 s query #t = yes
9400: 2c 20 23 66 20 3d 20 6e 6f 0a 3b 3b 0a 28 64 65 , #f = no.;;.(de
9410: 66 69 6e 65 20 28 64 62 3a 77 69 74 68 2d 64 62 fine (db:with-db
9420: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
9430: 20 72 2f 77 20 70 72 6f 63 20 2e 20 70 61 72 61 r/w proc . para
9440: 6d 73 29 0a 20 20 28 61 73 73 65 72 74 20 64 62 ms). (assert db
9450: 73 74 72 75 63 74 20 22 46 41 54 41 4c 3a 20 64 struct "FATAL: d
9460: 62 3a 77 69 74 68 2d 64 62 20 63 61 6c 6c 65 64 b:with-db called
9470: 20 77 69 74 68 20 64 62 73 74 72 75 63 74 20 22 with dbstruct "
9480: 23 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 #f). (let* ((us
9490: 65 2d 6d 75 74 65 78 20 28 3e 20 2a 61 70 69 2d e-mutex (> *api-
94a0: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d process-request-
94b0: 63 6f 75 6e 74 2a 20 32 35 29 29 20 3b 3b 20 72 count* 25)) ;; r
94c0: 69 73 6b 20 6f 66 20 64 62 20 63 6f 72 72 75 70 isk of db corrup
94d0: 74 69 6f 6e 0a 09 20 28 68 61 76 65 2d 73 74 72 tion.. (have-str
94e0: 75 63 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 uct (dbr:dbstruc
94f0: 74 3f 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 t? dbstruct)).
9500: 20 20 20 20 20 20 20 28 64 62 64 61 74 20 20 20 (dbdat
9510: 20 20 28 69 66 20 68 61 76 65 2d 73 74 72 75 63 (if have-struc
9520: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
9530: 20 3b 3b 20 74 68 69 73 20 73 74 75 66 66 20 6a ;; this stuff j
9540: 75 73 74 20 61 6c 6c 6f 77 73 20 75 73 20 74 6f ust allows us to
9550: 20 63 61 6c 6c 20 77 69 74 68 20 61 20 64 62 20 call with a db
9560: 68 61 6e 64 6c 65 20 64 69 72 65 63 74 6c 79 0a handle directly.
9570: 09 09 09 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 ...(db:open-db d
9580: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 28 bstruct run-id (
9590: 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 dbfile:db-init-p
95a0: 72 6f 63 29 29 20 3b 3b 20 28 64 62 66 69 6c 65 roc)) ;; (dbfile
95b0: 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 :get-subdb dbstr
95c0: 75 63 74 20 72 75 6e 2d 69 64 29 0a 09 09 09 23 uct run-id)....#
95d0: 66 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 f)).. (db
95e0: 20 28 69 66 20 68 61 76 65 2d 73 74 72 75 63 74 (if have-struct
95f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9600: 3b 3b 20 74 68 69 73 20 73 74 75 66 66 20 6a 75 ;; this stuff ju
9610: 73 74 20 61 6c 6c 6f 77 73 20 75 73 20 74 6f 20 st allows us to
9620: 63 61 6c 6c 20 77 69 74 68 20 61 20 64 62 20 68 call with a db h
9630: 61 6e 64 6c 65 20 64 69 72 65 63 74 6c 79 0a 09 andle directly..
9640: 09 09 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 ..(dbr:dbdat-dbh
9650: 20 64 62 64 61 74 29 0a 09 09 09 64 62 73 74 72 dbdat)....dbstr
9660: 75 63 74 29 29 0a 09 20 28 66 6e 61 6d 65 20 20 uct)).. (fname
9670: 20 20 20 28 69 66 20 64 62 64 61 74 0a 09 09 09 (if dbdat....
9680: 28 64 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c (dbr:dbdat-dbfil
9690: 65 20 64 62 64 61 74 29 0a 09 09 09 22 6e 6f 66 e dbdat)...."nof
96a0: 69 6c 65 6e 61 6d 65 61 76 61 69 6c 61 62 6c 65 ilenameavailable
96b0: 22 29 29 0a 09 20 28 6a 66 69 6c 65 20 20 20 20 ")).. (jfile
96c0: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 6a 6f (conc fname"-jo
96d0: 75 72 6e 61 6c 22 29 29 0a 09 20 23 3b 28 73 75 urnal")).. #;(su
96e0: 62 64 62 20 20 20 20 20 28 69 66 20 68 61 76 65 bdb (if have
96f0: 2d 73 74 72 75 63 74 0a 09 09 09 28 64 62 66 69 -struct....(dbfi
9700: 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 le:get-subdb dbs
9710: 74 72 75 63 74 20 72 75 6e 2d 69 64 29 0a 09 09 truct run-id)...
9720: 09 23 66 29 29 0a 09 20 29 20 3b 3b 20 77 61 73 .#f)).. ) ;; was
9730: 20 32 35 0a 20 20 20 20 28 61 73 73 65 72 74 20 25. (assert
9740: 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 (sqlite3:databas
9750: 65 3f 20 64 62 29 20 22 46 41 54 41 4c 3a 20 64 e? db) "FATAL: d
9760: 62 3a 77 69 74 68 2d 64 62 2c 20 64 62 20 69 73 b:with-db, db is
9770: 20 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 2c not a database,
9780: 20 64 62 3d 22 64 62 22 2c 20 66 6e 61 6d 65 3d db="db", fname=
9790: 22 66 6e 61 6d 65 29 0a 20 20 20 20 28 69 66 20 "fname). (if
97a0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6a 66 (file-exists? jf
97b0: 69 6c 65 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ile)..(begin..
97c0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
97d0: 72 20 22 49 4e 46 4f 3a 20 22 6a 66 69 6c 65 22 r "INFO: "jfile"
97e0: 20 65 78 69 73 74 73 2c 20 64 65 6c 61 79 69 6e exists, delayin
97f0: 67 20 74 6f 20 72 65 64 75 63 65 20 64 61 74 61 g to reduce data
9800: 62 61 73 65 20 6c 6f 61 64 22 29 0a 09 20 20 28 base load").. (
9810: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
9820: 32 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 2))). (if (an
9830: 64 20 75 73 65 2d 6d 75 74 65 78 0a 09 20 20 20 d use-mutex..
9840: 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f (common:low-no
9850: 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 6f ise-print 120 "o
9860: 76 65 72 2d 35 30 2d 70 61 72 61 6c 6c 65 6c 2d ver-50-parallel-
9870: 61 70 69 2d 72 65 71 75 65 73 74 73 22 29 29 0a api-requests")).
9880: 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 .(dbfile:print-e
9890: 72 72 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d rr *api-process-
98a0: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 22 request-count* "
98b0: 20 70 61 72 61 6c 6c 65 6c 20 61 70 69 20 72 65 parallel api re
98c0: 71 75 65 73 74 73 20 62 65 69 6e 67 20 70 72 6f quests being pro
98d0: 63 65 73 73 65 64 20 69 6e 20 70 72 6f 63 65 73 cessed in proces
98e0: 73 20 22 0a 09 09 09 20 20 28 63 75 72 72 65 6e s ".... (curren
98f0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 20 t-process-id)))
9900: 3b 3b 20 20 22 2c 20 74 68 72 6f 74 74 6c 69 6e ;; ", throttlin
9910: 67 20 61 63 63 65 73 73 22 29 29 0a 20 20 20 20 g access")).
9920: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a (condition-case.
9930: 09 28 62 65 67 69 6e 0a 09 20 20 28 69 66 20 75 .(begin.. (if u
9940: 73 65 2d 6d 75 74 65 78 20 28 6d 75 74 65 78 2d se-mutex (mutex-
9950: 6c 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 lock! *db-with-d
9960: 62 2d 6d 75 74 65 78 2a 29 29 0a 09 20 20 28 6c b-mutex*)).. (l
9970: 65 74 20 28 28 72 65 73 20 28 61 70 70 6c 79 20 et ((res (apply
9980: 70 72 6f 63 20 64 62 64 61 74 20 64 62 20 70 61 proc dbdat db pa
9990: 72 61 6d 73 29 29 29 20 3b 3b 20 74 68 65 20 61 rams))) ;; the a
99a0: 63 74 75 61 6c 20 63 61 6c 6c 20 69 73 20 68 65 ctual call is he
99b0: 72 65 2e 0a 09 20 20 20 20 28 69 66 20 75 73 65 re... (if use
99c0: 2d 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 75 6e -mutex (mutex-un
99d0: 6c 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 lock! *db-with-d
99e0: 62 2d 6d 75 74 65 78 2a 29 29 0a 09 20 20 20 20 b-mutex*))..
99f0: 3b 3b 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 ;; (if (vector?
9a00: 64 62 73 74 72 75 63 74 29 28 64 62 3a 64 6f 6e dbstruct)(db:don
9a10: 65 2d 77 69 74 68 20 64 62 73 74 72 75 63 74 20 e-with dbstruct
9a20: 72 75 6e 2d 69 64 20 72 2f 77 29 29 0a 09 20 20 run-id r/w))..
9a30: 20 20 28 69 66 20 64 62 64 61 74 0a 09 09 28 64 (if dbdat...(d
9a40: 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 bfile:add-dbdat
9a50: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
9a60: 64 62 64 61 74 29 29 0a 09 20 20 20 20 72 65 73 dbdat)).. res
9a70: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 69 )). (exn (i
9a80: 6f 2d 65 72 72 6f 72 29 0a 09 20 20 20 28 64 62 o-error).. (db
9a90: 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 :generic-error-p
9aa0: 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 rintout exn "ERR
9ab0: 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 OR: i/o error wi
9ac0: 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 th " fname ". Ch
9ad0: 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c eck permissions,
9ae0: 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e disk space etc.
9af0: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 and try again."
9b00: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 63 )). (exn (c
9b10: 6f 72 72 75 70 74 29 0a 09 20 20 20 28 64 62 3a orrupt).. (db:
9b20: 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 generic-error-pr
9b30: 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f intout exn "ERRO
9b40: 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e R: database " fn
9b50: 61 6d 65 20 22 20 69 73 20 63 6f 72 72 75 70 74 ame " is corrupt
9b60: 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 70 . Repair it to p
9b70: 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 20 20 20 roceed.")).
9b80: 20 28 65 78 6e 20 28 62 75 73 79 29 0a 09 20 20 (exn (busy)..
9b90: 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 (db:generic-err
9ba0: 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 or-printout exn
9bb0: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
9bc0: 20 22 20 66 6e 61 6d 65 0a 09 09 09 09 20 20 20 " fname.....
9bd0: 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 " is locked.
9be0: 54 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 Try copying to a
9bf0: 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c nother location,
9c00: 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c remove original
9c10: 20 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 and copy back."
9c20: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 70 )). (exn (p
9c30: 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 3a 67 65 ermission)(db:ge
9c40: 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e neric-error-prin
9c50: 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a tout exn "ERROR:
9c60: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
9c70: 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 e " has some per
9c80: 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d missions problem
9c90: 2e 22 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 .")). (exn
9ca0: 28 29 0a 09 20 20 20 28 64 62 3a 67 65 6e 65 72 ().. (db:gener
9cb0: 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 ic-error-printou
9cc0: 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e t exn "ERROR: Un
9cd0: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 known error with
9ce0: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
9cf0: 65 20 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 e " message: "..
9d00: 09 09 09 20 20 20 20 20 20 28 28 63 6f 6e 64 69 ... ((condi
9d10: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
9d20: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
9d30: 73 61 67 65 29 20 65 78 6e 29 29 29 29 29 29 0a sage) exn)))))).
9d40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
9d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 61 6e 6f =========.;; ano
9d90: 74 68 65 72 20 61 74 74 65 6d 70 74 20 61 74 20 ther attempt at
9da0: 61 20 74 72 61 6e 73 61 63 74 69 6f 6e 69 7a 65 a transactionize
9db0: 64 20 71 75 65 75 65 0a 3b 3b 3d 3d 3d 3d 3d 3d d queue.;;======
9dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e00: 0a 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 ..;; ;; ;; (defi
9e10: 6e 65 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d ne *transaction-
9e20: 71 75 65 75 65 73 2a 20 28 6d 61 6b 65 2d 68 61 queues* (make-ha
9e30: 73 68 2d 74 61 62 6c 65 29 29 0a 3b 3b 20 3b 3b sh-table)).;; ;;
9e40: 20 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 ;; .;; ;; ;; (d
9e50: 65 66 69 6e 65 20 28 64 62 3a 67 65 74 2d 71 75 efine (db:get-qu
9e60: 65 75 65 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 3b eue run-id).;; ;
9e70: 3b 20 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 72 ; ;; (let* ((r
9e80: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 es (hash-table-r
9e90: 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 72 61 6e ef/default *tran
9ea0: 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 73 2a 20 saction-queues*
9eb0: 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 3b 3b 20 run-id #f))).;;
9ec0: 3b 3b 20 3b 3b 20 20 20 20 20 28 69 66 20 72 65 ;; ;; (if re
9ed0: 73 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 72 65 73 0a s.;; ;; ;; .res.
9ee0: 3b 3b 20 3b 3b 20 3b 3b 20 09 28 6c 65 74 2a 20 ;; ;; ;; .(let*
9ef0: 28 28 6e 65 77 71 20 28 6d 61 6b 65 2d 71 75 65 ((newq (make-que
9f00: 75 65 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 ue))).;; ;; ;; .
9f10: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9f20: 74 21 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d t! *transaction-
9f30: 71 75 65 75 65 73 2a 20 72 75 6e 2d 69 64 20 6e queues* run-id n
9f40: 65 77 71 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 ewq).;; ;; ;; .
9f50: 20 6e 65 77 71 29 29 29 29 0a 3b 3b 20 3b 3b 20 newq)))).;; ;;
9f60: 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 ;; .;; ;; ;; (de
9f70: 66 69 6e 65 20 28 64 62 3a 61 64 64 2d 74 6f 2d fine (db:add-to-
9f80: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 transaction-queu
9f90: 65 20 64 62 73 74 72 75 63 74 20 70 72 6f 63 20 e dbstruct proc
9fa0: 70 61 72 61 6d 73 29 0a 3b 3b 20 3b 3b 20 3b 3b params).;; ;; ;;
9fb0: 20 20 20 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 (let* ((mbox
9fc0: 28 6d 61 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a (make-mailbox)).
9fd0: 3b 3b 20 3b 3b 20 3b 3b 20 09 20 28 71 20 20 20 ;; ;; ;; . (q
9fe0: 20 28 64 62 3a 67 65 74 2d 71 75 65 75 65 20 72 (db:get-queue r
9ff0: 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b un-id))).;; ;; ;
a000: 3b 20 20 20 20 20 28 71 75 65 75 65 2d 61 64 64 ; (queue-add
a010: 21 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 ! *transaction-q
a020: 75 65 75 65 2a 20 28 6c 69 73 74 20 64 62 73 74 ueue* (list dbst
a030: 72 75 63 74 20 70 72 6f 63 20 6d 62 6f 78 29 29 ruct proc mbox))
a040: 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 28 6d .;; ;; ;; (m
a050: 61 69 6c 62 6f 78 2d 72 65 63 65 69 76 65 20 6d ailbox-receive m
a060: 62 6f 78 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 box))).;; ;; ;;
a070: 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e .;; ;; ;; (defin
a080: 65 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 74 72 e (db:process-tr
a090: 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 20 ansaction-queue
a0a0: 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a 29 0a *dbstruct-dbs*).
a0b0: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 28 66 6f 72 2d ;; ;; ;; (for-
a0c0: 65 61 63 68 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 each.;; ;; ;;
a0d0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 (lambda (run-id
a0e0: 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 ).;; ;; ;;
a0f0: 28 6c 65 74 2a 20 28 28 71 20 28 68 61 73 68 2d (let* ((q (hash-
a100: 74 61 62 6c 65 2d 72 65 66 20 2a 74 72 61 6e 73 table-ref *trans
a110: 61 63 74 69 6f 6e 2d 71 75 65 75 65 2a 20 72 75 action-queue* ru
a120: 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b n-id))).;; ;; ;;
a130: 20 20 20 20 20 20 20 20 3b 3b 20 77 69 74 68 2d ;; with-
a140: 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 20 3b transaction.;; ;
a150: 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b 20 20 ; ;; ;;
a160: 20 20 20 64 62 73 74 72 75 63 74 0a 3b 3b 20 3b dbstruct.;; ;
a170: 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b 20 70 ; ;; ;; p
a180: 6f 70 20 69 74 65 6d 73 20 66 72 6f 6d 20 71 75 op items from qu
a190: 65 75 65 20 61 6e 64 20 65 78 65 63 75 74 65 20 eue and execute
a1a0: 74 68 65 6d 2c 20 72 65 74 75 72 6e 20 72 65 73 them, return res
a1b0: 75 6c 74 73 20 76 69 61 20 6d 61 69 6c 62 6f 78 ults via mailbox
a1c0: 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 .;; ;; ;;
a1d0: 20 71 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 q.;; ;; ;;
a1e0: 20 20 20 3b 3b 20 70 6f 70 20 0a 3b 3b 20 3b 3b ;; pop .;; ;;
a1f0: 20 3b 3b 20 20 20 20 20 20 20 20 29 29 0a 3b 3b ;; )).;;
a200: 20 3b 3b 20 3b 3b 20 20 20 20 28 68 61 73 68 2d ;; ;; (hash-
a210: 74 61 62 6c 65 2d 6b 65 79 73 20 2a 74 72 61 6e table-keys *tran
a220: 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 73 2a 29 saction-queues*)
a230: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
a240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
a280: 66 69 6c 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d file utils.;;===
a290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2d0: 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ===..;;=========
a2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
a320: 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 20 66 lazy-safe get f
a330: 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 6f 6e ile mod time. on
a340: 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 6c 65 any error (file
a350: 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 65 74 not existing et
a360: 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b 3b 0a c.) return 0.;;.
a370: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
a380: 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f lazy-modificatio
a390: 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 n-time fpath).
a3a0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
a3b0: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
a3c0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 64 (begin. (d
a3d0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
a3e0: 22 46 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6d "Failed to get m
a3f0: 6f 64 69 66 69 63 61 74 69 6f 6e 20 74 69 6d 65 odification time
a400: 20 66 6f 72 20 22 20 66 70 61 74 68 20 22 2c 20 for " fpath ",
a410: 74 72 65 61 74 69 6e 67 20 69 74 20 61 73 20 7a treating it as z
a420: 65 72 6f 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a ero. exn=" exn).
a430: 20 20 20 20 20 20 30 29 0a 20 20 20 20 28 69 66 0). (if
a440: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
a450: 70 61 74 68 29 0a 09 28 66 69 6c 65 2d 6d 6f 64 path)..(file-mod
a460: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
a470: 70 61 74 68 29 0a 09 30 29 29 29 0a 0a 3b 3b 3d path)..0)))..;;=
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 66 69 6e 64 20 74 69 =====.;; find ti
a4d0: 6d 65 73 74 61 6d 70 20 6f 66 20 6e 65 77 65 73 mestamp of newes
a4e0: 74 20 66 69 6c 65 20 61 73 73 6f 63 69 61 74 65 t file associate
a4f0: 64 20 77 69 74 68 20 61 20 73 71 6c 69 74 65 20 d with a sqlite
a500: 64 62 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 db file.(define
a510: 28 64 62 66 69 6c 65 3a 6c 61 7a 79 2d 73 71 6c (dbfile:lazy-sql
a520: 69 74 65 2d 64 62 2d 6d 6f 64 69 66 69 63 61 74 ite-db-modificat
a530: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a ion-time fpath).
a540: 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 2d 6c (let* ((glob-l
a550: 69 73 74 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ist (handle-exce
a560: 70 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 ptions....exn...
a570: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
a580: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
a590: 72 20 22 46 61 69 6c 65 64 20 74 6f 20 67 6c 6f r "Failed to glo
a5a0: 62 20 22 20 66 70 61 74 68 20 22 2a 2c 20 65 78 b " fpath "*, ex
a5b0: 6e 3d 22 20 65 78 6e 29 0a 09 09 09 60 28 2c 28 n=" exn)....`(,(
a5c0: 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 63 68 2f 66 conc "/no/such/f
a5d0: 69 6c 65 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 ile, message: "
a5e0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
a5f0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
a600: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
a610: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c ))))... (gl
a620: 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 68 20 22 ob (conc fpath "
a630: 2a 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 *")))).
a640: 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 (file-list (if (
a650: 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 20 67 6c eq? 0 (length gl
a660: 6f 62 2d 6c 69 73 74 29 29 0a 09 09 09 27 28 22 ob-list))....'("
a670: 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 22 29 0a /no/such/file").
a680: 09 09 09 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a ...glob-list))).
a690: 20 20 28 61 70 70 6c 79 20 6d 61 78 0a 09 20 28 (apply max.. (
a6a0: 6d 61 70 0a 09 20 20 64 62 66 69 6c 65 3a 6c 61 map.. dbfile:la
a6b0: 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d zy-modification-
a6c0: 74 69 6d 65 20 0a 09 20 20 66 69 6c 65 2d 6c 69 time .. file-li
a6d0: 73 74 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c st))))..;; dot-l
a6e0: 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 6d 73 ocking egg seems
a6f0: 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 not to work, us
a700: 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 ing this for now
a710: 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f .;; if lock is o
a720: 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 72 65 lder than expire
a730: 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 -time then remov
a740: 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 67 61 e it and try aga
a750: 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 in.;; to get the
a760: 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 lock.;;.(define
a770: 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d (dbfile:simple-
a780: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
a790: 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 #!key (expire-ti
a7a0: 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 me 300)). (let
a7b0: 28 28 66 6d 6f 64 2d 74 69 6d 65 20 28 68 61 6e ((fmod-time (han
a7c0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
a7d0: 09 20 20 20 20 20 20 20 65 78 74 0a 09 09 20 20 . ext...
a7e0: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
a7f0: 6e 64 73 29 0a 09 09 20 20 20 20 20 28 66 69 6c nds)... (fil
a800: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
a810: 69 6d 65 20 66 6e 61 6d 65 29 29 29 29 0a 20 20 ime fname)))).
a820: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
a830: 74 73 3f 20 66 6e 61 6d 65 29 0a 09 28 69 66 20 ts? fname)..(if
a840: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
a850: 65 63 6f 6e 64 73 29 20 66 6d 6f 64 2d 74 69 6d econds) fmod-tim
a860: 65 29 20 65 78 70 69 72 65 2d 74 69 6d 65 29 0a e) expire-time).
a870: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
a880: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
a890: 74 69 6f 6e 73 20 65 78 6e 20 23 66 20 28 64 65 tions exn #f (de
a8a0: 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 lete-file* fname
a8b0: 29 29 09 0a 09 20 20 20 20 20 20 28 64 62 66 69 ))... (dbfi
a8c0: 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c le:simple-file-l
a8d0: 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 ock fname expire
a8e0: 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 -time: expire-ti
a8f0: 6d 65 29 29 0a 09 20 20 20 20 23 66 29 0a 09 28 me)).. #f)..(
a900: 6c 65 74 20 28 28 6b 65 79 2d 73 74 72 69 6e 67 let ((key-string
a910: 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 (conc (get-host
a920: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 75 72 72 -name) "-" (curr
a930: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
a940: 29 0a 09 20 20 20 20 20 20 28 6f 75 70 20 20 20 ).. (oup
a950: 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
a960: 74 2d 66 69 6c 65 20 66 6e 61 6d 65 29 29 29 0a t-file fname))).
a970: 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
a980: 74 6f 2d 70 6f 72 74 0a 09 20 20 20 20 20 20 6f to-port.. o
a990: 75 70 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 up.. (lambda
a9a0: 28 29 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 ().. (print
a9b0: 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 key-string)))..
a9c0: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
a9d0: 70 6f 72 74 20 6f 75 70 29 0a 09 20 20 23 3b 28 port oup).. #;(
a9e0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
a9f0: 69 6c 65 20 66 6e 61 6d 65 20 3b 3b 20 62 69 7a ile fname ;; biz
aa00: 61 72 72 65 2e 20 77 69 74 68 2d 6f 75 74 70 75 arre. with-outpu
aa10: 74 2d 74 6f 2d 66 69 6c 65 20 64 6f 65 73 20 6e t-to-file does n
aa20: 6f 74 20 73 65 65 6d 20 74 6f 20 62 65 20 63 6c ot seem to be cl
aa30: 65 61 6e 69 6e 67 20 75 70 20 61 66 74 65 72 20 eaning up after
aa40: 69 74 73 65 6c 66 2e 0a 09 20 20 20 20 28 6c 61 itself... (la
aa50: 6d 62 64 61 20 28 29 0a 09 20 20 28 70 72 69 6e mbda ().. (prin
aa60: 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a t key-string))).
aa70: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
aa80: 21 20 30 2e 32 35 29 0a 09 20 20 28 69 66 20 28 ! 0.25).. (if (
aa90: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
aaa0: 6d 65 29 0a 09 20 20 20 20 20 20 28 68 61 6e 64 me).. (hand
aab0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 65 78 le-exceptions ex
aac0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
aad0: 20 20 23 66 20 0a 20 20 20 20 20 20 20 20 20 20 #f .
aae0: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
aaf0: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d t-from-file fnam
ab00: 65 0a 09 20 20 09 20 20 28 6c 61 6d 62 64 61 20 e.. . (lambda
ab10: 28 29 0a 09 09 20 20 20 20 28 65 71 75 61 6c 3f ()... (equal?
ab20: 20 6b 65 79 2d 73 74 72 69 6e 67 20 28 72 65 61 key-string (rea
ab30: 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 20 20 20 d-line)))))..
ab40: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 29 0a #f). ).
ab50: 20 20 20 20 29 0a 20 20 29 0a 29 0a 0a 28 64 65 ). ).)..(de
ab60: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 69 6d fine (dbfile:sim
ab70: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e ple-file-lock-an
ab80: 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 23 21 6b d-wait fname #!k
ab90: 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 ey (expire-time
aba0: 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 28 65 300)). (let ((e
abb0: 6e 64 2d 74 69 6d 65 20 28 2b 20 65 78 70 69 72 nd-time (+ expir
abc0: 65 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d e-time (current-
abd0: 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 seconds)))).
abe0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 67 6f 74 2d (let loop ((got-
abf0: 6c 6f 63 6b 20 28 64 62 66 69 6c 65 3a 73 69 6d lock (dbfile:sim
ac00: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e ple-file-lock fn
ac10: 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a ame expire-time:
ac20: 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 0a expire-time))).
ac30: 20 20 20 20 20 20 28 69 66 20 67 6f 74 2d 6c 6f (if got-lo
ac40: 63 6b 0a 09 20 20 23 74 0a 09 20 20 28 69 66 20 ck.. #t.. (if
ac50: 28 3e 20 65 6e 64 2d 74 69 6d 65 20 28 63 75 72 (> end-time (cur
ac60: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
ac70: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
ac80: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 thread-sleep! 3)
ac90: 0a 09 09 28 6c 6f 6f 70 20 28 64 62 66 69 6c 65 ...(loop (dbfile
aca0: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
acb0: 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 k fname expire-t
acc0: 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 ime: expire-time
acd0: 29 29 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 ))).. #f)))
ace0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 ))..(define (dbf
acf0: 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d ile:simple-file-
ad00: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 release-lock fna
ad10: 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 me). (handle-ex
ad20: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 ceptions. e
ad30: 78 6e 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 49 xn. #f ;; I
ad40: 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 20 63 61 don't really ca
ad50: 72 65 20 77 68 79 20 74 68 69 73 20 66 61 69 6c re why this fail
ad60: 65 64 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 ed (at least for
ad70: 20 6e 6f 77 29 0a 20 20 20 20 28 64 65 6c 65 74 now). (delet
ad80: 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 29 e-file* fname)))
ad90: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c ..(define (dbfil
ada0: 65 3a 77 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 e:with-simple-fi
adb0: 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 70 72 le-lock fname pr
adc0: 6f 63 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 oc #!key (expire
add0: 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 6c -time 300)). (l
ade0: 65 74 20 28 28 67 6f 74 6c 6f 63 6b 20 28 64 62 et ((gotlock (db
adf0: 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 file:simple-file
ae00: 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 61 69 74 20 66 -lock-and-wait f
ae10: 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 name expire-time
ae20: 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 : expire-time)))
ae30: 0a 20 20 20 20 28 69 66 20 67 6f 74 6c 6f 63 6b . (if gotlock
ae40: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 70 72 ..(let ((res (pr
ae50: 6f 63 29 29 29 0a 09 20 20 28 64 62 66 69 6c 65 oc))).. (dbfile
ae60: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
ae70: 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 ease-lock fname)
ae80: 0a 09 20 20 72 65 73 29 0a 09 28 61 73 73 65 72 .. res)..(asser
ae90: 74 20 23 74 20 22 46 41 54 41 4c 3a 20 73 69 6d t #t "FATAL: sim
aea0: 70 6c 65 20 66 69 6c 65 20 6c 6f 63 6b 20 6e 65 ple file lock ne
aeb0: 76 65 72 20 67 6f 74 20 61 20 6c 6f 63 6b 2e 22 ver got a lock."
aec0: 29 29 29 29 0a 20 20 0a 29 0a )))). .).