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 20 6a 6f 75 72 6e sync-mode journ
2fd0: 61 6c 2d 6d 6f 64 65 0a 09 09 09 09 09 09 09 20 al-mode........
2fe0: 20 28 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 31 (- tries-left 1
2ff0: 29 29 29 29 29 29 0a 20 20 20 20 28 61 73 73 65 )))))). (asse
3000: 72 74 20 28 3e 3d 20 74 72 69 65 73 2d 6c 65 66 rt (>= tries-lef
3010: 74 20 30 29 20 28 63 6f 6e 63 20 22 46 41 54 41 t 0) (conc "FATA
3020: 4c 3a 20 74 6f 6f 20 6d 61 6e 79 20 61 74 74 65 L: too many atte
3030: 6d 70 74 73 20 69 6e 20 64 62 66 69 6c 65 3a 63 mpts in dbfile:c
3040: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
3050: 61 62 61 73 65 20 6f 66 20 22 66 6e 61 6d 65 22 abase of "fname"
3060: 2c 20 67 69 76 69 6e 67 20 75 70 2e 22 29 29 0a , giving up.")).
3070: 20 20 20 20 0a 20 20 20 20 28 69 66 20 28 61 6e . (if (an
3080: 64 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 d (file-write-ac
3090: 63 65 73 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 cess? fname)..
30a0: 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f (file-exists?
30b0: 20 62 75 73 79 2d 66 69 6c 65 29 29 0a 09 28 62 busy-file))..(b
30c0: 65 67 69 6e 0a 09 20 20 28 69 66 20 28 63 6f 6d egin.. (if (com
30d0: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
30e0: 69 6e 74 20 31 32 30 20 62 75 73 79 2d 66 69 6c int 120 busy-fil
30f0: 65 29 0a 09 20 20 20 20 20 20 28 64 62 66 69 6c e).. (dbfil
3100: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 e:print-err "INF
3110: 4f 3a 20 64 62 66 69 6c 65 3a 63 61 75 74 69 6f O: dbfile:cautio
3120: 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 us-open-database
3130: 3a 20 6a 6f 75 72 6e 61 6c 20 66 69 6c 65 20 22 : journal file "
3140: 0a 09 09 09 09 62 75 73 79 2d 66 69 6c 65 22 20 .....busy-file"
3150: 65 78 69 73 74 73 2c 20 74 72 79 69 6e 67 20 61 exists, trying a
3160: 67 61 69 6e 20 69 6e 20 66 65 77 20 73 65 63 6f gain in few seco
3170: 6e 64 73 2e 22 29 29 0a 09 20 20 28 74 68 72 65 nds.")).. (thre
3180: 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 20 ad-sleep! 1)..
3190: 28 69 66 20 28 65 71 3f 20 74 72 69 65 73 2d 6c (if (eq? tries-l
31a0: 65 66 74 20 32 29 0a 09 20 20 20 20 20 20 28 62 eft 2).. (b
31b0: 65 67 69 6e 0a 09 20 20 09 28 64 62 66 69 6c 65 egin.. .(dbfile
31c0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f :print-err "INFO
31d0: 3a 20 66 6f 72 63 69 6e 67 20 6a 6f 75 72 6e 61 : forcing journa
31e0: 6c 20 72 6f 6c 6c 75 70 20 22 62 75 73 79 2d 66 l rollup "busy-f
31f0: 69 6c 65 29 0a 09 20 20 09 28 64 62 66 69 6c 65 ile).. .(dbfile
3200: 3a 62 72 75 74 65 2d 66 6f 72 63 65 2d 73 61 6c :brute-force-sal
3210: 76 61 67 65 2d 64 62 20 66 6e 61 6d 65 29 29 29 vage-db fname)))
3220: 0a 09 20 20 28 64 62 66 69 6c 65 3a 63 61 75 74 .. (dbfile:caut
3230: 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 ious-open-databa
3240: 73 65 20 66 6e 61 6d 65 20 69 6e 69 74 2d 70 72 se fname init-pr
3250: 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 20 6a 6f 75 oc sync-mode jou
3260: 72 6e 61 6c 2d 6d 6f 64 65 20 28 2d 20 74 72 69 rnal-mode (- tri
3270: 65 73 2d 6c 65 66 74 20 31 29 29 29 0a 09 0a 09 es-left 1)))....
3280: 28 6c 65 74 2a 20 28 28 72 65 73 75 6c 74 20 28 (let* ((result (
3290: 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 condition-case..
32a0: 09 20 20 20 20 20 20 20 20 28 69 66 20 64 69 72 . (if dir
32b0: 2d 61 63 63 65 73 73 0a 09 09 09 20 20 20 20 28 -access.... (
32c0: 64 62 66 69 6c 65 3a 77 69 74 68 2d 73 69 6d 70 dbfile:with-simp
32d0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 0a 09 09 09 le-file-lock....
32e0: 20 20 20 20 20 28 63 6f 6e 63 20 66 6e 61 6d 65 (conc fname
32f0: 20 22 2e 6c 6f 63 6b 22 29 0a 09 09 09 20 20 20 ".lock")....
3300: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ()....
3310: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 (let* ((d
3320: 62 2d 65 78 69 73 74 73 20 28 66 69 6c 65 2d 65 b-exists (file-e
3330: 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 29 0a 09 xists? fname))..
3340: 09 09 09 20 20 20 20 20 20 28 64 62 20 20 20 20 ... (db
3350: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 (sqlite3:ope
3360: 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 n-database fname
3370: 29 29 29 20 3b 3b 20 63 72 65 61 74 65 73 20 61 ))) ;; creates a
3380: 6e 20 65 6d 70 74 79 20 64 62 20 69 66 20 69 74 n empty db if it
3390: 20 64 69 64 20 6e 6f 74 20 61 6c 72 65 61 64 79 did not already
33a0: 20 65 78 69 73 74 2e 0a 20 20 20 20 20 20 20 20 exist..
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33c0: 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 (sqlite
33d0: 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 3:set-busy-handl
33e0: 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 33 3a er! db (sqlite3:
33f0: 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 make-busy-timeou
3400: 74 20 33 30 30 30 30 29 29 0a 09 09 09 09 20 28 t 30000))..... (
3410: 69 66 20 73 79 6e 63 2d 6d 6f 64 65 0a 09 09 09 if sync-mode....
3420: 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
3430: 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 xecute db (conc
3440: 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e "PRAGMA synchron
3450: 6f 75 73 20 3d 20 22 73 79 6e 63 2d 6d 6f 64 65 ous = "sync-mode
3460: 22 3b 22 29 29 29 0a 09 09 09 09 20 28 69 66 20 ";")))..... (if
3470: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 0a 09 09 09 journal-mode....
3480: 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
3490: 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 xecute db (conc
34a0: 22 50 52 41 47 4d 41 20 6a 6f 75 72 6e 61 6c 5f "PRAGMA journal_
34b0: 6d 6f 64 65 20 3d 20 22 6a 6f 75 72 6e 61 6c 2d mode = "journal-
34c0: 6d 6f 64 65 22 3b 22 29 29 29 0a 09 09 09 09 20 mode";"))).....
34d0: 28 69 66 20 28 61 6e 64 20 69 6e 69 74 2d 70 72 (if (and init-pr
34e0: 6f 63 20 28 6e 6f 74 20 64 62 2d 65 78 69 73 74 oc (not db-exist
34f0: 73 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 6e s))..... (in
3500: 69 74 2d 70 72 6f 63 20 64 62 29 29 0a 09 09 09 it-proc db))....
3510: 09 20 64 62 29 29 29 0a 20 20 20 20 20 20 20 20 . db))).
3520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3530: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
3540: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
3550: 69 73 74 73 3f 20 66 6e 61 6d 65 20 29 0a 20 20 ists? fname ).
3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3580: 28 6c 65 74 20 28 28 64 62 20 28 73 71 6c 69 74 (let ((db (sqlit
3590: 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 e3:open-database
35a0: 20 66 6e 61 6d 65 29 29 29 0a 09 09 09 09 20 20 fname))).....
35b0: 20 20 3b 3b 20 70 72 61 67 6d 61 73 20 73 79 6e ;; pragmas syn
35c0: 63 68 72 6f 6e 6f 75 73 20 6e 6f 74 20 6e 65 65 chronous not nee
35d0: 64 65 64 20 62 65 63 61 75 73 65 20 74 68 69 73 ded because this
35e0: 20 64 62 20 69 73 20 75 73 65 64 20 72 65 61 64 db is used read
35f0: 2d 6f 6e 6c 79 0a 09 09 09 09 20 20 20 20 3b 3b -only..... ;;
3600: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
3610: 65 20 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 e db (conc "PRAG
3620: 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d MA synchronous =
3630: 20 22 6d 6f 64 65 22 3b 22 29 0a 09 09 09 09 20 "mode";").....
3640: 20 20 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d (sqlite3:set-
3650: 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 busy-handler! db
3660: 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 (sqlite3:make-b
3670: 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 30 30 30 usy-timeout 3000
3680: 30 29 29 20 3b 3b 20 72 65 61 64 2d 6f 6e 6c 79 0)) ;; read-only
3690: 20 62 75 74 20 73 74 69 6c 6c 20 6e 65 65 64 20 but still need
36a0: 74 69 6d 65 6f 75 74 0a 09 09 09 09 20 20 20 20 timeout.....
36b0: 64 62 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 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 28 70 72 69 6e 74 20 22 66 (print "f
36e0: 69 6c 65 20 64 6f 65 73 6e 27 74 20 65 78 69 73 ile doesn't exis
36f0: 74 3a 20 22 20 66 6e 61 6d 65 29 29 29 29 0a 09 t: " fname))))..
3700: 09 09 28 65 78 6e 20 28 69 6f 2d 65 72 72 6f 72 ..(exn (io-error
3710: 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 6c ).... (dbfil
3720: 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 e:print-err exn
3730: 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f "ERROR: i/o erro
3740: 72 20 77 69 74 68 20 22 20 66 6e 61 6d 65 20 22 r with " fname "
3750: 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 73 73 69 . Check permissi
3760: 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 63 65 20 ons, disk space
3770: 65 74 63 2e 20 61 6e 64 20 74 72 79 20 61 67 61 etc. and try aga
3780: 69 6e 2e 22 29 0a 09 09 09 20 20 20 20 20 28 72 in.").... (r
3790: 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e 20 28 etry))....(exn (
37a0: 63 6f 72 72 75 70 74 29 0a 09 09 09 20 20 20 20 corrupt)....
37b0: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
37c0: 72 72 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 rr exn "ERROR: d
37d0: 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 atabase " fname
37e0: 22 20 69 73 20 63 6f 72 72 75 70 74 2e 20 52 65 " is corrupt. Re
37f0: 70 61 69 72 20 69 74 20 74 6f 20 70 72 6f 63 65 pair it to proce
3800: 65 64 2e 22 29 0a 09 09 09 20 20 20 20 20 28 72 ed.").... (r
3810: 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e 20 28 etry))....(exn (
3820: 62 75 73 79 29 0a 09 09 09 20 20 20 20 20 28 64 busy).... (d
3830: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
3840: 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 61 exn "ERROR: data
3850: 62 61 73 65 20 22 20 66 6e 61 6d 65 0a 09 09 09 base " fname....
3860: 09 09 20 20 20 20 20 20 20 22 20 69 73 20 6c 6f .. " is lo
3870: 63 6b 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e cked. Try copyin
3880: 67 20 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 g to another loc
3890: 61 74 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 ation, remove or
38a0: 69 67 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 iginal and copy
38b0: 62 61 63 6b 2e 22 29 0a 09 09 09 20 20 20 20 20 back.")....
38c0: 28 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e (retry))....(exn
38d0: 20 28 70 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 (permission)(db
38e0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 file:print-err e
38f0: 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 xn "ERROR: datab
3900: 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 68 61 ase " fname " ha
3910: 73 20 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f s some permissio
3920: 6e 73 20 70 72 6f 62 6c 65 6d 2e 22 29 0a 09 09 ns problem.")...
3930: 09 20 20 20 20 20 28 72 65 74 72 79 29 29 0a 09 . (retry))..
3940: 09 09 28 65 78 6e 20 28 29 0a 09 09 09 20 20 20 ..(exn ()....
3950: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
3960: 65 72 72 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 err exn "ERROR:
3970: 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 Unknown error wi
3980: 74 68 20 64 61 74 61 62 61 73 65 20 22 20 66 6e th database " fn
3990: 61 6d 65 20 22 20 6d 65 73 73 61 67 65 3a 20 22 ame " message: "
39a0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 28 63 ...... ((c
39b0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
39c0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
39d0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
39e0: 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 ... (retry))
39f0: 29 29 29 0a 09 20 20 72 65 73 75 6c 74 29 29 29 ))).. result)))
3a00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 )..(define (dbfi
3a10: 6c 65 3a 62 72 75 74 65 2d 66 6f 72 63 65 2d 73 le:brute-force-s
3a20: 61 6c 76 61 67 65 2d 64 62 20 66 6e 61 6d 65 29 alvage-db fname)
3a30: 0a 20 20 28 6c 65 74 2a 20 28 28 62 61 63 6b 75 . (let* ((backu
3a40: 70 66 6e 61 6d 65 20 28 63 6f 6e 63 20 66 6e 61 pfname (conc fna
3a50: 6d 65 22 2d 22 28 63 75 72 72 65 6e 74 2d 70 72 me"-"(current-pr
3a60: 6f 63 65 73 73 2d 69 64 29 22 2e 62 61 6b 22 29 ocess-id)".bak")
3a70: 29 0a 09 20 28 63 6d 64 20 28 63 6f 6e 63 20 22 ).. (cmd (conc "
3a80: 63 70 20 22 66 6e 61 6d 65 22 20 22 62 61 63 6b cp "fname" "back
3a90: 75 70 66 6e 61 6d 65 22 3b 6d 76 20 22 66 6e 61 upfname";mv "fna
3aa0: 6d 65 22 20 22 28 63 6f 6e 63 20 66 6e 61 6d 65 me" "(conc fname
3ab0: 20 22 2e 64 65 6c 6d 65 3b 22 29 0a 09 09 20 20 ".delme;")...
3ac0: 20 20 22 63 70 20 22 62 61 63 6b 75 70 66 6e 61 "cp "backupfna
3ad0: 6d 65 22 20 22 66 6e 61 6d 65 29 29 29 0a 20 20 me" "fname))).
3ae0: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
3af0: 65 72 72 20 22 57 41 52 4e 49 4e 47 3a 20 61 74 err "WARNING: at
3b00: 74 65 6d 70 74 69 6e 67 20 72 65 63 6f 76 65 72 tempting recover
3b10: 79 20 6f 66 20 66 69 6c 65 20 22 66 6e 61 6d 65 y of file "fname
3b20: 22 20 62 79 20 72 75 6e 6e 69 6e 67 20 63 6f 6d " by running com
3b30: 6d 61 6e 64 73 3a 5c 6e 22 0a 09 09 20 20 20 20 mands:\n"...
3b40: 20 20 22 20 20 22 63 6d 64 29 0a 20 20 20 20 28 " "cmd). (
3b50: 73 79 73 74 65 6d 20 63 6d 64 29 29 29 0a 0a 0a system cmd)))...
3b60: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
3b70: 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d 64 62 20 open-no-sync-db
3b80: 64 62 70 61 74 68 29 0a 20 20 28 69 66 20 2a 6e dbpath). (if *n
3b90: 6f 2d 73 79 6e 63 2d 64 62 2a 0a 20 20 20 20 20 o-sync-db*.
3ba0: 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 0a 20 20 *no-sync-db*.
3bb0: 20 20 20 20 28 62 65 67 69 6e 0a 09 28 69 66 20 (begin..(if
3bc0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
3bd0: 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 20 20 s? dbpath))..
3be0: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
3bf0: 72 79 20 64 62 70 61 74 68 20 23 74 29 29 0a 09 ry dbpath #t))..
3c00: 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 20 20 (let* ((dbname
3c10: 20 20 28 63 6f 6e 63 20 64 62 70 61 74 68 20 22 (conc dbpath "
3c20: 2f 6e 6f 2d 73 79 6e 63 2e 64 62 22 29 29 0a 09 /no-sync.db"))..
3c30: 20 20 20 20 20 20 20 28 64 62 2d 65 78 69 73 74 (db-exist
3c40: 73 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 s (file-exists?
3c50: 64 62 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 dbname))..
3c60: 20 28 69 6e 69 74 2d 70 72 6f 63 20 28 6c 61 6d (init-proc (lam
3c70: 62 64 61 20 28 64 62 29 0a 09 09 09 20 20 20 20 bda (db)....
3c80: 28 69 66 20 28 6e 6f 74 20 64 62 2d 65 78 69 73 (if (not db-exis
3c90: 74 73 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 ts).....(begin..
3ca0: 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 ... (sqlite3:ex
3cb0: 65 63 75 74 65 20 64 62 20 22 43 52 45 41 54 45 ecute db "CREATE
3cc0: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
3cd0: 49 53 54 53 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 ISTS no_sync_met
3ce0: 61 64 61 74 20 28 76 61 72 20 54 45 58 54 2c 76 adat (var TEXT,v
3cf0: 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 al TEXT, CONSTRA
3d00: 49 4e 54 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 INT no_sync_meta
3d10: 64 61 74 5f 63 6f 6e 73 74 72 61 69 6e 74 20 55 dat_constraint U
3d20: 4e 49 51 55 45 20 28 76 61 72 29 29 3b 22 29 29 NIQUE (var));"))
3d30: 0a 09 09 09 09 29 29 29 0a 09 20 20 20 20 20 20 .....)))..
3d40: 20 28 64 62 20 20 20 20 20 20 20 20 28 64 62 66 (db (dbf
3d50: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
3d60: 6e 2d 64 61 74 61 62 61 73 65 20 64 62 6e 61 6d n-database dbnam
3d70: 65 20 69 6e 69 74 2d 70 72 6f 63 20 30 20 22 57 e init-proc 0 "W
3d80: 41 4c 22 29 29 29 20 3b 3b 20 28 73 71 6c 69 74 AL"))) ;; (sqlit
3d90: 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 e3:open-database
3da0: 20 64 62 6e 61 6d 65 29 29 29 0a 09 20 20 3b 3b dbname))).. ;;
3db0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
3dc0: 65 20 64 62 20 22 50 52 41 47 4d 41 20 73 79 6e e db "PRAGMA syn
3dd0: 63 68 72 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 0a chronous = 0;").
3de0: 09 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 73 . ;; (sqlite3:s
3df0: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
3e00: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b db (sqlite3:mak
3e10: 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 e-busy-timeout 1
3e20: 33 36 30 30 30 29 29 20 3b 3b 20 64 6f 6e 65 20 36000)) ;; done
3e30: 69 6e 20 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e in cautious-open
3e40: 2d 64 61 74 61 62 61 73 65 0a 09 20 20 28 73 65 -database.. (se
3e50: 74 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 t! *no-sync-db*
3e60: 64 62 29 0a 09 20 20 64 62 29 29 29 29 0a 0a 28 db).. db))))..(
3e70: 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 define (db:no-sy
3e80: 6e 63 2d 73 65 74 20 64 62 20 76 61 72 20 76 61 nc-set db var va
3e90: 6c 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 l). (sqlite3:ex
3ea0: 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 54 ecute db "INSERT
3eb0: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
3ec0: 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 no_sync_metadat
3ed0: 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 45 (var,val) VALUE
3ee0: 53 20 28 3f 2c 3f 29 3b 22 20 76 61 72 20 76 61 S (?,?);" var va
3ef0: 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 l))..(define (db
3f00: 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 64 62 :no-sync-del! db
3f10: 20 76 61 72 29 0a 20 20 28 73 71 6c 69 74 65 33 var). (sqlite3
3f20: 3a 65 78 65 63 75 74 65 20 64 62 20 22 44 45 4c :execute db "DEL
3f30: 45 54 45 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 ETE FROM no_sync
3f40: 5f 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 76 _metadat WHERE v
3f50: 61 72 3d 3f 3b 22 20 76 61 72 29 29 0a 0a 28 64 ar=?;" var))..(d
3f60: 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 6e efine (db:no-syn
3f70: 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 64 62 c-get/default db
3f80: 20 76 61 72 20 64 65 66 61 75 6c 74 29 0a 20 20 var default).
3f90: 28 6c 65 74 20 28 28 72 65 73 20 64 65 66 61 75 (let ((res defau
3fa0: 6c 74 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 lt)). (sqlite
3fb0: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 3:for-each-row.
3fc0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 6c (lambda (val
3fd0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
3fe0: 65 73 20 76 61 6c 29 29 0a 20 20 20 20 20 64 62 es val)). db
3ff0: 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 76 61 . "SELECT va
4000: 6c 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d l FROM no_sync_m
4010: 65 74 61 64 61 74 20 57 48 45 52 45 20 76 61 72 etadat WHERE var
4020: 3d 3f 3b 22 0a 20 20 20 20 20 76 61 72 29 0a 20 =?;". var).
4030: 20 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 20 (if res.
4040: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 65 73 (let ((newres
4050: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 (if (string? re
4060: 73 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d s).... (string-
4070: 3e 6e 75 6d 62 65 72 20 72 65 73 29 0a 09 09 09 >number res)....
4080: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
4090: 20 20 28 69 66 20 6e 65 77 72 65 73 0a 20 20 20 (if newres.
40a0: 20 20 20 20 20 20 20 20 20 20 20 6e 65 77 72 65 newre
40b0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
40c0: 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 72 65 res)). re
40d0: 73 29 29 29 0a 0a 3b 3b 20 74 72 61 6e 73 61 63 s)))..;; transac
40e0: 74 69 6f 6e 20 70 72 6f 74 65 63 74 65 64 20 6c tion protected l
40f0: 6f 63 6b 20 61 71 75 69 73 69 74 69 6f 6e 0a 3b ock aquisition.;
4100: 3b 20 65 69 74 68 65 72 3a 0a 3b 3b 20 20 20 20 ; either:.;;
4110: 66 61 69 6c 73 20 20 20 20 72 65 74 75 72 6e 73 fails returns
4120: 20 20 28 23 66 20 2e 20 6c 6f 63 6b 2d 63 72 65 (#f . lock-cre
4130: 61 74 69 6f 6e 2d 74 69 6d 65 29 0a 3b 3b 20 20 ation-time).;;
4140: 20 20 73 75 63 63 65 65 64 73 20 28 72 65 74 75 succeeds (retu
4150: 72 6e 73 20 28 23 74 20 2e 20 6c 6f 63 6b 2d 63 rns (#t . lock-c
4160: 72 65 61 74 69 6f 6e 2d 74 69 6d 65 29 0a 3b 3b reation-time).;;
4170: 20 75 73 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 use (db:no-sync
4180: 2d 64 65 6c 21 20 64 62 20 6b 65 79 6e 61 6d 65 -del! db keyname
4190: 29 20 74 6f 20 72 65 6c 65 61 73 65 20 74 68 65 ) to release the
41a0: 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 lock.;;.(define
41b0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
41c0: 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d 65 -lock db keyname
41d0: 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 77 69 74 ). (sqlite3:wit
41e0: 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a 20 20 h-transaction.
41f0: 20 64 62 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 db. (lambda (
4200: 29 0a 20 20 20 20 20 28 63 6f 6e 64 69 74 69 6f ). (conditio
4210: 6e 2d 63 61 73 65 0a 09 20 28 6c 65 74 2a 20 28 n-case.. (let* (
4220: 28 63 75 72 72 2d 76 61 6c 20 28 64 62 3a 6e 6f (curr-val (db:no
4230: 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c -sync-get/defaul
4240: 74 20 64 62 20 6b 65 79 6e 61 6d 65 20 23 66 29 t db keyname #f)
4250: 29 29 0a 09 20 20 20 28 69 66 20 63 75 72 72 2d )).. (if curr-
4260: 76 61 6c 0a 09 20 20 20 20 20 20 20 60 28 23 66 val.. `(#f
4270: 20 2e 20 2c 63 75 72 72 2d 76 61 6c 29 20 20 20 . ,curr-val)
4280: 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 72 73 ;; (sqlite3:firs
4290: 74 2d 72 65 73 75 6c 74 20 64 62 20 22 53 45 4c t-result db "SEL
42a0: 45 43 54 20 76 61 6c 20 46 52 4f 4d 20 6e 6f 5f ECT val FROM no_
42b0: 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 57 48 45 sync_metadat WHE
42c0: 52 45 20 76 61 72 3d 3f 3b 22 20 6b 65 79 6e 61 RE var=?;" keyna
42d0: 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 65 me)).. (le
42e0: 74 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 20 28 63 t ((lock-time (c
42f0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4300: 29 0a 09 09 20 28 73 71 6c 69 74 65 33 3a 65 78 )... (sqlite3:ex
4310: 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 54 ecute db "INSERT
4320: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
4330: 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 no_sync_metadat
4340: 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 45 (var,val) VALUE
4350: 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e 61 6d 65 S(?,?);" keyname
4360: 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 09 20 60 lock-time)... `
4370: 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d 74 69 6d 65 (#t . ,lock-time
4380: 29 29 29 29 0a 20 20 20 20 20 20 20 28 65 78 6e )))). (exn
4390: 20 28 69 6f 2d 65 72 72 6f 72 29 20 20 28 64 62 (io-error) (db
43a0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
43b0: 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 ERROR: i/o error
43c0: 20 77 69 74 68 20 6e 6f 2d 73 79 6e 63 20 64 62 with no-sync db
43d0: 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 73 73 69 . Check permissi
43e0: 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 63 65 20 ons, disk space
43f0: 65 74 63 2e 20 61 6e 64 20 74 72 79 20 61 67 61 etc. and try aga
4400: 69 6e 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 in.")). (e
4410: 78 6e 20 28 63 6f 72 72 75 70 74 29 20 20 20 28 xn (corrupt) (
4420: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
4430: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
4440: 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 69 73 20 e no-sync db is
4450: 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 20 corrupt. Repair
4460: 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 29 it to proceed.")
4470: 29 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 62 ). (exn (b
4480: 75 73 79 29 20 20 20 20 20 20 28 64 62 66 69 6c usy) (dbfil
4490: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 e:print-err "ERR
44a0: 4f 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f 2d OR: database no-
44b0: 73 79 6e 63 20 64 62 20 69 73 20 6c 6f 63 6b 65 sync db is locke
44c0: 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 74 d. Try copying t
44d0: 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 o another locati
44e0: 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 on, remove origi
44f0: 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 63 nal and copy bac
4500: 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 78 k.")). (ex
4510: 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e 29 28 64 n (permission)(d
4520: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
4530: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
4540: 20 6e 6f 2d 73 79 6e 63 20 64 62 20 68 61 73 20 no-sync db has
4550: 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 some permissions
4560: 20 70 72 6f 62 6c 65 6d 2e 22 29 29 0a 20 20 20 problem.")).
4570: 20 20 20 20 28 65 78 6e 20 28 29 20 3b 3b 20 28 (exn () ;; (
4580: 73 74 61 74 75 73 20 64 6f 6e 65 29 20 3b 3b 20 status done) ;;
4590: 49 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 68 6f 77 I don't know how
45a0: 20 74 6f 20 64 65 74 65 63 74 20 73 74 61 74 75 to detect statu
45b0: 73 20 64 6f 6e 65 20 62 75 74 20 6e 6f 20 64 61 s done but no da
45c0: 74 61 21 0a 09 20 20 20 20 28 64 62 66 69 6c 65 ta!.. (dbfile
45d0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f :print-err "ERRO
45e0: 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 R: Unknown error
45f0: 20 77 69 74 68 20 64 61 74 61 62 61 73 65 20 6e with database n
4600: 6f 2d 73 79 6e 63 20 64 62 20 6d 65 73 73 61 67 o-sync db messag
4610: 65 3a 20 65 78 6e 3d 22 28 63 6f 6e 64 69 74 69 e: exn="(conditi
4620: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 22 2c 20 on->list exn)",
4630: 5c 6e 22 0a 09 09 09 20 20 20 20 20 20 28 28 63 \n".... ((c
4640: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
4650: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
4660: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
4670: 09 20 20 20 20 60 28 23 66 20 2e 20 2c 28 63 75 . `(#f . ,(cu
4680: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
4690: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 ))))..(define (d
46a0: 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f b:no-sync-get-lo
46b0: 63 6b 2d 74 69 6d 65 6f 75 74 20 64 62 20 6b 65 ck-timeout db ke
46c0: 79 6e 61 6d 65 20 74 69 6d 65 6f 75 74 29 0a 20 yname timeout).
46d0: 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 64 61 74 (let* ((lockdat
46e0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
46f0: 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d 65 -lock db keyname
4700: 29 29 29 0a 20 20 20 20 28 6d 61 74 63 68 20 6c ))). (match l
4710: 6f 63 6b 64 61 74 0a 20 20 20 20 20 20 28 28 23 ockdat. ((#
4720: 66 20 2e 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 20 f . lock-time).
4730: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 (if (> (-
4740: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4750: 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6c ) (if (string? l
4760: 6f 63 6b 2d 74 69 6d 65 29 28 73 74 72 69 6e 67 ock-time)(string
4770: 2d 3e 6e 75 6d 62 65 72 20 6c 6f 63 6b 2d 74 69 ->number lock-ti
4780: 6d 65 29 6c 6f 63 6b 2d 74 69 6d 65 29 29 20 74 me)lock-time)) t
4790: 69 6d 65 6f 75 74 29 0a 09 20 20 20 28 6c 65 74 imeout).. (let
47a0: 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 20 28 63 75 ((lock-time (cu
47b0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
47c0: 0a 09 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 .. ;; (debug
47d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
47e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
47f0: 20 22 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 "db:no-sync-get
4800: 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 3d 22 20 -lock keyname="
4810: 6b 65 79 6e 61 6d 65 20 22 2c 20 6c 6f 63 6b 2d keyname ", lock-
4820: 74 69 6d 65 3d 22 20 6c 6f 63 6b 2d 74 69 6d 65 time=" lock-time
4830: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 ", exn=" exn)..
4840: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
4850: 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 54 ecute db "INSERT
4860: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
4870: 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 no_sync_metadat
4880: 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 45 (var,val) VALUE
4890: 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e 61 6d 65 S(?,?);" keyname
48a0: 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 20 20 20 lock-time)..
48b0: 20 20 60 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d 74 `(#t . ,lock-t
48c0: 69 6d 65 29 29 0a 09 20 20 20 6c 6f 63 6b 64 61 ime)).. lockda
48d0: 74 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 20 t)). (else
48e0: 6c 6f 63 6b 64 61 74 29 29 29 29 0a 0a 3b 3b 20 lockdat))))..;;
48f0: 4e 4f 54 45 3a 20 54 68 69 73 20 77 69 6c 6c 20 NOTE: This will
4900: 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 6b 20 61 steal the lock a
4910: 66 74 65 72 20 74 69 6d 65 6f 75 74 20 6f 66 20 fter timeout of
4920: 77 61 69 74 69 6e 67 2e 0a 3b 3b 0a 28 64 65 66 waiting..;;.(def
4930: 69 6e 65 20 28 64 62 3a 77 69 74 68 2d 6e 6f 2d ine (db:with-no-
4940: 73 79 6e 63 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 sync-lock db key
4950: 6e 61 6d 65 20 74 69 6d 65 6f 75 74 20 70 72 6f name timeout pro
4960: 63 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 c). (let* ((loc
4970: 6b 64 61 74 20 20 28 64 62 3a 6e 6f 2d 73 79 6e kdat (db:no-syn
4980: 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 6f c-get-lock-timeo
4990: 75 74 20 64 62 20 6b 65 79 6e 61 6d 65 29 29 0a ut db keyname)).
49a0: 09 20 28 67 6f 74 6c 6f 63 6b 20 20 28 63 61 72 . (gotlock (car
49b0: 20 6c 6f 63 6b 64 61 74 29 29 0a 09 20 28 6c 6f lockdat)).. (lo
49c0: 63 6b 74 69 6d 65 20 28 63 64 72 20 6c 6f 63 6b cktime (cdr lock
49d0: 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 67 dat))). (if g
49e0: 6f 74 6c 6f 63 6b 0a 09 28 6c 65 74 20 28 28 72 otlock..(let ((r
49f0: 65 73 20 28 70 72 6f 63 29 29 29 0a 09 20 20 28 es (proc))).. (
4a00: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 db:no-sync-del!
4a10: 64 62 20 6b 65 79 6e 61 6d 65 29 0a 09 20 20 72 db keyname).. r
4a20: 65 73 29 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d es)))). .;;====
4a30: 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 73 79 6e 63 20 62 61 63 6b 20 ==.;; sync back
4a80: 66 75 6e 63 74 69 6f 6e 73 20 70 75 6c 6c 65 64 functions pulled
4a90: 20 66 72 6f 6d 20 64 62 2e 73 63 6d 0a 3b 3b 3d from db.scm.;;=
4aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 47 65 74 20 61 20 =====..;; Get a
4af0: 6c 6f 63 6b 20 66 72 6f 6d 20 74 68 65 20 6e 6f lock from the no
4b00: 2d 73 79 6e 63 2d 64 62 20 66 6f 72 20 74 68 65 -sync-db for the
4b10: 20 66 72 6f 6d 2d 64 62 2c 20 74 68 65 6e 20 64 from-db, then d
4b20: 65 6c 74 61 20 73 79 6e 63 20 74 68 65 20 66 72 elta sync the fr
4b30: 6f 6d 2d 64 62 20 74 6f 20 74 68 65 20 74 6f 2d om-db to the to-
4b40: 64 62 2c 20 6f 74 68 65 72 77 69 73 65 20 72 65 db, otherwise re
4b50: 74 75 72 6e 20 23 66 0a 3b 3b 0a 28 64 65 66 69 turn #f.;;.(defi
4b60: 6e 65 20 28 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d ne (db:lock-and-
4b70: 64 65 6c 74 61 2d 73 79 6e 63 20 6e 6f 2d 73 79 delta-sync no-sy
4b80: 6e 63 2d 64 62 20 64 62 73 74 72 75 63 74 20 66 nc-db dbstruct f
4b90: 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 75 6e 69 rom-db-file runi
4ba0: 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 20 d keys dbinit).
4bb0: 20 28 61 73 73 65 72 74 20 28 6e 6f 74 20 2a 64 (assert (not *d
4bc0: 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 b-sync-in-progre
4bd0: 73 73 2a 29 20 22 46 41 54 41 4c 3a 20 64 62 3a ss*) "FATAL: db:
4be0: 6c 6f 63 6b 2d 61 6e 64 2d 73 79 6e 63 20 63 61 lock-and-sync ca
4bf0: 6c 6c 65 64 20 77 68 69 6c 65 20 61 20 73 79 6e lled while a syn
4c00: 63 20 69 73 20 69 6e 20 70 72 6f 67 72 65 73 73 c is in progress
4c10: 2e 22 29 0a 20 20 3b 3b 20 28 64 62 66 69 6c 65 ."). ;; (dbfile
4c20: 3a 70 72 69 6e 74 2d 65 72 72 20 2a 64 65 66 61 :print-err *defa
4c30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 ult-log-port* "d
4c40: 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 b:lock-and-delta
4c50: 2d 73 79 6e 63 22 29 0a 20 20 28 6c 65 74 2a 20 -sync"). (let*
4c60: 28 28 6c 6f 63 6b 2d 66 69 6c 65 20 28 63 6f 6e ((lock-file (con
4c70: 63 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 c from-db-file "
4c80: 2e 6c 6f 63 6b 22 29 29 29 0a 20 20 20 20 28 69 .lock"))). (i
4c90: 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 f (common:simple
4ca0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d -file-lock lock-
4cb0: 66 69 6c 65 29 0a 09 28 62 65 67 69 6e 0a 09 20 file)..(begin..
4cc0: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
4cd0: 72 72 20 22 49 4e 46 4f 3a 20 64 62 3a 6c 6f 63 rr "INFO: db:loc
4ce0: 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 k-and-delta-sync
4cf0: 20 63 6f 70 79 69 6e 67 20 64 62 20 22 72 75 6e copying db "run
4d00: 69 64 22 20 61 74 20 22 28 63 75 72 72 65 6e 74 id" at "(current
4d10: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 28 73 -seconds)).. (s
4d20: 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d et! *db-sync-in-
4d30: 70 72 6f 67 72 65 73 73 2a 20 23 74 29 0a 09 20 progress* #t)..
4d40: 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 (db:sync-touche
4d50: 64 20 64 62 73 74 72 75 63 74 20 72 75 6e 69 64 d dbstruct runid
4d60: 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 09 20 keys dbinit)..
4d70: 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d (set! *db-sync-
4d80: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 in-progress* #f)
4d90: 0a 09 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 .. (delete-file
4da0: 2a 20 6c 6f 63 6b 2d 66 69 6c 65 29 0a 09 20 20 * lock-file)..
4db0: 23 74 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 #t). (beg
4dc0: 69 6e 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f in.. (if (commo
4dd0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
4de0: 74 20 31 32 30 20 28 63 6f 6e 63 20 22 6e 6f 20 t 120 (conc "no
4df0: 6c 6f 63 6b 20 22 66 72 6f 6d 2d 64 62 2d 66 69 lock "from-db-fi
4e00: 6c 65 29 29 0a 09 20 20 20 20 20 20 28 64 62 66 le)).. (dbf
4e10: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 ile:print-err "I
4e20: 4e 46 4f 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 67 NFO: could not g
4e30: 65 74 20 6c 6f 63 6b 20 66 6f 72 20 22 20 66 72 et lock for " fr
4e40: 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 2c 20 73 79 om-db-file ", sy
4e50: 6e 63 20 6c 69 6b 65 6c 79 20 69 6e 20 70 72 6f nc likely in pro
4e60: 67 72 65 73 73 2e 22 29 29 0a 09 20 20 23 66 0a gress.")).. #f.
4e70: 09 20 20 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 47 . ))))..;; ;; G
4e80: 65 74 20 61 20 6c 6f 63 6b 20 66 72 6f 6d 20 74 et a lock from t
4e90: 68 65 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 6f he no-sync-db fo
4ea0: 72 20 74 68 65 20 66 72 6f 6d 2d 64 62 2c 20 74 r the from-db, t
4eb0: 68 65 6e 20 64 65 6c 74 61 20 73 79 6e 63 20 74 hen delta sync t
4ec0: 68 65 20 66 72 6f 6d 2d 64 62 20 74 6f 20 74 68 he from-db to th
4ed0: 65 20 74 6f 2d 64 62 2c 20 6f 74 68 65 72 77 69 e to-db, otherwi
4ee0: 73 65 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b 20 se return #f.;;
4ef0: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 ;;.;; (define (d
4f00: 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 b:lock-and-delta
4f10: 2d 73 79 6e 63 2d 6f 72 69 67 20 6e 6f 2d 73 79 -sync-orig no-sy
4f20: 6e 63 2d 64 62 20 64 62 73 74 72 75 63 74 20 66 nc-db dbstruct f
4f30: 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 75 6e 69 rom-db-file runi
4f40: 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 3b d keys dbinit).;
4f50: 3b 20 20 20 28 61 73 73 65 72 74 20 28 6e 6f 74 ; (assert (not
4f60: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
4f70: 67 72 65 73 73 2a 29 20 22 46 41 54 41 4c 3a 20 gress*) "FATAL:
4f80: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 73 79 6e 63 db:lock-and-sync
4f90: 20 63 61 6c 6c 65 64 20 77 68 69 6c 65 20 61 20 called while a
4fa0: 73 79 6e 63 20 69 73 20 69 6e 20 70 72 6f 67 72 sync is in progr
4fb0: 65 73 73 2e 22 29 0a 3b 3b 20 20 20 3b 3b 20 28 ess.").;; ;; (
4fc0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
4fd0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4fe0: 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d 61 6e 64 rt* "db:lock-and
4ff0: 2d 64 65 6c 74 61 2d 73 79 6e 63 22 29 0a 3b 3b -delta-sync").;;
5000: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 64 (let* ((lockd
5010: 61 74 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d at (db:no-sync-
5020: 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 6f 75 74 get-lock-timeout
5030: 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 72 6f 6d no-sync-db from
5040: 2d 64 62 2d 66 69 6c 65 20 36 30 29 29 0a 3b 3b -db-file 60)).;;
5050: 20 09 20 28 67 6f 74 6c 6f 63 6b 20 20 28 63 61 . (gotlock (ca
5060: 72 20 6c 6f 63 6b 64 61 74 29 29 0a 3b 3b 20 09 r lockdat)).;; .
5070: 20 28 6c 6f 63 6b 74 69 6d 65 20 28 63 64 72 20 (locktime (cdr
5080: 6c 6f 63 6b 64 61 74 29 29 29 0a 3b 3b 20 20 20 lockdat))).;;
5090: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
50a0: 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 61 75 6c t-info 3 *defaul
50b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 3a t-log-port* "db:
50c0: 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 lock-and-delta-s
50d0: 79 6e 63 3a 20 67 6f 74 20 6c 6f 63 6b 3f 22 29 ync: got lock?")
50e0: 0a 3b 3b 20 20 20 20 20 0a 3b 3b 20 20 20 20 20 .;; .;;
50f0: 28 69 66 20 67 6f 74 6c 6f 63 6b 0a 3b 3b 20 09 (if gotlock.;; .
5100: 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 (begin.;;
5110: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
5120: 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 3a t-err "INFO: db:
5130: 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 lock-and-delta-s
5140: 79 6e 63 20 63 6f 70 79 69 6e 67 20 64 62 20 22 ync copying db "
5150: 72 75 6e 69 64 22 20 61 74 20 22 28 63 75 72 72 runid" at "(curr
5160: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b 3b ent-seconds)).;;
5170: 20 09 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 . (set! *db-sy
5180: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 nc-in-progress*
5190: 23 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 #t).;;
51a0: 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 (db:sync-touche
51b0: 64 20 64 62 73 74 72 75 63 74 20 72 75 6e 69 64 d dbstruct runid
51c0: 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 3b 3b keys dbinit).;;
51d0: 20 09 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 . (set! *db-sy
51e0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 nc-in-progress*
51f0: 23 66 29 0a 3b 3b 20 09 20 20 28 64 62 3a 6e 6f #f).;; . (db:no
5200: 2d 73 79 6e 63 2d 64 65 6c 21 20 6e 6f 2d 73 79 -sync-del! no-sy
5210: 6e 63 2d 64 62 20 66 72 6f 6d 2d 64 62 2d 66 69 nc-db from-db-fi
5220: 6c 65 29 0a 3b 3b 20 09 20 20 23 74 29 0a 3b 3b le).;; . #t).;;
5230: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
5240: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 64 62 ;; (db
5250: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
5260: 45 52 52 4f 52 3a 20 63 6f 75 6c 64 20 6e 6f 74 ERROR: could not
5270: 20 67 65 74 20 6c 6f 63 6b 20 66 6f 72 20 22 20 get lock for "
5280: 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 20 66 from-db-file " f
5290: 72 6f 6d 20 6e 6f 2d 73 79 6e 63 2d 64 62 22 29 rom no-sync-db")
52a0: 0a 3b 3b 20 09 20 20 23 66 0a 3b 3b 20 20 20 20 .;; . #f.;;
52b0: 20 20 20 20 20 29 29 29 29 0a 0a 3b 3b 20 73 79 ))))..;; sy
52c0: 6e 63 20 72 75 6e 20 66 72 6f 6d 20 74 6d 70 20 nc run from tmp
52d0: 64 69 73 6b 20 74 6f 20 6e 66 73 20 64 69 73 6b disk to nfs disk
52e0: 20 69 66 20 74 6f 75 63 68 65 64 0a 3b 3b 0a 3b if touched.;;.;
52f0: 3b 20 63 61 6c 6c 20 77 69 74 68 20 64 62 69 6e ; call with dbin
5300: 69 74 3d 64 62 3a 69 6e 69 74 69 61 6c 69 7a 65 it=db:initialize
5310: 2d 6d 61 69 6e 2d 64 62 0a 3b 3b 0a 28 64 65 66 -main-db.;;.(def
5320: 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 ine (db:sync-tou
5330: 63 68 65 64 20 64 62 73 74 72 75 63 74 20 72 75 ched dbstruct ru
5340: 6e 2d 69 64 20 6b 65 79 73 20 23 21 6b 65 79 20 n-id keys #!key
5350: 64 62 69 6e 69 74 20 28 66 6f 72 63 65 2d 73 79 dbinit (force-sy
5360: 6e 63 20 23 66 29 29 0a 20 20 28 64 62 66 69 6c nc #f)). (dbfil
5370: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a e:print-err "db:
5380: 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 53 79 6e sync-touched Syn
5390: 63 69 6e 67 3a 20 22 20 28 63 6f 6e 63 20 28 69 cing: " (conc (i
53a0: 66 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 f run-id run-id
53b0: 22 6d 61 69 6e 22 29 20 22 2e 64 62 22 29 29 0a "main") ".db")).
53c0: 20 20 28 6c 65 74 2a 20 28 3b 3b 20 74 68 65 20 (let* (;; the
53d0: 73 75 62 64 62 20 69 73 20 6e 65 65 64 65 64 20 subdb is needed
53e0: 74 6f 20 61 63 63 65 73 73 20 74 68 65 20 6d 74 to access the mt
53f0: 64 62 64 61 74 0a 09 20 28 73 75 62 64 62 20 20 dbdat.. (subdb
5400: 20 20 20 28 6f 72 20 28 64 62 66 69 6c 65 3a 67 (or (dbfile:g
5410: 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 et-subdb dbstruc
5420: 74 20 72 75 6e 2d 69 64 29 0a 09 09 09 28 64 62 t run-id)....(db
5430: 66 69 6c 65 3a 69 6e 69 74 2d 73 75 62 64 62 20 file:init-subdb
5440: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
5450: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
5460: 20 20 20 28 74 6d 70 64 62 66 69 6c 65 20 28 64 (tmpdbfile (d
5470: 62 72 3a 73 75 62 64 62 2d 74 6d 70 64 62 66 69 br:subdb-tmpdbfi
5480: 6c 65 20 73 75 62 64 62 29 29 0a 09 20 28 6d 74 le subdb)).. (mt
5490: 64 62 20 20 20 20 20 20 28 64 62 72 3a 73 75 62 db (dbr:sub
54a0: 64 62 2d 6d 74 64 62 64 61 74 20 73 75 62 64 62 db-mtdbdat subdb
54b0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6d 70 )). (tmp
54c0: 64 62 20 20 20 20 20 28 64 62 3a 6f 70 65 6e 2d db (db:open-
54d0: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
54e0: 69 64 20 64 62 69 6e 69 74 29 29 20 3b 3b 20 73 id dbinit)) ;; s
54f0: 71 6c 69 74 65 33 2d 64 62 20 74 6d 70 64 62 66 qlite3-db tmpdbf
5500: 69 6c 65 20 23 66 29 29 0a 09 20 28 73 74 61 72 ile #f)).. (star
5510: 74 2d 74 20 20 20 28 63 75 72 72 65 6e 74 2d 73 t-t (current-s
5520: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 6d econds))). (m
5530: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d utex-lock! *db-m
5540: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
5550: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 75 70 64 ). (let ((upd
5560: 61 74 65 5f 69 6e 66 6f 20 28 63 6f 6e 73 20 22 ate_info (cons "
5570: 6c 61 73 74 5f 75 70 64 61 74 65 22 20 28 69 66 last_update" (if
5580: 20 66 6f 72 63 65 2d 73 79 6e 63 20 30 20 2a 64 force-sync 0 *d
5590: 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 29 29 b-last-sync*) ))
55a0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
55b0: 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 nlock! *db-multi
55c0: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 -sync-mutex*).
55d0: 20 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 61 62 (db:sync-tab
55e0: 6c 65 73 20 28 64 62 3a 73 79 6e 63 2d 61 6c 6c les (db:sync-all
55f0: 2d 74 61 62 6c 65 73 2d 6c 69 73 74 20 64 62 73 -tables-list dbs
5600: 74 72 75 63 74 20 6b 65 79 73 29 20 75 70 64 61 truct keys) upda
5610: 74 65 5f 69 6e 66 6f 20 74 6d 70 64 62 20 6d 74 te_info tmpdb mt
5620: 64 62 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d db)). (mutex-
5630: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5640: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 sync-mutex*).
5650: 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d (set! *db-last-
5660: 73 79 6e 63 2a 20 73 74 61 72 74 2d 74 29 0a 20 sync* start-t).
5670: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 (set! *db-las
5680: 74 2d 61 63 63 65 73 73 2a 20 73 74 61 72 74 2d t-access* start-
5690: 74 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e t). (mutex-un
56a0: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
56b0: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 sync-mutex*).
56c0: 20 28 64 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 (dbfile:add-dbd
56d0: 61 74 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d at dbstruct run-
56e0: 69 64 20 74 6d 70 64 62 29 0a 20 20 23 74 29 29 id tmpdb). #t))
56f0: 0a 0a 3b 3b 20 6a 75 73 74 20 74 65 73 74 73 2c ..;; just tests,
5700: 20 74 65 73 74 5f 73 74 65 70 73 20 61 6e 64 20 test_steps and
5710: 74 65 73 74 5f 64 61 74 61 20 74 61 62 6c 65 73 test_data tables
5720: 0a 28 64 65 66 69 6e 65 20 64 62 3a 73 79 6e 63 .(define db:sync
5730: 2d 74 65 73 74 73 2d 6f 6e 6c 79 0a 20 20 28 6c -tests-only. (l
5740: 69 73 74 0a 20 20 20 3b 3b 20 28 6c 69 73 74 20 ist. ;; (list
5750: 22 73 74 72 73 22 0a 20 20 20 3b 3b 20 20 20 20 "strs". ;;
5760: 20 20 20 27 28 22 69 64 22 20 20 20 20 20 20 20 '("id"
5770: 20 20 20 20 20 20 23 66 29 0a 20 20 20 3b 3b 20 #f). ;;
5780: 20 20 20 20 20 20 27 28 22 73 74 72 22 20 20 20 '("str"
5790: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 #f)).
57a0: 20 28 6c 69 73 74 20 22 74 65 73 74 73 22 20 0a (list "tests" .
57b0: 09 20 27 28 22 69 64 22 20 20 20 20 20 20 20 20 . '("id"
57c0: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 72 75 #f).. '("ru
57d0: 6e 5f 69 64 22 20 20 20 20 20 20 20 20 20 23 66 n_id" #f
57e0: 29 0a 09 20 27 28 22 74 65 73 74 6e 61 6d 65 22 ).. '("testname"
57f0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5800: 68 6f 73 74 22 20 20 20 20 20 20 20 20 20 20 20 host"
5810: 23 66 29 0a 09 20 27 28 22 63 70 75 6c 6f 61 64 #f).. '("cpuload
5820: 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 " #f).. '
5830: 28 22 64 69 73 6b 66 72 65 65 22 20 20 20 20 20 ("diskfree"
5840: 20 20 23 66 29 0a 09 20 27 28 22 75 6e 61 6d 65 #f).. '("uname
5850: 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 " #f)..
5860: 20 27 28 22 72 75 6e 64 69 72 22 20 20 20 20 20 '("rundir"
5870: 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 68 6f #f).. '("sho
5880: 72 74 64 69 72 22 20 20 20 20 20 20 20 23 66 29 rtdir" #f)
5890: 0a 09 20 27 28 22 69 74 65 6d 5f 70 61 74 68 22 .. '("item_path"
58a0: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 #f).. '("s
58b0: 74 61 74 65 22 20 20 20 20 20 20 20 20 20 20 23 tate" #
58c0: 66 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 20 f).. '("status"
58d0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
58e0: 22 61 74 74 65 6d 70 74 6e 75 6d 22 20 20 20 20 "attemptnum"
58f0: 20 23 66 29 0a 09 20 27 28 22 66 69 6e 61 6c 5f #f).. '("final_
5900: 6c 6f 67 66 22 20 20 20 20 20 23 66 29 0a 09 20 logf" #f)..
5910: 27 28 22 6c 6f 67 64 61 74 22 20 20 20 20 20 20 '("logdat"
5920: 20 20 20 23 66 29 0a 09 20 27 28 22 72 75 6e 5f #f).. '("run_
5930: 64 75 72 61 74 69 6f 6e 22 20 20 20 23 66 29 0a duration" #f).
5940: 09 20 27 28 22 63 6f 6d 6d 65 6e 74 22 20 20 20 . '("comment"
5950: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 65 76 #f).. '("ev
5960: 65 6e 74 5f 74 69 6d 65 22 20 20 20 20 20 23 66 ent_time" #f
5970: 29 0a 09 20 27 28 22 66 61 69 6c 5f 63 6f 75 6e ).. '("fail_coun
5980: 74 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 t" #f).. '("
5990: 70 61 73 73 5f 63 6f 75 6e 74 22 20 20 20 20 20 pass_count"
59a0: 23 66 29 0a 09 20 27 28 22 61 72 63 68 69 76 65 #f).. '("archive
59b0: 64 22 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 d" #f).
59c0: 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 75 70 '("last_up
59d0: 64 61 74 65 22 20 20 20 20 23 66 29 29 0a 20 20 date" #f)).
59e0: 28 6c 69 73 74 20 22 74 65 73 74 5f 73 74 65 70 (list "test_step
59f0: 73 22 0a 09 20 27 28 22 69 64 22 20 20 20 20 20 s".. '("id"
5a00: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
5a10: 22 74 65 73 74 5f 69 64 22 20 20 20 20 20 20 20 "test_id"
5a20: 20 23 66 29 0a 09 20 27 28 22 73 74 65 70 6e 61 #f).. '("stepna
5a30: 6d 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 me" #f)..
5a40: 27 28 22 73 74 61 74 65 22 20 20 20 20 20 20 20 '("state"
5a50: 20 20 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 #f).. '("stat
5a60: 75 73 22 20 20 20 20 20 20 20 20 20 23 66 29 0a us" #f).
5a70: 09 20 27 28 22 65 76 65 6e 74 5f 74 69 6d 65 22 . '("event_time"
5a80: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 63 6f #f).. '("co
5a90: 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 20 23 66 mment" #f
5aa0: 29 0a 09 20 27 28 22 6c 6f 67 66 69 6c 65 22 20 ).. '("logfile"
5ab0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
5ac0: 20 20 20 20 27 28 22 6c 61 73 74 5f 75 70 64 61 '("last_upda
5ad0: 74 65 22 20 20 20 20 23 66 29 29 0a 20 20 20 28 te" #f)). (
5ae0: 6c 69 73 74 20 22 74 65 73 74 5f 64 61 74 61 22 list "test_data"
5af0: 0a 09 20 27 28 22 69 64 22 20 20 20 20 20 20 20 .. '("id"
5b00: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 #f).. '("t
5b10: 65 73 74 5f 69 64 22 20 20 20 20 20 20 20 20 23 est_id" #
5b20: 66 29 0a 09 20 27 28 22 63 61 74 65 67 6f 72 79 f).. '("category
5b30: 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 " #f).. '(
5b40: 22 76 61 72 69 61 62 6c 65 22 20 20 20 20 20 20 "variable"
5b50: 20 23 66 29 0a 09 20 27 28 22 76 61 6c 75 65 22 #f).. '("value"
5b60: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
5b70: 27 28 22 65 78 70 65 63 74 65 64 22 20 20 20 20 '("expected"
5b80: 20 20 20 23 66 29 0a 09 20 27 28 22 74 6f 6c 22 #f).. '("tol"
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
5ba0: 09 20 27 28 22 75 6e 69 74 73 22 20 20 20 20 20 . '("units"
5bb0: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 63 6f #f).. '("co
5bc0: 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 20 23 66 mment" #f
5bd0: 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 20 20 ).. '("status"
5be0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5bf0: 74 79 70 65 22 20 20 20 20 20 20 20 20 20 20 20 type"
5c00: 23 66 29 0a 20 20 20 20 20 20 20 20 20 27 28 22 #f). '("
5c10: 6c 61 73 74 5f 75 70 64 61 74 65 22 20 20 20 20 last_update"
5c20: 23 66 29 29 29 29 0a 0a 3b 3b 20 6e 65 65 64 73 #f))))..;; needs
5c30: 20 64 62 20 74 6f 20 67 65 74 20 6b 65 79 73 2c db to get keys,
5c40: 20 74 68 69 73 20 69 73 20 66 6f 72 20 73 79 6e this is for syn
5c50: 63 69 6e 67 20 61 6c 6c 20 74 61 62 6c 65 73 0a cing all tables.
5c60: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 73 ;;.(define (db:s
5c70: 79 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 20 64 62 ync-main-list db
5c80: 73 74 72 75 63 74 20 6b 65 79 73 29 0a 20 20 28 struct keys). (
5c90: 6c 65 74 20 28 28 6b 65 79 73 20 20 6b 65 79 73 let ((keys keys
5ca0: 29 29 20 3b 3b 20 28 64 62 3a 67 65 74 2d 6b 65 )) ;; (db:get-ke
5cb0: 79 73 20 64 62 73 74 72 75 63 74 29 29 29 0a 20 ys dbstruct))).
5cc0: 20 20 20 28 6c 69 73 74 0a 20 20 20 20 20 28 6c (list. (l
5cd0: 69 73 74 20 22 6b 65 79 73 22 0a 09 20 20 20 27 ist "keys".. '
5ce0: 28 22 69 64 22 20 20 20 20 20 20 20 20 23 66 29 ("id" #f)
5cf0: 0a 09 20 20 20 27 28 22 66 69 65 6c 64 6e 61 6d .. '("fieldnam
5d00: 65 22 20 23 66 29 0a 09 20 20 20 27 28 22 66 69 e" #f).. '("fi
5d10: 65 6c 64 74 79 70 65 22 20 23 66 29 29 0a 20 20 eldtype" #f)).
5d20: 20 20 20 28 6c 69 73 74 20 22 6d 65 74 61 64 61 (list "metada
5d30: 74 22 20 27 28 22 76 61 72 22 20 23 66 29 20 27 t" '("var" #f) '
5d40: 28 22 76 61 6c 22 20 23 66 29 29 0a 20 20 20 20 ("val" #f)).
5d50: 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 22 (append (list "
5d60: 72 75 6e 73 22 20 0a 09 09 20 20 20 27 28 22 69 runs" ... '("i
5d70: 64 22 20 20 23 66 29 29 0a 09 20 20 20 20 20 28 d" #f)).. (
5d80: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 map (lambda (k)(
5d90: 6c 69 73 74 20 6b 20 23 66 29 29 0a 09 09 20 20 list k #f))...
5da0: 28 61 70 70 65 6e 64 20 6b 65 79 73 0a 09 09 09 (append keys....
5db0: 20 20 28 6c 69 73 74 20 22 72 75 6e 6e 61 6d 65 (list "runname
5dc0: 22 20 22 73 74 61 74 65 22 20 22 73 74 61 74 75 " "state" "statu
5dd0: 73 22 20 22 6f 77 6e 65 72 22 20 22 65 76 65 6e s" "owner" "even
5de0: 74 5f 74 69 6d 65 22 20 22 63 6f 6d 6d 65 6e 74 t_time" "comment
5df0: 22 20 22 66 61 69 6c 5f 63 6f 75 6e 74 22 20 22 " "fail_count" "
5e00: 70 61 73 73 5f 63 6f 75 6e 74 22 20 22 63 6f 6e pass_count" "con
5e10: 74 6f 75 72 22 20 22 6c 61 73 74 5f 75 70 64 61 tour" "last_upda
5e20: 74 65 22 29 29 29 29 0a 20 20 20 20 20 28 6c 69 te")))). (li
5e30: 73 74 20 22 61 72 63 68 69 76 65 5f 64 69 73 6b st "archive_disk
5e40: 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 s". '(
5e50: 22 69 64 22 20 23 66 29 0a 20 20 20 20 20 20 20 "id" #f).
5e60: 20 20 20 20 27 28 22 61 72 63 68 69 76 65 5f 61 '("archive_a
5e70: 72 65 61 5f 6e 61 6d 65 22 20 23 66 29 20 0a 20 rea_name" #f) .
5e80: 20 20 20 20 20 20 20 20 20 20 27 28 22 64 69 73 '("dis
5e90: 6b 5f 70 61 74 68 22 20 23 66 29 0a 20 20 20 20 k_path" #f).
5ea0: 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 '("last_d
5eb0: 66 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 f" #f).
5ec0: 20 20 27 28 22 6c 61 73 74 5f 64 66 5f 74 69 6d '("last_df_tim
5ed0: 65 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 e" #f).
5ee0: 20 20 27 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 '("creation_ti
5ef0: 6d 65 22 20 23 66 29 29 20 0a 0a 20 20 20 20 20 me" #f)) ..
5f00: 28 6c 69 73 74 20 22 61 72 63 68 69 76 65 5f 62 (list "archive_b
5f10: 6c 6f 63 6b 73 22 0a 20 20 20 20 20 20 20 20 20 locks".
5f20: 20 20 27 28 22 69 64 22 20 23 66 29 0a 20 20 20 '("id" #f).
5f30: 20 20 20 20 20 20 20 20 27 28 22 61 72 63 68 69 '("archi
5f40: 76 65 5f 64 69 73 6b 5f 69 64 22 20 23 66 29 20 ve_disk_id" #f)
5f50: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 64 . '("d
5f60: 69 73 6b 5f 70 61 74 68 22 20 23 66 29 0a 20 20 isk_path" #f).
5f70: 20 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 '("last
5f80: 5f 64 75 22 20 23 66 29 0a 20 20 20 20 20 20 20 _du" #f).
5f90: 20 20 20 20 27 28 22 6c 61 73 74 5f 64 75 5f 74 '("last_du_t
5fa0: 69 6d 65 22 20 23 66 29 0a 20 20 20 20 20 20 20 ime" #f).
5fb0: 20 20 20 20 27 28 22 63 72 65 61 74 69 6f 6e 5f '("creation_
5fc0: 74 69 6d 65 22 20 23 66 29 29 20 0a 0a 20 20 20 time" #f)) ..
5fd0: 20 20 28 6c 69 73 74 20 22 74 65 73 74 5f 6d 65 (list "test_me
5fe0: 74 61 22 0a 09 20 20 20 27 28 22 69 64 22 20 20 ta".. '("id"
5ff0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
6000: 20 20 20 27 28 22 74 65 73 74 6e 61 6d 65 22 20 '("testname"
6010: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 #f).. '(
6020: 22 6f 77 6e 65 72 22 20 20 20 20 20 20 20 20 20 "owner"
6030: 20 23 66 29 0a 09 20 20 20 27 28 22 64 65 73 63 #f).. '("desc
6040: 72 69 70 74 69 6f 6e 22 20 20 20 20 23 66 29 0a ription" #f).
6050: 09 20 20 20 27 28 22 72 65 76 69 65 77 65 64 22 . '("reviewed"
6060: 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 #f).. '
6070: 28 22 69 74 65 72 61 74 65 64 22 20 20 20 20 20 ("iterated"
6080: 20 20 23 66 29 0a 09 20 20 20 27 28 22 61 76 67 #f).. '("avg
6090: 5f 72 75 6e 74 69 6d 65 22 20 20 20 20 23 66 29 _runtime" #f)
60a0: 0a 09 20 20 20 27 28 22 61 76 67 5f 64 69 73 6b .. '("avg_disk
60b0: 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 " #f)..
60c0: 27 28 22 74 61 67 73 22 20 20 20 20 20 20 20 20 '("tags"
60d0: 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 6a 6f #f).. '("jo
60e0: 62 67 72 6f 75 70 22 20 20 20 20 20 20 20 23 66 bgroup" #f
60f0: 29 29 0a 0a 0a 20 20 20 20 20 28 6c 69 73 74 20 ))... (list
6100: 22 74 61 73 6b 73 5f 71 75 65 75 65 22 0a 20 20 "tasks_queue".
6110: 20 20 20 20 20 20 20 20 20 27 28 22 69 64 22 20 '("id"
6120: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 #f).
6130: 20 20 20 20 20 20 20 20 20 20 27 28 22 61 63 74 '("act
6140: 69 6f 6e 22 20 20 20 20 20 20 20 20 23 66 29 0a ion" #f).
6150: 20 20 20 20 20 20 20 20 20 20 20 27 28 22 6f 77 '("ow
6160: 6e 65 72 22 20 20 20 20 20 20 20 20 20 23 66 29 ner" #f)
6170: 20 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 . '("
6180: 73 74 61 74 65 22 20 20 20 20 20 20 20 20 20 23 state" #
6190: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
61a0: 22 74 61 72 67 65 74 22 20 20 20 20 20 20 20 20 "target"
61b0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
61c0: 28 22 6e 61 6d 65 22 20 20 20 20 20 20 20 20 20 ("name"
61d0: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
61e0: 27 28 22 74 65 73 74 70 61 74 74 22 20 20 20 20 '("testpatt"
61f0: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
6200: 20 27 28 22 6b 65 79 6c 6f 63 6b 22 20 20 20 20 '("keylock"
6210: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
6220: 20 20 27 28 22 70 61 72 61 6d 73 22 20 20 20 20 '("params"
6230: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
6240: 20 20 20 27 28 22 63 72 65 61 74 69 6f 6e 5f 74 '("creation_t
6250: 69 6d 65 22 20 23 66 29 0a 20 20 20 20 20 20 20 ime" #f).
6260: 20 20 20 20 27 28 22 65 78 65 63 75 74 69 6f 6e '("execution
6270: 5f 74 69 6d 65 22 20 23 66 29 29 0a 20 20 20 20 _time" #f)).
6280: 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 )))..(define (d
6290: 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 62 6c 65 b:sync-all-table
62a0: 73 2d 6c 69 73 74 20 64 62 73 74 72 75 63 74 20 s-list dbstruct
62b0: 6b 65 79 73 29 0a 20 20 28 61 70 70 65 6e 64 20 keys). (append
62c0: 28 64 62 3a 73 79 6e 63 2d 6d 61 69 6e 2d 6c 69 (db:sync-main-li
62d0: 73 74 20 64 62 73 74 72 75 63 74 20 6b 65 79 73 st dbstruct keys
62e0: 29 0a 09 20 20 64 62 3a 73 79 6e 63 2d 74 65 73 ).. db:sync-tes
62f0: 74 73 2d 6f 6e 6c 79 29 29 0a 0a 3b 3b 20 74 62 ts-only))..;; tb
6300: 6c 73 20 69 73 20 28 20 28 22 74 61 62 6c 65 6e ls is ( ("tablen
6310: 61 6d 65 22 20 28 20 22 66 69 65 6c 64 31 22 20 ame" ( "field1"
6320: 5b 23 66 7c 70 72 6f 63 31 5d 20 29 20 28 20 22 [#f|proc1] ) ( "
6330: 66 69 65 6c 64 32 22 20 5b 23 66 7c 70 72 6f 63 field2" [#f|proc
6340: 32 5d 20 29 20 2e 2e 2e 2e 20 29 20 29 0a 3b 3b 2] ) .... ) ).;;
6350: 20 64 62 27 73 20 61 72 65 20 64 62 64 61 74 27 db's are dbdat'
6360: 73 0a 3b 3b 0a 3b 3b 20 69 66 20 6c 61 73 74 2d s.;;.;; if last-
6370: 75 70 64 61 74 65 20 73 70 65 63 69 66 69 65 64 update specified
6380: 20 28 22 66 69 65 6c 64 2d 6e 61 6d 65 22 20 2e ("field-name" .
6390: 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 time-in-seconds
63a0: 29 0a 3b 3b 20 20 20 20 74 68 65 6e 20 73 79 6e ).;; then syn
63b0: 63 20 6f 6e 6c 79 20 72 65 63 6f 72 64 73 20 77 c only records w
63c0: 68 65 72 65 20 66 69 65 6c 64 2d 6e 61 6d 65 20 here field-name
63d0: 3e 3d 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e >= time-in-secon
63e0: 64 73 0a 3b 3b 20 20 20 20 49 46 46 20 66 69 65 ds.;; IFF fie
63f0: 6c 64 2d 6e 61 6d 65 20 65 78 69 73 74 73 0a 3b ld-name exists.;
6400: 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 73 79 ;.(define (db:sy
6410: 6e 63 2d 74 61 62 6c 65 73 20 74 62 6c 73 20 6c nc-tables tbls l
6420: 61 73 74 2d 75 70 64 61 74 65 20 66 72 6f 6d 64 ast-update fromd
6430: 62 20 74 6f 64 62 20 2e 20 73 6c 61 76 65 2d 64 b todb . slave-d
6440: 62 73 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 bs). (handle-ex
6450: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
6460: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 (begin. (
6470: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
6480: 20 20 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 "EXCEPTION: da
6490: 74 61 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 tabase probably
64a0: 6f 76 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e overloaded or un
64b0: 72 65 61 64 61 62 6c 65 20 69 6e 20 64 62 3a 73 readable in db:s
64c0: 79 6e 63 2d 74 61 62 6c 65 73 2e 22 29 0a 20 20 ync-tables.").
64d0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
64e0: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
64f0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 ror-port)).
6500: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
6510: 72 20 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 r " message: "
6520: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
6530: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
6540: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
6550: 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a )). (dbfile:
6560: 70 72 69 6e 74 2d 65 72 72 20 20 22 65 78 6e 3d print-err "exn=
6570: 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 " (condition->li
6580: 73 74 20 65 78 6e 29 29 0a 20 20 20 20 20 28 64 st exn)). (d
6590: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
65a0: 20 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 " status: " ((
65b0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
65c0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c ty-accessor 'sql
65d0: 69 74 65 33 20 27 73 74 61 74 75 73 29 20 65 78 ite3 'status) ex
65e0: 6e 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 n)). (dbfile
65f0: 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 20 73 72 :print-err " sr
6600: 63 20 64 62 3a 20 20 22 20 28 64 62 72 3a 64 62 c db: " (dbr:db
6610: 64 61 74 2d 64 62 66 69 6c 65 20 66 72 6f 6d 64 dat-dbfile fromd
6620: 62 29 29 0a 20 20 20 20 20 28 66 6f 72 2d 65 61 b)). (for-ea
6630: 63 68 20 28 6c 61 6d 62 64 61 20 28 64 62 64 61 ch (lambda (dbda
6640: 74 29 0a 09 09 20 28 6c 65 74 20 28 28 64 62 70 t)... (let ((dbp
6650: 61 74 68 20 28 64 62 72 3a 64 62 64 61 74 2d 64 ath (dbr:dbdat-d
6660: 62 66 69 6c 65 20 64 62 64 61 74 29 29 29 0a 09 bfile dbdat)))..
6670: 09 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e . (dbfile:prin
6680: 74 2d 65 72 72 20 20 22 20 64 62 70 61 74 68 3a t-err " dbpath:
6690: 20 20 22 20 64 62 70 61 74 68 29 0a 09 09 20 20 " dbpath)...
66a0: 20 28 69 66 20 23 74 20 3b 3b 20 28 6e 6f 74 20 (if #t ;; (not
66b0: 28 64 62 3a 72 65 70 61 69 72 2d 64 62 20 64 62 (db:repair-db db
66c0: 64 61 74 29 29 0a 09 09 20 20 20 20 20 20 20 28 dat))... (
66d0: 62 65 67 69 6e 0a 09 09 09 20 28 64 62 66 69 6c begin.... (dbfil
66e0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 46 61 69 e:print-err "Fai
66f0: 6c 65 64 20 74 6f 20 72 65 62 75 69 6c 64 20 28 led to rebuild (
6700: 72 65 70 61 69 72 20 69 73 20 74 75 72 6e 65 64 repair is turned
6710: 20 6f 66 66 29 20 22 20 64 62 70 61 74 68 20 22 off) " dbpath "
6720: 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 , exiting now.")
6730: 0a 09 09 09 20 28 65 78 69 74 29 29 29 29 29 0a .... (exit))))).
6740: 09 20 20 20 20 20 20 20 28 63 6f 6e 73 20 74 6f . (cons to
6750: 64 62 20 73 6c 61 76 65 2d 64 62 73 29 29 0a 20 db slave-dbs)).
6760: 20 20 20 20 0a 20 20 20 20 20 30 29 0a 0a 20 20 . 0)..
6770: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
6780: 77 6f 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 22 work to be done"
6790: 29 0a 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 28 ). (cond. (
67a0: 28 6e 6f 74 20 66 72 6f 6d 64 62 29 20 28 64 62 (not fromdb) (db
67b0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 file:print-err
67c0: 22 57 41 52 4e 49 4e 47 3a 20 64 62 3a 73 79 6e "WARNING: db:syn
67d0: 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 c-tables called
67e0: 77 69 74 68 20 66 72 6f 6d 64 62 20 6d 69 73 73 with fromdb miss
67f0: 69 6e 67 22 29 0a 20 20 20 20 20 2d 31 29 0a 20 ing"). -1).
6800: 20 20 20 28 28 6e 6f 74 20 74 6f 64 62 29 20 20 ((not todb)
6810: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
6820: 72 72 20 20 22 57 41 52 4e 49 4e 47 3a 20 64 62 rr "WARNING: db
6830: 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c :sync-tables cal
6840: 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 6d 69 led with todb mi
6850: 73 73 69 6e 67 22 29 0a 20 20 20 20 20 2d 32 29 ssing"). -2)
6860: 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 71 6c 69 . ((not (sqli
6870: 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 28 64 te3:database? (d
6880: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 66 72 6f br:dbdat-dbh fro
6890: 6d 64 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 mdb))). (dbf
68a0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 ile:print-err "d
68b0: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 b:sync-tables ca
68c0: 6c 6c 65 64 20 77 69 74 68 20 66 72 6f 6d 64 62 lled with fromdb
68d0: 20 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 20 not a database
68e0: 22 20 66 72 6f 6d 64 62 29 0a 20 20 20 2d 33 29 " fromdb). -3)
68f0: 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 71 6c 69 . ((not (sqli
6900: 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 28 64 te3:database? (d
6910: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 74 6f 64 br:dbdat-dbh tod
6920: 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c b))). (dbfil
6930: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a e:print-err "db:
6940: 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c sync-tables call
6950: 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 ed with todb not
6960: 20 61 20 64 61 74 61 62 61 73 65 20 22 20 74 6f a database " to
6970: 64 62 29 0a 20 20 20 2d 34 29 0a 0a 20 20 20 20 db). -4)..
6980: 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 ((not (file-writ
6990: 65 2d 61 63 63 65 73 73 3f 20 28 64 62 72 3a 64 e-access? (dbr:d
69a0: 62 64 61 74 2d 64 62 66 69 6c 65 20 74 6f 64 62 bdat-dbfile todb
69b0: 29 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 ))). (dbfile
69c0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 :print-err "db:s
69d0: 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 ync-tables calle
69e0: 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 20 d with todb not
69f0: 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 a read-only data
6a00: 62 61 73 65 20 22 20 74 6f 64 62 29 0a 20 20 20 base " todb).
6a10: 20 20 2d 35 29 0a 20 20 20 20 28 28 6e 6f 74 20 -5). ((not
6a20: 28 6e 75 6c 6c 3f 20 28 6c 65 74 20 28 28 72 65 (null? (let ((re
6a30: 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 73 adonly-slave-dbs
6a40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6a50: 20 20 20 20 20 20 20 20 20 28 66 69 6c 74 65 72 (filter
6a60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6a70: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
6a80: 61 20 28 64 62 64 61 74 29 0a 20 20 20 20 20 20 a (dbdat).
6a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6aa0: 20 20 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 2d (not (file-
6ab0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 64 write-access? (d
6ac0: 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 br:dbdat-dbfile
6ad0: 74 6f 64 62 29 29 29 29 0a 20 20 20 20 20 20 20 todb)))).
6ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6af0: 20 20 73 6c 61 76 65 2d 64 62 73 29 29 29 0a 20 slave-dbs))).
6b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b10: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
6b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b30: 28 6c 61 6d 62 64 61 20 28 62 61 64 2d 64 62 64 (lambda (bad-dbd
6b40: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
6b50: 20 20 20 20 20 20 20 20 20 20 28 64 62 66 69 6c (dbfil
6b60: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a e:print-err "db:
6b70: 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c sync-tables call
6b80: 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 ed with todb not
6b90: 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 a read-only dat
6ba0: 61 62 61 73 65 20 22 20 62 61 64 2d 64 62 64 61 abase " bad-dbda
6bb0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
6bc0: 20 20 20 20 20 20 20 20 72 65 61 64 6f 6e 6c 79 readonly
6bd0: 2d 73 6c 61 76 65 2d 64 62 73 29 0a 20 20 20 20 -slave-dbs).
6be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
6bf0: 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 eadonly-slave-db
6c00: 73 29 29 29 20 2d 36 29 0a 20 20 20 20 28 65 6c s))) -6). (el
6c10: 73 65 0a 20 20 20 20 20 3b 3b 20 28 64 62 66 69 se. ;; (dbfi
6c20: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 le:print-err "db
6c30: 3a 73 79 6e 63 2d 74 61 62 6c 65 73 3a 20 61 72 :sync-tables: ar
6c40: 67 73 20 61 72 65 20 67 6f 6f 64 22 29 0a 0a 20 gs are good")..
6c50: 20 20 20 20 28 6c 65 74 20 28 28 73 74 6d 74 73 (let ((stmts
6c60: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
6c70: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 62 h-table)) ;; tab
6c80: 6c 65 2d 66 69 65 6c 64 20 3d 3e 20 73 74 6d 74 le-field => stmt
6c90: 0a 09 20 20 20 28 61 6c 6c 2d 73 74 6d 74 73 20 .. (all-stmts
6ca0: 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 20 '())
6cb0: 20 20 20 20 3b 3b 20 28 20 28 20 73 74 6d 74 31 ;; ( ( stmt1
6cc0: 20 76 61 6c 75 65 31 20 29 20 28 20 73 74 6d 6c value1 ) ( stml
6cd0: 32 20 76 61 6c 75 65 32 20 29 29 0a 09 20 20 20 2 value2 ))..
6ce0: 28 6e 75 6d 72 65 63 73 20 20 20 20 20 28 6d 61 (numrecs (ma
6cf0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
6d00: 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 . (start-time
6d10: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
6d20: 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 28 74 6f econds)).. (to
6d30: 74 2d 63 6f 75 6e 74 20 20 20 30 29 29 0a 20 20 t-count 0)).
6d40: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 3b (for-each ;
6d50: 3b 20 74 61 62 6c 65 0a 09 28 6c 61 6d 62 64 61 ; table..(lambda
6d60: 20 28 74 61 62 6c 65 64 61 74 29 0a 09 20 20 28 (tabledat).. (
6d70: 6c 65 74 2a 20 28 28 74 61 62 6c 65 6e 61 6d 65 let* ((tablename
6d80: 20 20 20 20 20 20 20 20 28 63 61 72 20 74 61 62 (car tab
6d90: 6c 65 64 61 74 29 29 0a 09 09 20 28 66 69 65 6c ledat))... (fiel
6da0: 64 73 20 20 20 20 20 20 20 20 20 20 20 28 63 64 ds (cd
6db0: 72 20 74 61 62 6c 65 64 61 74 29 29 0a 09 09 20 r tabledat))...
6dc0: 28 68 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 (has-last-update
6dd0: 20 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f (member "last_
6de0: 75 70 64 61 74 65 22 20 66 69 65 6c 64 73 29 29 update" fields))
6df0: 0a 09 09 20 28 75 73 65 2d 6c 61 73 74 2d 75 70 ... (use-last-up
6e00: 64 61 74 65 20 20 28 63 6f 6e 64 0a 09 09 09 09 date (cond.....
6e10: 20 20 20 20 28 28 61 6e 64 20 68 61 73 2d 6c 61 ((and has-la
6e20: 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 09 20 st-update......
6e30: 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 (member "last_u
6e40: 70 64 61 74 65 22 20 66 69 65 6c 64 73 29 29 0a pdate" fields)).
6e50: 09 09 09 09 20 20 20 20 20 23 74 29 20 3b 3b 20 .... #t) ;;
6e60: 69 66 20 67 69 76 65 6e 20 61 20 6e 75 6d 62 65 if given a numbe
6e70: 72 2c 20 6a 75 73 74 20 75 73 65 20 69 74 20 66 r, just use it f
6e80: 6f 72 20 61 6c 6c 20 66 69 65 6c 64 73 0a 09 09 or all fields...
6e90: 09 09 20 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 .. ((number?
6ea0: 6c 61 73 74 2d 75 70 64 61 74 65 29 20 23 66 29 last-update) #f)
6eb0: 20 3b 3b 20 69 66 20 6e 6f 74 20 6d 61 74 63 68 ;; if not match
6ec0: 65 64 20 66 69 72 73 74 20 65 6e 74 72 79 20 74 ed first entry t
6ed0: 68 65 6e 20 69 67 6e 6f 72 65 20 6c 61 73 74 2d hen ignore last-
6ee0: 75 70 64 61 74 65 20 66 6f 72 20 74 68 69 73 20 update for this
6ef0: 74 61 62 6c 65 0a 09 09 09 09 20 20 20 20 28 28 table..... ((
6f00: 61 6e 64 20 28 70 61 69 72 3f 20 6c 61 73 74 2d and (pair? last-
6f10: 75 70 64 61 74 65 29 0a 09 09 09 09 09 20 20 28 update)...... (
6f20: 6d 65 6d 62 65 72 20 28 63 61 72 20 6c 61 73 74 member (car last
6f30: 2d 75 70 64 61 74 65 29 20 20 20 20 3b 3b 20 6c -update) ;; l
6f40: 61 73 74 2d 75 70 64 61 74 65 20 66 69 65 6c 64 ast-update field
6f50: 20 6e 61 6d 65 0a 09 09 09 09 09 09 20 20 28 6d name....... (m
6f60: 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 29 ap car fields)))
6f70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f90: 20 20 20 20 20 20 20 20 20 23 74 29 0a 09 09 09 #t)....
6fa0: 09 20 20 20 20 28 28 61 6e 64 20 6c 61 73 74 2d . ((and last-
6fb0: 75 70 64 61 74 65 20 28 6e 6f 74 20 28 70 61 69 update (not (pai
6fc0: 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 r? last-update))
6fd0: 20 28 6e 6f 74 20 28 6e 75 6d 62 65 72 3f 20 6c (not (number? l
6fe0: 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a 09 09 ast-update)))...
6ff0: 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 .. (dbfile:p
7000: 72 69 6e 74 2d 65 72 72 20 20 22 45 52 52 4f 52 rint-err "ERROR
7010: 3a 20 70 61 72 61 6d 65 74 65 72 20 6c 61 73 74 : parameter last
7020: 2d 75 70 64 61 74 65 20 66 6f 72 20 64 62 3a 73 -update for db:s
7030: 79 6e 63 2d 74 61 62 6c 65 73 20 6d 75 73 74 20 ync-tables must
7040: 62 65 20 61 20 70 61 69 72 20 6f 72 20 61 20 6e be a pair or a n
7050: 75 6d 62 65 72 2c 20 72 65 63 65 69 76 65 64 3a umber, received:
7060: 20 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 3b " last-update);
7070: 3b 20 66 6f 75 6e 64 20 69 6e 20 66 69 65 6c 64 ; found in field
7080: 73 0a 09 09 09 09 20 20 20 20 20 23 66 29 0a 09 s..... #f)..
7090: 09 09 09 20 20 20 20 28 65 6c 73 65 0a 09 09 09 ... (else....
70a0: 09 20 20 20 20 20 23 66 29 29 29 0a 09 09 20 28 . #f)))... (
70b0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 61 6c 75 last-update-valu
70c0: 65 20 28 69 66 20 75 73 65 2d 6c 61 73 74 2d 75 e (if use-last-u
70d0: 70 64 61 74 65 20 3b 3b 20 6e 6f 20 6e 65 65 64 pdate ;; no need
70e0: 20 74 6f 20 63 68 65 63 6b 20 66 6f 72 20 68 61 to check for ha
70f0: 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 2d 20 s-last-update -
7100: 69 74 20 69 73 20 61 6c 72 65 61 64 79 20 61 63 it is already ac
7110: 63 6f 75 6e 74 65 64 20 66 6f 72 0a 09 09 09 09 counted for.....
7120: 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6c 61 .(if (number? la
7130: 73 74 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 st-update)......
7140: 20 20 20 20 6c 61 73 74 2d 75 70 64 61 74 65 0a last-update.
7150: 09 09 09 09 09 20 20 20 20 28 63 64 72 20 6c 61 ..... (cdr la
7160: 73 74 2d 75 70 64 61 74 65 29 29 0a 09 09 09 09 st-update)).....
7170: 09 23 66 29 29 0a 09 09 20 28 6c 61 73 74 2d 75 .#f))... (last-u
7180: 70 64 61 74 65 2d 66 69 65 6c 64 20 28 69 66 20 pdate-field (if
7190: 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 0a use-last-update.
71a0: 09 09 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 .....(if (number
71b0: 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 09 ? last-update)..
71c0: 09 09 09 09 20 20 20 20 22 6c 61 73 74 5f 75 70 .... "last_up
71d0: 64 61 74 65 22 0a 09 09 09 09 09 20 20 20 20 28 date"...... (
71e0: 63 61 72 20 6c 61 73 74 2d 75 70 64 61 74 65 29 car last-update)
71f0: 29 0a 09 09 09 09 09 23 66 29 29 0a 09 09 20 28 )......#f))... (
7200: 6e 75 6d 2d 66 69 65 6c 64 73 20 28 6c 65 6e 67 num-fields (leng
7210: 74 68 20 66 69 65 6c 64 73 29 29 0a 09 09 20 28 th fields))... (
7220: 66 69 65 6c 64 2d 3e 6e 75 6d 20 28 6d 61 6b 65 field->num (make
7230: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 -hash-table))...
7240: 20 28 6e 75 6d 2d 3e 66 69 65 6c 64 20 28 61 70 (num->field (ap
7250: 70 6c 79 20 76 65 63 74 6f 72 20 28 6d 61 70 20 ply vector (map
7260: 63 61 72 20 66 69 65 6c 64 73 29 29 29 20 3b 3b car fields))) ;;
7270: 20 42 42 48 45 52 45 0a 09 09 20 28 66 75 6c 6c BBHERE... (full
7280: 2d 73 65 6c 20 20 20 28 63 6f 6e 63 20 22 53 45 -sel (conc "SE
7290: 4c 45 43 54 20 22 20 28 73 74 72 69 6e 67 2d 69 LECT " (string-i
72a0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
72b0: 63 61 72 20 66 69 65 6c 64 73 29 20 22 2c 22 29 car fields) ",")
72c0: 20 0a 09 09 09 09 20 20 20 22 20 46 52 4f 4d 20 ..... " FROM
72d0: 22 20 74 61 62 6c 65 6e 61 6d 65 20 28 69 66 20 " tablename (if
72e0: 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 use-last-update
72f0: 3b 3b 20 61 70 70 6c 79 20 6c 61 73 74 2d 75 70 ;; apply last-up
7300: 64 61 74 65 20 63 72 69 74 65 72 69 61 0a 09 09 date criteria...
7310: 09 09 09 09 09 20 20 28 63 6f 6e 63 20 22 20 57 ..... (conc " W
7320: 48 45 52 45 20 22 20 6c 61 73 74 2d 75 70 64 61 HERE " last-upda
7330: 74 65 2d 66 69 65 6c 64 20 22 20 3e 3d 20 22 20 te-field " >= "
7340: 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 61 6c 75 last-update-valu
7350: 65 29 0a 09 09 09 09 09 09 09 20 20 22 22 29 0a e)........ "").
7360: 09 09 09 09 20 20 20 22 3b 22 29 29 0a 09 09 20 .... ";"))...
7370: 28 66 75 6c 6c 2d 69 6e 73 20 20 20 28 63 6f 6e (full-ins (con
7380: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
7390: 4c 41 43 45 20 49 4e 54 4f 20 22 20 74 61 62 6c LACE INTO " tabl
73a0: 65 6e 61 6d 65 20 22 20 28 20 22 20 28 73 74 72 ename " ( " (str
73b0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
73c0: 28 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 (map car fields)
73d0: 20 22 2c 22 29 20 22 20 29 20 22 0a 09 09 09 09 ",") " ) ".....
73e0: 20 20 20 22 20 56 41 4c 55 45 53 20 28 20 22 20 " VALUES ( "
73f0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
7400: 72 73 65 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e rse (make-list n
7410: 75 6d 2d 66 69 65 6c 64 73 20 22 3f 22 29 20 22 um-fields "?") "
7420: 2c 22 29 20 22 20 29 3b 22 29 29 0a 09 09 20 28 ,") " );"))... (
7430: 66 72 6f 6d 64 61 74 20 20 20 20 27 28 29 29 0a fromdat '()).
7440: 09 09 20 28 66 72 6f 6d 64 61 74 73 20 20 20 27 .. (fromdats '
7450: 28 29 29 0a 09 09 20 28 74 6f 74 72 65 63 6f 72 ())... (totrecor
7460: 64 73 20 30 29 0a 09 09 20 28 62 61 74 63 68 2d ds 0)... (batch-
7470: 6c 65 6e 20 20 31 30 30 29 20 3b 3b 20 28 73 74 len 100) ;; (st
7480: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 ring->number (or
7490: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
74a0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 79 *configdat* "sy
74b0: 6e 63 22 20 22 62 61 74 63 68 73 69 7a 65 22 29 nc" "batchsize")
74c0: 20 22 31 30 30 22 29 29 29 0a 09 09 20 28 74 6f "100")))... (to
74d0: 64 61 74 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 dat (make-h
74e0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 20 28 ash-table))... (
74f0: 63 6f 75 6e 74 20 20 20 20 20 20 30 29 0a 20 20 count 0).
7500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7510: 66 69 65 6c 64 2d 6e 61 6d 65 73 20 28 6d 61 70 field-names (map
7520: 20 63 61 72 20 66 69 65 6c 64 73 29 29 0a 20 20 car fields)).
7530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7540: 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 20 delay-handicap
7550: 30 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 3e 6e 0) ;; (string->n
7560: 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 umber (or (confi
7570: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
7580: 67 64 61 74 2a 20 22 73 79 6e 63 22 20 22 64 65 gdat* "sync" "de
7590: 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 29 20 22 lay-handicap") "
75a0: 30 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 0"))).
75b0: 20 20 20 20 20 20 20 29 0a 0a 09 20 20 20 20 3b )... ;
75c0: 3b 20 73 65 74 20 75 70 20 74 68 65 20 66 69 65 ; set up the fie
75d0: 6c 64 2d 3e 6e 75 6d 20 74 61 62 6c 65 0a 09 20 ld->num table..
75e0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 (for-each..
75f0: 20 20 20 28 6c 61 6d 62 64 61 20 28 66 69 65 6c (lambda (fiel
7600: 64 29 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 d).. (hash
7610: 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 69 65 6c -table-set! fiel
7620: 64 2d 3e 6e 75 6d 20 66 69 65 6c 64 20 63 6f 75 d->num field cou
7630: 6e 74 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 nt).. (set
7640: 21 20 63 6f 75 6e 74 20 28 2b 20 63 6f 75 6e 74 ! count (+ count
7650: 20 31 29 29 29 0a 09 20 20 20 20 20 66 69 65 6c 1))).. fiel
7660: 64 73 29 0a 0a 09 20 20 20 20 3b 3b 20 72 65 61 ds)... ;; rea
7670: 64 20 74 68 65 20 73 6f 75 72 63 65 20 74 61 62 d the source tab
7680: 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b le. ;
7690: 3b 20 73 74 6f 72 65 20 61 20 6c 69 73 74 20 6f ; store a list o
76a0: 66 20 61 6c 6c 20 72 6f 77 73 20 69 6e 20 74 68 f all rows in th
76b0: 65 20 74 61 62 6c 65 20 69 6e 20 66 72 6f 6d 64 e table in fromd
76c0: 61 74 2c 20 75 70 20 74 6f 20 62 61 74 63 68 2d at, up to batch-
76d0: 6c 65 6e 2e 0a 20 20 20 20 20 20 20 20 20 20 20 len..
76e0: 20 3b 3b 20 54 68 65 6e 20 61 64 64 20 66 72 6f ;; Then add fro
76f0: 6d 64 61 74 20 74 6f 20 74 68 65 20 66 72 6f 6d mdat to the from
7700: 64 61 74 73 20 6c 69 73 74 2c 20 63 6c 65 61 72 dats list, clear
7710: 20 66 72 6f 6d 64 61 74 20 61 6e 64 20 72 65 70 fromdat and rep
7720: 65 61 74 2e 0a 09 20 20 20 20 28 73 71 6c 69 74 eat... (sqlit
7730: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
7740: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
7750: 20 2e 20 62 29 0a 09 20 20 20 20 20 20 20 28 73 . b).. (s
7760: 65 74 21 20 66 72 6f 6d 64 61 74 20 28 63 6f 6e et! fromdat (con
7770: 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 s (apply vector
7780: 61 20 62 29 20 66 72 6f 6d 64 61 74 29 29 0a 09 a b) fromdat))..
7790: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c (if (> (l
77a0: 65 6e 67 74 68 20 66 72 6f 6d 64 61 74 29 20 62 ength fromdat) b
77b0: 61 74 63 68 2d 6c 65 6e 29 0a 09 09 20 20 20 28 atch-len)... (
77c0: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 begin... (se
77d0: 74 21 20 66 72 6f 6d 64 61 74 73 20 28 63 6f 6e t! fromdats (con
77e0: 73 20 66 72 6f 6d 64 61 74 20 66 72 6f 6d 64 61 s fromdat fromda
77f0: 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 ts))... (set
7800: 21 20 66 72 6f 6d 64 61 74 20 20 27 28 29 29 0a ! fromdat '()).
7810: 09 09 20 20 20 20 20 28 73 65 74 21 20 74 6f 74 .. (set! tot
7820: 72 65 63 6f 72 64 73 20 28 2b 20 74 6f 74 72 65 records (+ totre
7830: 63 6f 72 64 73 20 31 29 29 29 0a 20 20 20 20 20 cords 1))).
7840: 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 ).
7850: 20 20 20 20 20 20 20 20 20 29 0a 09 20 20 20 20 )..
7860: 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 (dbr:dbdat-dbh
7870: 66 72 6f 6d 64 62 29 0a 09 20 20 20 20 20 66 75 fromdb).. fu
7880: 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 20 20 ll-sel)..
7890: 20 20 20 20 20 20 3b 3b 20 43 6f 75 6e 74 20 6c ;; Count l
78a0: 65 73 73 20 74 68 61 6e 20 62 61 74 63 68 2d 6c ess than batch-l
78b0: 65 6e 20 61 73 20 61 20 72 65 63 6f 72 64 0a 20 en as a record.
78c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
78d0: 28 3e 20 28 6c 65 6e 67 74 68 20 66 72 6f 6d 64 (> (length fromd
78e0: 61 74 29 20 30 29 0a 20 20 20 20 20 20 20 20 20 at) 0).
78f0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 74 6f (set! to
7900: 74 72 65 63 6f 72 64 73 20 28 2b 20 74 6f 74 72 trecords (+ totr
7910: 65 63 6f 72 64 73 20 31 29 29 29 0a 0a 09 20 20 ecords 1)))...
7920: 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 72 65 6d ;; tack on rem
7930: 61 69 6e 69 6e 67 20 72 65 63 6f 72 64 73 20 69 aining records i
7940: 6e 20 66 72 6f 6d 64 61 74 0a 09 20 20 20 20 28 n fromdat.. (
7950: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 if (not (null? f
7960: 72 6f 6d 64 61 74 29 29 0a 09 09 28 73 65 74 21 romdat))...(set!
7970: 20 66 72 6f 6d 64 61 74 73 20 28 63 6f 6e 73 20 fromdats (cons
7980: 66 72 6f 6d 64 61 74 20 66 72 6f 6d 64 61 74 73 fromdat fromdats
7990: 29 29 29 0a 0a 09 20 20 20 20 28 73 71 6c 69 74 )))... (sqlit
79a0: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
79b0: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
79c0: 20 2e 20 62 29 0a 09 20 20 20 20 20 20 20 28 68 . b).. (h
79d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
79e0: 6f 64 61 74 20 61 20 28 61 70 70 6c 79 20 76 65 odat a (apply ve
79f0: 63 74 6f 72 20 61 20 62 29 29 29 0a 09 20 20 20 ctor a b)))..
7a00: 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 (dbr:dbdat-dbh
7a10: 20 74 6f 64 62 29 0a 09 20 20 20 20 20 66 75 6c todb).. ful
7a20: 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 20 20 20 l-sel)..
7a30: 20 20 20 20 28 77 68 65 6e 20 28 61 6e 64 20 64 (when (and d
7a40: 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 28 3e elay-handicap (>
7a50: 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 delay-handicap
7a60: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
7a70: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
7a80: 65 72 72 20 22 69 6d 70 6f 73 69 6e 67 20 73 79 err "imposing sy
7a90: 6e 74 68 65 74 69 63 20 73 79 6e 63 20 64 65 6c nthetic sync del
7aa0: 61 79 20 6f 66 20 22 64 65 6c 61 79 2d 68 61 6e ay of "delay-han
7ab0: 64 69 63 61 70 22 20 73 65 63 6f 6e 64 73 20 73 dicap" seconds s
7ac0: 69 6e 63 65 20 73 79 6e 63 2f 64 65 6c 61 79 2d ince sync/delay-
7ad0: 68 61 6e 64 69 63 61 70 20 69 73 20 63 6f 6e 66 handicap is conf
7ae0: 69 67 75 72 65 64 22 29 0a 20 20 20 20 20 20 20 igured").
7af0: 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 (thread-s
7b00: 6c 65 65 70 21 20 64 65 6c 61 79 2d 68 61 6e 64 leep! delay-hand
7b10: 69 63 61 70 29 0a 20 20 20 20 20 20 20 20 20 20 icap).
7b20: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
7b30: 74 2d 65 72 72 20 22 73 79 6e 74 68 65 74 69 63 t-err "synthetic
7b40: 20 73 79 6e 63 20 64 65 6c 61 79 20 6f 66 20 22 sync delay of "
7b50: 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 20 delay-handicap"
7b60: 73 65 63 6f 6e 64 73 20 63 6f 6d 70 6c 65 74 65 seconds complete
7b70: 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d").
7b80: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ).
7b90: 0a 09 20 20 20 20 3b 3b 20 66 69 72 73 74 20 70 .. ;; first p
7ba0: 61 73 73 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 ass implementati
7bb0: 6f 6e 2c 20 6a 75 73 74 20 69 6e 73 65 72 74 20 on, just insert
7bc0: 61 6c 6c 20 63 68 61 6e 67 65 64 20 72 6f 77 73 all changed rows
7bd0: 0a 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ... (for-each
7be0: 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
7bf0: 28 74 61 72 67 64 62 29 0a 09 20 20 20 20 20 20 (targdb)..
7c00: 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
7c10: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 72 (dbr
7c20: 3a 64 62 64 61 74 2d 64 62 68 20 74 61 72 67 64 :dbdat-dbh targd
7c30: 62 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 b)).
7c40: 20 20 20 20 20 20 20 20 20 20 28 64 72 70 2d 74 (drp-t
7c50: 72 69 67 67 65 72 20 20 20 20 20 20 20 20 28 69 rigger (i
7c60: 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f f (member "last_
7c70: 75 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e 61 update" field-na
7c80: 6d 65 73 29 0a 09 09 09 09 09 20 20 20 20 20 20 mes)......
7c90: 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 72 (db:drop-trigger
7ca0: 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 20 0a db tablename) .
7cb0: 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 0a ..... #f)).
7cc0: 09 09 20 20 20 20 20 20 28 68 61 73 2d 6c 61 73 .. (has-las
7cd0: 74 2d 75 70 64 61 74 65 20 20 20 20 28 6d 65 6d t-update (mem
7ce0: 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 ber "last_update
7cf0: 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 29 29 0a " field-names)).
7d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d10: 20 20 20 20 20 20 28 69 73 2d 74 72 69 67 67 65 (is-trigge
7d20: 72 2d 64 72 6f 70 70 65 64 20 28 69 66 20 68 61 r-dropped (if ha
7d30: 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 0a 20 20 s-last-update.
7d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a (db:
7d70: 69 73 2d 74 72 69 67 67 65 72 2d 64 72 6f 70 70 is-trigger-dropp
7d80: 65 64 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 ed db tablename)
7d90: 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 ...... #f))
7da0: 20 0a 09 09 20 20 20 20 20 20 28 73 74 6d 74 68 ... (stmth
7db0: 20 20 28 73 71 6c 69 74 65 33 3a 70 72 65 70 61 (sqlite3:prepa
7dc0: 72 65 20 64 62 20 66 75 6c 6c 2d 69 6e 73 29 29 re db full-ins))
7dd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7de0: 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 2d (changed-
7df0: 72 6f 77 73 20 30 29 29 0a 09 09 20 28 66 6f 72 rows 0))... (for
7e00: 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 -each... (lambd
7e10: 61 20 28 66 72 6f 6d 64 61 74 2d 6c 73 74 29 0a a (fromdat-lst).
7e20: 09 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 77 .. (sqlite3:w
7e30: 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a ith-transaction.
7e40: 09 09 20 20 20 20 20 64 62 0a 09 09 20 20 20 20 .. db...
7e50: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 (lambda ()...
7e60: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 3b (for-each ;
7e70: 3b 20 0a 09 09 09 28 6c 61 6d 62 64 61 20 28 66 ; ....(lambda (f
7e80: 72 6f 6d 72 6f 77 29 0a 09 09 09 20 20 28 6c 65 romrow).... (le
7e90: 74 2a 20 28 28 61 20 20 20 20 28 76 65 63 74 6f t* ((a (vecto
7ea0: 72 2d 72 65 66 20 66 72 6f 6d 72 6f 77 20 30 29 r-ref fromrow 0)
7eb0: 29 0a 09 09 09 09 20 28 63 75 72 72 20 28 68 61 )..... (curr (ha
7ec0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7ed0: 61 75 6c 74 20 74 6f 64 61 74 20 61 20 23 66 29 ault todat a #f)
7ee0: 29 0a 09 09 09 09 20 28 73 61 6d 65 20 23 74 29 )..... (same #t)
7ef0: 29 0a 09 09 09 20 20 20 20 28 6c 65 74 20 6c 6f ).... (let lo
7f00: 6f 70 20 28 28 69 20 30 29 29 0a 09 09 09 20 20 op ((i 0))....
7f10: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
7f20: 20 63 75 72 72 29 0a 09 09 09 09 20 20 20 20 20 curr).....
7f30: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 (not (equal? (v
7f40: 65 63 74 6f 72 2d 72 65 66 20 66 72 6f 6d 72 6f ector-ref fromro
7f50: 77 20 69 29 28 76 65 63 74 6f 72 2d 72 65 66 20 w i)(vector-ref
7f60: 63 75 72 72 20 69 29 29 29 29 0a 09 09 09 09 20 curr i)))).....
7f70: 20 28 73 65 74 21 20 73 61 6d 65 20 23 66 29 29 (set! same #f))
7f80: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 .... (if (a
7f90: 6e 64 20 73 61 6d 65 0a 09 09 09 09 20 20 20 20 nd same.....
7fa0: 20 20 20 28 3c 20 69 20 28 2d 20 6e 75 6d 2d 66 (< i (- num-f
7fb0: 69 65 6c 64 73 20 31 29 29 29 0a 09 09 09 09 20 ields 1))).....
7fc0: 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 29 29 (loop (+ i 1)))
7fd0: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f ).... (if (no
7fe0: 74 20 73 61 6d 65 29 0a 09 09 09 09 28 62 65 67 t same).....(beg
7ff0: 69 6e 0a 09 09 09 09 20 20 28 61 70 70 6c 79 20 in..... (apply
8000: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
8010: 73 74 6d 74 68 20 28 76 65 63 74 6f 72 2d 3e 6c stmth (vector->l
8020: 69 73 74 20 66 72 6f 6d 72 6f 77 29 29 0a 09 09 ist fromrow))...
8030: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
8040: 73 65 74 21 20 6e 75 6d 72 65 63 73 20 74 61 62 set! numrecs tab
8050: 6c 65 6e 61 6d 65 20 28 2b 20 31 20 28 68 61 73 lename (+ 1 (has
8060: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
8070: 75 6c 74 20 6e 75 6d 72 65 63 73 20 74 61 62 6c ult numrecs tabl
8080: 65 6e 61 6d 65 20 30 29 29 29 0a 20 20 20 20 20 ename 0))).
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
80b0: 74 21 20 63 68 61 6e 67 65 64 2d 72 6f 77 73 20 t! changed-rows
80c0: 28 2b 20 63 68 61 6e 67 65 64 2d 72 6f 77 73 20 (+ changed-rows
80d0: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80f0: 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 ).
8100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8110: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ).
8120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8130: 29 29 0a 09 09 09 66 72 6f 6d 64 61 74 2d 6c 73 ))....fromdat-ls
8140: 74 29 29 29 29 0a 09 09 20 20 66 72 6f 6d 64 61 t))))... fromda
8150: 74 73 29 0a 0a 09 09 20 28 73 71 6c 69 74 65 33 ts).... (sqlite3
8160: 3a 66 69 6e 61 6c 69 7a 65 21 20 73 74 6d 74 68 :finalize! stmth
8170: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8180: 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 22 (if (member "
8190: 6c 61 73 74 5f 75 70 64 61 74 65 22 20 66 69 65 last_update" fie
81a0: 6c 64 2d 6e 61 6d 65 73 29 0a 20 20 20 20 20 20 ld-names).
81b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
81c0: 62 3a 63 72 65 61 74 65 2d 74 72 69 67 67 65 72 b:create-trigger
81d0: 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 29 29 db tablename)))
81e0: 29 0a 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 ).. (append
81f0: 28 6c 69 73 74 20 74 6f 64 62 29 20 73 6c 61 76 (list todb) slav
8200: 65 2d 64 62 73 29 0a 20 20 20 20 20 20 20 20 20 e-dbs).
8210: 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 29 0a ). ).
8220: 20 20 20 20 20 20 20 20 29 0a 09 74 62 6c 73 29 )..tbls)
8230: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
8240: 72 75 6e 74 69 6d 65 20 20 20 20 20 20 28 2d 20 runtime (-
8250: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
8260: 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d conds) start-tim
8270: 65 29 29 0a 09 20 20 20 20 20 20 28 73 68 6f 75 e)).. (shou
8280: 6c 64 2d 70 72 69 6e 74 20 28 6f 72 20 3b 3b 20 ld-print (or ;;
8290: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
82a0: 65 20 31 32 29 0a 09 09 09 09 28 63 6f 6d 6d 6f e 12).....(commo
82b0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
82c0: 74 20 31 32 30 20 22 64 62 20 73 79 6e 63 22 20 t 120 "db sync"
82d0: 28 3e 20 72 75 6e 74 69 6d 65 20 35 30 30 29 29 (> runtime 500))
82e0: 29 29 29 20 3b 3b 20 6c 6f 77 20 61 6e 64 20 68 ))) ;; low and h
82f0: 69 67 68 20 73 79 6e 63 20 74 69 6d 65 73 20 74 igh sync times t
8300: 72 65 61 74 65 64 20 61 73 20 73 65 70 61 72 61 reated as separa
8310: 74 65 2e 0a 09 20 28 66 6f 72 2d 65 61 63 68 20 te... (for-each
8320: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 64 61 74 .. (lambda (dat
8330: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 62 ).. (let ((tb
8340: 6c 6e 61 6d 65 20 28 63 61 72 20 64 61 74 29 29 lname (car dat))
8350: 0a 09 09 20 20 28 63 6f 75 6e 74 20 20 20 28 63 ... (count (c
8360: 64 72 20 64 61 74 29 29 29 0a 09 20 20 20 20 20 dr dat)))..
8370: 20 28 73 65 74 21 20 74 6f 74 2d 63 6f 75 6e 74 (set! tot-count
8380: 20 28 2b 20 74 6f 74 2d 63 6f 75 6e 74 20 63 6f (+ tot-count co
8390: 75 6e 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 unt)).
83a0: 20 20 20 20 29 29 20 0a 09 20 20 28 73 6f 72 74 )) .. (sort
83b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
83c0: 69 73 74 20 6e 75 6d 72 65 63 73 29 28 6c 61 6d ist numrecs)(lam
83d0: 62 64 61 20 28 61 20 62 29 28 3e 20 28 63 64 72 bda (a b)(> (cdr
83e0: 20 61 29 28 63 64 72 20 62 29 29 29 29 29 29 0a a)(cdr b)))))).
83f0: 20 20 20 20 20 20 20 74 6f 74 2d 63 6f 75 6e 74 tot-count
8400: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
8410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8450: 3b 3b 20 74 72 69 67 67 65 72 20 73 65 74 75 70 ;; trigger setup
8460: 2f 74 61 6b 65 64 6f 77 6e 0a 3b 3b 3d 3d 3d 3d /takedown.;;====
8470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84b0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 64 62 3a 74 ==..(define db:t
84c0: 72 69 67 67 65 72 2d 6c 69 73 74 20 0a 20 20 20 rigger-list .
84d0: 20 20 28 6c 69 73 74 20 28 6c 69 73 74 20 22 75 (list (list "u
84e0: 70 64 61 74 65 5f 72 75 6e 73 5f 74 72 69 67 67 pdate_runs_trigg
84f0: 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 er" "CREATE TRI
8500: 47 47 45 52 20 49 46 20 4e 4f 54 20 45 58 49 53 GGER IF NOT EXIS
8510: 54 53 20 75 70 64 61 74 65 5f 72 75 6e 73 5f 74 TS update_runs_t
8520: 72 69 67 67 65 72 20 41 46 54 45 52 20 55 50 44 rigger AFTER UPD
8530: 41 54 45 20 4f 4e 20 72 75 6e 73 0a 20 20 20 20 ATE ON runs.
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8550: 20 20 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 FOR EAC
8560: 48 20 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 H ROW.
8570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8580: 20 20 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 BEGIN .
8590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 55 50 44 UPD
85b0: 41 54 45 20 72 75 6e 73 20 53 45 54 20 6c 61 73 ATE runs SET las
85c0: 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 t_update=(strfti
85d0: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a me('%s','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 20 20 20 20
8600: 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e WHERE id=old.
8610: 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 id;.
8620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8630: 20 20 20 45 4e 44 3b 22 20 29 20 0a 09 20 20 20 END;" ) ..
8640: 28 6c 69 73 74 20 22 75 70 64 61 74 65 5f 72 75 (list "update_ru
8650: 6e 5f 73 74 61 74 73 5f 74 72 69 67 67 65 72 22 n_stats_trigger"
8660: 20 20 22 43 52 45 41 54 45 20 54 52 49 47 47 45 "CREATE TRIGGE
8670: 52 20 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 R IF NOT EXISTS
8680: 20 75 70 64 61 74 65 5f 72 75 6e 5f 73 74 61 74 update_run_stat
8690: 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 s_trigger AFTER
86a0: 55 50 44 41 54 45 20 4f 4e 20 72 75 6e 5f 73 74 UPDATE ON run_st
86b0: 61 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ats.
86c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86d0: 20 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 FOR EACH ROW.
86e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 42 45 47 BEG
8700: 49 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 IN .
8710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8720: 20 20 20 20 20 55 50 44 41 54 45 20 72 75 6e 5f UPDATE run_
8730: 73 74 61 74 73 20 53 45 54 20 6c 61 73 74 5f 75 stats SET last_u
8740: 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 pdate=(strftime(
8750: 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 '%s','now')).
8760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b WHERE id=old.id;
8790: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
87a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87b0: 45 4e 44 3b 22 20 29 0a 09 20 20 20 28 6c 69 73 END;" ).. (lis
87c0: 74 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 5f t "update_tests_
87d0: 74 72 69 67 67 65 72 22 20 20 22 43 52 45 41 54 trigger" "CREAT
87e0: 45 20 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f E TRIGGER IF NO
87f0: 54 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f T EXISTS update_
8800: 74 65 73 74 73 5f 74 72 69 67 67 65 72 20 41 46 tests_trigger AF
8810: 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 TER UPDATE ON te
8820: 73 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 sts.
8830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8840: 20 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 FOR EACH ROW.
8850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8860: 20 20 20 20 20 20 20 20 20 20 20 20 20 42 45 47 BEG
8870: 49 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 IN .
8880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8890: 20 20 20 20 20 55 50 44 41 54 45 20 74 65 73 74 UPDATE test
88a0: 73 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 s SET last_updat
88b0: 65 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 e=(strftime('%s'
88c0: 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 ,'now')).
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 WHER
88f0: 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 E id=old.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 20 20 20 20 20 20 45 4e 44 3b END;
8920: 22 20 29 0a 09 20 20 20 28 6c 69 73 74 20 22 75 " ).. (list "u
8930: 70 64 61 74 65 5f 74 65 73 74 73 74 65 70 73 5f pdate_teststeps_
8940: 74 72 69 67 67 65 72 22 20 20 22 43 52 45 41 54 trigger" "CREAT
8950: 45 20 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f E TRIGGER IF NO
8960: 54 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f T EXISTS update_
8970: 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 teststeps_trigge
8980: 72 20 41 46 54 45 52 20 55 50 44 41 54 45 20 4f r AFTER UPDATE O
8990: 4e 20 74 65 73 74 5f 73 74 65 70 73 0a 20 20 20 N test_steps.
89a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89b0: 20 20 20 20 20 20 20 20 20 20 46 4f 52 20 45 41 FOR EA
89c0: 43 48 20 52 4f 57 0a 20 20 20 20 20 20 20 20 20 CH ROW.
89d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89e0: 20 20 20 20 20 20 42 45 47 49 4e 20 0a 20 20 20 BEGIN .
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 20 20 20 20 20 20 20 55 50 UP
8a10: 44 41 54 45 20 74 65 73 74 5f 73 74 65 70 73 20 DATE test_steps
8a20: 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d SET last_update=
8a30: 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 (strftime('%s','
8a40: 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 now')).
8a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a60: 20 20 20 20 20 20 20 20 20 20 57 48 45 52 45 20 WHERE
8a70: 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 id=old.id;.
8a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a90: 20 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 20 END;"
8aa0: 29 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 64 ).. (list "upd
8ab0: 61 74 65 5f 74 65 73 74 5f 64 61 74 61 5f 74 72 ate_test_data_tr
8ac0: 69 67 67 65 72 22 20 20 22 43 52 45 41 54 45 20 igger" "CREATE
8ad0: 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 TRIGGER IF NOT
8ae0: 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 EXISTS update_te
8af0: 73 74 5f 64 61 74 61 5f 74 72 69 67 67 65 72 20 st_data_trigger
8b00: 41 46 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 AFTER UPDATE ON
8b10: 74 65 73 74 5f 64 61 74 61 0a 20 20 20 20 20 20 test_data.
8b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b30: 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 FOR EACH
8b40: 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 ROW.
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b60: 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 BEGIN .
8b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b80: 20 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 UPDAT
8b90: 45 20 74 65 73 74 5f 64 61 74 61 20 53 45 54 20 E test_data SET
8ba0: 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 last_update=(str
8bb0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
8bc0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8be0: 20 20 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f WHERE id=o
8bf0: 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 ld.id;.
8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c10: 20 20 20 20 20 20 45 4e 44 3b 22 20 29 29 29 0a END;" ))).
8c20: 3b 3b 0a 3b 3b 20 41 44 44 20 72 75 6e 2d 69 64 ;;.;; ADD run-id
8c30: 20 53 55 50 50 4f 52 54 0a 3b 3b 0a 28 64 65 66 SUPPORT.;;.(def
8c40: 69 6e 65 20 28 64 62 3a 63 72 65 61 74 65 2d 61 ine (db:create-a
8c50: 6c 6c 2d 74 72 69 67 67 65 72 73 20 64 62 73 74 ll-triggers dbst
8c60: 72 75 63 74 29 0a 20 20 28 64 62 3a 77 69 74 68 ruct). (db:with
8c70: 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 -db. dbstruct
8c80: 23 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 #f #f. (lambda
8c90: 20 28 64 62 64 61 74 20 64 62 29 0a 20 20 20 20 (dbdat db).
8ca0: 20 28 64 62 3a 63 72 65 61 74 65 2d 74 72 69 67 (db:create-trig
8cb0: 67 65 72 73 20 64 62 29 29 29 29 0a 0a 28 64 65 gers db))))..(de
8cc0: 66 69 6e 65 20 28 64 62 3a 63 72 65 61 74 65 2d fine (db:create-
8cd0: 74 72 69 67 67 65 72 73 20 64 62 29 0a 20 20 20 triggers db).
8ce0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
8cf0: 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 da (key).
8d00: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
8d10: 65 78 65 63 75 74 65 20 64 62 20 28 63 61 64 72 execute db (cadr
8d20: 20 6b 65 79 29 29 29 0a 20 20 20 20 20 20 20 20 key))).
8d30: 20 20 64 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 db:trigger-lis
8d40: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 t))..(define (db
8d50: 3a 64 72 6f 70 2d 61 6c 6c 2d 74 72 69 67 67 65 :drop-all-trigge
8d60: 72 73 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 rs dbstruct). (
8d70: 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 64 62 db:with-db. db
8d80: 73 74 72 75 63 74 20 23 66 20 23 66 0a 20 20 20 struct #f #f.
8d90: 28 6c 61 6d 62 64 61 20 28 64 62 64 61 74 20 64 (lambda (dbdat d
8da0: 62 29 0a 20 20 20 20 20 28 64 62 3a 64 72 6f 70 b). (db:drop
8db0: 2d 74 72 69 67 67 65 72 73 20 64 62 29 29 29 29 -triggers db))))
8dc0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 69 73 ..(define (db:is
8dd0: 2d 74 72 69 67 67 65 72 2d 64 72 6f 70 70 65 64 -trigger-dropped
8de0: 20 64 62 20 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 db tbl-name).
8df0: 28 6c 65 74 2a 20 28 28 74 72 69 67 67 65 72 2d (let* ((trigger-
8e00: 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f name (if (equal?
8e10: 20 74 62 6c 2d 6e 61 6d 65 20 22 74 65 73 74 5f tbl-name "test_
8e20: 73 74 65 70 73 22 29 0a 09 09 09 20 20 20 22 75 steps").... "u
8e30: 70 64 61 74 65 5f 74 65 73 74 73 74 65 70 73 5f pdate_teststeps_
8e40: 74 72 69 67 67 65 72 22 20 0a 20 20 20 20 20 20 trigger" .
8e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e60: 20 20 20 20 20 28 63 6f 6e 63 20 22 75 70 64 61 (conc "upda
8e70: 74 65 5f 22 20 74 62 6c 2d 6e 61 6d 65 20 22 5f te_" tbl-name "_
8e80: 74 72 69 67 67 65 72 22 29 29 29 0a 09 20 28 72 trigger"))).. (r
8e90: 65 73 20 20 20 20 20 20 20 20 20 20 23 66 29 29 es #f))
8ea0: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
8eb0: 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 r-each-row.
8ec0: 28 6c 61 6d 62 64 61 20 28 6e 61 6d 65 29 0a 20 (lambda (name).
8ed0: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
8ee0: 3f 20 6e 61 6d 65 20 74 72 69 67 67 65 72 2d 6e ? name trigger-n
8ef0: 61 6d 65 29 0a 09 20 20 20 28 73 65 74 21 20 72 ame).. (set! r
8f00: 65 73 20 23 74 29 29 29 0a 20 20 20 20 20 64 62 es #t))). db
8f10: 20 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 6e . "SELECT n
8f20: 61 6d 65 20 46 52 4f 4d 20 73 71 6c 69 74 65 5f ame FROM sqlite_
8f30: 6d 61 73 74 65 72 20 57 48 45 52 45 20 74 79 70 master WHERE typ
8f40: 65 20 3d 20 27 74 72 69 67 67 65 72 27 20 3b 22 e = 'trigger' ;"
8f50: 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 ). res))..(de
8f60: 66 69 6e 65 20 28 64 62 3a 64 72 6f 70 2d 74 72 fine (db:drop-tr
8f70: 69 67 67 65 72 73 20 64 62 29 0a 20 20 28 66 6f iggers db). (fo
8f80: 72 2d 65 61 63 68 0a 20 20 20 28 6c 61 6d 62 64 r-each. (lambd
8f90: 61 20 28 6b 65 79 29 20 0a 20 20 20 20 20 28 73 a (key) . (s
8fa0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
8fb0: 62 20 28 63 6f 6e 63 20 22 64 72 6f 70 20 74 72 b (conc "drop tr
8fc0: 69 67 67 65 72 20 69 66 20 65 78 69 73 74 73 20 igger if exists
8fd0: 22 20 28 63 61 72 20 6b 65 79 29 29 29 29 0a 20 " (car key)))).
8fe0: 20 20 64 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 db:trigger-lis
8ff0: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 20 28 64 t))..(define (d
9000: 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 72 20 64 b:drop-trigger d
9010: 62 20 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c b tbl-name). (l
9020: 65 74 2a 20 28 28 74 72 69 67 67 65 72 2d 6e 61 et* ((trigger-na
9030: 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 me (if (equal? t
9040: 62 6c 2d 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 bl-name "test_st
9050: 65 70 73 22 29 0a 09 09 09 20 20 20 22 75 70 64 eps").... "upd
9060: 61 74 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 ate_teststeps_tr
9070: 69 67 67 65 72 22 20 0a 20 20 20 20 20 20 20 20 igger" .
9080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9090: 20 20 20 28 63 6f 6e 63 20 22 75 70 64 61 74 65 (conc "update
90a0: 5f 22 20 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 _" tbl-name "_tr
90b0: 69 67 67 65 72 22 29 29 29 29 0a 20 20 20 20 28 igger")))). (
90c0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
90d0: 61 6d 62 64 61 20 28 6b 65 79 29 20 0a 20 20 20 ambda (key) .
90e0: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
90f0: 28 63 61 72 20 6b 65 79 29 20 74 72 69 67 67 65 (car key) trigge
9100: 72 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 r-name).
9110: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
9120: 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 64 72 ute db (conc "dr
9130: 6f 70 20 74 72 69 67 67 65 72 20 69 66 20 65 78 op trigger if ex
9140: 69 73 74 73 20 22 20 74 72 69 67 67 65 72 2d 6e ists " trigger-n
9150: 61 6d 65 29 29 29 29 0a 20 20 20 20 20 64 62 3a ame)))). db:
9160: 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 29 0a trigger-list))).
9170: 0a 28 64 65 66 69 6e 65 20 20 28 64 62 3a 63 72 .(define (db:cr
9180: 65 61 74 65 2d 74 72 69 67 67 65 72 20 64 62 20 eate-trigger db
9190: 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 tbl-name).
91a0: 28 6c 65 74 2a 20 28 28 74 72 69 67 67 65 72 2d (let* ((trigger-
91b0: 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f name (if (equal?
91c0: 20 74 62 6c 2d 6e 61 6d 65 20 22 74 65 73 74 5f tbl-name "test_
91d0: 73 74 65 70 73 22 29 0a 20 20 20 20 20 20 20 20 steps").
91e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91f0: 20 20 20 20 20 20 22 75 70 64 61 74 65 5f 74 65 "update_te
9200: 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 72 22 ststeps_trigger"
9210: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9230: 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 (conc "update_"
9240: 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 tbl-name "_trigg
9250: 65 72 22 29 29 29 29 0a 20 20 20 20 20 20 20 28 er")))). (
9260: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
9270: 20 28 6b 65 79 29 20 0a 20 20 20 20 20 20 20 20 (key) .
9280: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
9290: 20 28 63 61 72 20 6b 65 79 29 20 74 72 69 67 67 (car key) trigg
92a0: 65 72 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 er-name).
92b0: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 (sqlite3:e
92c0: 78 65 63 75 74 65 20 64 62 20 28 63 61 64 72 20 xecute db (cadr
92d0: 6b 65 79 29 29 29 29 0a 20 20 20 20 20 20 64 62 key)))). db
92e0: 3a 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 29 :trigger-list)))
92f0: 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;===========
9300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 64 ===========.;; d
9340: 62 20 61 63 63 65 73 73 20 73 74 75 66 66 0a 3b b access stuff.;
9350: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
9360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9390: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 61 6c 6c =======..;; call
93a0: 20 77 69 74 68 20 64 62 69 6e 69 74 3d 64 62 3a with dbinit=db:
93b0: 69 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 69 6e 2d initialize-main-
93c0: 64 62 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 db.;;.(define (d
93d0: 62 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 72 75 b:open-db dbstru
93e0: 63 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 ct run-id dbinit
93f0: 29 0a 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f ). ;; (mutex-lo
9400: 63 6b 21 20 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 ck! *db-open-mut
9410: 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ex*). (let* ((d
9420: 62 64 61 74 20 28 64 62 66 69 6c 65 3a 6f 70 65 bdat (dbfile:ope
9430: 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 n-db dbstruct ru
9440: 6e 2d 69 64 20 64 62 69 6e 69 74 29 29 29 0a 20 n-id dbinit))).
9450: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 77 72 69 (set! *db-wri
9460: 74 65 2d 61 63 63 65 73 73 2a 20 28 6e 6f 74 20 te-access* (not
9470: 28 64 62 72 3a 64 62 64 61 74 2d 72 65 61 64 2d (dbr:dbdat-read-
9480: 6f 6e 6c 79 20 64 62 64 61 74 29 29 29 0a 20 20 only dbdat))).
9490: 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f ;; (mutex-unlo
94a0: 63 6b 21 20 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 ck! *db-open-mut
94b0: 65 78 2a 29 0a 20 20 20 20 64 62 64 61 74 29 29 ex*). dbdat))
94c0: 0a 0a 28 64 65 66 69 6e 65 20 64 62 66 69 6c 65 ..(define dbfile
94d0: 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 20 28 6d :db-init-proc (m
94e0: 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 23 66 ake-parameter #f
94f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6b 65 65 70 ))..(define keep
9500: 2d 61 67 65 2d 70 61 72 61 6d 20 28 6d 61 6b 65 -age-param (make
9510: 2d 70 61 72 61 6d 65 74 65 72 20 31 30 29 29 0a -parameter 10)).
9520: 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 64 72 6f .;; create a dro
9530: 70 70 69 6e 67 20 6e 65 61 72 20 74 68 65 20 64 pping near the d
9540: 62 20 66 69 6c 65 20 69 6e 20 61 20 71 69 66 20 b file in a qif
9550: 64 69 72 0a 3b 3b 20 75 73 65 20 63 6f 75 6e 74 dir.;; use count
9560: 20 6f 66 20 73 75 63 68 20 66 69 6c 65 73 20 74 of such files t
9570: 6f 20 67 61 74 65 20 71 75 65 72 69 65 73 20 28 o gate queries (
9580: 71 75 65 72 69 65 73 20 69 6e 20 66 6c 69 67 68 queries in fligh
9590: 74 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 t).;;.(define (d
95a0: 62 66 69 6c 65 3a 77 61 69 74 2d 66 6f 72 2d 71 bfile:wait-for-q
95b0: 69 66 20 66 6e 61 6d 65 20 72 75 6e 2d 69 64 20 if fname run-id
95c0: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
95d0: 28 28 74 68 65 64 69 72 20 20 28 70 61 74 68 6e ((thedir (pathn
95e0: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 66 6e ame-directory fn
95f0: 61 6d 65 29 29 0a 09 20 28 64 65 73 74 64 69 72 ame)).. (destdir
9600: 20 28 63 6f 6e 63 20 74 68 65 64 69 72 22 2f 71 (conc thedir"/q
9610: 69 66 22 29 29 0a 09 20 28 75 6e 69 71 6e 20 20 if")).. (uniqn
9620: 20 28 67 65 74 2d 61 72 65 61 2d 70 61 74 68 2d (get-area-path-
9630: 73 69 67 6e 61 74 75 72 65 20 28 63 6f 6e 63 20 signature (conc
9640: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 29 run-id params)))
9650: 0a 09 20 28 63 72 75 6d 62 6e 20 20 28 63 6f 6e .. (crumbn (con
9660: 63 20 64 65 73 74 64 69 72 22 2f 22 28 63 75 72 c destdir"/"(cur
9670: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 22 2d 22 rent-seconds)"-"
9680: 75 6e 69 71 6e 22 2e 22 28 63 75 72 72 65 6e 74 uniqn"."(current
9690: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a -process-id)))).
96a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
96b0: 6c 65 2d 65 78 69 73 74 73 3f 20 64 65 73 74 64 le-exists? destd
96c0: 69 72 29 29 28 63 72 65 61 74 65 2d 64 69 72 65 ir))(create-dire
96d0: 63 74 6f 72 79 20 28 63 6f 6e 63 20 64 65 73 74 ctory (conc dest
96e0: 64 69 72 22 2f 61 74 74 69 63 22 29 20 23 74 29 dir"/attic") #t)
96f0: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
9700: 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 ((count 0)).
9710: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 6c 6b (let* ((currlk
9720: 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 64 65 s (glob (conc de
9730: 73 74 64 69 72 22 2f 2a 22 29 29 29 0a 09 20 20 stdir"/*")))..
9740: 20 20 20 28 6e 75 6d 71 72 79 73 20 28 6c 65 6e (numqrys (len
9750: 67 74 68 20 63 75 72 72 6c 6b 73 29 29 0a 09 20 gth currlks))..
9760: 20 20 20 20 28 64 65 6c 61 79 76 61 6c 20 28 63 (delayval (c
9770: 6f 6e 64 20 3b 3b 20 64 6f 20 61 20 64 72 6f 6f ond ;; do a droo
9780: 70 69 73 68 20 63 75 72 76 65 0a 09 09 09 28 28 pish curve....((
9790: 3e 20 6e 75 6d 71 72 79 73 20 35 30 29 0a 09 09 > numqrys 50)...
97a0: 09 20 28 69 66 20 28 3e 20 6e 75 6d 71 72 79 73 . (if (> numqrys
97b0: 20 35 30 29 0a 09 09 09 20 20 20 20 20 28 66 6f 50).... (fo
97c0: 72 2d 65 61 63 68 0a 09 09 09 20 20 20 20 20 20 r-each....
97d0: 28 6c 61 6d 62 64 61 20 28 66 29 0a 09 09 09 09 (lambda (f).....
97e0: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
97f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 09 nt-seconds).....
9800: 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
9810: 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 20 20 tions......
9820: 20 65 78 6e 0a 09 09 09 09 09 20 20 20 20 28 63 exn...... (c
9830: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
9840: 3b 3b 20 66 69 6c 65 20 69 73 20 6c 69 6b 65 6c ;; file is likel
9850: 79 20 67 6f 6e 65 2c 20 6a 75 73 74 20 66 61 6b y gone, just fak
9860: 65 20 6f 75 74 0a 09 09 09 09 09 20 20 20 20 28 e out...... (
9870: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
9880: 6e 2d 74 69 6d 65 20 66 29 29 29 0a 09 09 09 09 n-time f))).....
9890: 20 20 20 20 20 20 20 28 6b 65 65 70 2d 61 67 65 (keep-age
98a0: 2d 70 61 72 61 6d 29 29 0a 09 09 09 09 20 20 20 -param)).....
98b0: 20 28 6c 65 74 2a 20 28 28 62 61 73 65 64 69 72 (let* ((basedir
98c0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
98d0: 74 6f 72 79 20 66 29 29 0a 09 09 09 09 09 20 20 tory f))......
98e0: 20 28 66 69 6c 65 6e 20 20 20 28 70 61 74 68 6e (filen (pathn
98f0: 61 6d 65 2d 66 69 6c 65 20 66 29 29 0a 09 09 09 ame-file f))....
9900: 09 09 20 20 20 28 64 65 73 74 66 20 20 20 28 63 .. (destf (c
9910: 6f 6e 63 20 62 61 73 65 64 69 72 22 2f 61 74 74 onc basedir"/att
9920: 69 63 2f 22 66 69 6c 65 6e 29 29 29 0a 09 09 09 ic/"filen)))....
9930: 09 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 . (dbfile:p
9940: 72 69 6e 74 2d 65 72 72 20 22 4d 6f 76 69 6e 67 rint-err "Moving
9950: 20 71 69 66 20 66 69 6c 65 20 22 66 22 20 6f 6c qif file "f" ol
9960: 64 65 72 20 74 68 61 6e 20 31 30 20 73 65 63 6f der than 10 seco
9970: 6e 64 73 20 74 6f 20 22 64 65 73 74 66 29 0a 09 nds to "destf)..
9980: 09 09 09 20 20 20 20 20 20 3b 3b 20 28 64 65 6c ... ;; (del
9990: 65 74 65 2d 66 69 6c 65 2a 20 66 29 0a 09 09 09 ete-file* f)....
99a0: 09 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 76 . (file-mov
99b0: 65 20 66 20 64 65 73 74 66 20 23 74 29 29 29 29 e f destf #t))))
99c0: 0a 09 09 09 20 20 20 20 20 20 63 75 72 72 6c 6b .... currlk
99d0: 73 29 29 0a 09 09 09 20 31 29 0a 09 09 09 28 28 s)).... 1)....((
99e0: 3e 20 6e 75 6d 71 72 79 73 20 33 30 29 20 30 2e > numqrys 30) 0.
99f0: 35 30 29 0a 09 09 09 28 28 3e 20 6e 75 6d 71 72 50)....((> numqr
9a00: 79 73 20 32 35 29 20 30 2e 32 30 29 0a 09 09 09 ys 25) 0.20)....
9a10: 28 28 3e 20 6e 75 6d 71 72 79 73 20 32 30 29 20 ((> numqrys 20)
9a20: 30 2e 31 30 29 0a 09 09 09 28 28 3e 20 6e 75 6d 0.10)....((> num
9a30: 71 72 79 73 20 31 35 29 20 30 2e 30 35 29 0a 09 qrys 15) 0.05)..
9a40: 09 09 28 28 3e 20 6e 75 6d 71 72 79 73 20 31 30 ..((> numqrys 10
9a50: 29 20 30 2e 30 31 29 0a 09 09 09 28 65 6c 73 65 ) 0.01)....(else
9a60: 20 23 66 29 29 29 29 0a 09 28 69 66 20 28 61 6e #f))))..(if (an
9a70: 64 20 64 65 6c 61 79 76 61 6c 0a 09 09 20 28 3c d delayval... (<
9a80: 20 63 6f 75 6e 74 20 35 29 29 0a 09 20 20 20 20 count 5))..
9a90: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 (begin.. (t
9aa0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 64 65 6c hread-sleep! del
9ab0: 61 79 76 61 6c 29 0a 09 20 20 20 20 20 20 28 6c ayval).. (l
9ac0: 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 oop (+ count 1))
9ad0: 29 29 29 29 0a 20 20 20 20 28 77 69 74 68 2d 6f )))). (with-o
9ae0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 63 72 utput-to-file cr
9af0: 75 6d 62 6e 0a 20 20 20 20 20 20 28 6c 61 6d 62 umbn. (lamb
9b00: 64 61 20 28 29 0a 09 28 70 72 69 6e 74 20 66 6e da ()..(print fn
9b10: 61 6d 65 22 20 22 72 75 6e 2d 69 64 22 20 22 70 ame" "run-id" "p
9b20: 61 72 61 6d 73 29 0a 09 29 29 0a 20 20 20 20 63 arams)..)). c
9b30: 72 75 6d 62 6e 29 29 0a 20 20 0a 3b 3b 20 28 64 rumbn)). .;; (d
9b40: 62 3a 77 69 74 68 2d 64 62 20 64 62 73 74 72 75 b:with-db dbstru
9b50: 63 74 20 72 75 6e 2d 69 64 20 73 71 6c 69 74 65 ct run-id sqlite
9b60: 33 3a 65 78 65 63 20 22 73 65 6c 65 63 74 20 62 3:exec "select b
9b70: 6c 61 68 20 66 67 72 6f 6d 20 62 6c 61 7a 3b 22 lah fgrom blaz;"
9b80: 29 0a 3b 3b 20 72 2f 77 20 69 73 20 61 20 66 6c ).;; r/w is a fl
9b90: 61 67 20 74 6f 20 69 6e 64 69 63 61 74 65 20 69 ag to indicate i
9ba0: 66 20 74 68 65 20 64 62 20 69 73 20 6d 6f 64 69 f the db is modi
9bb0: 66 69 65 64 20 62 79 20 74 68 69 73 20 71 75 65 fied by this que
9bc0: 72 79 20 23 74 20 3d 20 79 65 73 2c 20 23 66 20 ry #t = yes, #f
9bd0: 3d 20 6e 6f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 = no.;;.(define
9be0: 28 64 62 3a 77 69 74 68 2d 64 62 20 64 62 73 74 (db:with-db dbst
9bf0: 72 75 63 74 20 72 75 6e 2d 69 64 20 72 2f 77 20 ruct run-id r/w
9c00: 70 72 6f 63 20 2e 20 70 61 72 61 6d 73 29 0a 20 proc . params).
9c10: 20 28 61 73 73 65 72 74 20 64 62 73 74 72 75 63 (assert dbstruc
9c20: 74 20 22 46 41 54 41 4c 3a 20 64 62 3a 77 69 74 t "FATAL: db:wit
9c30: 68 2d 64 62 20 63 61 6c 6c 65 64 20 77 69 74 68 h-db called with
9c40: 20 64 62 73 74 72 75 63 74 20 22 23 66 29 0a 20 dbstruct "#f).
9c50: 20 28 61 73 73 65 72 74 20 28 64 62 72 3a 64 62 (assert (dbr:db
9c60: 73 74 72 75 63 74 3f 20 64 62 73 74 72 75 63 74 struct? dbstruct
9c70: 29 20 22 46 41 54 41 4c 3a 20 64 62 73 74 72 75 ) "FATAL: dbstru
9c80: 63 74 20 69 73 20 22 64 62 73 74 72 75 63 74 29 ct is "dbstruct)
9c90: 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 65 2d 6d . (let* ((use-m
9ca0: 75 74 65 78 20 28 3e 20 2a 61 70 69 2d 70 72 6f utex (> *api-pro
9cb0: 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 cess-request-cou
9cc0: 6e 74 2a 20 32 35 29 29 20 3b 3b 20 72 69 73 6b nt* 25)) ;; risk
9cd0: 20 6f 66 20 64 62 20 63 6f 72 72 75 70 74 69 6f of db corruptio
9ce0: 6e 0a 09 20 28 68 61 76 65 2d 73 74 72 75 63 74 n.. (have-struct
9cf0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 3f 20 (dbr:dbstruct?
9d00: 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 20 dbstruct)).
9d10: 20 20 20 20 28 64 62 64 61 74 20 20 20 20 20 28 (dbdat (
9d20: 69 66 20 68 61 76 65 2d 73 74 72 75 63 74 20 20 if have-struct
9d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
9d40: 20 74 68 69 73 20 73 74 75 66 66 20 6a 75 73 74 this stuff just
9d50: 20 61 6c 6c 6f 77 73 20 75 73 20 74 6f 20 63 61 allows us to ca
9d60: 6c 6c 20 77 69 74 68 20 61 20 64 62 20 68 61 6e ll with a db han
9d70: 64 6c 65 20 64 69 72 65 63 74 6c 79 0a 09 09 09 dle directly....
9d80: 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 (db:open-db dbst
9d90: 72 75 63 74 20 72 75 6e 2d 69 64 20 28 64 62 66 ruct run-id (dbf
9da0: 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 ile:db-init-proc
9db0: 29 29 20 3b 3b 20 28 64 62 66 69 6c 65 3a 67 65 )) ;; (dbfile:ge
9dc0: 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 t-subdb dbstruct
9dd0: 20 72 75 6e 2d 69 64 29 0a 09 09 09 23 66 29 29 run-id)....#f))
9de0: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 28 69 .. (db (i
9df0: 66 20 68 61 76 65 2d 73 74 72 75 63 74 20 20 20 f have-struct
9e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
9e10: 74 68 69 73 20 73 74 75 66 66 20 6a 75 73 74 20 this stuff just
9e20: 61 6c 6c 6f 77 73 20 75 73 20 74 6f 20 63 61 6c allows us to cal
9e30: 6c 20 77 69 74 68 20 61 20 64 62 20 68 61 6e 64 l with a db hand
9e40: 6c 65 20 64 69 72 65 63 74 6c 79 0a 09 09 09 28 le directly....(
9e50: 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 64 62 dbr:dbdat-dbh db
9e60: 64 61 74 29 0a 09 09 09 64 62 73 74 72 75 63 74 dat)....dbstruct
9e70: 29 29 0a 09 20 28 66 6e 61 6d 65 20 20 20 20 20 )).. (fname
9e80: 28 69 66 20 64 62 64 61 74 0a 09 09 09 28 64 62 (if dbdat....(db
9e90: 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 64 r:dbdat-dbfile d
9ea0: 62 64 61 74 29 0a 09 09 09 22 6e 6f 66 69 6c 65 bdat)...."nofile
9eb0: 6e 61 6d 65 61 76 61 69 6c 61 62 6c 65 22 29 29 nameavailable"))
9ec0: 0a 09 20 28 6a 66 69 6c 65 20 20 20 20 20 28 63 .. (jfile (c
9ed0: 6f 6e 63 20 66 6e 61 6d 65 22 2d 6a 6f 75 72 6e onc fname"-journ
9ee0: 61 6c 22 29 29 29 0a 09 20 3b 3b 20 28 63 72 75 al"))).. ;; (cru
9ef0: 6d 62 66 69 6c 65 20 28 64 62 66 69 6c 65 3a 77 mbfile (dbfile:w
9f00: 61 69 74 2d 66 6f 72 2d 71 69 66 20 66 6e 61 6d ait-for-qif fnam
9f10: 65 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 e run-id params)
9f20: 29 29 0a 20 20 20 20 28 61 73 73 65 72 74 20 28 )). (assert (
9f30: 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 sqlite3:database
9f40: 3f 20 64 62 29 20 22 46 41 54 41 4c 3a 20 64 62 ? db) "FATAL: db
9f50: 3a 77 69 74 68 2d 64 62 2c 20 64 62 20 69 73 20 :with-db, db is
9f60: 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 2c 20 not a database,
9f70: 64 62 3d 22 64 62 22 2c 20 66 6e 61 6d 65 3d 22 db="db", fname="
9f80: 66 6e 61 6d 65 29 0a 20 20 20 20 28 69 66 20 28 fname). (if (
9f90: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6a 66 69 file-exists? jfi
9fa0: 6c 65 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 le)..(begin.. (
9fb0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
9fc0: 20 22 49 4e 46 4f 3a 20 22 6a 66 69 6c 65 22 20 "INFO: "jfile"
9fd0: 65 78 69 73 74 73 2c 20 64 65 6c 61 79 69 6e 67 exists, delaying
9fe0: 20 74 6f 20 72 65 64 75 63 65 20 64 61 74 61 62 to reduce datab
9ff0: 61 73 65 20 6c 6f 61 64 22 29 0a 09 20 20 28 74 ase load").. (t
a000: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
a010: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
a020: 20 75 73 65 2d 6d 75 74 65 78 0a 09 20 20 20 20 use-mutex..
a030: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
a040: 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 6f 76 se-print 120 "ov
a050: 65 72 2d 35 30 2d 70 61 72 61 6c 6c 65 6c 2d 61 er-50-parallel-a
a060: 70 69 2d 72 65 71 75 65 73 74 73 22 29 29 0a 09 pi-requests"))..
a070: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
a080: 72 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 r *api-process-r
a090: 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 22 20 equest-count* "
a0a0: 70 61 72 61 6c 6c 65 6c 20 61 70 69 20 72 65 71 parallel api req
a0b0: 75 65 73 74 73 20 62 65 69 6e 67 20 70 72 6f 63 uests being proc
a0c0: 65 73 73 65 64 20 69 6e 20 70 72 6f 63 65 73 73 essed in process
a0d0: 20 22 0a 09 09 09 20 20 28 63 75 72 72 65 6e 74 ".... (current
a0e0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 20 3b -process-id))) ;
a0f0: 3b 20 20 22 2c 20 74 68 72 6f 74 74 6c 69 6e 67 ; ", throttling
a100: 20 61 63 63 65 73 73 22 29 29 0a 20 20 20 20 28 access")). (
a110: 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 condition-case..
a120: 28 62 65 67 69 6e 0a 09 20 20 28 69 66 20 75 73 (begin.. (if us
a130: 65 2d 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 6c e-mutex (mutex-l
a140: 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 62 ock! *db-with-db
a150: 2d 6d 75 74 65 78 2a 29 29 0a 09 20 20 28 6c 65 -mutex*)).. (le
a160: 74 20 28 28 72 65 73 20 28 61 70 70 6c 79 20 70 t ((res (apply p
a170: 72 6f 63 20 64 62 64 61 74 20 64 62 20 70 61 72 roc dbdat db par
a180: 61 6d 73 29 29 29 20 3b 3b 20 74 68 65 20 61 63 ams))) ;; the ac
a190: 74 75 61 6c 20 63 61 6c 6c 20 69 73 20 68 65 72 tual call is her
a1a0: 65 2e 0a 09 20 20 20 20 28 69 66 20 75 73 65 2d e... (if use-
a1b0: 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 75 6e 6c mutex (mutex-unl
a1c0: 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 62 ock! *db-with-db
a1d0: 2d 6d 75 74 65 78 2a 29 29 0a 09 20 20 20 20 3b -mutex*)).. ;
a1e0: 3b 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 64 ; (if (vector? d
a1f0: 62 73 74 72 75 63 74 29 28 64 62 3a 64 6f 6e 65 bstruct)(db:done
a200: 2d 77 69 74 68 20 64 62 73 74 72 75 63 74 20 72 -with dbstruct r
a210: 75 6e 2d 69 64 20 72 2f 77 29 29 0a 09 20 20 20 un-id r/w))..
a220: 20 28 69 66 20 64 62 64 61 74 0a 09 09 28 64 62 (if dbdat...(db
a230: 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 file:add-dbdat d
a240: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 bstruct run-id d
a250: 62 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 28 bdat)).. ;; (
a260: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 63 72 75 delete-file* cru
a270: 6d 62 66 69 6c 65 29 0a 09 20 20 20 20 72 65 73 mbfile).. res
a280: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 69 )). (exn (i
a290: 6f 2d 65 72 72 6f 72 29 0a 09 20 20 20 28 64 62 o-error).. (db
a2a0: 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 :generic-error-p
a2b0: 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 rintout exn "ERR
a2c0: 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 OR: i/o error wi
a2d0: 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 th " fname ". Ch
a2e0: 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c eck permissions,
a2f0: 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e disk space etc.
a300: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 and try again."
a310: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 63 )). (exn (c
a320: 6f 72 72 75 70 74 29 0a 09 20 20 20 28 64 62 3a orrupt).. (db:
a330: 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 generic-error-pr
a340: 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f intout exn "ERRO
a350: 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e R: database " fn
a360: 61 6d 65 20 22 20 69 73 20 63 6f 72 72 75 70 74 ame " is corrupt
a370: 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 70 . Repair it to p
a380: 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 20 20 20 roceed.")).
a390: 20 28 65 78 6e 20 28 62 75 73 79 29 0a 09 20 20 (exn (busy)..
a3a0: 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 (db:generic-err
a3b0: 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 or-printout exn
a3c0: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
a3d0: 20 22 20 66 6e 61 6d 65 0a 09 09 09 09 20 20 20 " fname.....
a3e0: 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 " is locked.
a3f0: 54 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 Try copying to a
a400: 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c nother location,
a410: 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c remove original
a420: 20 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 and copy back."
a430: 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 28 70 )). (exn (p
a440: 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 3a 67 65 ermission)(db:ge
a450: 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e neric-error-prin
a460: 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a tout exn "ERROR:
a470: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
a480: 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 e " has some per
a490: 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d missions problem
a4a0: 2e 22 29 29 0a 20 20 20 20 20 20 28 65 78 6e 20 .")). (exn
a4b0: 28 29 0a 09 20 20 20 28 64 62 3a 67 65 6e 65 72 ().. (db:gener
a4c0: 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 ic-error-printou
a4d0: 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e t exn "ERROR: Un
a4e0: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 known error with
a4f0: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
a500: 65 20 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 e " message: "..
a510: 09 09 09 20 20 20 20 20 20 28 28 63 6f 6e 64 69 ... ((condi
a520: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
a530: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
a540: 73 61 67 65 29 20 65 78 6e 29 29 29 29 29 29 0a sage) exn)))))).
a550: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 61 6e 6f =========.;; ano
a5a0: 74 68 65 72 20 61 74 74 65 6d 70 74 20 61 74 20 ther attempt at
a5b0: 61 20 74 72 61 6e 73 61 63 74 69 6f 6e 69 7a 65 a transactionize
a5c0: 64 20 71 75 65 75 65 0a 3b 3b 3d 3d 3d 3d 3d 3d d queue.;;======
a5d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a610: 0a 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 ..;; ;; ;; (defi
a620: 6e 65 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d ne *transaction-
a630: 71 75 65 75 65 73 2a 20 28 6d 61 6b 65 2d 68 61 queues* (make-ha
a640: 73 68 2d 74 61 62 6c 65 29 29 0a 3b 3b 20 3b 3b sh-table)).;; ;;
a650: 20 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 ;; .;; ;; ;; (d
a660: 65 66 69 6e 65 20 28 64 62 3a 67 65 74 2d 71 75 efine (db:get-qu
a670: 65 75 65 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 3b eue run-id).;; ;
a680: 3b 20 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 72 ; ;; (let* ((r
a690: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 es (hash-table-r
a6a0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 72 61 6e ef/default *tran
a6b0: 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 73 2a 20 saction-queues*
a6c0: 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 3b 3b 20 run-id #f))).;;
a6d0: 3b 3b 20 3b 3b 20 20 20 20 20 28 69 66 20 72 65 ;; ;; (if re
a6e0: 73 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 72 65 73 0a s.;; ;; ;; .res.
a6f0: 3b 3b 20 3b 3b 20 3b 3b 20 09 28 6c 65 74 2a 20 ;; ;; ;; .(let*
a700: 28 28 6e 65 77 71 20 28 6d 61 6b 65 2d 71 75 65 ((newq (make-que
a710: 75 65 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 ue))).;; ;; ;; .
a720: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
a730: 74 21 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d t! *transaction-
a740: 71 75 65 75 65 73 2a 20 72 75 6e 2d 69 64 20 6e queues* run-id n
a750: 65 77 71 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 ewq).;; ;; ;; .
a760: 20 6e 65 77 71 29 29 29 29 0a 3b 3b 20 3b 3b 20 newq)))).;; ;;
a770: 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 ;; .;; ;; ;; (de
a780: 66 69 6e 65 20 28 64 62 3a 61 64 64 2d 74 6f 2d fine (db:add-to-
a790: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 transaction-queu
a7a0: 65 20 64 62 73 74 72 75 63 74 20 70 72 6f 63 20 e dbstruct proc
a7b0: 70 61 72 61 6d 73 29 0a 3b 3b 20 3b 3b 20 3b 3b params).;; ;; ;;
a7c0: 20 20 20 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 (let* ((mbox
a7d0: 28 6d 61 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a (make-mailbox)).
a7e0: 3b 3b 20 3b 3b 20 3b 3b 20 09 20 28 71 20 20 20 ;; ;; ;; . (q
a7f0: 20 28 64 62 3a 67 65 74 2d 71 75 65 75 65 20 72 (db:get-queue r
a800: 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b un-id))).;; ;; ;
a810: 3b 20 20 20 20 20 28 71 75 65 75 65 2d 61 64 64 ; (queue-add
a820: 21 20 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 ! *transaction-q
a830: 75 65 75 65 2a 20 28 6c 69 73 74 20 64 62 73 74 ueue* (list dbst
a840: 72 75 63 74 20 70 72 6f 63 20 6d 62 6f 78 29 29 ruct proc mbox))
a850: 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 28 6d .;; ;; ;; (m
a860: 61 69 6c 62 6f 78 2d 72 65 63 65 69 76 65 20 6d ailbox-receive m
a870: 62 6f 78 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 box))).;; ;; ;;
a880: 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e .;; ;; ;; (defin
a890: 65 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 74 72 e (db:process-tr
a8a0: 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 20 ansaction-queue
a8b0: 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a 29 0a *dbstruct-dbs*).
a8c0: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 28 66 6f 72 2d ;; ;; ;; (for-
a8d0: 65 61 63 68 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 each.;; ;; ;;
a8e0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 (lambda (run-id
a8f0: 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 ).;; ;; ;;
a900: 28 6c 65 74 2a 20 28 28 71 20 28 68 61 73 68 2d (let* ((q (hash-
a910: 74 61 62 6c 65 2d 72 65 66 20 2a 74 72 61 6e 73 table-ref *trans
a920: 61 63 74 69 6f 6e 2d 71 75 65 75 65 2a 20 72 75 action-queue* ru
a930: 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b n-id))).;; ;; ;;
a940: 20 20 20 20 20 20 20 20 3b 3b 20 77 69 74 68 2d ;; with-
a950: 74 72 61 6e 73 61 63 74 69 6f 6e 0a 3b 3b 20 3b transaction.;; ;
a960: 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b 20 20 ; ;; ;;
a970: 20 20 20 64 62 73 74 72 75 63 74 0a 3b 3b 20 3b dbstruct.;; ;
a980: 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b 20 70 ; ;; ;; p
a990: 6f 70 20 69 74 65 6d 73 20 66 72 6f 6d 20 71 75 op items from qu
a9a0: 65 75 65 20 61 6e 64 20 65 78 65 63 75 74 65 20 eue and execute
a9b0: 74 68 65 6d 2c 20 72 65 74 75 72 6e 20 72 65 73 them, return res
a9c0: 75 6c 74 73 20 76 69 61 20 6d 61 69 6c 62 6f 78 ults via mailbox
a9d0: 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 .;; ;; ;;
a9e0: 20 71 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 q.;; ;; ;;
a9f0: 20 20 20 3b 3b 20 70 6f 70 20 0a 3b 3b 20 3b 3b ;; pop .;; ;;
aa00: 20 3b 3b 20 20 20 20 20 20 20 20 29 29 0a 3b 3b ;; )).;;
aa10: 20 3b 3b 20 3b 3b 20 20 20 20 28 68 61 73 68 2d ;; ;; (hash-
aa20: 74 61 62 6c 65 2d 6b 65 79 73 20 2a 74 72 61 6e table-keys *tran
aa30: 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 73 2a 29 saction-queues*)
aa40: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
aa50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
aa90: 66 69 6c 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d file utils.;;===
aaa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aae0: 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ===..;;=========
aaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
ab30: 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 20 66 lazy-safe get f
ab40: 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 6f 6e ile mod time. on
ab50: 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 6c 65 any error (file
ab60: 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 65 74 not existing et
ab70: 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b 3b 0a c.) return 0.;;.
ab80: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
ab90: 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f lazy-modificatio
aba0: 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 n-time fpath).
abb0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
abc0: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
abd0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 64 (begin. (d
abe0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
abf0: 22 46 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6d "Failed to get m
ac00: 6f 64 69 66 69 63 61 74 69 6f 6e 20 74 69 6d 65 odification time
ac10: 20 66 6f 72 20 22 20 66 70 61 74 68 20 22 2c 20 for " fpath ",
ac20: 74 72 65 61 74 69 6e 67 20 69 74 20 61 73 20 7a treating it as z
ac30: 65 72 6f 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a ero. exn=" exn).
ac40: 20 20 20 20 20 20 30 29 0a 20 20 20 20 28 69 66 0). (if
ac50: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
ac60: 70 61 74 68 29 0a 09 28 66 69 6c 65 2d 6d 6f 64 path)..(file-mod
ac70: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
ac80: 70 61 74 68 29 0a 09 30 29 29 29 0a 0a 3b 3b 3d path)..0)))..;;=
ac90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acd0: 3d 3d 3d 3d 3d 0a 3b 3b 20 66 69 6e 64 20 74 69 =====.;; find ti
ace0: 6d 65 73 74 61 6d 70 20 6f 66 20 6e 65 77 65 73 mestamp of newes
acf0: 74 20 66 69 6c 65 20 61 73 73 6f 63 69 61 74 65 t file associate
ad00: 64 20 77 69 74 68 20 61 20 73 71 6c 69 74 65 20 d with a sqlite
ad10: 64 62 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 db file.(define
ad20: 28 64 62 66 69 6c 65 3a 6c 61 7a 79 2d 73 71 6c (dbfile:lazy-sql
ad30: 69 74 65 2d 64 62 2d 6d 6f 64 69 66 69 63 61 74 ite-db-modificat
ad40: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a ion-time fpath).
ad50: 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 2d 6c (let* ((glob-l
ad60: 69 73 74 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ist (handle-exce
ad70: 70 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 ptions....exn...
ad80: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
ad90: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
ada0: 72 20 22 46 61 69 6c 65 64 20 74 6f 20 67 6c 6f r "Failed to glo
adb0: 62 20 22 20 66 70 61 74 68 20 22 2a 2c 20 65 78 b " fpath "*, ex
adc0: 6e 3d 22 20 65 78 6e 29 0a 09 09 09 60 28 2c 28 n=" exn)....`(,(
add0: 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 63 68 2f 66 conc "/no/such/f
ade0: 69 6c 65 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 ile, message: "
adf0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
ae00: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
ae10: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
ae20: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c ))))... (gl
ae30: 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 68 20 22 ob (conc fpath "
ae40: 2a 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 *")))).
ae50: 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 (file-list (if (
ae60: 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 20 67 6c eq? 0 (length gl
ae70: 6f 62 2d 6c 69 73 74 29 29 0a 09 09 09 27 28 22 ob-list))....'("
ae80: 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 22 29 0a /no/such/file").
ae90: 09 09 09 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a ...glob-list))).
aea0: 20 20 28 61 70 70 6c 79 20 6d 61 78 0a 09 20 28 (apply max.. (
aeb0: 6d 61 70 0a 09 20 20 64 62 66 69 6c 65 3a 6c 61 map.. dbfile:la
aec0: 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d zy-modification-
aed0: 74 69 6d 65 20 0a 09 20 20 66 69 6c 65 2d 6c 69 time .. file-li
aee0: 73 74 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c st))))..;; dot-l
aef0: 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 6d 73 ocking egg seems
af00: 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 not to work, us
af10: 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 ing this for now
af20: 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f .;; if lock is o
af30: 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 72 65 lder than expire
af40: 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 -time then remov
af50: 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 67 61 e it and try aga
af60: 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 in.;; to get the
af70: 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 lock.;;.(define
af80: 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d (dbfile:simple-
af90: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
afa0: 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 #!key (expire-ti
afb0: 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 me 300)). (let
afc0: 28 28 66 6d 6f 64 2d 74 69 6d 65 20 28 68 61 6e ((fmod-time (han
afd0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
afe0: 09 20 20 20 20 20 20 20 65 78 74 0a 09 09 20 20 . ext...
aff0: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
b000: 6e 64 73 29 0a 09 09 20 20 20 20 20 28 66 69 6c nds)... (fil
b010: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
b020: 69 6d 65 20 66 6e 61 6d 65 29 29 29 29 0a 20 20 ime fname)))).
b030: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
b040: 74 73 3f 20 66 6e 61 6d 65 29 0a 09 28 69 66 20 ts? fname)..(if
b050: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
b060: 65 63 6f 6e 64 73 29 20 66 6d 6f 64 2d 74 69 6d econds) fmod-tim
b070: 65 29 20 65 78 70 69 72 65 2d 74 69 6d 65 29 0a e) expire-time).
b080: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
b090: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
b0a0: 74 69 6f 6e 73 20 65 78 6e 20 23 66 20 28 64 65 tions exn #f (de
b0b0: 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 lete-file* fname
b0c0: 29 29 09 0a 09 20 20 20 20 20 20 28 64 62 66 69 ))... (dbfi
b0d0: 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c le:simple-file-l
b0e0: 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 ock fname expire
b0f0: 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 -time: expire-ti
b100: 6d 65 29 29 0a 09 20 20 20 20 23 66 29 0a 09 28 me)).. #f)..(
b110: 6c 65 74 20 28 28 6b 65 79 2d 73 74 72 69 6e 67 let ((key-string
b120: 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 (conc (get-host
b130: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 75 72 72 -name) "-" (curr
b140: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
b150: 29 0a 09 20 20 20 20 20 20 28 6f 75 70 20 20 20 ).. (oup
b160: 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
b170: 74 2d 66 69 6c 65 20 66 6e 61 6d 65 29 29 29 0a t-file fname))).
b180: 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
b190: 74 6f 2d 70 6f 72 74 0a 09 20 20 20 20 20 20 6f to-port.. o
b1a0: 75 70 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 up.. (lambda
b1b0: 28 29 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 ().. (print
b1c0: 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 key-string)))..
b1d0: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
b1e0: 70 6f 72 74 20 6f 75 70 29 0a 09 20 20 23 3b 28 port oup).. #;(
b1f0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
b200: 69 6c 65 20 66 6e 61 6d 65 20 3b 3b 20 62 69 7a ile fname ;; biz
b210: 61 72 72 65 2e 20 77 69 74 68 2d 6f 75 74 70 75 arre. with-outpu
b220: 74 2d 74 6f 2d 66 69 6c 65 20 64 6f 65 73 20 6e t-to-file does n
b230: 6f 74 20 73 65 65 6d 20 74 6f 20 62 65 20 63 6c ot seem to be cl
b240: 65 61 6e 69 6e 67 20 75 70 20 61 66 74 65 72 20 eaning up after
b250: 69 74 73 65 6c 66 2e 0a 09 20 20 20 20 28 6c 61 itself... (la
b260: 6d 62 64 61 20 28 29 0a 09 20 20 28 70 72 69 6e mbda ().. (prin
b270: 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a t key-string))).
b280: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
b290: 21 20 30 2e 32 35 29 0a 09 20 20 28 69 66 20 28 ! 0.25).. (if (
b2a0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
b2b0: 6d 65 29 0a 09 20 20 20 20 20 20 28 68 61 6e 64 me).. (hand
b2c0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 65 78 le-exceptions ex
b2d0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
b2e0: 20 20 23 66 20 0a 20 20 20 20 20 20 20 20 20 20 #f .
b2f0: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
b300: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d t-from-file fnam
b310: 65 0a 09 20 20 09 20 20 28 6c 61 6d 62 64 61 20 e.. . (lambda
b320: 28 29 0a 09 09 20 20 20 20 28 65 71 75 61 6c 3f ()... (equal?
b330: 20 6b 65 79 2d 73 74 72 69 6e 67 20 28 72 65 61 key-string (rea
b340: 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 20 20 20 d-line)))))..
b350: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 29 0a #f). ).
b360: 20 20 20 20 29 0a 20 20 29 0a 29 0a 0a 28 64 65 ). ).)..(de
b370: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 69 6d fine (dbfile:sim
b380: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e ple-file-lock-an
b390: 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 23 21 6b d-wait fname #!k
b3a0: 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 ey (expire-time
b3b0: 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 28 65 300)). (let ((e
b3c0: 6e 64 2d 74 69 6d 65 20 28 2b 20 65 78 70 69 72 nd-time (+ expir
b3d0: 65 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d e-time (current-
b3e0: 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 seconds)))).
b3f0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 67 6f 74 2d (let loop ((got-
b400: 6c 6f 63 6b 20 28 64 62 66 69 6c 65 3a 73 69 6d lock (dbfile:sim
b410: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e ple-file-lock fn
b420: 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a ame expire-time:
b430: 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 0a expire-time))).
b440: 20 20 20 20 20 20 28 69 66 20 67 6f 74 2d 6c 6f (if got-lo
b450: 63 6b 0a 09 20 20 23 74 0a 09 20 20 28 69 66 20 ck.. #t.. (if
b460: 28 3e 20 65 6e 64 2d 74 69 6d 65 20 28 63 75 72 (> end-time (cur
b470: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
b480: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
b490: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 thread-sleep! 3)
b4a0: 0a 09 09 28 6c 6f 6f 70 20 28 64 62 66 69 6c 65 ...(loop (dbfile
b4b0: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
b4c0: 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 k fname expire-t
b4d0: 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 ime: expire-time
b4e0: 29 29 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 ))).. #f)))
b4f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 ))..(define (dbf
b500: 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d ile:simple-file-
b510: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 release-lock fna
b520: 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 me). (handle-ex
b530: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 ceptions. e
b540: 78 6e 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 49 xn. #f ;; I
b550: 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 20 63 61 don't really ca
b560: 72 65 20 77 68 79 20 74 68 69 73 20 66 61 69 6c re why this fail
b570: 65 64 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 ed (at least for
b580: 20 6e 6f 77 29 0a 20 20 20 20 28 64 65 6c 65 74 now). (delet
b590: 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 29 e-file* fname)))
b5a0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c ..(define (dbfil
b5b0: 65 3a 77 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 e:with-simple-fi
b5c0: 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 70 72 le-lock fname pr
b5d0: 6f 63 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 oc #!key (expire
b5e0: 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 6c -time 300)). (l
b5f0: 65 74 20 28 28 67 6f 74 6c 6f 63 6b 20 28 64 62 et ((gotlock (db
b600: 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 file:simple-file
b610: 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 61 69 74 20 66 -lock-and-wait f
b620: 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 name expire-time
b630: 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 : expire-time)))
b640: 0a 20 20 20 20 28 69 66 20 67 6f 74 6c 6f 63 6b . (if gotlock
b650: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 70 72 ..(let ((res (pr
b660: 6f 63 29 29 29 0a 09 20 20 28 64 62 66 69 6c 65 oc))).. (dbfile
b670: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
b680: 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 ease-lock fname)
b690: 0a 09 20 20 72 65 73 29 0a 09 28 61 73 73 65 72 .. res)..(asser
b6a0: 74 20 23 74 20 22 46 41 54 41 4c 3a 20 73 69 6d t #t "FATAL: sim
b6b0: 70 6c 65 20 66 69 6c 65 20 6c 6f 63 6b 20 6e 65 ple file lock ne
b6c0: 76 65 72 20 67 6f 74 20 61 20 6c 6f 63 6b 2e 22 ver got a lock."
b6d0: 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 )))). .(define
b6e0: 28 64 62 3a 67 65 74 2d 63 61 63 68 65 2d 73 74 (db:get-cache-st
b6f0: 6d 74 68 20 64 62 64 61 74 20 64 62 20 73 74 6d mth dbdat db stm
b700: 74 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 t). (let* (;; (
b710: 64 62 64 61 74 20 20 20 20 20 20 20 28 64 62 66 dbdat (dbf
b720: 69 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 64 62 ile:get-dbdat db
b730: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 29 0a struct run-id)).
b740: 09 20 28 73 74 6d 74 2d 63 61 63 68 65 20 20 28 . (stmt-cache (
b750: 64 62 72 3a 64 62 64 61 74 2d 73 74 6d 74 2d 63 dbr:dbdat-stmt-c
b760: 61 63 68 65 20 64 62 64 61 74 29 29 0a 09 20 3b ache dbdat)).. ;
b770: 3b 20 28 73 74 6d 74 68 20 20 20 20 20 20 20 28 ; (stmth (
b780: 64 62 3a 68 6f 68 2d 67 65 74 20 73 74 6d 74 2d db:hoh-get stmt-
b790: 63 61 63 68 65 20 64 62 20 73 74 6d 74 29 29 0a cache db stmt)).
b7a0: 09 20 28 73 74 6d 74 68 20 20 20 20 20 20 20 28 . (stmth (
b7b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
b7c0: 65 66 61 75 6c 74 20 73 74 6d 74 2d 63 61 63 68 efault stmt-cach
b7d0: 65 20 73 74 6d 74 20 23 66 29 29 29 0a 20 20 20 e stmt #f))).
b7e0: 20 28 6f 72 20 73 74 6d 74 68 0a 09 28 6c 65 74 (or stmth..(let
b7f0: 2a 20 28 28 6e 65 77 73 74 6d 74 68 20 28 73 71 * ((newstmth (sq
b800: 6c 69 74 65 33 3a 70 72 65 70 61 72 65 20 64 62 lite3:prepare db
b810: 20 73 74 6d 74 29 29 29 0a 09 20 20 3b 3b 20 28 stmt))).. ;; (
b820: 64 62 3a 68 6f 68 2d 73 65 74 21 20 73 74 6d 74 db:hoh-set! stmt
b830: 2d 63 61 63 68 65 20 64 62 20 73 74 6d 74 20 6e -cache db stmt n
b840: 65 77 73 74 6d 74 68 29 0a 09 20 20 28 68 61 73 ewstmth).. (has
b850: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 74 6d h-table-set! stm
b860: 74 2d 63 61 63 68 65 20 73 74 6d 74 20 6e 65 77 t-cache stmt new
b870: 73 74 6d 74 68 29 0a 09 20 20 6e 65 77 73 74 6d stmth).. newstm
b880: 74 68 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 th))))..(define
b890: 28 64 62 3a 68 61 76 65 2d 69 6e 63 6f 6d 70 6c (db:have-incompl
b8a0: 65 74 65 73 3f 20 64 62 73 74 72 75 63 74 20 72 etes? dbstruct r
b8b0: 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 un-id ovr-deadti
b8c0: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 6e me). (let* ((in
b8d0: 63 6f 6d 70 6c 65 74 65 64 20 27 28 29 29 0a 09 completed '())..
b8e0: 20 28 6f 6c 64 6c 61 75 6e 63 68 65 64 20 27 28 (oldlaunched '(
b8f0: 29 29 0a 09 20 28 74 6f 70 6c 65 76 65 6c 73 20 )).. (toplevels
b900: 20 20 27 28 29 29 0a 09 20 3b 3b 20 28 64 65 61 '()).. ;; (dea
b910: 64 74 69 6d 65 2d 73 74 72 20 28 63 6f 6e 66 69 dtime-str (confi
b920: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
b930: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 gdat* "setup" "d
b940: 65 61 64 74 69 6d 65 22 29 29 0a 09 20 28 64 65 eadtime")).. (de
b950: 61 64 74 69 6d 65 20 20 28 6f 72 20 6f 76 72 2d adtime (or ovr-
b960: 64 65 61 64 74 69 6d 65 20 37 32 30 30 30 29 29 deadtime 72000))
b970: 29 20 3b 3b 20 74 77 65 6e 74 79 20 68 6f 75 72 ) ;; twenty hour
b980: 73 0a 20 20 20 20 28 64 62 3a 77 69 74 68 2d 64 s. (db:with-d
b990: 62 0a 20 20 20 20 20 64 62 73 74 72 75 63 74 20 b. dbstruct
b9a0: 72 75 6e 2d 69 64 20 23 66 0a 20 20 20 20 20 28 run-id #f. (
b9b0: 6c 61 6d 62 64 61 20 28 64 62 64 61 74 20 64 62 lambda (dbdat db
b9c0: 29 0a 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 ). .
b9d0: 20 3b 3b 20 69 6e 20 52 55 4e 4e 49 4e 47 20 6f ;; in RUNNING o
b9e0: 72 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 r REMOTEHOSTSTAR
b9f0: 54 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 T for more than
ba00: 31 30 20 6d 69 6e 75 74 65 73 0a 20 20 20 20 20 10 minutes.
ba10: 20 20 3b 3b 0a 20 20 20 20 20 20 20 3b 3b 20 48 ;;. ;; H
ba20: 4f 57 45 56 45 52 3a 20 74 68 69 73 20 63 6f 64 OWEVER: this cod
ba30: 65 20 69 6e 20 72 75 6e 3a 74 65 73 74 20 73 65 e in run:test se
ba40: 65 6d 73 20 74 6f 20 77 6f 72 6b 20 66 69 6e 65 ems to work fine
ba50: 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
ba60: 20 20 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 (> (- (c
ba70: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
ba80: 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 + (db:test-get-e
ba90: 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 vent_time testda
baa0: 74 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 t). ;;
bab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bac0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
bad0: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 n_duration testd
bae0: 61 74 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 at))). ;;
baf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb00: 20 20 20 36 30 30 29 20 0a 20 20 20 20 20 20 20 600) .
bb10: 3b 3b 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d ;; (db:delay-if-
bb20: 62 75 73 79 20 64 62 64 61 74 29 0a 20 20 20 20 busy dbdat).
bb30: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
bb40: 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 20 each-row .
bb50: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
bb60: 69 64 20 72 75 6e 2d 64 69 72 20 75 6e 61 6d 65 id run-dir uname
bb70: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 testname item-p
bb80: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 28 ath). (
bb90: 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 if (and (equal?
bba0: 75 6e 61 6d 65 20 22 6e 2f 61 22 29 0a 20 20 20 uname "n/a").
bbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bbc0: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat
bbd0: 68 20 22 22 29 29 20 3b 3b 20 74 68 69 73 20 69 h "")) ;; this i
bbe0: 73 20 61 20 74 6f 70 6c 65 76 65 6c 20 74 65 73 s a toplevel tes
bbf0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
bc00: 3b 3b 20 77 68 61 74 20 74 6f 20 64 6f 20 77 69 ;; what to do wi
bc10: 74 68 20 74 6f 70 6c 65 76 65 6c 3f 20 63 61 6c th toplevel? cal
bc20: 6c 20 72 6f 6c 6c 75 70 3f 0a 20 20 20 20 20 20 l rollup?.
bc30: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
bc40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
bc50: 73 65 74 21 20 74 6f 70 6c 65 76 65 6c 73 20 20 set! toplevels
bc60: 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 74 65 73 (cons (list tes
bc70: 74 2d 69 64 20 72 75 6e 2d 64 69 72 20 75 6e 61 t-id run-dir una
bc80: 6d 65 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d me testname item
bc90: 2d 70 61 74 68 20 72 75 6e 2d 69 64 29 20 74 6f -path run-id) to
bca0: 70 6c 65 76 65 6c 73 29 29 29 0a 20 20 20 20 20 plevels))).
bcb0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 ;; (p
bcc0: 72 69 6e 74 2d 69 6e 66 6f 20 22 46 6f 75 6e 64 rint-info "Found
bcd0: 20 6f 6c 64 20 74 6f 70 6c 65 76 65 6c 20 74 65 old toplevel te
bce0: 73 74 20 69 6e 20 52 55 4e 4e 49 4e 47 20 73 74 st in RUNNING st
bcf0: 61 74 65 2c 20 74 65 73 74 2d 69 64 3d 22 20 74 ate, test-id=" t
bd00: 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 20 est-id)).
bd10: 20 20 20 20 20 20 20 28 73 65 74 21 20 69 6e 63 (set! inc
bd20: 6f 6d 70 6c 65 74 65 64 20 28 63 6f 6e 73 20 28 ompleted (cons (
bd30: 6c 69 73 74 20 74 65 73 74 2d 69 64 20 72 75 6e list test-id run
bd40: 2d 64 69 72 20 75 6e 61 6d 65 20 74 65 73 74 6e -dir uname testn
bd50: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 72 75 ame item-path ru
bd60: 6e 2d 69 64 29 20 69 6e 63 6f 6d 70 6c 65 74 65 n-id) incomplete
bd70: 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 64 d)))). (d
bd80: 62 3a 67 65 74 2d 63 61 63 68 65 2d 73 74 6d 74 b:get-cache-stmt
bd90: 68 20 64 62 64 61 74 20 64 62 0a 20 20 20 20 20 h dbdat db.
bda0: 20 20 20 22 53 45 4c 45 43 54 20 69 64 2c 72 75 "SELECT id,ru
bdb0: 6e 64 69 72 2c 75 6e 61 6d 65 2c 74 65 73 74 6e ndir,uname,testn
bdc0: 61 6d 65 2c 69 74 65 6d 5f 70 61 74 68 20 46 52 ame,item_path FR
bdd0: 4f 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 OM tests WHERE r
bde0: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 28 73 74 72 un_id=? AND (str
bdf0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
be00: 29 20 2d 20 65 76 65 6e 74 5f 74 69 6d 65 29 20 ) - event_time)
be10: 3e 20 28 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 > (run_duration
be20: 2b 20 3f 29 20 41 4e 44 20 73 74 61 74 65 20 49 + ?) AND state I
be30: 4e 20 28 27 52 55 4e 4e 49 4e 47 27 2c 27 52 45 N ('RUNNING','RE
be40: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 27 29 3b MOTEHOSTSTART');
be50: 22 29 0a 20 20 20 20 20 20 20 20 72 75 6e 2d 69 "). run-i
be60: 64 20 64 65 61 64 74 69 6d 65 29 0a 0a 20 20 20 d deadtime)..
be70: 20 20 20 20 3b 3b 20 69 6e 20 4c 41 55 4e 43 48 ;; in LAUNCH
be80: 45 44 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e ED for more than
be90: 20 6f 6e 65 20 64 61 79 2e 20 43 6f 75 6c 64 20 one day. Could
bea0: 62 65 20 6c 6f 6e 67 20 64 75 65 20 74 6f 20 6a be long due to j
beb0: 6f 62 20 71 75 65 75 65 73 20 54 4f 44 4f 2f 42 ob queues TODO/B
bec0: 55 47 3a 20 4e 65 65 64 20 6f 76 65 72 72 69 64 UG: Need overrid
bed0: 65 20 66 6f 72 20 74 68 69 73 20 69 6e 20 63 6f e for this in co
bee0: 6e 66 69 67 0a 20 20 20 20 20 20 20 3b 3b 0a 20 nfig. ;;.
bef0: 20 20 20 20 20 20 3b 3b 20 28 64 62 3a 64 65 6c ;; (db:del
bf00: 61 79 2d 69 66 2d 62 75 73 79 20 64 62 64 61 74 ay-if-busy dbdat
bf10: 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 ). (sqlite
bf20: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 3:for-each-row.
bf30: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
bf40: 74 65 73 74 2d 69 64 20 72 75 6e 2d 64 69 72 20 test-id run-dir
bf50: 75 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 69 uname testname i
bf60: 74 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 20 20 tem-path).
bf70: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
bf80: 75 61 6c 3f 20 75 6e 61 6d 65 20 22 6e 2f 61 22 ual? uname "n/a"
bf90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bfa0: 20 20 20 20 20 28 65 71 75 61 6c 3f 20 69 74 65 (equal? ite
bfb0: 6d 2d 70 61 74 68 20 22 22 29 29 20 3b 3b 20 74 m-path "")) ;; t
bfc0: 68 69 73 20 69 73 20 61 20 74 6f 70 6c 65 76 65 his is a topleve
bfd0: 6c 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 l test.
bfe0: 20 20 20 20 20 3b 3b 20 77 68 61 74 20 74 6f 20 ;; what to
bff0: 64 6f 20 77 69 74 68 20 74 6f 70 6c 65 76 65 6c do with toplevel
c000: 3f 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 3f 0a 20 ? call rollup?.
c010: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
c020: 74 21 20 74 6f 70 6c 65 76 65 6c 73 20 20 20 28 t! toplevels (
c030: 63 6f 6e 73 20 28 6c 69 73 74 20 74 65 73 74 2d cons (list test-
c040: 69 64 20 72 75 6e 2d 64 69 72 20 75 6e 61 6d 65 id run-dir uname
c050: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 testname item-p
c060: 61 74 68 20 72 75 6e 2d 69 64 29 20 74 6f 70 6c ath run-id) topl
c070: 65 76 65 6c 73 29 29 0a 20 20 20 20 20 20 20 20 evels)).
c080: 20 20 20 20 20 20 28 73 65 74 21 20 6f 6c 64 6c (set! oldl
c090: 61 75 6e 63 68 65 64 20 28 63 6f 6e 73 20 28 6c aunched (cons (l
c0a0: 69 73 74 20 74 65 73 74 2d 69 64 20 72 75 6e 2d ist test-id run-
c0b0: 64 69 72 20 75 6e 61 6d 65 20 74 65 73 74 6e 61 dir uname testna
c0c0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 72 75 6e me item-path run
c0d0: 2d 69 64 29 20 6f 6c 64 6c 61 75 6e 63 68 65 64 -id) oldlaunched
c0e0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 64 62 )))). (db
c0f0: 3a 67 65 74 2d 63 61 63 68 65 2d 73 74 6d 74 68 :get-cache-stmth
c100: 20 64 62 64 61 74 20 64 62 0a 20 20 20 20 20 20 dbdat db.
c110: 20 20 22 53 45 4c 45 43 54 20 69 64 2c 72 75 6e "SELECT id,run
c120: 64 69 72 2c 75 6e 61 6d 65 2c 74 65 73 74 6e 61 dir,uname,testna
c130: 6d 65 2c 69 74 65 6d 5f 70 61 74 68 20 46 52 4f me,item_path FRO
c140: 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 M tests WHERE ru
c150: 6e 5f 69 64 3d 3f 20 41 4e 44 20 28 73 74 72 66 n_id=? AND (strf
c160: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
c170: 20 2d 20 65 76 65 6e 74 5f 74 69 6d 65 29 20 3e - event_time) >
c180: 20 38 36 34 30 30 20 41 4e 44 20 73 74 61 74 65 86400 AND state
c190: 20 49 4e 20 28 27 4c 41 55 4e 43 48 45 44 27 29 IN ('LAUNCHED')
c1a0: 3b 22 29 0a 20 20 20 20 20 20 20 20 72 75 6e 2d ;"). run-
c1b0: 69 64 29 0a 20 20 20 20 20 20 20 0a 20 20 20 20 id). .
c1c0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 2d 69 6e 66 ;; (print-inf
c1d0: 6f 20 22 46 6f 75 6e 64 20 22 20 28 6c 65 6e 67 o "Found " (leng
c1e0: 74 68 20 6f 6c 64 6c 61 75 6e 63 68 65 64 29 20 th oldlaunched)
c1f0: 22 20 6f 6c 64 20 4c 41 55 4e 43 48 45 44 20 69 " old LAUNCHED i
c200: 74 65 6d 73 2c 20 22 20 28 6c 65 6e 67 74 68 20 tems, " (length
c210: 74 6f 70 6c 65 76 65 6c 73 29 20 22 20 6f 6c 64 toplevels) " old
c220: 20 4c 41 55 4e 43 48 45 44 20 74 6f 70 6c 65 76 LAUNCHED toplev
c230: 65 6c 20 74 65 73 74 73 20 61 6e 64 20 22 20 28 el tests and " (
c240: 6c 65 6e 67 74 68 20 69 6e 63 6f 6d 70 6c 65 74 length incomplet
c250: 65 64 29 20 22 20 74 65 73 74 73 20 6d 61 72 6b ed) " tests mark
c260: 65 64 20 52 55 4e 4e 49 4e 47 20 62 75 74 20 61 ed RUNNING but a
c270: 70 70 61 72 65 6e 74 6c 79 20 64 65 61 64 2e 22 pparently dead."
c280: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 61 6e ). (if (an
c290: 64 20 28 6e 75 6c 6c 3f 20 69 6e 63 6f 6d 70 6c d (null? incompl
c2a0: 65 74 65 64 29 0a 20 20 20 20 20 20 20 20 20 20 eted).
c2b0: 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 6f 6c 64 (null? old
c2c0: 6c 61 75 6e 63 68 65 64 29 0a 20 20 20 20 20 20 launched).
c2d0: 20 20 20 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f (null?
c2e0: 20 74 6f 70 6c 65 76 65 6c 73 29 29 0a 20 20 20 toplevels)).
c2f0: 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 #f.
c300: 20 20 20 20 20 20 23 74 29 29 29 29 29 0a 0a 0a #t)))))...
c310: 29 0a ).