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 3b 3b 20 64 65 62 75 67 monmod..;; debug
04b0: 70 72 69 6e 74 0a 09 29 0a 0a 28 64 65 66 69 6e print..)..(defin
04c0: 65 20 6b 65 65 70 2d 61 67 65 2d 70 61 72 61 6d e keep-age-param
04d0: 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 (make-parameter
04e0: 20 31 30 29 29 20 3b 3b 20 71 69 66 20 66 69 6c 10)) ;; qif fil
04f0: 65 20 61 67 65 2c 20 69 66 20 6f 76 65 72 20 6d e age, if over m
0500: 6f 76 65 20 74 6f 20 61 74 74 69 63 0a 28 64 65 ove to attic.(de
0510: 66 69 6e 65 20 6e 75 6d 2d 72 75 6e 2d 64 62 73 fine num-run-dbs
0520: 20 20 20 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 (make-parame
0530: 74 65 72 20 31 30 29 29 20 20 20 20 20 3b 3b 20 ter 10)) ;;
0540: 6e 75 6d 62 65 72 20 6f 66 20 64 62 27 73 20 69 number of db's i
0550: 6e 20 2e 6d 65 67 61 74 65 73 74 0a 28 64 65 66 n .megatest.(def
0560: 69 6e 65 20 64 62 66 69 6c 65 3a 74 65 73 74 73 ine dbfile:tests
0570: 75 69 74 65 2d 6e 61 6d 65 20 28 6d 61 6b 65 2d uite-name (make-
0580: 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 0a 0a parameter #f))..
0590: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
05a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 45 ========.;; R E
05e0: 20 43 20 4f 20 52 20 44 20 53 0a 3b 3b 3d 3d 3d C O R D S.;;===
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0630: 3d 3d 3d 0a 0a 3b 3b 20 61 20 73 69 6e 67 6c 65 ===..;; a single
0640: 20 4d 65 67 61 74 65 73 74 20 61 72 65 61 20 77 Megatest area w
0650: 69 74 68 20 69 74 27 73 20 6d 75 6c 74 69 70 6c ith it's multipl
0660: 65 20 64 62 73 20 69 73 0a 3b 3b 20 6d 61 6e 61 e dbs is.;; mana
0670: 67 65 64 20 69 6e 20 61 20 64 62 73 74 72 75 63 ged in a dbstruc
0680: 74 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 t.;;.(defstruct
0690: 64 62 72 3a 64 62 73 74 72 75 63 74 0a 20 20 28 dbr:dbstruct. (
06a0: 61 72 65 61 70 61 74 68 20 20 23 66 29 0a 20 20 areapath #f).
06b0: 28 68 6f 6d 65 68 6f 73 74 20 20 23 66 29 0a 20 (homehost #f).
06c0: 20 28 74 6d 70 70 61 74 68 20 20 20 23 66 29 0a (tmppath #f).
06d0: 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 23 66 29 (read-only #f)
06e0: 0a 20 20 28 73 75 62 64 62 73 20 28 6d 61 6b 65 . (subdbs (make
06f0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
0700: 3b 3b 0a 20 20 3b 3b 20 66 6f 72 20 74 68 65 20 ;;. ;; for the
0710: 69 6e 6d 65 6d 20 61 70 70 72 6f 61 63 68 20 28 inmem approach (
0720: 73 65 65 20 64 62 6d 6f 64 2e 73 63 6d 29 0a 20 see dbmod.scm).
0730: 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 6e 65 20 ;; this is one
0740: 64 62 20 70 65 72 20 73 65 72 76 65 72 0a 20 20 db per server.
0750: 28 69 6e 6d 65 6d 20 20 20 20 20 23 66 29 20 20 (inmem #f)
0760: 3b 3b 20 68 61 6e 64 6c 65 20 66 6f 72 20 74 68 ;; handle for th
0770: 65 20 69 6e 20 6d 65 6d 6f 72 79 20 63 6f 70 79 e in memory copy
0780: 0a 20 20 28 64 62 66 69 6c 65 20 20 20 20 23 66 . (dbfile #f
0790: 29 20 20 3b 3b 20 70 61 74 68 20 74 6f 20 74 68 ) ;; path to th
07a0: 65 20 64 62 20 66 69 6c 65 20 6f 6e 20 64 69 73 e db file on dis
07b0: 6b 0a 20 20 28 6f 6e 64 69 73 6b 64 62 20 20 23 k. (ondiskdb #
07c0: 66 29 20 20 3b 3b 20 68 61 6e 64 6c 65 20 66 6f f) ;; handle fo
07d0: 72 20 74 68 65 20 6f 6e 2d 64 69 73 6b 20 66 69 r the on-disk fi
07e0: 6c 65 0a 20 20 28 64 62 64 61 74 20 20 20 20 20 le. (dbdat
07f0: 23 66 29 20 20 3b 3b 20 63 72 65 61 74 65 20 61 #f) ;; create a
0800: 20 64 62 64 61 74 20 66 6f 72 20 74 68 65 20 64 dbdat for the d
0810: 6f 77 6e 73 74 72 65 61 6d 20 63 61 6c 6c 73 20 ownstream calls
0820: 73 75 63 68 20 61 73 20 64 62 3a 77 69 74 68 2d such as db:with-
0830: 64 62 0a 20 20 28 6c 61 73 74 2d 75 70 64 61 74 db. (last-updat
0840: 65 20 30 29 0a 20 20 28 73 79 6e 63 2d 70 72 6f e 0). (sync-pro
0850: 63 20 23 66 29 0a 20 20 29 0a 0a 3b 3b 20 4e 4f c #f). )..;; NO
0860: 54 45 3a 20 4e 65 65 64 20 6f 6e 65 20 64 62 72 TE: Need one dbr
0870: 3a 73 75 62 64 62 20 70 65 72 20 6d 61 69 6e 2e :subdb per main.
0880: 64 62 2c 20 31 2e 64 62 20 2e 2e 2e 0a 3b 3b 0a db, 1.db ....;;.
0890: 28 64 65 66 73 74 72 75 63 74 20 64 62 72 3a 73 (defstruct dbr:s
08a0: 75 62 64 62 0a 20 20 28 64 62 6e 61 6d 65 20 20 ubdb. (dbname
08b0: 20 20 20 20 23 66 29 20 3b 3b 20 2e 6d 65 67 61 #f) ;; .mega
08c0: 74 65 73 74 2f 31 2e 64 62 0a 20 20 28 6d 74 64 test/1.db. (mtd
08d0: 62 66 69 6c 65 20 20 20 20 23 66 29 20 3b 3b 20 bfile #f) ;;
08e0: 6d 74 72 61 68 2f 2e 6d 65 67 61 74 65 73 74 2f mtrah/.megatest/
08f0: 31 2e 64 62 0a 20 20 28 6d 74 64 62 64 61 74 20 1.db. (mtdbdat
0900: 20 20 20 20 23 66 29 20 3b 3b 20 6f 6e 6c 79 20 #f) ;; only
0910: 6e 65 65 64 20 6f 6e 65 20 6f 66 20 74 68 65 73 need one of thes
0920: 65 20 66 6f 72 20 73 79 6e 63 69 6e 67 0a 20 20 e for syncing.
0930: 3b 3b 20 28 64 62 64 61 74 73 20 20 20 20 20 20 ;; (dbdats
0940: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0950: 29 29 20 20 3b 3b 20 69 64 20 3d 3e 20 64 62 64 )) ;; id => dbd
0960: 61 74 20 0a 20 20 28 74 6d 70 64 62 66 69 6c 65 at . (tmpdbfile
0970: 20 20 20 23 66 29 20 3b 3b 20 2f 74 6d 70 2f 2e #f) ;; /tmp/.
0980: 2e 2e 2f 2e 6d 65 67 61 74 65 73 74 2f 31 2e 64 ../.megatest/1.d
0990: 62 0a 20 20 3b 3b 20 28 72 65 66 6e 64 62 66 69 b. ;; (refndbfi
09a0: 6c 65 20 20 23 66 29 20 3b 3b 20 2f 74 6d 70 2f le #f) ;; /tmp/
09b0: 2e 2e 2e 2f 2e 6d 65 67 61 74 65 73 74 2f 31 2e .../.megatest/1.
09c0: 64 62 5f 72 65 66 0a 20 20 28 64 62 73 74 61 63 db_ref. (dbstac
09d0: 6b 20 20 20 20 20 28 6d 61 6b 65 2d 73 74 61 63 k (make-stac
09e0: 6b 29 29 20 3b 3b 20 73 74 61 63 6b 20 66 6f 72 k)) ;; stack for
09f0: 20 74 6d 70 20 64 62 72 3a 64 62 64 61 74 2c 0a tmp dbr:dbdat,.
0a00: 20 20 28 68 6f 6d 65 68 6f 73 74 20 20 20 20 23 (homehost #
0a10: 66 29 20 3b 3b 20 6e 6f 74 20 75 73 65 64 20 79 f) ;; not used y
0a20: 65 74 0a 20 20 28 6f 6e 2d 68 6f 6d 65 68 6f 73 et. (on-homehos
0a30: 74 20 23 66 29 20 3b 3b 20 6e 6f 74 20 75 73 65 t #f) ;; not use
0a40: 64 20 79 65 74 0a 20 20 28 72 65 61 64 2d 6f 6e d yet. (read-on
0a50: 6c 79 20 20 20 23 66 29 0a 20 20 28 6c 61 73 74 ly #f). (last
0a60: 2d 73 79 6e 63 20 20 20 30 29 0a 20 20 28 6c 61 -sync 0). (la
0a70: 73 74 2d 77 72 69 74 65 20 20 28 63 75 72 72 65 st-write (curre
0a80: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 29 nt-seconds)). )
0a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0aa0: 3b 3b 20 67 6f 61 6c 20 69 73 20 74 6f 20 63 6f ;; goal is to co
0ab0: 6e 76 65 72 67 65 20 6f 6e 20 6f 6e 65 20 73 74 nverge on one st
0ac0: 72 75 63 74 20 66 6f 72 20 61 6e 20 61 72 65 61 ruct for an area
0ad0: 20 62 75 74 20 66 6f 72 20 6e 6f 77 20 69 74 20 but for now it
0ae0: 69 73 20 74 6f 6f 20 63 6f 6e 66 75 73 69 6e 67 is too confusing
0af0: 0a 0a 3b 3b 20 6e 65 65 64 20 74 6f 20 6b 65 65 ..;; need to kee
0b00: 70 20 64 62 68 61 6e 64 6c 65 73 20 61 6e 64 20 p dbhandles and
0b10: 63 61 63 68 65 64 20 73 74 61 74 65 6d 65 6e 74 cached statement
0b20: 73 20 74 6f 67 65 74 68 65 72 0a 28 64 65 66 73 s together.(defs
0b30: 74 72 75 63 74 20 64 62 72 3a 64 62 64 61 74 0a truct dbr:dbdat.
0b40: 20 20 28 64 62 66 69 6c 65 20 20 20 20 20 20 23 (dbfile #
0b50: 66 29 0a 20 20 28 64 62 68 20 20 20 20 20 20 20 f). (dbh
0b60: 20 20 23 66 29 20 20 20 20 0a 20 20 28 73 74 6d #f) . (stm
0b70: 74 2d 63 61 63 68 65 20 20 28 6d 61 6b 65 2d 68 t-cache (make-h
0b80: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 72 ash-table)). (r
0b90: 65 61 64 2d 6f 6e 6c 79 20 20 20 23 66 29 0a 20 ead-only #f).
0ba0: 20 28 62 69 72 74 68 2d 73 65 63 20 20 20 28 63 (birth-sec (c
0bb0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0bc0: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 74 )..(define *dbst
0bd0: 72 75 63 74 2d 64 62 73 2a 20 23 66 29 0a 28 64 ruct-dbs* #f).(d
0be0: 65 66 69 6e 65 20 2a 64 62 2d 6f 70 65 6e 2d 6d efine *db-open-m
0bf0: 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 utex* (make-mute
0c00: 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d x)).(define *db-
0c10: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 20 28 6d access-mutex* (m
0c20: 61 6b 65 2d 6d 75 74 65 78 29 29 20 3b 3b 20 75 ake-mutex)) ;; u
0c30: 73 65 64 20 69 6e 20 63 6f 6d 6d 6f 6e 2e 73 63 sed in common.sc
0c40: 6d 0a 28 64 65 66 69 6e 65 20 2a 6e 6f 2d 73 79 m.(define *no-sy
0c50: 6e 63 2d 64 62 2a 20 20 20 23 66 29 0a 28 64 65 nc-db* #f).(de
0c60: 66 69 6e 65 20 2a 64 62 2d 73 79 6e 63 2d 69 6e fine *db-sync-in
0c70: 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a 28 -progress* #f).(
0c80: 64 65 66 69 6e 65 20 2a 64 62 2d 77 69 74 68 2d define *db-with-
0c90: 64 62 2d 6d 75 74 65 78 2a 20 20 20 20 28 6d 61 db-mutex* (ma
0ca0: 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 ke-mutex)).(defi
0cb0: 6e 65 20 2a 6d 61 78 2d 61 70 69 2d 70 72 6f 63 ne *max-api-proc
0cc0: 65 73 73 2d 72 65 71 75 65 73 74 73 2a 20 30 29 ess-requests* 0)
0cd0: 0a 28 64 65 66 69 6e 65 20 2a 61 70 69 2d 70 72 .(define *api-pr
0ce0: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f ocess-request-co
0cf0: 75 6e 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 unt* 0).(define
0d00: 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 65 73 73 *db-write-access
0d10: 2a 20 20 20 20 20 23 74 29 0a 28 64 65 66 69 6e * #t).(defin
0d20: 65 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a e *db-last-sync*
0d30: 20 20 20 20 20 20 20 20 30 29 20 20 20 20 20 20 0)
0d40: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 ;; la
0d50: 73 74 20 74 69 6d 65 20 74 68 65 20 73 79 6e 63 st time the sync
0d60: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 to megatest.db
0d70: 68 61 70 70 65 6e 65 64 0a 28 64 65 66 69 6e 65 happened.(define
0d80: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
0d90: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
0da0: 65 78 29 29 20 20 20 20 20 20 3b 3b 20 70 72 6f ex)) ;; pro
0db0: 74 65 63 74 20 61 63 63 65 73 73 20 74 6f 20 2a tect access to *
0dc0: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
0dd0: 65 73 73 2a 2c 20 2a 64 62 2d 6c 61 73 74 2d 73 ess*, *db-last-s
0de0: 79 6e 63 2a 0a 28 64 65 66 69 6e 65 20 2a 64 62 ync*.(define *db
0df0: 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 20 20 -last-access*
0e00: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
0e10: 6e 64 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nds))..(define (
0e20: 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 db:generic-error
0e30: 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 2e 20 -printout exn .
0e40: 6d 65 73 73 61 67 65 29 0a 20 20 28 70 72 69 6e message). (prin
0e50: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
0e60: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
0e70: 29 29 0a 20 20 28 61 70 70 6c 79 20 64 62 66 69 )). (apply dbfi
0e80: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 6d 65 73 le:print-err mes
0e90: 73 61 67 65 29 0a 20 20 28 64 62 66 69 6c 65 3a sage). (dbfile:
0ea0: 70 72 69 6e 74 2d 65 72 72 0a 20 20 20 20 22 2c print-err. ",
0eb0: 20 65 72 72 6f 72 3a 20 22 20 20 20 20 20 28 28 error: " ((
0ec0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
0ed0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
0ee0: 20 27 6d 65 73 73 61 67 65 29 20 20 20 65 78 6e 'message) exn
0ef0: 29 0a 20 20 20 20 22 2c 20 61 72 67 75 6d 65 6e ). ", argumen
0f00: 74 73 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ts: " ((conditio
0f10: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
0f20: 73 6f 72 20 27 65 78 6e 20 27 61 72 67 75 6d 65 sor 'exn 'argume
0f30: 6e 74 73 29 20 65 78 6e 29 0a 20 20 20 20 22 2c nts) exn). ",
0f40: 20 6c 6f 63 61 74 69 6f 6e 3a 20 22 20 20 28 28 location: " ((
0f50: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
0f60: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
0f70: 20 27 6c 6f 63 61 74 69 6f 6e 29 20 20 65 78 6e 'location) exn
0f80: 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e ). ))..(defin
0f90: 65 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 e (dbfile:run-id
0fa0: 2d 3e 6b 65 79 20 72 75 6e 2d 69 64 29 0a 20 20 ->key run-id).
0fb0: 28 6f 72 20 72 75 6e 2d 69 64 20 27 6d 61 69 6e (or run-id 'main
0fc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a ))..(define (db:
0fd0: 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c safely-close-sql
0fe0: 69 74 65 33 2d 64 62 20 64 62 20 73 74 6d 74 2d ite3-db db stmt-
0ff0: 63 61 63 68 65 20 23 21 6b 65 79 20 28 74 72 79 cache #!key (try
1000: 2d 6e 75 6d 20 33 29 29 0a 20 20 28 69 66 20 28 -num 3)). (if (
1010: 3c 3d 20 74 72 79 2d 6e 75 6d 20 30 29 0a 20 20 <= try-num 0).
1020: 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 68 61 #f. (ha
1030: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
1040: 09 20 20 65 78 6e 0a 09 28 62 65 67 69 6e 0a 09 . exn..(begin..
1050: 20 20 28 70 72 69 6e 74 20 22 41 74 74 65 6d 70 (print "Attemp
1060: 74 20 74 6f 20 73 61 66 65 6c 79 20 63 6c 6f 73 t to safely clos
1070: 65 20 73 71 6c 69 74 65 33 20 64 62 20 66 61 69 e sqlite3 db fai
1080: 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 led. Trying agai
1090: 6e 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 20 n. exn=" exn)..
10a0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
10b0: 33 29 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 69 3).. (sqlite3:i
10c0: 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 20 nterrupt! db)..
10d0: 20 28 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 (db:safely-clos
10e0: 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 64 62 20 e-sqlite3-db db
10f0: 73 74 6d 74 2d 63 61 63 68 65 20 74 72 79 2d 6e stmt-cache try-n
1100: 75 6d 3a 20 28 2d 20 74 72 79 2d 6e 75 6d 20 31 um: (- try-num 1
1110: 29 29 29 0a 09 28 69 66 20 28 73 71 6c 69 74 65 )))..(if (sqlite
1120: 33 3a 64 61 74 61 62 61 73 65 3f 20 64 62 29 0a 3:database? db).
1130: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 6d . (let* ((stm
1140: 74 73 20 28 61 6e 64 20 73 74 6d 74 2d 63 61 63 ts (and stmt-cac
1150: 68 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 he (hash-table-r
1160: 65 66 2f 64 65 66 61 75 6c 74 20 73 74 6d 74 2d ef/default stmt-
1170: 63 61 63 68 65 20 64 62 20 23 66 29 29 29 29 0a cache db #f)))).
1180: 09 20 20 20 20 20 20 28 69 66 20 73 74 6d 74 73 . (if stmts
1190: 20 28 6d 61 70 20 73 71 6c 69 74 65 33 3a 66 69 (map sqlite3:fi
11a0: 6e 61 6c 69 7a 65 21 20 28 68 61 73 68 2d 74 61 nalize! (hash-ta
11b0: 62 6c 65 2d 76 61 6c 75 65 73 20 73 74 6d 74 73 ble-values stmts
11c0: 29 29 29 0a 09 20 20 20 20 20 20 28 73 71 6c 69 ))).. (sqli
11d0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
11e0: 29 0a 09 20 20 20 20 20 20 23 74 29 0a 20 20 20 ).. #t).
11f0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
1210: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
1220: 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d db:safely-close-
1230: 73 71 6c 69 74 65 33 2d 64 62 3a 20 22 20 64 62 sqlite3-db: " db
1240: 20 22 20 69 73 20 6e 6f 74 20 61 6e 20 73 71 6c " is not an sql
1250: 69 74 65 33 20 64 62 22 29 0a 09 20 20 20 20 20 ite3 db")..
1260: 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 29 #f. )
1270: 0a 20 20 20 20 20 20 20 20 29 29 29 29 0a 0a 3b . ))))..;
1280: 3b 20 63 6c 6f 73 65 20 61 6c 6c 20 6f 70 65 6e ; close all open
1290: 65 64 20 72 75 6e 2d 69 64 20 64 62 73 0a 28 64 ed run-id dbs.(d
12a0: 65 66 69 6e 65 20 28 64 62 3a 63 6c 6f 73 65 2d efine (db:close-
12b0: 61 6c 6c 20 64 62 73 74 72 75 63 74 29 0a 20 20 all dbstruct).
12c0: 28 69 66 20 28 64 62 72 3a 64 62 73 74 72 75 63 (if (dbr:dbstruc
12d0: 74 3f 20 64 62 73 74 72 75 63 74 29 0a 3b 3b 20 t? dbstruct).;;
12e0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
12f0: 6e 73 0a 3b 3b 20 09 20 20 65 78 6e 0a 3b 3b 20 ns.;; . exn.;;
1300: 09 20 20 28 62 65 67 69 6e 0a 3b 3b 20 09 20 20 . (begin.;; .
1310: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1320: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1330: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 46 69 rt* "WARNING: Fi
1340: 6e 61 6c 69 7a 69 6e 67 20 66 61 69 6c 65 64 2c nalizing failed,
1350: 20 22 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
1360: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
1370: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
1380: 20 65 78 6e 29 20 22 2c 20 6e 6f 74 65 20 2d 20 exn) ", note -
1390: 65 78 6e 3d 22 20 65 78 6e 29 0a 3b 3b 20 09 20 exn=" exn).;; .
13a0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
13b0: 68 61 69 6e 20 2a 64 65 66 61 75 6c 74 2d 6c 6f hain *default-lo
13c0: 67 2d 70 6f 72 74 2a 29 29 0a 09 3b 3b 20 28 64 g-port*))..;; (d
13d0: 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 b:sync-touched d
13e0: 62 73 74 72 75 63 74 20 30 20 66 6f 72 63 65 2d bstruct 0 force-
13f0: 73 79 6e 63 3a 20 23 74 29 20 3b 3b 20 4e 4f 2e sync: #t) ;; NO.
1400: 20 44 6f 20 6e 6f 74 20 64 6f 20 74 68 69 73 20 Do not do this
1410: 68 65 72 65 2e 20 49 6e 73 74 65 61 64 20 77 65 here. Instead we
1420: 20 72 65 6c 79 20 6f 6e 20 61 20 73 65 72 76 65 rely on a serve
1430: 72 20 74 6f 20 62 65 20 73 74 61 72 74 65 64 20 r to be started
1440: 77 68 65 6e 20 74 68 65 72 65 20 61 72 65 20 77 when there are w
1450: 72 69 74 65 73 2c 20 65 76 65 6e 20 69 66 20 74 rites, even if t
1460: 68 65 20 73 65 72 76 65 72 20 69 74 73 65 6c 66 he server itself
1470: 20 69 73 20 6e 6f 74 20 67 6f 69 6e 67 20 74 6f is not going to
1480: 20 62 65 20 75 73 65 64 20 61 73 20 61 20 73 65 be used as a se
1490: 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 28 6c rver.. (l
14a0: 65 74 2a 20 28 28 73 75 62 64 62 73 20 20 20 20 et* ((subdbs
14b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c (hash-table-val
14c0: 75 65 73 20 28 64 62 72 3a 64 62 73 74 72 75 63 ues (dbr:dbstruc
14d0: 74 2d 73 75 62 64 62 73 20 64 62 73 74 72 75 63 t-subdbs dbstruc
14e0: 74 29 29 29 29 0a 09 20 20 28 66 6f 72 2d 65 61 t)))).. (for-ea
14f0: 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 ch.. (lambda (
1500: 73 75 62 64 62 29 0a 09 20 20 20 20 20 28 6c 65 subdb).. (le
1510: 74 2a 20 28 28 74 64 62 73 20 20 20 20 20 20 20 t* ((tdbs
1520: 28 73 74 61 63 6b 2d 3e 6c 69 73 74 20 28 64 62 (stack->list (db
1530: 72 3a 73 75 62 64 62 2d 64 62 73 74 61 63 6b 20 r:subdb-dbstack
1540: 73 75 62 64 62 29 29 29 0a 09 09 20 20 20 20 28 subdb)))... (
1550: 6d 74 64 62 64 61 74 20 20 20 20 28 64 62 72 3a mtdbdat (dbr:
1560: 64 62 64 61 74 2d 64 62 68 20 28 64 62 72 3a 73 dbdat-dbh (dbr:s
1570: 75 62 64 62 2d 6d 74 64 62 64 61 74 20 73 75 62 ubdb-mtdbdat sub
1580: 64 62 29 29 29 0a 09 09 20 20 20 20 23 3b 28 72 db)))... #;(r
1590: 64 62 20 20 20 20 20 20 20 20 28 64 62 72 3a 64 db (dbr:d
15a0: 62 64 61 74 2d 64 62 68 20 28 64 62 72 3a 73 75 bdat-dbh (dbr:su
15b0: 62 64 62 2d 72 65 66 6e 64 62 20 73 75 62 64 62 bdb-refndb subdb
15c0: 29 29 29 29 0a 09 09 20 20 20 20 0a 09 20 20 20 ))))... ..
15d0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
15e0: 20 28 64 62 64 61 74 29 0a 09 09 20 20 20 20 20 (dbdat)...
15f0: 20 28 6c 65 74 2a 20 28 28 73 74 6d 74 2d 63 61 (let* ((stmt-ca
1600: 63 68 65 20 28 64 62 72 3a 64 62 64 61 74 2d 73 che (dbr:dbdat-s
1610: 74 6d 74 2d 63 61 63 68 65 20 64 62 64 61 74 29 tmt-cache dbdat)
1620: 29 0a 09 09 09 20 20 20 20 20 28 64 62 68 20 20 ).... (dbh
1630: 20 20 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 (dbr:dbdat
1640: 2d 64 62 68 20 20 20 20 20 20 20 20 64 62 64 61 -dbh dbda
1650: 74 29 29 29 0a 09 09 09 28 64 62 3a 73 61 66 65 t)))....(db:safe
1660: 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 ly-close-sqlite3
1670: 2d 64 62 20 64 62 68 20 73 74 6d 74 2d 63 61 63 -db dbh stmt-cac
1680: 68 65 29 29 29 0a 09 09 20 20 20 20 74 64 62 73 he)))... tdbs
1690: 29 0a 09 20 20 20 20 20 20 20 28 64 62 3a 73 61 ).. (db:sa
16a0: 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 fely-close-sqlit
16b0: 65 33 2d 64 62 20 6d 74 64 62 64 61 74 20 28 64 e3-db mtdbdat (d
16c0: 62 72 3a 64 62 64 61 74 2d 73 74 6d 74 2d 63 61 br:dbdat-stmt-ca
16d0: 63 68 65 20 20 28 64 62 72 3a 73 75 62 64 62 2d che (dbr:subdb-
16e0: 6d 74 64 62 64 61 74 20 73 75 62 64 62 29 29 29 mtdbdat subdb)))
16f0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1700: 20 3b 3b 20 28 69 66 20 28 73 71 6c 69 74 65 33 ;; (if (sqlite3
1710: 3a 64 61 74 61 62 61 73 65 3f 20 6d 64 62 29 20 :database? mdb)
1720: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
1730: 65 21 20 6d 64 62 29 29 0a 09 20 20 20 20 20 20 e! mdb))..
1740: 20 23 3b 28 64 62 3a 73 61 66 65 6c 79 2d 63 6c #;(db:safely-cl
1750: 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 72 ose-sqlite3-db r
1760: 64 62 20 23 66 29 29 29 20 3b 3b 20 73 74 6d 74 db #f))) ;; stmt
1770: 2d 63 61 63 68 65 29 29 29 29 29 20 3b 3b 20 28 -cache))))) ;; (
1780: 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 if (sqlite3:data
1790: 62 61 73 65 3f 20 72 64 62 29 20 28 73 71 6c 69 base? rdb) (sqli
17a0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 72 64 te3:finalize! rd
17b0: 62 29 29 29 29 29 29 0a 09 20 20 20 73 75 62 64 b)))))).. subd
17c0: 62 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 23 bs). #
17d0: 74 0a 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 t. ).
17e0: 20 20 20 20 20 20 20 20 23 66 0a 20 20 29 0a 29 #f. ).)
17f0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c ..(define (dbfil
1800: 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 74 68 20 61 e:run-id->path a
1810: 70 61 74 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 path run-id). (
1820: 63 6f 6e 63 20 61 70 61 74 68 22 2f 22 28 64 62 conc apath"/"(db
1830: 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e file:run-id->dbn
1840: 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 ame run-id)))..(
1850: 64 65 66 69 6e 65 20 28 64 62 3a 64 62 6e 61 6d define (db:dbnam
1860: 65 2d 3e 70 61 74 68 20 61 70 61 74 68 20 64 62 e->path apath db
1870: 6e 61 6d 65 29 0a 20 20 28 63 6f 6e 63 20 61 70 name). (conc ap
1880: 61 74 68 22 2f 22 64 62 6e 61 6d 65 29 29 0a 0a ath"/"dbname))..
1890: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
18a0: 72 75 6e 2d 69 64 2d 3e 64 62 6e 75 6d 20 72 75 run-id->dbnum ru
18b0: 6e 2d 69 64 29 0a 20 20 28 63 6f 6e 64 0a 20 20 n-id). (cond.
18c0: 20 28 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 ((number? run-i
18d0: 64 29 0a 20 20 20 20 28 6d 6f 64 75 6c 6f 20 72 d). (modulo r
18e0: 75 6e 2d 69 64 20 28 6e 75 6d 2d 72 75 6e 2d 64 un-id (num-run-d
18f0: 62 73 29 29 29 0a 20 20 20 28 28 6e 6f 74 20 72 bs))). ((not r
1900: 75 6e 2d 69 64 29 20 22 6d 61 69 6e 22 29 20 20 un-id) "main")
1910: 20 3b 3b 20 30 20 6f 72 20 6d 61 69 6e 3f 0a 20 ;; 0 or main?.
1920: 20 20 28 65 6c 73 65 20 72 75 6e 2d 69 64 29 29 (else run-id))
1930: 29 0a 0a 3b 3b 20 50 4f 54 45 4e 54 49 41 4c 20 )..;; POTENTIAL
1940: 42 55 47 3a 20 74 68 69 73 20 69 6d 70 6c 65 6d BUG: this implem
1950: 65 6e 74 61 74 69 6f 6e 20 63 6f 75 6c 64 20 70 entation could p
1960: 72 6f 64 75 63 65 20 61 20 64 62 20 66 69 6c 65 roduce a db file
1970: 20 69 66 20 72 75 6e 2d 69 64 20 69 73 20 6e 65 if run-id is ne
1980: 69 74 68 65 72 20 23 66 20 6f 72 20 61 20 6e 75 ither #f or a nu
1990: 6d 62 65 72 0a 28 64 65 66 69 6e 65 20 28 64 62 mber.(define (db
19a0: 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e file:run-id->dbn
19b0: 61 6d 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 63 ame run-id). (c
19c0: 6f 6e 63 20 22 2e 6d 65 67 61 74 65 73 74 2f 22 onc ".megatest/"
19d0: 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e (dbfile:run-id->
19e0: 64 62 6e 75 6d 20 72 75 6e 2d 69 64 29 22 2e 64 dbnum run-id)".d
19f0: 62 22 29 29 0a 0a 3b 3b 20 4d 61 6b 65 20 74 68 b"))..;; Make th
1a00: 65 20 64 62 73 74 72 75 63 74 2c 20 73 65 74 75 e dbstruct, setu
1a10: 70 20 75 70 20 61 75 78 69 6c 6c 61 72 79 20 64 p up auxillary d
1a20: 62 27 73 20 61 6e 64 20 63 61 6c 6c 20 66 6f 72 b's and call for
1a30: 20 6d 61 69 6e 20 64 62 20 61 74 20 6c 65 61 73 main db at leas
1a40: 74 20 6f 6e 63 65 0a 3b 3b 0a 3b 3b 20 63 61 6c t once.;;.;; cal
1a50: 6c 65 64 20 69 6e 20 68 74 74 70 2d 74 72 61 6e led in http-tran
1a60: 73 70 6f 72 74 20 61 6e 64 20 72 65 70 6c 69 63 sport and replic
1a70: 61 74 65 64 20 69 6e 20 72 6d 74 2e 73 63 6d 20 ated in rmt.scm
1a80: 66 6f 72 20 2a 6c 6f 63 61 6c 2a 20 61 63 63 65 for *local* acce
1a90: 73 73 2e 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ss. .;;.(define
1aa0: 28 64 62 66 69 6c 65 3a 73 65 74 75 70 20 64 6f (dbfile:setup do
1ab0: 2d 73 79 6e 63 20 61 72 65 61 70 61 74 68 20 74 -sync areapath t
1ac0: 6d 70 70 61 74 68 29 0a 20 20 28 63 6f 6e 64 0a mppath). (cond.
1ad0: 20 20 20 28 2a 64 62 73 74 72 75 63 74 2d 64 62 (*dbstruct-db
1ae0: 73 2a 0a 20 20 20 20 28 64 62 66 69 6c 65 3a 70 s*. (dbfile:p
1af0: 72 69 6e 74 2d 65 72 72 20 22 57 41 52 4e 49 4e rint-err "WARNIN
1b00: 47 3a 20 64 62 66 69 6c 65 3a 73 65 74 75 70 20 G: dbfile:setup
1b10: 63 61 6c 6c 65 64 20 77 68 65 6e 20 2a 64 62 73 called when *dbs
1b20: 74 72 75 63 74 2d 64 62 73 2a 20 69 73 20 61 6c truct-dbs* is al
1b30: 72 65 61 64 79 20 69 6e 69 74 69 61 6c 69 7a 65 ready initialize
1b40: 64 22 29 0a 20 20 20 20 2a 64 62 73 74 72 75 63 d"). *dbstruc
1b50: 74 2d 64 62 73 2a 29 20 3b 3b 20 54 4f 44 4f 3a t-dbs*) ;; TODO:
1b60: 20 77 68 65 6e 20 6d 75 6c 74 69 70 6c 65 20 61 when multiple a
1b70: 72 65 61 73 20 61 72 65 20 73 75 70 70 6f 72 74 reas are support
1b80: 65 64 2c 20 74 68 69 73 20 6f 70 74 69 6d 69 7a ed, this optimiz
1b90: 61 74 69 6f 6e 20 77 69 6c 6c 20 62 65 20 61 20 ation will be a
1ba0: 68 61 7a 61 72 64 0a 20 20 20 28 65 6c 73 65 0a hazard. (else.
1bb0: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 62 73 74 (let* ((dbst
1bc0: 72 75 63 74 20 28 6d 61 6b 65 2d 64 62 72 3a 64 ruct (make-dbr:d
1bd0: 62 73 74 72 75 63 74 20 61 72 65 61 70 61 74 68 bstruct areapath
1be0: 3a 20 61 72 65 61 70 61 74 68 20 74 6d 70 70 61 : areapath tmppa
1bf0: 74 68 3a 20 74 6d 70 70 61 74 68 29 29 29 0a 20 th: tmppath))).
1c00: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 73 74 (set! *dbst
1c10: 72 75 63 74 2d 64 62 73 2a 20 64 62 73 74 72 75 ruct-dbs* dbstru
1c20: 63 74 29 0a 20 20 20 20 20 20 64 62 73 74 72 75 ct). dbstru
1c30: 63 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ct))))..(define
1c40: 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 (dbfile:get-subd
1c50: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
1c60: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 66 d). (let* ((dbf
1c70: 6e 61 6d 65 20 28 64 62 66 69 6c 65 3a 72 75 6e name (dbfile:run
1c80: 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d -id->dbname run-
1c90: 69 64 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d id))). (hash-
1ca0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1cb0: 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d t (dbr:dbstruct-
1cc0: 73 75 62 64 62 73 20 64 62 73 74 72 75 63 74 29 subdbs dbstruct)
1cd0: 20 64 62 66 6e 61 6d 65 20 23 66 29 29 29 0a 0a dbfname #f)))..
1ce0: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
1cf0: 73 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 set-subdb dbstru
1d00: 63 74 20 72 75 6e 2d 69 64 20 73 75 62 64 62 29 ct run-id subdb)
1d10: 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
1d20: 65 74 21 20 28 64 62 72 3a 64 62 73 74 72 75 63 et! (dbr:dbstruc
1d30: 74 2d 73 75 62 64 62 73 20 64 62 73 74 72 75 63 t-subdbs dbstruc
1d40: 74 29 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 t) (dbfile:run-i
1d50: 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 d->dbname run-id
1d60: 29 20 73 75 62 64 62 29 29 0a 0a 3b 3b 20 28 64 ) subdb))..;; (d
1d70: 65 66 69 6e 65 20 2a 64 62 66 69 6c 65 3a 6e 75 efine *dbfile:nu
1d80: 6d 2d 68 61 6e 64 6c 65 73 2d 69 6e 2d 75 73 65 m-handles-in-use
1d90: 2a 20 30 29 0a 0a 3b 3b 20 47 65 74 2f 6f 70 65 * 0)..;; Get/ope
1da0: 6e 20 61 20 64 61 74 61 62 61 73 65 2e 0a 3b 3b n a database..;;
1db0: 0a 3b 3b 20 20 20 20 4e 4f 54 45 3a 20 6d 6f 73 .;; NOTE: mos
1dc0: 74 20 75 73 61 67 65 20 73 68 6f 75 6c 64 20 63 t usage should c
1dd0: 61 6c 6c 20 64 62 66 69 6c 65 3a 6f 70 65 6e 2d all dbfile:open-
1de0: 64 62 20 74 6f 20 67 65 74 20 61 20 64 62 64 61 db to get a dbda
1df0: 74 0a 3b 3b 0a 3b 3b 20 20 20 20 69 66 20 72 75 t.;;.;; if ru
1e00: 6e 2d 69 64 20 3d 3e 20 67 65 74 20 72 75 6e 20 n-id => get run
1e10: 73 70 65 63 69 66 69 63 20 64 62 0a 3b 3b 20 20 specific db.;;
1e20: 20 20 69 66 20 23 66 20 20 20 20 20 3d 3e 20 67 if #f => g
1e30: 65 74 20 6d 61 69 6e 20 64 62 0a 3b 3b 20 20 20 et main db.;;
1e40: 20 69 66 20 72 75 6e 2d 69 64 20 69 73 20 61 20 if run-id is a
1e50: 73 74 72 69 6e 67 20 74 72 65 61 74 20 69 74 20 string treat it
1e60: 61 73 20 61 20 66 69 6c 65 6e 61 6d 65 20 2d 20 as a filename -
1e70: 44 4f 4e 27 54 20 75 73 65 20 74 68 69 73 20 2d DON'T use this -
1e80: 20 77 65 27 6c 6c 20 67 65 74 20 72 69 64 20 6f we'll get rid o
1e90: 66 20 69 74 2e 0a 3b 3b 20 20 20 20 69 66 20 64 f it..;; if d
1ea0: 62 20 61 6c 72 65 61 64 79 20 6f 70 65 6e 20 2d b already open -
1eb0: 20 72 65 74 75 72 6e 20 69 6e 6d 65 6d 0a 3b 3b return inmem.;;
1ec0: 20 20 20 20 69 66 20 64 62 20 6e 6f 74 20 6f 70 if db not op
1ed0: 65 6e 2c 20 6f 70 65 6e 20 69 6e 6d 65 6d 2c 20 en, open inmem,
1ee0: 72 75 6e 64 62 20 61 6e 64 20 73 79 6e 63 20 74 rundb and sync t
1ef0: 68 65 6e 20 72 65 74 75 72 6e 20 69 6e 6d 65 6d hen return inmem
1f00: 0a 3b 3b 20 20 20 20 69 6e 75 73 65 20 67 65 74 .;; inuse get
1f10: 73 20 73 65 74 20 61 75 74 6f 6d 61 74 69 63 61 s set automatica
1f20: 6c 6c 79 20 66 6f 72 20 72 75 6e 64 62 27 73 0a lly for rundb's.
1f30: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 ;;.(define (dbfi
1f40: 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 64 62 73 le:get-dbdat dbs
1f50: 74 72 75 63 74 20 72 75 6e 2d 69 64 29 0a 20 20 truct run-id).
1f60: 28 6c 65 74 2a 20 28 28 73 75 62 64 62 20 28 64 (let* ((subdb (d
1f70: 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 bfile:get-subdb
1f80: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 dbstruct run-id)
1f90: 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 61 63 )). (if (stac
1fa0: 6b 2d 65 6d 70 74 79 3f 20 28 64 62 72 3a 73 75 k-empty? (dbr:su
1fb0: 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 bdb-dbstack subd
1fc0: 62 29 29 0a 09 23 66 0a 09 28 62 65 67 69 6e 0a b))..#f..(begin.
1fd0: 09 20 20 28 73 74 61 63 6b 2d 70 6f 70 21 20 28 . (stack-pop! (
1fe0: 64 62 72 3a 73 75 62 64 62 2d 64 62 73 74 61 63 dbr:subdb-dbstac
1ff0: 6b 20 73 75 62 64 62 29 29 29 29 29 29 0a 0a 3b k subdb))))))..;
2000: 3b 20 72 65 74 75 72 6e 20 61 20 70 72 65 76 69 ; return a previ
2010: 6f 75 73 6c 79 20 6f 70 65 6e 65 64 20 64 62 20 ously opened db
2020: 68 61 6e 64 6c 65 20 74 6f 20 74 68 65 20 73 74 handle to the st
2030: 61 63 6b 20 6f 66 20 61 76 61 69 6c 61 62 6c 65 ack of available
2040: 20 68 61 6e 64 6c 65 73 0a 28 64 65 66 69 6e 65 handles.(define
2050: 20 28 64 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 (dbfile:add-dbd
2060: 61 74 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d at dbstruct run-
2070: 69 64 20 64 62 64 61 74 29 0a 20 20 28 6c 65 74 id dbdat). (let
2080: 2a 20 28 28 73 75 62 64 62 20 28 64 62 66 69 6c * ((subdb (dbfil
2090: 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 e:get-subdb dbst
20a0: 72 75 63 74 20 72 75 6e 2d 69 64 29 29 0a 09 20 ruct run-id))..
20b0: 28 64 62 73 74 6b 20 28 64 62 72 3a 73 75 62 64 (dbstk (dbr:subd
20c0: 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 62 29 b-dbstack subdb)
20d0: 29 0a 09 20 28 63 6f 75 6e 74 20 28 73 74 61 63 ).. (count (stac
20e0: 6b 2d 63 6f 75 6e 74 20 64 62 73 74 6b 29 29 29 k-count dbstk)))
20f0: 0a 20 20 20 20 28 69 66 20 28 3e 20 63 6f 75 6e . (if (> coun
2100: 74 20 31 35 29 0a 09 28 64 62 66 69 6c 65 3a 70 t 15)..(dbfile:p
2110: 72 69 6e 74 2d 65 72 72 20 22 57 41 52 4e 49 4e rint-err "WARNIN
2120: 47 3a 20 73 74 61 63 6b 20 66 6f 72 20 22 72 75 G: stack for "ru
2130: 6e 2d 69 64 22 2e 64 62 20 69 73 20 22 63 6f 75 n-id".db is "cou
2140: 6e 74 22 2e 22 29 29 0a 20 20 20 20 28 73 74 61 nt".")). (sta
2150: 63 6b 2d 70 75 73 68 21 20 64 62 73 74 6b 20 64 ck-push! dbstk d
2160: 62 64 61 74 29 0a 20 20 20 20 64 62 64 61 74 29 bdat). dbdat)
2170: 29 0a 0a 3b 3b 20 73 65 74 20 75 70 20 61 20 73 )..;; set up a s
2180: 75 62 64 62 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ubdb.;;.(define
2190: 28 64 62 66 69 6c 65 3a 69 6e 69 74 2d 73 75 62 (dbfile:init-sub
21a0: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
21b0: 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a 20 20 id init-proc).
21c0: 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 20 20 (let* ((dbname
21d0: 20 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 (dbfile:run-id
21e0: 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 29 ->dbname run-id)
21f0: 29 0a 09 20 28 61 72 65 61 70 61 74 68 20 20 28 ).. (areapath (
2200: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 61 72 65 dbr:dbstruct-are
2210: 61 70 61 74 68 20 64 62 73 74 72 75 63 74 29 29 apath dbstruct))
2220: 0a 09 20 28 74 6d 70 70 61 74 68 20 20 20 28 64 .. (tmppath (d
2230: 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d 70 70 br:dbstruct-tmpp
2240: 61 74 68 20 20 64 62 73 74 72 75 63 74 29 29 0a ath dbstruct)).
2250: 09 20 28 6d 74 64 62 70 61 74 68 20 20 28 64 62 . (mtdbpath (db
2260: 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 74 file:run-id->pat
2270: 68 20 61 72 65 61 70 61 74 68 20 72 75 6e 2d 69 h areapath run-i
2280: 64 29 29 0a 09 20 28 74 6d 70 64 62 70 61 74 68 d)).. (tmpdbpath
2290: 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d (dbfile:run-id-
22a0: 3e 70 61 74 68 20 74 6d 70 70 61 74 68 20 72 75 >path tmppath ru
22b0: 6e 2d 69 64 29 29 0a 09 20 28 6d 74 64 62 64 61 n-id)).. (mtdbda
22c0: 74 20 20 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e t (dbfile:open
22d0: 2d 73 71 6c 69 74 65 33 2d 64 62 20 6d 74 64 62 -sqlite3-db mtdb
22e0: 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 20 73 path init-proc s
22f0: 79 6e 63 2d 6d 6f 64 65 3a 20 30 20 6a 6f 75 72 ync-mode: 0 jour
2300: 6e 61 6c 2d 6d 6f 64 65 3a 20 23 66 29 29 20 3b nal-mode: #f)) ;
2310: 3b 20 22 57 41 4c 22 29 29 0a 09 20 28 6e 65 77 ; "WAL")).. (new
2320: 73 75 62 64 62 20 20 28 6d 61 6b 65 2d 64 62 72 subdb (make-dbr
2330: 3a 73 75 62 64 62 20 64 62 6e 61 6d 65 3a 20 20 :subdb dbname:
2340: 20 20 64 62 6e 61 6d 65 0a 09 09 09 09 20 20 20 dbname.....
2350: 20 6d 74 64 62 66 69 6c 65 3a 20 20 6d 74 64 62 mtdbfile: mtdb
2360: 70 61 74 68 0a 09 09 09 09 20 20 20 20 74 6d 70 path..... tmp
2370: 64 62 66 69 6c 65 3a 20 74 6d 70 64 62 70 61 74 dbfile: tmpdbpat
2380: 68 0a 09 09 09 09 20 20 20 20 6d 74 64 62 64 61 h..... mtdbda
2390: 74 3a 20 20 20 6d 74 64 62 64 61 74 29 29 29 0a t: mtdbdat))).
23a0: 20 20 20 20 28 64 62 66 69 6c 65 3a 73 65 74 2d (dbfile:set-
23b0: 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 subdb dbstruct r
23c0: 75 6e 2d 69 64 20 6e 65 77 73 75 62 64 62 29 0a un-id newsubdb).
23d0: 20 20 20 20 6e 65 77 73 75 62 64 62 29 29 20 3b newsubdb)) ;
23e0: 3b 20 72 65 74 75 72 6e 20 74 68 65 20 6e 65 77 ; return the new
23f0: 20 73 75 62 64 62 20 2d 20 62 75 74 20 73 68 6f subdb - but sho
2400: 75 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 75 73 uldn't really us
2410: 65 20 69 74 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 e it..;; returns
2420: 20 64 62 64 61 74 20 77 69 74 68 20 64 62 68 20 dbdat with dbh
2430: 61 6e 64 20 64 62 66 69 6c 65 70 61 74 68 0a 3b and dbfilepath.;
2440: 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 20 68 ;.;; NOTE: the h
2450: 61 6e 64 6c 65 20 69 73 20 6f 6e 20 2f 74 6d 70 andle is on /tmp
2460: 20 64 62 20 66 69 6c 65 21 0a 3b 3b 0a 3b 3b 20 db file!.;;.;;
2470: 20 31 2e 20 69 66 20 6e 65 65 64 65 64 20 73 65 1. if needed se
2480: 74 75 70 20 74 68 65 20 73 75 62 64 62 20 66 6f tup the subdb fo
2490: 72 20 74 68 65 20 67 69 76 65 6e 20 72 75 6e 2d r the given run-
24a0: 69 64 0a 3b 3b 20 20 32 2e 20 69 66 20 74 68 65 id.;; 2. if the
24b0: 72 65 20 69 73 20 6e 6f 20 65 78 69 73 74 69 6e re is no existin
24c0: 67 20 64 62 20 68 61 6e 64 6c 65 20 69 6e 20 74 g db handle in t
24d0: 68 65 20 73 74 61 63 6b 0a 3b 3b 20 20 20 20 20 he stack.;;
24e0: 63 72 65 61 74 65 20 61 20 6e 65 77 20 68 61 6e create a new han
24f0: 64 6c 65 20 61 6e 64 20 72 65 74 75 72 6e 20 69 dle and return i
2500: 74 20 28 64 6f 20 4e 4f 54 20 61 64 64 0a 3b 3b t (do NOT add.;;
2510: 20 20 20 20 20 69 74 20 74 6f 20 74 68 65 20 73 it to the s
2520: 74 61 63 6b 29 2e 0a 3b 3b 0a 28 64 65 66 69 6e tack)..;;.(defin
2530: 65 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 e (dbfile:open-d
2540: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
2550: 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a 20 20 28 d init-proc). (
2560: 6c 65 74 2a 20 28 28 73 75 62 64 62 20 28 64 62 let* ((subdb (db
2570: 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 64 file:get-subdb d
2580: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 29 bstruct run-id))
2590: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 ). (if (not s
25a0: 75 62 64 62 29 20 3b 3b 20 6e 6f 74 20 79 65 74 ubdb) ;; not yet
25b0: 20 64 65 66 69 6e 65 64 0a 09 28 62 65 67 69 6e defined..(begin
25c0: 0a 09 20 20 28 64 62 66 69 6c 65 3a 69 6e 69 74 .. (dbfile:init
25d0: 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 -subdb dbstruct
25e0: 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 run-id init-proc
25f0: 29 0a 09 20 20 28 64 62 66 69 6c 65 3a 6f 70 65 ).. (dbfile:ope
2600: 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 n-db dbstruct ru
2610: 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 29 n-id init-proc))
2620: 0a 09 28 6c 65 74 2a 20 28 28 64 62 64 61 74 20 ..(let* ((dbdat
2630: 28 64 62 66 69 6c 65 3a 67 65 74 2d 64 62 64 61 (dbfile:get-dbda
2640: 74 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 t dbstruct run-i
2650: 64 29 29 29 0a 09 20 20 28 69 66 20 64 62 64 61 d))).. (if dbda
2660: 74 0a 09 20 20 20 20 20 20 64 62 64 61 74 0a 09 t.. dbdat..
2670: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 6d (let* ((tm
2680: 70 70 61 74 68 20 20 20 28 64 62 72 3a 64 62 73 ppath (dbr:dbs
2690: 74 72 75 63 74 2d 74 6d 70 70 61 74 68 20 20 64 truct-tmppath d
26a0: 62 73 74 72 75 63 74 29 29 0a 09 09 20 20 20 20 bstruct))...
26b0: 20 28 74 6d 70 64 62 70 61 74 68 20 28 64 62 66 (tmpdbpath (dbf
26c0: 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 74 68 ile:run-id->path
26d0: 20 74 6d 70 70 61 74 68 20 72 75 6e 2d 69 64 29 tmppath run-id)
26e0: 29 0a 09 09 20 20 20 20 20 28 64 62 64 61 74 20 )... (dbdat
26f0: 20 20 20 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e (dbfile:open
2700: 2d 73 71 6c 69 74 65 33 2d 64 62 20 74 6d 70 64 -sqlite3-db tmpd
2710: 62 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 20 bpath init-proc
2720: 73 79 6e 63 2d 6d 6f 64 65 3a 20 30 20 6a 6f 75 sync-mode: 0 jou
2730: 72 6e 61 6c 2d 6d 6f 64 65 3a 20 22 57 41 4c 22 rnal-mode: "WAL"
2740: 29 29 29 0a 09 09 3b 3b 20 74 68 65 20 66 6f 6c )))...;; the fol
2750: 6c 6f 77 69 6e 67 20 6c 69 6e 65 20 73 68 6f 72 lowing line shor
2760: 74 2d 63 69 72 63 75 69 74 73 20 74 68 65 20 22 t-circuits the "
2770: 6f 6e 65 20 64 62 20 68 61 6e 64 6c 65 20 70 65 one db handle pe
2780: 72 20 74 68 72 65 61 64 22 20 6d 6f 64 65 6c 0a r thread" model.
2790: 09 09 3b 3b 20 0a 09 09 3b 3b 20 28 64 62 66 69 ..;; ...;; (dbfi
27a0: 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 62 73 le:add-dbdat dbs
27b0: 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 64 truct run-id dbd
27c0: 61 74 29 0a 09 09 3b 3b 0a 09 09 64 62 64 61 74 at)...;;...dbdat
27d0: 29 29 29 29 29 29 0a 20 20 20 20 0a 3b 3b 20 43 )))))). .;; C
27e0: 4f 4d 42 49 4e 45 20 64 62 66 69 6c 65 3a 6f 70 OMBINE dbfile:op
27f0: 65 6e 2d 73 71 6c 69 74 65 2d 64 62 20 61 6e 64 en-sqlite-db and
2800: 20 64 62 66 69 6c 65 3a 6c 6f 63 6b 2d 63 72 65 dbfile:lock-cre
2810: 61 74 65 2d 6f 70 65 6e 0a 3b 3b 0a 0a 3b 3b 20 ate-open.;;..;;
2820: 74 68 69 73 20 73 74 75 66 66 20 69 73 20 66 6f this stuff is fo
2830: 72 20 69 6e 69 74 69 61 6c 20 64 65 62 75 67 67 r initial debugg
2840: 69 6e 67 2c 20 70 6c 65 61 73 65 20 72 65 6d 6f ing, please remo
2850: 76 65 20 69 74 20 77 68 65 6e 0a 3b 3b 20 74 68 ve it when.;; th
2860: 69 73 20 63 6f 64 65 20 73 74 61 62 69 6c 69 7a is code stabiliz
2870: 65 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 6f 70 es.(define *dbop
2880: 65 6e 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d ens* (make-hash-
2890: 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 table)).(define
28a0: 28 64 62 66 69 6c 65 3a 69 6e 63 2d 64 62 2d 6f (dbfile:inc-db-o
28b0: 70 65 6e 20 64 62 66 69 6c 65 29 0a 20 20 28 6c pen dbfile). (l
28c0: 65 74 2a 20 28 28 63 75 72 72 2d 6f 70 65 6e 73 et* ((curr-opens
28d0: 2d 63 6f 75 6e 74 20 28 2b 20 28 68 61 73 68 2d -count (+ (hash-
28e0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
28f0: 74 20 2a 64 62 6f 70 65 6e 73 2a 20 64 62 66 69 t *dbopens* dbfi
2900: 6c 65 20 30 29 20 31 29 29 29 0a 20 20 20 20 28 le 0) 1))). (
2910: 69 66 20 28 61 6e 64 20 28 3e 20 63 75 72 72 2d if (and (> curr-
2920: 6f 70 65 6e 73 2d 63 6f 75 6e 74 20 31 29 20 3b opens-count 1) ;
2930: 3b 20 74 68 69 73 20 73 68 6f 75 6c 64 20 4e 4f ; this should NO
2940: 54 20 62 65 20 68 61 70 70 65 6e 69 6e 67 0a 09 T be happening..
2950: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (common:low
2960: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 35 20 -noise-print 15
2970: 22 64 62 2d 6f 70 65 6e 73 22 29 29 0a 09 28 64 "db-opens"))..(d
2980: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
2990: 22 49 4e 46 4f 3a 20 64 62 20 22 64 62 66 69 6c "INFO: db "dbfil
29a0: 65 22 20 68 61 73 20 62 65 65 6e 20 6f 70 65 6e e" has been open
29b0: 65 64 20 22 63 75 72 72 2d 6f 70 65 6e 73 2d 63 ed "curr-opens-c
29c0: 6f 75 6e 74 22 20 74 69 6d 65 73 21 22 29 29 0a ount" times!")).
29d0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
29e0: 73 65 74 21 20 2a 64 62 6f 70 65 6e 73 2a 20 64 set! *dbopens* d
29f0: 62 66 69 6c 65 20 63 75 72 72 2d 6f 70 65 6e 73 bfile curr-opens
2a00: 2d 63 6f 75 6e 74 29 0a 20 20 20 20 63 75 72 72 -count). curr
2a10: 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 29 29 0a 0a -opens-count))..
2a20: 3b 3b 20 4f 70 65 6e 20 74 68 65 20 63 6c 61 73 ;; Open the clas
2a30: 73 69 63 20 6d 65 67 61 74 65 73 74 2e 64 62 20 sic megatest.db
2a40: 66 69 6c 65 20 28 64 65 66 61 75 6c 74 73 20 74 file (defaults t
2a50: 6f 20 6f 70 65 6e 20 69 6e 20 74 6f 70 70 61 74 o open in toppat
2a60: 68 29 0a 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a h).;;.;; NOTE:
2a70: 20 72 65 74 75 72 6e 73 20 61 20 64 62 64 61 74 returns a dbdat
2a80: 20 6e 6f 74 20 61 20 64 62 73 74 72 75 63 74 21 not a dbstruct!
2a90: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 .;;.(define (dbf
2aa0: 69 6c 65 3a 6f 70 65 6e 2d 73 71 6c 69 74 65 33 ile:open-sqlite3
2ab0: 2d 64 62 20 64 62 70 61 74 68 20 69 6e 69 74 2d -db dbpath init-
2ac0: 70 72 6f 63 20 23 21 6b 65 79 20 28 73 79 6e 63 proc #!key (sync
2ad0: 2d 6d 6f 64 65 20 30 29 28 6a 6f 75 72 6e 61 6c -mode 0)(journal
2ae0: 2d 6d 6f 64 65 20 23 66 29 29 0a 20 20 28 6c 65 -mode #f)). (le
2af0: 74 2a 20 28 28 64 62 65 78 69 73 74 73 20 20 20 t* ((dbexists
2b00: 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 (file-exists?
2b10: 64 62 70 61 74 68 29 29 0a 09 20 28 77 72 69 74 dbpath)).. (writ
2b20: 65 2d 61 63 63 65 73 73 20 28 66 69 6c 65 2d 77 e-access (file-w
2b30: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 70 rite-access? dbp
2b40: 61 74 68 29 29 0a 09 20 28 64 62 20 20 20 20 20 ath)).. (db
2b50: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 63 61 (dbfile:ca
2b60: 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 utious-open-data
2b70: 62 61 73 65 20 64 62 70 61 74 68 20 69 6e 69 74 base dbpath init
2b80: 2d 70 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 20 -proc sync-mode
2b90: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 29 29 29 0a journal-mode))).
2ba0: 20 20 20 20 28 64 62 66 69 6c 65 3a 69 6e 63 2d (dbfile:inc-
2bb0: 64 62 2d 6f 70 65 6e 20 64 62 70 61 74 68 29 0a db-open dbpath).
2bc0: 20 20 20 20 3b 3b 20 28 69 6e 69 74 2d 70 72 6f ;; (init-pro
2bd0: 63 20 64 62 29 0a 20 20 20 20 28 6d 61 6b 65 2d c db). (make-
2be0: 64 62 72 3a 64 62 64 61 74 20 64 62 66 69 6c 65 dbr:dbdat dbfile
2bf0: 3a 20 64 62 70 61 74 68 20 64 62 68 3a 20 64 62 : dbpath dbh: db
2c00: 20 72 65 61 64 2d 6f 6e 6c 79 3a 20 28 6e 6f 74 read-only: (not
2c10: 20 77 72 69 74 65 2d 61 63 63 65 73 73 29 29 29 write-access)))
2c20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 )..(define (dbfi
2c30: 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 2d 65 78 69 le:print-and-exi
2c40: 74 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 77 t . params). (w
2c50: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
2c60: 72 74 0a 20 20 20 20 20 20 28 63 75 72 72 65 6e rt. (curren
2c70: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 20 20 t-error-port).
2c80: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
2c90: 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 (apply print
2ca0: 70 61 72 61 6d 73 29 29 29 0a 20 20 28 65 78 69 params))). (exi
2cb0: 74 20 31 29 29 0a 20 20 20 20 0a 28 64 65 66 69 t 1)). .(defi
2cc0: 6e 65 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 ne (dbfile:print
2cd0: 2d 65 72 72 20 2e 20 70 61 72 61 6d 73 29 0a 20 -err . params).
2ce0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
2cf0: 2d 70 6f 72 74 0a 20 20 20 20 20 20 28 63 75 72 -port. (cur
2d00: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
2d10: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
2d20: 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 (apply pri
2d30: 6e 74 20 70 61 72 61 6d 73 29 29 29 29 0a 0a 28 nt params))))..(
2d40: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 63 define (dbfile:c
2d50: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
2d60: 61 62 61 73 65 20 66 6e 61 6d 65 20 69 6e 69 74 abase fname init
2d70: 2d 70 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 20 -proc sync-mode
2d80: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 20 23 21 6f journal-mode #!o
2d90: 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 73 2d 6c ptional (tries-l
2da0: 65 66 74 20 35 30 30 29 29 0a 20 20 28 6c 65 74 eft 500)). (let
2db0: 2a 20 28 28 62 75 73 79 2d 66 69 6c 65 20 20 28 * ((busy-file (
2dc0: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2d 6a 6f 75 conc fname "-jou
2dd0: 72 6e 61 6c 22 29 29 0a 09 20 28 64 65 6c 61 79 rnal")).. (delay
2de0: 2d 74 69 6d 65 20 28 2a 20 28 2d 20 35 31 20 74 -time (* (- 51 t
2df0: 72 69 65 73 2d 6c 65 66 74 29 20 31 2e 31 29 29 ries-left) 1.1))
2e00: 0a 20 20 20 20 20 20 09 20 28 77 72 69 74 65 2d . . (write-
2e10: 61 63 63 65 73 73 20 28 66 69 6c 65 2d 77 72 69 access (file-wri
2e20: 74 65 2d 61 63 63 65 73 73 3f 20 66 6e 61 6d 65 te-access? fname
2e30: 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 69 72 )). (dir
2e40: 2d 61 63 63 65 73 73 20 28 66 69 6c 65 2d 77 72 -access (file-wr
2e50: 69 74 65 2d 61 63 63 65 73 73 3f 20 28 70 61 74 ite-access? (pat
2e60: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
2e70: 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 fname))).
2e80: 20 20 28 72 65 74 72 79 20 20 20 20 20 20 28 6c (retry (l
2e90: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 ambda ()...
2ea0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
2eb0: 20 64 65 6c 61 79 2d 74 69 6d 65 29 0a 09 09 20 delay-time)...
2ec0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 69 (if (> tri
2ed0: 65 73 2d 6c 65 66 74 20 30 29 0a 09 09 09 20 20 es-left 0)....
2ee0: 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 (dbfile:cautiou
2ef0: 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 s-open-database
2f00: 66 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 0a fname init-proc.
2f10: 09 09 09 09 09 09 09 20 20 73 79 6e 63 2d 6d 6f ....... sync-mo
2f20: 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 0a de journal-mode.
2f30: 09 09 09 09 09 09 09 20 20 28 2d 20 74 72 69 65 ....... (- trie
2f40: 73 2d 6c 65 66 74 20 31 29 29 29 29 29 29 0a 20 s-left 1)))))).
2f50: 20 20 20 28 61 73 73 65 72 74 20 28 3e 3d 20 74 (assert (>= t
2f60: 72 69 65 73 2d 6c 65 66 74 20 30 29 20 28 63 6f ries-left 0) (co
2f70: 6e 63 20 22 46 41 54 41 4c 3a 20 74 6f 6f 20 6d nc "FATAL: too m
2f80: 61 6e 79 20 61 74 74 65 6d 70 74 73 20 69 6e 20 any attempts in
2f90: 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d dbfile:cautious-
2fa0: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 6f 66 open-database of
2fb0: 20 22 66 6e 61 6d 65 22 2c 20 67 69 76 69 6e 67 "fname", giving
2fc0: 20 75 70 2e 22 29 29 0a 20 20 20 20 0a 20 20 20 up.")). .
2fd0: 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d (if (and (file-
2fe0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 6e write-access? fn
2ff0: 61 6d 65 29 0a 09 20 20 20 20 20 28 66 69 6c 65 ame).. (file
3000: 2d 65 78 69 73 74 73 3f 20 62 75 73 79 2d 66 69 -exists? busy-fi
3010: 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 le))..(begin..
3020: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
3030: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 noise-print 120
3040: 62 75 73 79 2d 66 69 6c 65 29 0a 09 20 20 20 20 busy-file)..
3050: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
3060: 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 66 69 6c err "INFO: dbfil
3070: 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d e:cautious-open-
3080: 64 61 74 61 62 61 73 65 3a 20 6a 6f 75 72 6e 61 database: journa
3090: 6c 20 66 69 6c 65 20 22 0a 09 09 09 09 62 75 73 l file ".....bus
30a0: 79 2d 66 69 6c 65 22 20 65 78 69 73 74 73 2c 20 y-file" exists,
30b0: 74 72 79 69 6e 67 20 61 67 61 69 6e 20 69 6e 20 trying again in
30c0: 66 65 77 20 73 65 63 6f 6e 64 73 2e 22 29 29 0a few seconds.")).
30d0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
30e0: 21 20 31 29 0a 09 20 20 28 69 66 20 28 65 71 3f ! 1).. (if (eq?
30f0: 20 74 72 69 65 73 2d 6c 65 66 74 20 32 29 0a 09 tries-left 2)..
3100: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 (begin..
3110: 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 .(dbfile:print-e
3120: 72 72 20 22 49 4e 46 4f 3a 20 66 6f 72 63 69 6e rr "INFO: forcin
3130: 67 20 6a 6f 75 72 6e 61 6c 20 72 6f 6c 6c 75 70 g journal rollup
3140: 20 22 62 75 73 79 2d 66 69 6c 65 29 0a 09 20 20 "busy-file)..
3150: 09 28 64 62 66 69 6c 65 3a 62 72 75 74 65 2d 66 .(dbfile:brute-f
3160: 6f 72 63 65 2d 73 61 6c 76 61 67 65 2d 64 62 20 orce-salvage-db
3170: 66 6e 61 6d 65 29 29 29 0a 09 20 20 28 64 62 66 fname))).. (dbf
3180: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
3190: 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 n-database fname
31a0: 20 69 6e 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d init-proc sync-
31b0: 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 mode journal-mod
31c0: 65 20 28 2d 20 74 72 69 65 73 2d 6c 65 66 74 20 e (- tries-left
31d0: 31 29 29 29 0a 09 0a 09 28 6c 65 74 2a 20 28 28 1)))....(let* ((
31e0: 72 65 73 75 6c 74 20 28 63 6f 6e 64 69 74 69 6f result (conditio
31f0: 6e 2d 63 61 73 65 0a 09 09 20 20 20 20 20 20 20 n-case...
3200: 20 28 69 66 20 64 69 72 2d 61 63 63 65 73 73 0a (if dir-access.
3210: 09 09 09 20 20 20 20 28 64 62 66 69 6c 65 3a 77 ... (dbfile:w
3220: 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 6c 65 2d ith-simple-file-
3230: 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 28 63 6f lock.... (co
3240: 6e 63 20 66 6e 61 6d 65 20 22 2e 6c 6f 63 6b 22 nc fname ".lock"
3250: 29 0a 09 09 09 20 20 20 20 20 28 6c 61 6d 62 64 ).... (lambd
3260: 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 20 28 a ().... (
3270: 6c 65 74 2a 20 28 28 64 62 2d 65 78 69 73 74 73 let* ((db-exists
3280: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
3290: 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 20 20 20 name)).....
32a0: 20 28 64 62 20 20 20 20 20 20 20 20 28 73 71 6c (db (sql
32b0: 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 ite3:open-databa
32c0: 73 65 20 66 6e 61 6d 65 29 29 29 20 3b 3b 20 63 se fname))) ;; c
32d0: 72 65 61 74 65 73 20 61 6e 20 65 6d 70 74 79 20 reates an empty
32e0: 64 62 20 69 66 20 69 74 20 64 69 64 20 6e 6f 74 db if it did not
32f0: 20 61 6c 72 65 61 64 79 20 65 78 69 73 74 2e 0a already exist..
3300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3320: 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 (sqlite3:set-bu
3330: 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 sy-handler! db (
3340: 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 sqlite3:make-bus
3350: 79 2d 74 69 6d 65 6f 75 74 20 33 30 30 30 30 29 y-timeout 30000)
3360: 29 0a 09 09 09 09 20 28 69 66 20 73 79 6e 63 2d )..... (if sync-
3370: 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 20 28 73 mode..... (s
3380: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
3390: 62 20 28 63 6f 6e 63 20 22 50 52 41 47 4d 41 20 b (conc "PRAGMA
33a0: 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 22 73 synchronous = "s
33b0: 79 6e 63 2d 6d 6f 64 65 22 3b 22 29 29 29 0a 09 ync-mode";")))..
33c0: 09 09 09 20 28 69 66 20 6a 6f 75 72 6e 61 6c 2d ... (if journal-
33d0: 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 20 28 73 mode..... (s
33e0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
33f0: 62 20 28 63 6f 6e 63 20 22 50 52 41 47 4d 41 20 b (conc "PRAGMA
3400: 6a 6f 75 72 6e 61 6c 5f 6d 6f 64 65 20 3d 20 22 journal_mode = "
3410: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 22 3b 22 29 journal-mode";")
3420: 29 29 0a 09 09 09 09 20 28 69 66 20 28 61 6e 64 ))..... (if (and
3430: 20 69 6e 69 74 2d 70 72 6f 63 20 28 6e 6f 74 20 init-proc (not
3440: 64 62 2d 65 78 69 73 74 73 29 29 0a 09 09 09 09 db-exists)).....
3450: 20 20 20 20 20 28 69 6e 69 74 2d 70 72 6f 63 20 (init-proc
3460: 64 62 29 29 0a 09 09 09 09 20 64 62 29 29 29 0a db))..... db))).
3470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3480: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
3490: 69 6e 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 in.... (if
34a0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e (file-exists? fn
34b0: 61 6d 65 20 29 0a 20 20 20 20 20 20 20 20 20 20 ame ).
34c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
34d0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 (let ((d
34e0: 62 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d b (sqlite3:open-
34f0: 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 29 29 database fname))
3500: 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 70 72 61 )..... ;; pra
3510: 67 6d 61 73 20 73 79 6e 63 68 72 6f 6e 6f 75 73 gmas synchronous
3520: 20 6e 6f 74 20 6e 65 65 64 65 64 20 62 65 63 61 not needed beca
3530: 75 73 65 20 74 68 69 73 20 64 62 20 69 73 20 75 use this db is u
3540: 73 65 64 20 72 65 61 64 2d 6f 6e 6c 79 0a 09 09 sed read-only...
3550: 09 09 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 .. ;; (sqlite
3560: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
3570: 6e 63 20 22 50 52 41 47 4d 41 20 73 79 6e 63 68 nc "PRAGMA synch
3580: 72 6f 6e 6f 75 73 20 3d 20 22 6d 6f 64 65 22 3b ronous = "mode";
3590: 22 29 0a 09 09 09 09 20 20 20 20 28 73 71 6c 69 ")..... (sqli
35a0: 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e te3:set-busy-han
35b0: 64 6c 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 dler! db (sqlite
35c0: 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 3:make-busy-time
35d0: 6f 75 74 20 33 30 30 30 30 29 29 20 3b 3b 20 72 out 30000)) ;; r
35e0: 65 61 64 2d 6f 6e 6c 79 20 62 75 74 20 73 74 69 ead-only but sti
35f0: 6c 6c 20 6e 65 65 64 20 74 69 6d 65 6f 75 74 0a ll need timeout.
3600: 09 09 09 09 20 20 20 20 64 62 20 29 0a 20 20 20 .... db ).
3610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3630: 70 72 69 6e 74 20 22 66 69 6c 65 20 64 6f 65 73 print "file does
3640: 6e 27 74 20 65 78 69 73 74 3a 20 22 20 66 6e 61 n't exist: " fna
3650: 6d 65 29 29 29 29 0a 09 09 09 28 65 78 6e 20 28 me))))....(exn (
3660: 69 6f 2d 65 72 72 6f 72 29 0a 09 09 09 20 20 20 io-error)....
3670: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
3680: 65 72 72 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 err exn "ERROR:
3690: 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 20 22 i/o error with "
36a0: 20 66 6e 61 6d 65 20 22 2e 20 43 68 65 63 6b 20 fname ". Check
36b0: 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 69 73 permissions, dis
36c0: 6b 20 73 70 61 63 65 20 65 74 63 2e 20 61 6e 64 k space etc. and
36d0: 20 74 72 79 20 61 67 61 69 6e 2e 22 29 0a 09 09 try again.")...
36e0: 09 20 20 20 20 20 28 72 65 74 72 79 29 29 0a 09 . (retry))..
36f0: 09 09 28 65 78 6e 20 28 63 6f 72 72 75 70 74 29 ..(exn (corrupt)
3700: 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 .... (dbfile
3710: 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 :print-err exn "
3720: 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 ERROR: database
3730: 22 20 66 6e 61 6d 65 20 22 20 69 73 20 63 6f 72 " fname " is cor
3740: 72 75 70 74 2e 20 52 65 70 61 69 72 20 69 74 20 rupt. Repair it
3750: 74 6f 20 70 72 6f 63 65 65 64 2e 22 29 0a 09 09 to proceed.")...
3760: 09 20 20 20 20 20 28 72 65 74 72 79 29 29 0a 09 . (retry))..
3770: 09 09 28 65 78 6e 20 28 62 75 73 79 29 0a 09 09 ..(exn (busy)...
3780: 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 . (dbfile:pr
3790: 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 int-err exn "ERR
37a0: 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 OR: database " f
37b0: 6e 61 6d 65 0a 09 09 09 09 09 20 20 20 20 20 20 name......
37c0: 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 54 72 " is locked. Tr
37d0: 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 6e 6f y copying to ano
37e0: 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c 20 72 ther location, r
37f0: 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c 20 61 emove original a
3800: 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 29 0a nd copy back.").
3810: 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 ... (retry))
3820: 0a 09 09 09 28 65 78 6e 20 28 70 65 72 6d 69 73 ....(exn (permis
3830: 73 69 6f 6e 29 28 64 62 66 69 6c 65 3a 70 72 69 sion)(dbfile:pri
3840: 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f nt-err exn "ERRO
3850: 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e R: database " fn
3860: 61 6d 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 ame " has some p
3870: 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c ermissions probl
3880: 65 6d 2e 22 29 0a 09 09 09 20 20 20 20 20 28 72 em.").... (r
3890: 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e 20 28 etry))....(exn (
38a0: 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 6c ).... (dbfil
38b0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 e:print-err exn
38c0: 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 "ERROR: Unknown
38d0: 65 72 72 6f 72 20 77 69 74 68 20 64 61 74 61 62 error with datab
38e0: 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 6d 65 ase " fname " me
38f0: 73 73 61 67 65 3a 20 22 0a 09 09 09 09 09 20 20 ssage: "......
3900: 20 20 20 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e ((condition
3910: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
3920: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
3930: 29 20 65 78 6e 29 29 0a 09 09 09 20 20 20 20 20 ) exn))....
3940: 28 72 65 74 72 79 29 29 29 29 29 0a 09 20 20 72 (retry))))).. r
3950: 65 73 75 6c 74 29 29 29 29 0a 0a 28 64 65 66 69 esult))))..(defi
3960: 6e 65 20 28 64 62 66 69 6c 65 3a 62 72 75 74 65 ne (dbfile:brute
3970: 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 65 2d 64 -force-salvage-d
3980: 62 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a b fname). (let*
3990: 20 28 28 62 61 63 6b 75 70 66 6e 61 6d 65 20 28 ((backupfname (
39a0: 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 22 28 63 75 conc fname"-"(cu
39b0: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
39c0: 29 22 2e 62 61 6b 22 29 29 0a 09 20 28 63 6d 64 )".bak")).. (cmd
39d0: 20 28 63 6f 6e 63 20 22 63 70 20 22 66 6e 61 6d (conc "cp "fnam
39e0: 65 22 20 22 62 61 63 6b 75 70 66 6e 61 6d 65 22 e" "backupfname"
39f0: 3b 6d 76 20 22 66 6e 61 6d 65 22 20 22 28 63 6f ;mv "fname" "(co
3a00: 6e 63 20 66 6e 61 6d 65 20 22 2e 64 65 6c 6d 65 nc fname ".delme
3a10: 3b 22 29 0a 09 09 20 20 20 20 22 63 70 20 22 62 ;")... "cp "b
3a20: 61 63 6b 75 70 66 6e 61 6d 65 22 20 22 66 6e 61 ackupfname" "fna
3a30: 6d 65 29 29 29 0a 20 20 20 20 28 64 62 66 69 6c me))). (dbfil
3a40: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 57 41 52 e:print-err "WAR
3a50: 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 69 6e 67 NING: attempting
3a60: 20 72 65 63 6f 76 65 72 79 20 6f 66 20 66 69 6c recovery of fil
3a70: 65 20 22 66 6e 61 6d 65 22 20 62 79 20 72 75 6e e "fname" by run
3a80: 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 73 3a 5c 6e ning commands:\n
3a90: 22 0a 09 09 20 20 20 20 20 20 22 20 20 22 63 6d "... " "cm
3aa0: 64 29 0a 20 20 20 20 28 73 79 73 74 65 6d 20 63 d). (system c
3ab0: 6d 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 md)))..(define (
3ac0: 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 6e 6f 2d 73 dbfile:open-no-s
3ad0: 79 6e 63 2d 64 62 20 64 62 70 61 74 68 29 0a 20 ync-db dbpath).
3ae0: 20 28 69 66 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 (if *no-sync-db
3af0: 2a 0a 20 20 20 20 20 20 2a 6e 6f 2d 73 79 6e 63 *. *no-sync
3b00: 2d 64 62 2a 0a 20 20 20 20 20 20 28 62 65 67 69 -db*. (begi
3b10: 6e 0a 09 28 69 66 20 28 6e 6f 74 20 28 66 69 6c n..(if (not (fil
3b20: 65 2d 65 78 69 73 74 73 3f 20 64 62 70 61 74 68 e-exists? dbpath
3b30: 29 29 0a 09 20 20 20 20 28 63 72 65 61 74 65 2d )).. (create-
3b40: 64 69 72 65 63 74 6f 72 79 20 64 62 70 61 74 68 directory dbpath
3b50: 20 23 74 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 #t))..(let* ((d
3b60: 62 6e 61 6d 65 20 20 20 20 28 63 6f 6e 63 20 64 bname (conc d
3b70: 62 70 61 74 68 20 22 2f 6e 6f 2d 73 79 6e 63 2e bpath "/no-sync.
3b80: 64 62 22 29 29 0a 09 20 20 20 20 20 20 20 28 64 db")).. (d
3b90: 62 2d 65 78 69 73 74 73 20 28 66 69 6c 65 2d 65 b-exists (file-e
3ba0: 78 69 73 74 73 3f 20 64 62 6e 61 6d 65 29 29 0a xists? dbname)).
3bb0: 09 20 20 20 20 20 20 20 28 69 6e 69 74 2d 70 72 . (init-pr
3bc0: 6f 63 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a oc (lambda (db).
3bd0: 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ... (if (not
3be0: 64 62 2d 65 78 69 73 74 73 29 0a 09 09 09 09 28 db-exists).....(
3bf0: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 73 71 6c begin..... (sql
3c00: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
3c10: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 "CREATE TABLE IF
3c20: 20 4e 4f 54 20 45 58 49 53 54 53 20 6e 6f 5f 73 NOT EXISTS no_s
3c30: 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 ync_metadat (var
3c40: 20 54 45 58 54 2c 76 61 6c 20 54 45 58 54 2c 20 TEXT,val TEXT,
3c50: 43 4f 4e 53 54 52 41 49 4e 54 20 6e 6f 5f 73 79 CONSTRAINT no_sy
3c60: 6e 63 5f 6d 65 74 61 64 61 74 5f 63 6f 6e 73 74 nc_metadat_const
3c70: 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 76 61 raint UNIQUE (va
3c80: 72 29 29 3b 22 29 29 0a 09 09 09 09 29 29 29 0a r));")).....))).
3c90: 09 20 20 20 20 20 20 20 28 6f 6e 2d 74 6d 70 20 . (on-tmp
3ca0: 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 63 61 (equal? (ca
3cb0: 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
3cc0: 64 62 70 61 74 68 20 22 2f 22 29 29 20 22 74 6d dbpath "/")) "tm
3cd0: 70 22 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 p")).. (db
3ce0: 20 20 20 20 20 20 20 20 28 69 66 20 6f 6e 2d 74 (if on-t
3cf0: 6d 70 0a 09 09 09 20 20 20 20 20 20 28 64 62 66 mp.... (dbf
3d00: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
3d10: 6e 2d 64 61 74 61 62 61 73 65 20 64 62 6e 61 6d n-database dbnam
3d20: 65 20 69 6e 69 74 2d 70 72 6f 63 20 30 20 22 57 e init-proc 0 "W
3d30: 41 4c 22 29 0a 09 09 09 20 20 20 20 20 20 28 73 AL").... (s
3d40: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
3d50: 62 61 73 65 20 64 62 6e 61 6d 65 29 29 29 29 0a base dbname)))).
3d60: 09 20 20 28 69 66 20 6f 6e 2d 74 6d 70 09 20 20 . (if on-tmp.
3d70: 20 20 20 20 3b 3b 20 64 6f 6e 65 20 69 6e 20 63 ;; done in c
3d80: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
3d90: 61 62 61 73 65 0a 09 20 20 20 20 20 20 28 62 65 abase.. (be
3da0: 67 69 6e 0a 09 09 28 73 71 6c 69 74 65 33 3a 65 gin...(sqlite3:e
3db0: 78 65 63 75 74 65 20 64 62 20 22 50 52 41 47 4d xecute db "PRAGM
3dc0: 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 A synchronous =
3dd0: 30 3b 22 29 0a 09 09 28 73 71 6c 69 74 65 33 3a 0;")...(sqlite3:
3de0: 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 set-busy-handler
3df0: 21 20 64 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 ! db (sqlite3:ma
3e00: 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 ke-busy-timeout
3e10: 31 33 36 30 30 30 29 29 29 29 0a 09 20 20 28 73 136000)))).. (s
3e20: 65 74 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a et! *no-sync-db*
3e30: 20 64 62 29 0a 09 20 20 64 62 29 29 29 29 0a 0a db).. db))))..
3e40: 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 (define (db:no-s
3e50: 79 6e 63 2d 73 65 74 20 64 62 20 76 61 72 20 76 ync-set db var v
3e60: 61 6c 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 al). (sqlite3:e
3e70: 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 xecute db "INSER
3e80: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
3e90: 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 O no_sync_metada
3ea0: 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 t (var,val) VALU
3eb0: 45 53 20 28 3f 2c 3f 29 3b 22 20 76 61 72 20 76 ES (?,?);" var v
3ec0: 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 al))..(define (d
3ed0: 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 64 b:no-sync-del! d
3ee0: 62 20 76 61 72 29 0a 20 20 28 73 71 6c 69 74 65 b var). (sqlite
3ef0: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 44 45 3:execute db "DE
3f00: 4c 45 54 45 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e LETE FROM no_syn
3f10: 63 5f 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 c_metadat WHERE
3f20: 76 61 72 3d 3f 3b 22 20 76 61 72 29 29 0a 0a 28 var=?;" var))..(
3f30: 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 define (db:no-sy
3f40: 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 64 nc-get/default d
3f50: 62 20 76 61 72 20 64 65 66 61 75 6c 74 29 0a 20 b var default).
3f60: 20 28 6c 65 74 20 28 28 72 65 73 20 64 65 66 61 (let ((res defa
3f70: 75 6c 74 29 29 0a 20 20 20 20 28 73 71 6c 69 74 ult)). (sqlit
3f80: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
3f90: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 (lambda (va
3fa0: 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 l). (set!
3fb0: 72 65 73 20 76 61 6c 29 29 0a 20 20 20 20 20 64 res val)). d
3fc0: 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 76 b. "SELECT v
3fd0: 61 6c 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f al FROM no_sync_
3fe0: 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 76 61 metadat WHERE va
3ff0: 72 3d 3f 3b 22 0a 20 20 20 20 20 76 61 72 29 0a r=?;". var).
4000: 20 20 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 (if res.
4010: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 72 65 (let ((newre
4020: 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 s (if (string? r
4030: 65 73 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 es).... (string
4040: 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 0a 09 09 ->number res)...
4050: 09 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 . #f))).
4060: 20 20 20 28 69 66 20 6e 65 77 72 65 73 0a 20 20 (if newres.
4070: 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 77 72 newr
4080: 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
4090: 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 72 res)). r
40a0: 65 73 29 29 29 0a 0a 3b 3b 20 74 72 61 6e 73 61 es)))..;; transa
40b0: 63 74 69 6f 6e 20 70 72 6f 74 65 63 74 65 64 20 ction protected
40c0: 6c 6f 63 6b 20 61 71 75 69 73 69 74 69 6f 6e 0a lock aquisition.
40d0: 3b 3b 20 65 69 74 68 65 72 3a 0a 3b 3b 20 20 20 ;; either:.;;
40e0: 20 66 61 69 6c 73 20 20 20 20 72 65 74 75 72 6e fails return
40f0: 73 20 20 28 23 66 20 2e 20 6c 6f 63 6b 2d 63 72 s (#f . lock-cr
4100: 65 61 74 69 6f 6e 2d 74 69 6d 65 29 0a 3b 3b 20 eation-time).;;
4110: 20 20 20 73 75 63 63 65 65 64 73 20 28 72 65 74 succeeds (ret
4120: 75 72 6e 73 20 28 23 74 20 2e 20 6c 6f 63 6b 2d urns (#t . lock-
4130: 63 72 65 61 74 69 6f 6e 2d 74 69 6d 65 29 0a 3b creation-time).;
4140: 3b 20 75 73 65 20 28 64 62 3a 6e 6f 2d 73 79 6e ; use (db:no-syn
4150: 63 2d 64 65 6c 21 20 64 62 20 6b 65 79 6e 61 6d c-del! db keynam
4160: 65 29 20 74 6f 20 72 65 6c 65 61 73 65 20 74 68 e) to release th
4170: 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e e lock.;;.(defin
4180: 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 e (db:no-sync-ge
4190: 74 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d t-lock db keynam
41a0: 65 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 77 69 e). (sqlite3:wi
41b0: 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a 20 th-transaction.
41c0: 20 20 64 62 0a 20 20 20 28 6c 61 6d 62 64 61 20 db. (lambda
41d0: 28 29 0a 20 20 20 20 20 28 63 6f 6e 64 69 74 69 (). (conditi
41e0: 6f 6e 2d 63 61 73 65 0a 09 20 28 6c 65 74 2a 20 on-case.. (let*
41f0: 28 28 63 75 72 72 2d 76 61 6c 20 28 64 62 3a 6e ((curr-val (db:n
4200: 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 o-sync-get/defau
4210: 6c 74 20 64 62 20 6b 65 79 6e 61 6d 65 20 23 66 lt db keyname #f
4220: 29 29 29 0a 09 20 20 20 28 69 66 20 63 75 72 72 ))).. (if curr
4230: 2d 76 61 6c 0a 09 20 20 20 20 20 20 20 60 28 23 -val.. `(#
4240: 66 20 2e 20 2c 63 75 72 72 2d 76 61 6c 29 20 20 f . ,curr-val)
4250: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 72 ;; (sqlite3:fir
4260: 73 74 2d 72 65 73 75 6c 74 20 64 62 20 22 53 45 st-result db "SE
4270: 4c 45 43 54 20 76 61 6c 20 46 52 4f 4d 20 6e 6f LECT val FROM no
4280: 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 57 48 _sync_metadat WH
4290: 45 52 45 20 76 61 72 3d 3f 3b 22 20 6b 65 79 6e ERE var=?;" keyn
42a0: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c ame)).. (l
42b0: 65 74 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 20 28 et ((lock-time (
42c0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
42d0: 29 29 0a 09 09 20 28 73 71 6c 69 74 65 33 3a 65 ))... (sqlite3:e
42e0: 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 xecute db "INSER
42f0: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
4300: 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 O no_sync_metada
4310: 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 t (var,val) VALU
4320: 45 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e 61 6d ES(?,?);" keynam
4330: 65 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 09 20 e lock-time)...
4340: 60 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d 74 69 6d `(#t . ,lock-tim
4350: 65 29 29 29 29 0a 20 20 20 20 20 20 20 28 65 78 e)))). (ex
4360: 6e 20 28 69 6f 2d 65 72 72 6f 72 29 20 20 28 64 n (io-error) (d
4370: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
4380: 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f "ERROR: i/o erro
4390: 72 20 77 69 74 68 20 6e 6f 2d 73 79 6e 63 20 64 r with no-sync d
43a0: 62 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 73 73 b. Check permiss
43b0: 69 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 63 65 ions, disk space
43c0: 20 65 74 63 2e 20 61 6e 64 20 74 72 79 20 61 67 etc. and try ag
43d0: 61 69 6e 2e 22 29 29 0a 20 20 20 20 20 20 20 28 ain.")). (
43e0: 65 78 6e 20 28 63 6f 72 72 75 70 74 29 20 20 20 exn (corrupt)
43f0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
4400: 72 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 r "ERROR: databa
4410: 73 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 69 73 se no-sync db is
4420: 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 corrupt. Repair
4430: 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 it to proceed."
4440: 29 29 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 )). (exn (
4450: 62 75 73 79 29 20 20 20 20 20 20 28 64 62 66 69 busy) (dbfi
4460: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 le:print-err "ER
4470: 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f ROR: database no
4480: 2d 73 79 6e 63 20 64 62 20 69 73 20 6c 6f 63 6b -sync db is lock
4490: 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 ed. Try copying
44a0: 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 to another locat
44b0: 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 ion, remove orig
44c0: 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 inal and copy ba
44d0: 63 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 ck.")). (e
44e0: 78 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e 29 28 xn (permission)(
44f0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
4500: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
4510: 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 68 61 73 e no-sync db has
4520: 20 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f 6e some permission
4530: 73 20 70 72 6f 62 6c 65 6d 2e 22 29 29 0a 20 20 s problem.")).
4540: 20 20 20 20 20 28 65 78 6e 20 28 29 20 3b 3b 20 (exn () ;;
4550: 28 73 74 61 74 75 73 20 64 6f 6e 65 29 20 3b 3b (status done) ;;
4560: 20 49 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 68 6f I don't know ho
4570: 77 20 74 6f 20 64 65 74 65 63 74 20 73 74 61 74 w to detect stat
4580: 75 73 20 64 6f 6e 65 20 62 75 74 20 6e 6f 20 64 us done but no d
4590: 61 74 61 21 0a 09 20 20 20 20 28 64 62 66 69 6c ata!.. (dbfil
45a0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 e:print-err "ERR
45b0: 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f OR: Unknown erro
45c0: 72 20 77 69 74 68 20 64 61 74 61 62 61 73 65 20 r with database
45d0: 6e 6f 2d 73 79 6e 63 20 64 62 20 6d 65 73 73 61 no-sync db messa
45e0: 67 65 3a 20 65 78 6e 3d 22 28 63 6f 6e 64 69 74 ge: exn="(condit
45f0: 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 22 2c ion->list exn)",
4600: 20 5c 6e 22 0a 09 09 09 20 20 20 20 20 20 28 28 \n".... ((
4610: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
4620: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
4630: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
4640: 0a 09 20 20 20 20 60 28 23 66 20 2e 20 2c 28 63 .. `(#f . ,(c
4650: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4660: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
4670: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c db:no-sync-get-l
4680: 6f 63 6b 2d 74 69 6d 65 6f 75 74 20 64 62 20 6b ock-timeout db k
4690: 65 79 6e 61 6d 65 20 74 69 6d 65 6f 75 74 29 0a eyname timeout).
46a0: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 64 61 (let* ((lockda
46b0: 74 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 t (db:no-sync-ge
46c0: 74 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d t-lock db keynam
46d0: 65 29 29 29 0a 20 20 20 20 28 6d 61 74 63 68 20 e))). (match
46e0: 6c 6f 63 6b 64 61 74 0a 20 20 20 20 20 20 28 28 lockdat. ((
46f0: 23 66 20 2e 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a #f . lock-time).
4700: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d (if (> (-
4710: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
4720: 73 29 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 s) (if (string?
4730: 6c 6f 63 6b 2d 74 69 6d 65 29 28 73 74 72 69 6e lock-time)(strin
4740: 67 2d 3e 6e 75 6d 62 65 72 20 6c 6f 63 6b 2d 74 g->number lock-t
4750: 69 6d 65 29 6c 6f 63 6b 2d 74 69 6d 65 29 29 20 ime)lock-time))
4760: 74 69 6d 65 6f 75 74 29 0a 09 20 20 20 28 6c 65 timeout).. (le
4770: 74 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 20 28 63 t ((lock-time (c
4780: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4790: 29 0a 09 20 20 20 20 20 3b 3b 20 28 64 65 62 75 ).. ;; (debu
47a0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
47b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
47c0: 2a 20 22 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 * "db:no-sync-ge
47d0: 74 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 3d 22 t-lock keyname="
47e0: 20 6b 65 79 6e 61 6d 65 20 22 2c 20 6c 6f 63 6b keyname ", lock
47f0: 2d 74 69 6d 65 3d 22 20 6c 6f 63 6b 2d 74 69 6d -time=" lock-tim
4800: 65 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a e ", exn=" exn).
4810: 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 . (sqlite3:e
4820: 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 45 52 xecute db "INSER
4830: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
4840: 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 O no_sync_metada
4850: 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 4c 55 t (var,val) VALU
4860: 45 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e 61 6d ES(?,?);" keynam
4870: 65 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 20 20 e lock-time)..
4880: 20 20 20 60 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d `(#t . ,lock-
4890: 74 69 6d 65 29 29 0a 09 20 20 20 6c 6f 63 6b 64 time)).. lockd
48a0: 61 74 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 at)). (else
48b0: 20 6c 6f 63 6b 64 61 74 29 29 29 29 0a 0a 3b 3b lockdat))))..;;
48c0: 20 4e 4f 54 45 3a 20 54 68 69 73 20 77 69 6c 6c NOTE: This will
48d0: 20 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 6b 20 steal the lock
48e0: 61 66 74 65 72 20 74 69 6d 65 6f 75 74 20 6f 66 after timeout of
48f0: 20 77 61 69 74 69 6e 67 2e 0a 3b 3b 0a 28 64 65 waiting..;;.(de
4900: 66 69 6e 65 20 28 64 62 3a 77 69 74 68 2d 6e 6f fine (db:with-no
4910: 2d 73 79 6e 63 2d 6c 6f 63 6b 20 64 62 20 6b 65 -sync-lock db ke
4920: 79 6e 61 6d 65 20 74 69 6d 65 6f 75 74 20 70 72 yname timeout pr
4930: 6f 63 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f oc). (let* ((lo
4940: 63 6b 64 61 74 20 20 28 64 62 3a 6e 6f 2d 73 79 ckdat (db:no-sy
4950: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 nc-get-lock-time
4960: 6f 75 74 20 64 62 20 6b 65 79 6e 61 6d 65 29 29 out db keyname))
4970: 0a 09 20 28 67 6f 74 6c 6f 63 6b 20 20 28 63 61 .. (gotlock (ca
4980: 72 20 6c 6f 63 6b 64 61 74 29 29 0a 09 20 28 6c r lockdat)).. (l
4990: 6f 63 6b 74 69 6d 65 20 28 63 64 72 20 6c 6f 63 ocktime (cdr loc
49a0: 6b 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 kdat))). (if
49b0: 67 6f 74 6c 6f 63 6b 0a 09 28 6c 65 74 20 28 28 gotlock..(let ((
49c0: 72 65 73 20 28 70 72 6f 63 29 29 29 0a 09 20 20 res (proc)))..
49d0: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 (db:no-sync-del!
49e0: 20 64 62 20 6b 65 79 6e 61 6d 65 29 0a 09 20 20 db keyname)..
49f0: 72 65 73 29 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d res)))). .;;===
4a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a40: 3d 3d 3d 0a 3b 3b 20 73 79 6e 63 20 62 61 63 6b ===.;; sync back
4a50: 20 66 75 6e 63 74 69 6f 6e 73 20 70 75 6c 6c 65 functions pulle
4a60: 64 20 66 72 6f 6d 20 64 62 2e 73 63 6d 0a 3b 3b d from db.scm.;;
4a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ab0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 20 61 ======..;; Get a
4ac0: 20 6c 6f 63 6b 20 66 72 6f 6d 20 74 68 65 20 6e lock from the n
4ad0: 6f 2d 73 79 6e 63 2d 64 62 20 66 6f 72 20 74 68 o-sync-db for th
4ae0: 65 20 66 72 6f 6d 2d 64 62 2c 20 74 68 65 6e 20 e from-db, then
4af0: 64 65 6c 74 61 20 73 79 6e 63 20 74 68 65 20 66 delta sync the f
4b00: 72 6f 6d 2d 64 62 20 74 6f 20 74 68 65 20 74 6f rom-db to the to
4b10: 2d 64 62 2c 20 6f 74 68 65 72 77 69 73 65 20 72 -db, otherwise r
4b20: 65 74 75 72 6e 20 23 66 0a 3b 3b 0a 28 64 65 66 eturn #f.;;.(def
4b30: 69 6e 65 20 28 64 62 3a 6c 6f 63 6b 2d 61 6e 64 ine (db:lock-and
4b40: 2d 64 65 6c 74 61 2d 73 79 6e 63 20 6e 6f 2d 73 -delta-sync no-s
4b50: 79 6e 63 2d 64 62 20 64 62 73 74 72 75 63 74 20 ync-db dbstruct
4b60: 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 75 6e from-db-file run
4b70: 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a id keys dbinit).
4b80: 20 20 28 61 73 73 65 72 74 20 28 6e 6f 74 20 2a (assert (not *
4b90: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
4ba0: 65 73 73 2a 29 20 22 46 41 54 41 4c 3a 20 64 62 ess*) "FATAL: db
4bb0: 3a 6c 6f 63 6b 2d 61 6e 64 2d 73 79 6e 63 20 63 :lock-and-sync c
4bc0: 61 6c 6c 65 64 20 77 68 69 6c 65 20 61 20 73 79 alled while a sy
4bd0: 6e 63 20 69 73 20 69 6e 20 70 72 6f 67 72 65 73 nc is in progres
4be0: 73 2e 22 29 0a 20 20 3b 3b 20 28 64 62 66 69 6c s."). ;; (dbfil
4bf0: 65 3a 70 72 69 6e 74 2d 65 72 72 20 2a 64 65 66 e:print-err *def
4c00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4c10: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 db:lock-and-delt
4c20: 61 2d 73 79 6e 63 22 29 0a 20 20 28 6c 65 74 2a a-sync"). (let*
4c30: 20 28 28 6c 6f 63 6b 2d 66 69 6c 65 20 28 63 6f ((lock-file (co
4c40: 6e 63 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 nc from-db-file
4c50: 22 2e 6c 6f 63 6b 22 29 29 29 0a 20 20 20 20 28 ".lock"))). (
4c60: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c if (common:simpl
4c70: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b e-file-lock lock
4c80: 2d 66 69 6c 65 29 0a 09 28 62 65 67 69 6e 0a 09 -file)..(begin..
4c90: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
4ca0: 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 3a 6c 6f err "INFO: db:lo
4cb0: 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e ck-and-delta-syn
4cc0: 63 20 63 6f 70 79 69 6e 67 20 64 62 20 22 72 75 c copying db "ru
4cd0: 6e 69 64 22 20 61 74 20 22 28 63 75 72 72 65 6e nid" at "(curren
4ce0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 28 t-seconds)).. (
4cf0: 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e set! *db-sync-in
4d00: 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 0a 09 -progress* #t)..
4d10: 20 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 (db:sync-touch
4d20: 65 64 20 64 62 73 74 72 75 63 74 20 72 75 6e 69 ed dbstruct runi
4d30: 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 09 d keys dbinit)..
4d40: 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 (set! *db-sync
4d50: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 -in-progress* #f
4d60: 29 0a 09 20 20 28 64 65 6c 65 74 65 2d 66 69 6c ).. (delete-fil
4d70: 65 2a 20 6c 6f 63 6b 2d 66 69 6c 65 29 0a 09 20 e* lock-file)..
4d80: 20 23 74 29 0a 20 20 20 20 20 20 20 20 28 62 65 #t). (be
4d90: 67 69 6e 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d gin.. (if (comm
4da0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
4db0: 6e 74 20 31 32 30 20 28 63 6f 6e 63 20 22 6e 6f nt 120 (conc "no
4dc0: 20 6c 6f 63 6b 20 22 66 72 6f 6d 2d 64 62 2d 66 lock "from-db-f
4dd0: 69 6c 65 29 29 0a 09 20 20 20 20 20 20 28 64 62 ile)).. (db
4de0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
4df0: 49 4e 46 4f 3a 20 63 6f 75 6c 64 20 6e 6f 74 20 INFO: could not
4e00: 67 65 74 20 6c 6f 63 6b 20 66 6f 72 20 22 20 66 get lock for " f
4e10: 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 2c 20 73 rom-db-file ", s
4e20: 79 6e 63 20 6c 69 6b 65 6c 79 20 69 6e 20 70 72 ync likely in pr
4e30: 6f 67 72 65 73 73 2e 22 29 29 0a 09 20 20 23 66 ogress.")).. #f
4e40: 0a 09 20 20 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 .. ))))..;; ;;
4e50: 47 65 74 20 61 20 6c 6f 63 6b 20 66 72 6f 6d 20 Get a lock from
4e60: 74 68 65 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 the no-sync-db f
4e70: 6f 72 20 74 68 65 20 66 72 6f 6d 2d 64 62 2c 20 or the from-db,
4e80: 74 68 65 6e 20 64 65 6c 74 61 20 73 79 6e 63 20 then delta sync
4e90: 74 68 65 20 66 72 6f 6d 2d 64 62 20 74 6f 20 74 the from-db to t
4ea0: 68 65 20 74 6f 2d 64 62 2c 20 6f 74 68 65 72 77 he to-db, otherw
4eb0: 69 73 65 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b ise return #f.;;
4ec0: 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;;.;; (define (
4ed0: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 db:lock-and-delt
4ee0: 61 2d 73 79 6e 63 2d 6f 72 69 67 20 6e 6f 2d 73 a-sync-orig no-s
4ef0: 79 6e 63 2d 64 62 20 64 62 73 74 72 75 63 74 20 ync-db dbstruct
4f00: 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 75 6e from-db-file run
4f10: 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a id keys dbinit).
4f20: 3b 3b 20 20 20 28 61 73 73 65 72 74 20 28 6e 6f ;; (assert (no
4f30: 74 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 t *db-sync-in-pr
4f40: 6f 67 72 65 73 73 2a 29 20 22 46 41 54 41 4c 3a ogress*) "FATAL:
4f50: 20 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 73 79 6e db:lock-and-syn
4f60: 63 20 63 61 6c 6c 65 64 20 77 68 69 6c 65 20 61 c called while a
4f70: 20 73 79 6e 63 20 69 73 20 69 6e 20 70 72 6f 67 sync is in prog
4f80: 72 65 73 73 2e 22 29 0a 3b 3b 20 20 20 3b 3b 20 ress.").;; ;;
4f90: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
4fa0: 72 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 r *default-log-p
4fb0: 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d 61 6e ort* "db:lock-an
4fc0: 64 2d 64 65 6c 74 61 2d 73 79 6e 63 22 29 0a 3b d-delta-sync").;
4fd0: 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ; (let* ((lock
4fe0: 64 61 74 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 dat (db:no-sync
4ff0: 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 6f 75 -get-lock-timeou
5000: 74 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 72 6f t no-sync-db fro
5010: 6d 2d 64 62 2d 66 69 6c 65 20 36 30 29 29 0a 3b m-db-file 60)).;
5020: 3b 20 09 20 28 67 6f 74 6c 6f 63 6b 20 20 28 63 ; . (gotlock (c
5030: 61 72 20 6c 6f 63 6b 64 61 74 29 29 0a 3b 3b 20 ar lockdat)).;;
5040: 09 20 28 6c 6f 63 6b 74 69 6d 65 20 28 63 64 72 . (locktime (cdr
5050: 20 6c 6f 63 6b 64 61 74 29 29 29 0a 3b 3b 20 20 lockdat))).;;
5060: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
5070: 6e 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 61 75 nt-info 3 *defau
5080: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 lt-log-port* "db
5090: 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d :lock-and-delta-
50a0: 73 79 6e 63 3a 20 67 6f 74 20 6c 6f 63 6b 3f 22 sync: got lock?"
50b0: 29 0a 3b 3b 20 20 20 20 20 0a 3b 3b 20 20 20 20 ).;; .;;
50c0: 20 28 69 66 20 67 6f 74 6c 6f 63 6b 0a 3b 3b 20 (if gotlock.;;
50d0: 09 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 .(begin.;;
50e0: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
50f0: 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 nt-err "INFO: db
5100: 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d :lock-and-delta-
5110: 73 79 6e 63 20 63 6f 70 79 69 6e 67 20 64 62 20 sync copying db
5120: 22 72 75 6e 69 64 22 20 61 74 20 22 28 63 75 72 "runid" at "(cur
5130: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 3b rent-seconds)).;
5140: 3b 20 09 20 20 28 73 65 74 21 20 2a 64 62 2d 73 ; . (set! *db-s
5150: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
5160: 20 23 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 #t).;;
5170: 20 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 (db:sync-touch
5180: 65 64 20 64 62 73 74 72 75 63 74 20 72 75 6e 69 ed dbstruct runi
5190: 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 0a 3b d keys dbinit).;
51a0: 3b 20 09 20 20 28 73 65 74 21 20 2a 64 62 2d 73 ; . (set! *db-s
51b0: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
51c0: 20 23 66 29 0a 3b 3b 20 09 20 20 28 64 62 3a 6e #f).;; . (db:n
51d0: 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 6e 6f 2d 73 o-sync-del! no-s
51e0: 79 6e 63 2d 64 62 20 66 72 6f 6d 2d 64 62 2d 66 ync-db from-db-f
51f0: 69 6c 65 29 0a 3b 3b 20 09 20 20 23 74 29 0a 3b ile).;; . #t).;
5200: 3b 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ; (begin
5210: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 64 .;; (d
5220: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
5230: 22 45 52 52 4f 52 3a 20 63 6f 75 6c 64 20 6e 6f "ERROR: could no
5240: 74 20 67 65 74 20 6c 6f 63 6b 20 66 6f 72 20 22 t get lock for "
5250: 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 20 from-db-file "
5260: 66 72 6f 6d 20 6e 6f 2d 73 79 6e 63 2d 64 62 22 from no-sync-db"
5270: 29 0a 3b 3b 20 09 20 20 23 66 0a 3b 3b 20 20 20 ).;; . #f.;;
5280: 20 20 20 20 20 20 29 29 29 29 0a 0a 3b 3b 20 73 ))))..;; s
5290: 79 6e 63 20 72 75 6e 20 66 72 6f 6d 20 74 6d 70 ync run from tmp
52a0: 20 64 69 73 6b 20 74 6f 20 6e 66 73 20 64 69 73 disk to nfs dis
52b0: 6b 20 69 66 20 74 6f 75 63 68 65 64 0a 3b 3b 0a k if touched.;;.
52c0: 3b 3b 20 63 61 6c 6c 20 77 69 74 68 20 64 62 69 ;; call with dbi
52d0: 6e 69 74 3d 64 62 3a 69 6e 69 74 69 61 6c 69 7a nit=db:initializ
52e0: 65 2d 6d 61 69 6e 2d 64 62 0a 3b 3b 0a 28 64 65 e-main-db.;;.(de
52f0: 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d 74 6f fine (db:sync-to
5300: 75 63 68 65 64 20 64 62 73 74 72 75 63 74 20 72 uched dbstruct r
5310: 75 6e 2d 69 64 20 6b 65 79 73 20 23 21 6b 65 79 un-id keys #!key
5320: 20 64 62 69 6e 69 74 20 28 66 6f 72 63 65 2d 73 dbinit (force-s
5330: 79 6e 63 20 23 66 29 29 0a 20 20 28 64 62 66 69 ync #f)). (dbfi
5340: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 le:print-err "db
5350: 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 53 79 :sync-touched Sy
5360: 6e 63 69 6e 67 3a 20 22 20 28 63 6f 6e 63 20 28 ncing: " (conc (
5370: 69 66 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 if run-id run-id
5380: 20 22 6d 61 69 6e 22 29 20 22 2e 64 62 22 29 29 "main") ".db"))
5390: 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 74 68 65 . (let* (;; the
53a0: 20 73 75 62 64 62 20 69 73 20 6e 65 65 64 65 64 subdb is needed
53b0: 20 74 6f 20 61 63 63 65 73 73 20 74 68 65 20 6d to access the m
53c0: 74 64 62 64 61 74 0a 09 20 28 73 75 62 64 62 20 tdbdat.. (subdb
53d0: 20 20 20 20 28 6f 72 20 28 64 62 66 69 6c 65 3a (or (dbfile:
53e0: 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 get-subdb dbstru
53f0: 63 74 20 72 75 6e 2d 69 64 29 0a 09 09 09 28 64 ct run-id)....(d
5400: 62 66 69 6c 65 3a 69 6e 69 74 2d 73 75 62 64 62 bfile:init-subdb
5410: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
5420: 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 dbinit))).
5430: 20 20 20 20 28 74 6d 70 64 62 66 69 6c 65 20 28 (tmpdbfile (
5440: 64 62 72 3a 73 75 62 64 62 2d 74 6d 70 64 62 66 dbr:subdb-tmpdbf
5450: 69 6c 65 20 73 75 62 64 62 29 29 0a 09 20 28 6d ile subdb)).. (m
5460: 74 64 62 20 20 20 20 20 20 28 64 62 72 3a 73 75 tdb (dbr:su
5470: 62 64 62 2d 6d 74 64 62 64 61 74 20 73 75 62 64 bdb-mtdbdat subd
5480: 62 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6d b)). (tm
5490: 70 64 62 20 20 20 20 20 28 64 62 3a 6f 70 65 6e pdb (db:open
54a0: 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e -db dbstruct run
54b0: 2d 69 64 20 64 62 69 6e 69 74 29 29 20 3b 3b 20 -id dbinit)) ;;
54c0: 73 71 6c 69 74 65 33 2d 64 62 20 74 6d 70 64 62 sqlite3-db tmpdb
54d0: 66 69 6c 65 20 23 66 29 29 0a 09 20 28 73 74 61 file #f)).. (sta
54e0: 72 74 2d 74 20 20 20 28 63 75 72 72 65 6e 74 2d rt-t (current-
54f0: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 seconds))). (
5500: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
5510: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
5520: 2a 29 0a 20 20 20 20 28 6c 65 74 20 28 28 75 70 *). (let ((up
5530: 64 61 74 65 5f 69 6e 66 6f 20 28 63 6f 6e 73 20 date_info (cons
5540: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 28 69 "last_update" (i
5550: 66 20 66 6f 72 63 65 2d 73 79 6e 63 20 30 20 2a f force-sync 0 *
5560: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 29 db-last-sync*) )
5570: 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d )). (mutex-
5580: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 unlock! *db-mult
5590: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 i-sync-mutex*).
55a0: 20 20 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 61 (db:sync-ta
55b0: 62 6c 65 73 20 28 64 62 3a 73 79 6e 63 2d 61 6c bles (db:sync-al
55c0: 6c 2d 74 61 62 6c 65 73 2d 6c 69 73 74 20 6b 65 l-tables-list ke
55d0: 79 73 29 20 75 70 64 61 74 65 5f 69 6e 66 6f 20 ys) update_info
55e0: 74 6d 70 64 62 20 6d 74 64 62 29 29 0a 20 20 20 tmpdb mtdb)).
55f0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
5600: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
5610: 65 78 2a 29 0a 20 20 20 20 28 73 65 74 21 20 2a ex*). (set! *
5620: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 db-last-sync* st
5630: 61 72 74 2d 74 29 0a 20 20 20 20 28 73 65 74 21 art-t). (set!
5640: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
5650: 2a 20 73 74 61 72 74 2d 74 29 0a 20 20 20 20 28 * start-t). (
5660: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
5670: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
5680: 65 78 2a 29 0a 20 20 20 20 28 64 62 66 69 6c 65 ex*). (dbfile
5690: 3a 61 64 64 2d 64 62 64 61 74 20 64 62 73 74 72 :add-dbdat dbstr
56a0: 75 63 74 20 72 75 6e 2d 69 64 20 74 6d 70 64 62 uct run-id tmpdb
56b0: 29 0a 20 20 23 74 29 29 0a 0a 3b 3b 20 6a 75 73 ). #t))..;; jus
56c0: 74 20 74 65 73 74 73 2c 20 74 65 73 74 5f 73 74 t tests, test_st
56d0: 65 70 73 20 61 6e 64 20 74 65 73 74 5f 64 61 74 eps and test_dat
56e0: 61 20 74 61 62 6c 65 73 0a 28 64 65 66 69 6e 65 a tables.(define
56f0: 20 64 62 3a 73 79 6e 63 2d 74 65 73 74 73 2d 6f db:sync-tests-o
5700: 6e 6c 79 0a 20 20 28 6c 69 73 74 0a 20 20 20 3b nly. (list. ;
5710: 3b 20 28 6c 69 73 74 20 22 73 74 72 73 22 0a 20 ; (list "strs".
5720: 20 20 3b 3b 20 20 20 20 20 20 20 27 28 22 69 64 ;; '("id
5730: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 " #f
5740: 29 0a 20 20 20 3b 3b 20 20 20 20 20 20 20 27 28 ). ;; '(
5750: 22 73 74 72 22 20 20 20 20 20 20 20 20 20 20 20 "str"
5760: 20 23 66 29 29 0a 20 20 20 28 6c 69 73 74 20 22 #f)). (list "
5770: 74 65 73 74 73 22 20 0a 09 20 27 28 22 69 64 22 tests" .. '("id"
5780: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
5790: 0a 09 20 27 28 22 72 75 6e 5f 69 64 22 20 20 20 .. '("run_id"
57a0: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 #f).. '("t
57b0: 65 73 74 6e 61 6d 65 22 20 20 20 20 20 20 20 23 estname" #
57c0: 66 29 0a 09 20 27 28 22 68 6f 73 74 22 20 20 20 f).. '("host"
57d0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
57e0: 22 63 70 75 6c 6f 61 64 22 20 20 20 20 20 20 20 "cpuload"
57f0: 20 23 66 29 0a 09 20 27 28 22 64 69 73 6b 66 72 #f).. '("diskfr
5800: 65 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 ee" #f)..
5810: 27 28 22 75 6e 61 6d 65 22 20 20 20 20 20 20 20 '("uname"
5820: 20 20 20 23 66 29 0a 09 20 27 28 22 72 75 6e 64 #f).. '("rund
5830: 69 72 22 20 20 20 20 20 20 20 20 20 23 66 29 0a ir" #f).
5840: 09 20 27 28 22 73 68 6f 72 74 64 69 72 22 20 20 . '("shortdir"
5850: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 69 74 #f).. '("it
5860: 65 6d 5f 70 61 74 68 22 20 20 20 20 20 20 23 66 em_path" #f
5870: 29 0a 09 20 27 28 22 73 74 61 74 65 22 20 20 20 ).. '("state"
5880: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5890: 73 74 61 74 75 73 22 20 20 20 20 20 20 20 20 20 status"
58a0: 23 66 29 0a 09 20 27 28 22 61 74 74 65 6d 70 74 #f).. '("attempt
58b0: 6e 75 6d 22 20 20 20 20 20 23 66 29 0a 09 20 27 num" #f).. '
58c0: 28 22 66 69 6e 61 6c 5f 6c 6f 67 66 22 20 20 20 ("final_logf"
58d0: 20 20 23 66 29 0a 09 20 27 28 22 6c 6f 67 64 61 #f).. '("logda
58e0: 74 22 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 t" #f)..
58f0: 20 27 28 22 72 75 6e 5f 64 75 72 61 74 69 6f 6e '("run_duration
5900: 22 20 20 20 23 66 29 0a 09 20 27 28 22 63 6f 6d " #f).. '("com
5910: 6d 65 6e 74 22 20 20 20 20 20 20 20 20 23 66 29 ment" #f)
5920: 0a 09 20 27 28 22 65 76 65 6e 74 5f 74 69 6d 65 .. '("event_time
5930: 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 66 " #f).. '("f
5940: 61 69 6c 5f 63 6f 75 6e 74 22 20 20 20 20 20 23 ail_count" #
5950: 66 29 0a 09 20 27 28 22 70 61 73 73 5f 63 6f 75 f).. '("pass_cou
5960: 6e 74 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 nt" #f).. '(
5970: 22 61 72 63 68 69 76 65 64 22 20 20 20 20 20 20 "archived"
5980: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 27 28 #f). '(
5990: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 20 20 "last_update"
59a0: 20 23 66 29 29 0a 20 20 28 6c 69 73 74 20 22 74 #f)). (list "t
59b0: 65 73 74 5f 73 74 65 70 73 22 0a 09 20 27 28 22 est_steps".. '("
59c0: 69 64 22 20 20 20 20 20 20 20 20 20 20 20 20 20 id"
59d0: 23 66 29 0a 09 20 27 28 22 74 65 73 74 5f 69 64 #f).. '("test_id
59e0: 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 " #f).. '
59f0: 28 22 73 74 65 70 6e 61 6d 65 22 20 20 20 20 20 ("stepname"
5a00: 20 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 65 #f).. '("state
5a10: 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 " #f)..
5a20: 20 27 28 22 73 74 61 74 75 73 22 20 20 20 20 20 '("status"
5a30: 20 20 20 20 23 66 29 0a 09 20 27 28 22 65 76 65 #f).. '("eve
5a40: 6e 74 5f 74 69 6d 65 22 20 20 20 20 20 23 66 29 nt_time" #f)
5a50: 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 22 20 20 .. '("comment"
5a60: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 6c #f).. '("l
5a70: 6f 67 66 69 6c 65 22 20 20 20 20 20 20 20 20 23 ogfile" #
5a80: 66 29 0a 20 20 20 20 20 20 20 20 20 27 28 22 6c f). '("l
5a90: 61 73 74 5f 75 70 64 61 74 65 22 20 20 20 20 23 ast_update" #
5aa0: 66 29 29 0a 20 20 20 28 6c 69 73 74 20 22 74 65 f)). (list "te
5ab0: 73 74 5f 64 61 74 61 22 0a 09 20 27 28 22 69 64 st_data".. '("id
5ac0: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 " #f
5ad0: 29 0a 09 20 27 28 22 74 65 73 74 5f 69 64 22 20 ).. '("test_id"
5ae0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5af0: 63 61 74 65 67 6f 72 79 22 20 20 20 20 20 20 20 category"
5b00: 23 66 29 0a 09 20 27 28 22 76 61 72 69 61 62 6c #f).. '("variabl
5b10: 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 e" #f).. '
5b20: 28 22 76 61 6c 75 65 22 20 20 20 20 20 20 20 20 ("value"
5b30: 20 20 23 66 29 0a 09 20 27 28 22 65 78 70 65 63 #f).. '("expec
5b40: 74 65 64 22 20 20 20 20 20 20 20 23 66 29 0a 09 ted" #f)..
5b50: 20 27 28 22 74 6f 6c 22 20 20 20 20 20 20 20 20 '("tol"
5b60: 20 20 20 20 23 66 29 0a 09 20 27 28 22 75 6e 69 #f).. '("uni
5b70: 74 73 22 20 20 20 20 20 20 20 20 20 20 23 66 29 ts" #f)
5b80: 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 22 20 20 .. '("comment"
5b90: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 #f).. '("s
5ba0: 74 61 74 75 73 22 20 20 20 20 20 20 20 20 20 23 tatus" #
5bb0: 66 29 0a 09 20 27 28 22 74 79 70 65 22 20 20 20 f).. '("type"
5bc0: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 #f).
5bd0: 20 20 20 20 20 27 28 22 6c 61 73 74 5f 75 70 64 '("last_upd
5be0: 61 74 65 22 20 20 20 20 23 66 29 29 29 29 0a 0a ate" #f))))..
5bf0: 3b 3b 20 6e 65 65 64 73 20 64 62 20 74 6f 20 67 ;; needs db to g
5c00: 65 74 20 6b 65 79 73 2c 20 74 68 69 73 20 69 73 et keys, this is
5c10: 20 66 6f 72 20 73 79 6e 63 69 6e 67 20 61 6c 6c for syncing all
5c20: 20 74 61 62 6c 65 73 0a 3b 3b 0a 28 64 65 66 69 tables.;;.(defi
5c30: 6e 65 20 28 64 62 3a 73 79 6e 63 2d 6d 61 69 6e ne (db:sync-main
5c40: 2d 6c 69 73 74 20 6b 65 79 73 29 0a 20 20 28 6c -list keys). (l
5c50: 65 74 20 28 28 6b 65 79 73 20 20 6b 65 79 73 29 et ((keys keys)
5c60: 29 0a 20 20 20 20 28 6c 69 73 74 0a 20 20 20 20 ). (list.
5c70: 20 28 6c 69 73 74 20 22 6b 65 79 73 22 0a 09 20 (list "keys"..
5c80: 20 20 27 28 22 69 64 22 20 20 20 20 20 20 20 20 '("id"
5c90: 23 66 29 0a 09 20 20 20 27 28 22 66 69 65 6c 64 #f).. '("field
5ca0: 6e 61 6d 65 22 20 23 66 29 0a 09 20 20 20 27 28 name" #f).. '(
5cb0: 22 66 69 65 6c 64 74 79 70 65 22 20 23 66 29 29 "fieldtype" #f))
5cc0: 0a 20 20 20 20 20 28 6c 69 73 74 20 22 6d 65 74 . (list "met
5cd0: 61 64 61 74 22 20 27 28 22 76 61 72 22 20 23 66 adat" '("var" #f
5ce0: 29 20 27 28 22 76 61 6c 22 20 23 66 29 29 0a 20 ) '("val" #f)).
5cf0: 20 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 (append (lis
5d00: 74 20 22 72 75 6e 73 22 20 0a 09 09 20 20 20 27 t "runs" ... '
5d10: 28 22 69 64 22 20 20 23 66 29 29 0a 09 20 20 20 ("id" #f))..
5d20: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
5d30: 6b 29 28 6c 69 73 74 20 6b 20 23 66 29 29 0a 09 k)(list k #f))..
5d40: 09 20 20 28 61 70 70 65 6e 64 20 6b 65 79 73 0a . (append keys.
5d50: 09 09 09 20 20 28 6c 69 73 74 20 22 72 75 6e 6e ... (list "runn
5d60: 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 ame" "state" "st
5d70: 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 atus" "owner" "e
5d80: 76 65 6e 74 5f 74 69 6d 65 22 20 22 63 6f 6d 6d vent_time" "comm
5d90: 65 6e 74 22 20 22 66 61 69 6c 5f 63 6f 75 6e 74 ent" "fail_count
5da0: 22 20 22 70 61 73 73 5f 63 6f 75 6e 74 22 20 22 " "pass_count" "
5db0: 63 6f 6e 74 6f 75 72 22 20 22 6c 61 73 74 5f 75 contour" "last_u
5dc0: 70 64 61 74 65 22 29 29 29 29 0a 20 20 20 20 20 pdate")))).
5dd0: 28 6c 69 73 74 20 22 61 72 63 68 69 76 65 5f 64 (list "archive_d
5de0: 69 73 6b 73 22 0a 20 20 20 20 20 20 20 20 20 20 isks".
5df0: 20 27 28 22 69 64 22 20 23 66 29 0a 20 20 20 20 '("id" #f).
5e00: 20 20 20 20 20 20 20 27 28 22 61 72 63 68 69 76 '("archiv
5e10: 65 5f 61 72 65 61 5f 6e 61 6d 65 22 20 23 66 29 e_area_name" #f)
5e20: 20 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 . '("
5e30: 64 69 73 6b 5f 70 61 74 68 22 20 23 66 29 0a 20 disk_path" #f).
5e40: 20 20 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 '("las
5e50: 74 5f 64 66 22 20 23 66 29 0a 20 20 20 20 20 20 t_df" #f).
5e60: 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 66 5f '("last_df_
5e70: 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 20 20 time" #f).
5e80: 20 20 20 20 20 27 28 22 63 72 65 61 74 69 6f 6e '("creation
5e90: 5f 74 69 6d 65 22 20 23 66 29 29 20 0a 0a 20 20 _time" #f)) ..
5ea0: 20 20 20 28 6c 69 73 74 20 22 61 72 63 68 69 76 (list "archiv
5eb0: 65 5f 62 6c 6f 63 6b 73 22 0a 20 20 20 20 20 20 e_blocks".
5ec0: 20 20 20 20 20 27 28 22 69 64 22 20 23 66 29 0a '("id" #f).
5ed0: 20 20 20 20 20 20 20 20 20 20 20 27 28 22 61 72 '("ar
5ee0: 63 68 69 76 65 5f 64 69 73 6b 5f 69 64 22 20 23 chive_disk_id" #
5ef0: 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 27 f) . '
5f00: 28 22 64 69 73 6b 5f 70 61 74 68 22 20 23 66 29 ("disk_path" #f)
5f10: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 6c . '("l
5f20: 61 73 74 5f 64 75 22 20 23 66 29 0a 20 20 20 20 ast_du" #f).
5f30: 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 '("last_d
5f40: 75 5f 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 u_time" #f).
5f50: 20 20 20 20 20 20 20 27 28 22 63 72 65 61 74 69 '("creati
5f60: 6f 6e 5f 74 69 6d 65 22 20 23 66 29 29 20 0a 0a on_time" #f)) ..
5f70: 20 20 20 20 20 28 6c 69 73 74 20 22 74 65 73 74 (list "test
5f80: 5f 6d 65 74 61 22 0a 09 20 20 20 27 28 22 69 64 _meta".. '("id
5f90: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 " #f
5fa0: 29 0a 09 20 20 20 27 28 22 74 65 73 74 6e 61 6d ).. '("testnam
5fb0: 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 e" #f)..
5fc0: 20 27 28 22 6f 77 6e 65 72 22 20 20 20 20 20 20 '("owner"
5fd0: 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 64 #f).. '("d
5fe0: 65 73 63 72 69 70 74 69 6f 6e 22 20 20 20 20 23 escription" #
5ff0: 66 29 0a 09 20 20 20 27 28 22 72 65 76 69 65 77 f).. '("review
6000: 65 64 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 ed" #f)..
6010: 20 20 27 28 22 69 74 65 72 61 74 65 64 22 20 20 '("iterated"
6020: 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 #f).. '("
6030: 61 76 67 5f 72 75 6e 74 69 6d 65 22 20 20 20 20 avg_runtime"
6040: 23 66 29 0a 09 20 20 20 27 28 22 61 76 67 5f 64 #f).. '("avg_d
6050: 69 73 6b 22 20 20 20 20 20 20 20 23 66 29 0a 09 isk" #f)..
6060: 20 20 20 27 28 22 74 61 67 73 22 20 20 20 20 20 '("tags"
6070: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 #f).. '(
6080: 22 6a 6f 62 67 72 6f 75 70 22 20 20 20 20 20 20 "jobgroup"
6090: 20 23 66 29 29 0a 0a 0a 20 20 20 20 20 28 6c 69 #f))... (li
60a0: 73 74 20 22 74 61 73 6b 73 5f 71 75 65 75 65 22 st "tasks_queue"
60b0: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 69 . '("i
60c0: 64 22 20 20 20 20 20 20 20 20 20 20 20 20 23 66 d" #f
60d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ). '("
60e0: 61 63 74 69 6f 6e 22 20 20 20 20 20 20 20 20 23 action" #
60f0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
6100: 22 6f 77 6e 65 72 22 20 20 20 20 20 20 20 20 20 "owner"
6110: 23 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 #f) .
6120: 27 28 22 73 74 61 74 65 22 20 20 20 20 20 20 20 '("state"
6130: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
6140: 20 27 28 22 74 61 72 67 65 74 22 20 20 20 20 20 '("target"
6150: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
6160: 20 20 27 28 22 6e 61 6d 65 22 20 20 20 20 20 20 '("name"
6170: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
6180: 20 20 20 27 28 22 74 65 73 74 70 61 74 74 22 20 '("testpatt"
6190: 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 #f).
61a0: 20 20 20 20 27 28 22 6b 65 79 6c 6f 63 6b 22 20 '("keylock"
61b0: 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 #f).
61c0: 20 20 20 20 20 27 28 22 70 61 72 61 6d 73 22 20 '("params"
61d0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
61e0: 20 20 20 20 20 20 27 28 22 63 72 65 61 74 69 6f '("creatio
61f0: 6e 5f 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 n_time" #f).
6200: 20 20 20 20 20 20 20 27 28 22 65 78 65 63 75 74 '("execut
6210: 69 6f 6e 5f 74 69 6d 65 22 20 23 66 29 29 0a 20 ion_time" #f)).
6220: 20 20 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))..(define
6230: 20 28 64 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 (db:sync-all-ta
6240: 62 6c 65 73 2d 6c 69 73 74 20 6b 65 79 73 29 0a bles-list keys).
6250: 20 20 28 61 70 70 65 6e 64 20 28 64 62 3a 73 79 (append (db:sy
6260: 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 20 6b 65 79 nc-main-list key
6270: 73 29 0a 09 20 20 64 62 3a 73 79 6e 63 2d 74 65 s).. db:sync-te
6280: 73 74 73 2d 6f 6e 6c 79 29 29 0a 0a 3b 3b 20 74 sts-only))..;; t
6290: 62 6c 73 20 69 73 20 28 20 28 22 74 61 62 6c 65 bls is ( ("table
62a0: 6e 61 6d 65 22 20 28 20 22 66 69 65 6c 64 31 22 name" ( "field1"
62b0: 20 5b 23 66 7c 70 72 6f 63 31 5d 20 29 20 28 20 [#f|proc1] ) (
62c0: 22 66 69 65 6c 64 32 22 20 5b 23 66 7c 70 72 6f "field2" [#f|pro
62d0: 63 32 5d 20 29 20 2e 2e 2e 2e 20 29 20 29 0a 3b c2] ) .... ) ).;
62e0: 3b 20 64 62 27 73 20 61 72 65 20 64 62 64 61 74 ; db's are dbdat
62f0: 27 73 0a 3b 3b 0a 3b 3b 20 69 66 20 6c 61 73 74 's.;;.;; if last
6300: 2d 75 70 64 61 74 65 20 73 70 65 63 69 66 69 65 -update specifie
6310: 64 20 28 22 66 69 65 6c 64 2d 6e 61 6d 65 22 20 d ("field-name"
6320: 2e 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f 6e 64 . time-in-second
6330: 73 29 0a 3b 3b 20 20 20 20 74 68 65 6e 20 73 79 s).;; then sy
6340: 6e 63 20 6f 6e 6c 79 20 72 65 63 6f 72 64 73 20 nc only records
6350: 77 68 65 72 65 20 66 69 65 6c 64 2d 6e 61 6d 65 where field-name
6360: 20 3e 3d 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f >= time-in-seco
6370: 6e 64 73 0a 3b 3b 20 20 20 20 49 46 46 20 66 69 nds.;; IFF fi
6380: 65 6c 64 2d 6e 61 6d 65 20 65 78 69 73 74 73 0a eld-name exists.
6390: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 73 ;;.(define (db:s
63a0: 79 6e 63 2d 74 61 62 6c 65 73 20 74 62 6c 73 20 ync-tables tbls
63b0: 6c 61 73 74 2d 75 70 64 61 74 65 20 66 72 6f 6d last-update from
63c0: 64 62 20 74 6f 64 62 20 2e 20 73 6c 61 76 65 2d db todb . slave-
63d0: 64 62 73 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 dbs). (handle-e
63e0: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
63f0: 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 . (begin.
6400: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
6410: 72 20 20 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 r "EXCEPTION: d
6420: 61 74 61 62 61 73 65 20 70 72 6f 62 61 62 6c 79 atabase probably
6430: 20 6f 76 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 overloaded or u
6440: 6e 72 65 61 64 61 62 6c 65 20 69 6e 20 64 62 3a nreadable in db:
6450: 73 79 6e 63 2d 74 61 62 6c 65 73 2e 22 29 0a 20 sync-tables.").
6460: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
6470: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
6480: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 rror-port)).
6490: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
64a0: 72 72 20 20 22 20 6d 65 73 73 61 67 65 3a 20 22 rr " message: "
64b0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
64c0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
64d0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
64e0: 6e 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 n)). (dbfile
64f0: 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 65 78 6e :print-err "exn
6500: 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c =" (condition->l
6510: 69 73 74 20 65 78 6e 29 29 0a 20 20 20 20 20 28 ist exn)). (
6520: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
6530: 20 20 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 " status: " (
6540: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
6550: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 rty-accessor 'sq
6560: 6c 69 74 65 33 20 27 73 74 61 74 75 73 29 20 65 lite3 'status) e
6570: 78 6e 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c xn)). (dbfil
6580: 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 20 73 e:print-err " s
6590: 72 63 20 64 62 3a 20 20 22 20 28 64 62 72 3a 64 rc db: " (dbr:d
65a0: 62 64 61 74 2d 64 62 66 69 6c 65 20 66 72 6f 6d bdat-dbfile from
65b0: 64 62 29 29 0a 20 20 20 20 20 28 66 6f 72 2d 65 db)). (for-e
65c0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 64 62 64 ach (lambda (dbd
65d0: 61 74 29 0a 09 09 20 28 6c 65 74 20 28 28 64 62 at)... (let ((db
65e0: 70 61 74 68 20 28 64 62 72 3a 64 62 64 61 74 2d path (dbr:dbdat-
65f0: 64 62 66 69 6c 65 20 64 62 64 61 74 29 29 29 0a dbfile dbdat))).
6600: 09 09 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 .. (dbfile:pri
6610: 6e 74 2d 65 72 72 20 20 22 20 64 62 70 61 74 68 nt-err " dbpath
6620: 3a 20 20 22 20 64 62 70 61 74 68 29 0a 09 09 20 : " dbpath)...
6630: 20 20 28 69 66 20 23 74 20 3b 3b 20 28 6e 6f 74 (if #t ;; (not
6640: 20 28 64 62 3a 72 65 70 61 69 72 2d 64 62 20 64 (db:repair-db d
6650: 62 64 61 74 29 29 0a 09 09 20 20 20 20 20 20 20 bdat))...
6660: 28 62 65 67 69 6e 0a 09 09 09 20 28 64 62 66 69 (begin.... (dbfi
6670: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 46 61 le:print-err "Fa
6680: 69 6c 65 64 20 74 6f 20 72 65 62 75 69 6c 64 20 iled to rebuild
6690: 28 72 65 70 61 69 72 20 69 73 20 74 75 72 6e 65 (repair is turne
66a0: 64 20 6f 66 66 29 20 22 20 64 62 70 61 74 68 20 d off) " dbpath
66b0: 22 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 ", exiting now."
66c0: 29 0a 09 09 09 20 28 65 78 69 74 29 29 29 29 29 ).... (exit)))))
66d0: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 73 20 74 .. (cons t
66e0: 6f 64 62 20 73 6c 61 76 65 2d 64 62 73 29 29 0a odb slave-dbs)).
66f0: 20 20 20 20 20 0a 20 20 20 20 20 30 29 0a 0a 20 . 0)..
6700: 20 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 ;; this is the
6710: 20 77 6f 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 work to be done
6720: 22 29 0a 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 "). (cond.
6730: 28 28 6e 6f 74 20 66 72 6f 6d 64 62 29 20 28 64 ((not fromdb) (d
6740: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
6750: 20 22 57 41 52 4e 49 4e 47 3a 20 64 62 3a 73 79 "WARNING: db:sy
6760: 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 nc-tables called
6770: 20 77 69 74 68 20 66 72 6f 6d 64 62 20 6d 69 73 with fromdb mis
6780: 73 69 6e 67 22 29 0a 20 20 20 20 20 2d 31 29 0a sing"). -1).
6790: 20 20 20 20 28 28 6e 6f 74 20 74 6f 64 62 29 20 ((not todb)
67a0: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
67b0: 65 72 72 20 20 22 57 41 52 4e 49 4e 47 3a 20 64 err "WARNING: d
67c0: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 b:sync-tables ca
67d0: 6c 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 6d lled with todb m
67e0: 69 73 73 69 6e 67 22 29 0a 20 20 20 20 20 2d 32 issing"). -2
67f0: 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 71 6c ). ((not (sql
6800: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 28 ite3:database? (
6810: 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 66 72 dbr:dbdat-dbh fr
6820: 6f 6d 64 62 29 29 29 0a 20 20 20 20 20 28 64 62 omdb))). (db
6830: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
6840: 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 db:sync-tables c
6850: 61 6c 6c 65 64 20 77 69 74 68 20 66 72 6f 6d 64 alled with fromd
6860: 62 20 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 b not a database
6870: 20 22 20 66 72 6f 6d 64 62 29 0a 20 20 20 2d 33 " fromdb). -3
6880: 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 71 6c ). ((not (sql
6890: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 28 ite3:database? (
68a0: 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 74 6f dbr:dbdat-dbh to
68b0: 64 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 69 db))). (dbfi
68c0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 le:print-err "db
68d0: 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c :sync-tables cal
68e0: 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f led with todb no
68f0: 74 20 61 20 64 61 74 61 62 61 73 65 20 22 20 74 t a database " t
6900: 6f 64 62 29 0a 20 20 20 2d 34 29 0a 0a 20 20 20 odb). -4)..
6910: 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 ((not (file-wri
6920: 74 65 2d 61 63 63 65 73 73 3f 20 28 64 62 72 3a te-access? (dbr:
6930: 64 62 64 61 74 2d 64 62 66 69 6c 65 20 74 6f 64 dbdat-dbfile tod
6940: 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c b))). (dbfil
6950: 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a e:print-err "db:
6960: 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c sync-tables call
6970: 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f 74 ed with todb not
6980: 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 a read-only dat
6990: 61 62 61 73 65 20 22 20 74 6f 64 62 29 0a 20 20 abase " todb).
69a0: 20 20 20 2d 35 29 0a 20 20 20 20 28 28 6e 6f 74 -5). ((not
69b0: 20 28 6e 75 6c 6c 3f 20 28 6c 65 74 20 28 28 72 (null? (let ((r
69c0: 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 eadonly-slave-db
69d0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
69e0: 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 74 65 (filte
69f0: 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r.
6a00: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
6a10: 64 61 20 28 64 62 64 61 74 29 0a 20 20 20 20 20 da (dbdat).
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a30: 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 (not (file
6a40: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 -write-access? (
6a50: 64 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 dbr:dbdat-dbfile
6a60: 20 74 6f 64 62 29 29 29 29 0a 20 20 20 20 20 20 todb)))).
6a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a80: 20 20 20 73 6c 61 76 65 2d 64 62 73 29 29 29 0a slave-dbs))).
6a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6aa0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
6ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ac0: 20 28 6c 61 6d 62 64 61 20 28 62 61 64 2d 64 62 (lambda (bad-db
6ad0: 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 dat).
6ae0: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 66 69 (dbfi
6af0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 le:print-err "db
6b00: 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c :sync-tables cal
6b10: 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e 6f led with todb no
6b20: 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 61 t a read-only da
6b30: 74 61 62 61 73 65 20 22 20 62 61 64 2d 64 62 64 tabase " bad-dbd
6b40: 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 at)).
6b50: 20 20 20 20 20 20 20 20 20 72 65 61 64 6f 6e 6c readonl
6b60: 79 2d 73 6c 61 76 65 2d 64 62 73 29 0a 20 20 20 y-slave-dbs).
6b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b80: 72 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d 64 readonly-slave-d
6b90: 62 73 29 29 29 20 2d 36 29 0a 20 20 20 20 28 65 bs))) -6). (e
6ba0: 6c 73 65 0a 20 20 20 20 20 3b 3b 20 28 64 62 66 lse. ;; (dbf
6bb0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 ile:print-err "d
6bc0: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 3a 20 61 b:sync-tables: a
6bd0: 72 67 73 20 61 72 65 20 67 6f 6f 64 22 29 0a 0a rgs are good")..
6be0: 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 6d 74 (let ((stmt
6bf0: 73 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 s (make-ha
6c00: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 sh-table)) ;; ta
6c10: 62 6c 65 2d 66 69 65 6c 64 20 3d 3e 20 73 74 6d ble-field => stm
6c20: 74 0a 09 20 20 20 28 61 6c 6c 2d 73 74 6d 74 73 t.. (all-stmts
6c30: 20 20 20 27 28 29 29 20 20 20 20 20 20 20 20 20 '())
6c40: 20 20 20 20 20 3b 3b 20 28 20 28 20 73 74 6d 74 ;; ( ( stmt
6c50: 31 20 76 61 6c 75 65 31 20 29 20 28 20 73 74 6d 1 value1 ) ( stm
6c60: 6c 32 20 76 61 6c 75 65 32 20 29 29 0a 09 20 20 l2 value2 ))..
6c70: 20 28 6e 75 6d 72 65 63 73 20 20 20 20 20 28 6d (numrecs (m
6c80: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
6c90: 0a 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 .. (start-time
6ca0: 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 (current-milli
6cb0: 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 28 74 seconds)).. (t
6cc0: 6f 74 2d 63 6f 75 6e 74 20 20 20 30 29 29 0a 20 ot-count 0)).
6cd0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
6ce0: 3b 3b 20 74 61 62 6c 65 0a 09 28 6c 61 6d 62 64 ;; table..(lambd
6cf0: 61 20 28 74 61 62 6c 65 64 61 74 29 0a 09 20 20 a (tabledat)..
6d00: 28 6c 65 74 2a 20 28 28 74 61 62 6c 65 6e 61 6d (let* ((tablenam
6d10: 65 20 20 20 20 20 20 20 20 28 63 61 72 20 74 61 e (car ta
6d20: 62 6c 65 64 61 74 29 29 0a 09 09 20 28 66 69 65 bledat))... (fie
6d30: 6c 64 73 20 20 20 20 20 20 20 20 20 20 20 28 63 lds (c
6d40: 64 72 20 74 61 62 6c 65 64 61 74 29 29 0a 09 09 dr tabledat))...
6d50: 20 28 68 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 (has-last-updat
6d60: 65 20 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 e (member "last
6d70: 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 73 29 _update" fields)
6d80: 29 0a 09 09 20 28 75 73 65 2d 6c 61 73 74 2d 75 )... (use-last-u
6d90: 70 64 61 74 65 20 20 28 63 6f 6e 64 0a 09 09 09 pdate (cond....
6da0: 09 20 20 20 20 28 28 61 6e 64 20 68 61 73 2d 6c . ((and has-l
6db0: 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 09 ast-update......
6dc0: 20 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f (member "last_
6dd0: 75 70 64 61 74 65 22 20 66 69 65 6c 64 73 29 29 update" fields))
6de0: 0a 09 09 09 09 20 20 20 20 20 23 74 29 20 3b 3b ..... #t) ;;
6df0: 20 69 66 20 67 69 76 65 6e 20 61 20 6e 75 6d 62 if given a numb
6e00: 65 72 2c 20 6a 75 73 74 20 75 73 65 20 69 74 20 er, just use it
6e10: 66 6f 72 20 61 6c 6c 20 66 69 65 6c 64 73 0a 09 for all fields..
6e20: 09 09 09 20 20 20 20 28 28 6e 75 6d 62 65 72 3f ... ((number?
6e30: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 20 23 66 last-update) #f
6e40: 29 20 3b 3b 20 69 66 20 6e 6f 74 20 6d 61 74 63 ) ;; if not matc
6e50: 68 65 64 20 66 69 72 73 74 20 65 6e 74 72 79 20 hed first entry
6e60: 74 68 65 6e 20 69 67 6e 6f 72 65 20 6c 61 73 74 then ignore last
6e70: 2d 75 70 64 61 74 65 20 66 6f 72 20 74 68 69 73 -update for this
6e80: 20 74 61 62 6c 65 0a 09 09 09 09 20 20 20 20 28 table..... (
6e90: 28 61 6e 64 20 28 70 61 69 72 3f 20 6c 61 73 74 (and (pair? last
6ea0: 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 20 20 -update)......
6eb0: 28 6d 65 6d 62 65 72 20 28 63 61 72 20 6c 61 73 (member (car las
6ec0: 74 2d 75 70 64 61 74 65 29 20 20 20 20 3b 3b 20 t-update) ;;
6ed0: 6c 61 73 74 2d 75 70 64 61 74 65 20 66 69 65 6c last-update fiel
6ee0: 64 20 6e 61 6d 65 0a 09 09 09 09 09 09 20 20 28 d name....... (
6ef0: 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 map car fields))
6f00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f20: 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 09 09 #t)...
6f30: 09 09 20 20 20 20 28 28 61 6e 64 20 6c 61 73 74 .. ((and last
6f40: 2d 75 70 64 61 74 65 20 28 6e 6f 74 20 28 70 61 -update (not (pa
6f50: 69 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 ir? last-update)
6f60: 29 20 28 6e 6f 74 20 28 6e 75 6d 62 65 72 3f 20 ) (not (number?
6f70: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a 09 last-update)))..
6f80: 09 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a ... (dbfile:
6f90: 70 72 69 6e 74 2d 65 72 72 20 20 22 45 52 52 4f print-err "ERRO
6fa0: 52 3a 20 70 61 72 61 6d 65 74 65 72 20 6c 61 73 R: parameter las
6fb0: 74 2d 75 70 64 61 74 65 20 66 6f 72 20 64 62 3a t-update for db:
6fc0: 73 79 6e 63 2d 74 61 62 6c 65 73 20 6d 75 73 74 sync-tables must
6fd0: 20 62 65 20 61 20 70 61 69 72 20 6f 72 20 61 20 be a pair or a
6fe0: 6e 75 6d 62 65 72 2c 20 72 65 63 65 69 76 65 64 number, received
6ff0: 3a 20 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 : " last-update)
7000: 3b 3b 20 66 6f 75 6e 64 20 69 6e 20 66 69 65 6c ;; found in fiel
7010: 64 73 0a 09 09 09 09 20 20 20 20 20 23 66 29 0a ds..... #f).
7020: 09 09 09 09 20 20 20 20 28 65 6c 73 65 0a 09 09 .... (else...
7030: 09 09 20 20 20 20 20 23 66 29 29 29 0a 09 09 20 .. #f)))...
7040: 28 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 61 6c (last-update-val
7050: 75 65 20 28 69 66 20 75 73 65 2d 6c 61 73 74 2d ue (if use-last-
7060: 75 70 64 61 74 65 20 3b 3b 20 6e 6f 20 6e 65 65 update ;; no nee
7070: 64 20 74 6f 20 63 68 65 63 6b 20 66 6f 72 20 68 d to check for h
7080: 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 2d as-last-update -
7090: 20 69 74 20 69 73 20 61 6c 72 65 61 64 79 20 61 it is already a
70a0: 63 63 6f 75 6e 74 65 64 20 66 6f 72 0a 09 09 09 ccounted for....
70b0: 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6c ..(if (number? l
70c0: 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 09 09 ast-update).....
70d0: 09 20 20 20 20 6c 61 73 74 2d 75 70 64 61 74 65 . last-update
70e0: 0a 09 09 09 09 09 20 20 20 20 28 63 64 72 20 6c ...... (cdr l
70f0: 61 73 74 2d 75 70 64 61 74 65 29 29 0a 09 09 09 ast-update))....
7100: 09 09 23 66 29 29 0a 09 09 20 28 6c 61 73 74 2d ..#f))... (last-
7110: 75 70 64 61 74 65 2d 66 69 65 6c 64 20 28 69 66 update-field (if
7120: 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 use-last-update
7130: 0a 09 09 09 09 09 28 69 66 20 28 6e 75 6d 62 65 ......(if (numbe
7140: 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a r? last-update).
7150: 09 09 09 09 09 20 20 20 20 22 6c 61 73 74 5f 75 ..... "last_u
7160: 70 64 61 74 65 22 0a 09 09 09 09 09 20 20 20 20 pdate"......
7170: 28 63 61 72 20 6c 61 73 74 2d 75 70 64 61 74 65 (car last-update
7180: 29 29 0a 09 09 09 09 09 23 66 29 29 0a 09 09 20 ))......#f))...
7190: 28 6e 75 6d 2d 66 69 65 6c 64 73 20 28 6c 65 6e (num-fields (len
71a0: 67 74 68 20 66 69 65 6c 64 73 29 29 0a 09 09 20 gth fields))...
71b0: 28 66 69 65 6c 64 2d 3e 6e 75 6d 20 28 6d 61 6b (field->num (mak
71c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
71d0: 09 20 28 6e 75 6d 2d 3e 66 69 65 6c 64 20 28 61 . (num->field (a
71e0: 70 70 6c 79 20 76 65 63 74 6f 72 20 28 6d 61 70 pply vector (map
71f0: 20 63 61 72 20 66 69 65 6c 64 73 29 29 29 20 3b car fields))) ;
7200: 3b 20 42 42 48 45 52 45 0a 09 09 20 28 66 75 6c ; BBHERE... (ful
7210: 6c 2d 73 65 6c 20 20 20 28 63 6f 6e 63 20 22 53 l-sel (conc "S
7220: 45 4c 45 43 54 20 22 20 28 73 74 72 69 6e 67 2d ELECT " (string-
7230: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
7240: 20 63 61 72 20 66 69 65 6c 64 73 29 20 22 2c 22 car fields) ","
7250: 29 20 0a 09 09 09 09 20 20 20 22 20 46 52 4f 4d ) ..... " FROM
7260: 20 22 20 74 61 62 6c 65 6e 61 6d 65 20 28 69 66 " tablename (if
7270: 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 use-last-update
7280: 20 3b 3b 20 61 70 70 6c 79 20 6c 61 73 74 2d 75 ;; apply last-u
7290: 70 64 61 74 65 20 63 72 69 74 65 72 69 61 0a 09 pdate criteria..
72a0: 09 09 09 09 09 09 20 20 28 63 6f 6e 63 20 22 20 ...... (conc "
72b0: 57 48 45 52 45 20 22 20 6c 61 73 74 2d 75 70 64 WHERE " last-upd
72c0: 61 74 65 2d 66 69 65 6c 64 20 22 20 3e 3d 20 22 ate-field " >= "
72d0: 20 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 61 6c last-update-val
72e0: 75 65 29 0a 09 09 09 09 09 09 09 20 20 22 22 29 ue)........ "")
72f0: 0a 09 09 09 09 20 20 20 22 3b 22 29 29 0a 09 09 ..... ";"))...
7300: 20 28 66 75 6c 6c 2d 69 6e 73 20 20 20 28 63 6f (full-ins (co
7310: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
7320: 50 4c 41 43 45 20 49 4e 54 4f 20 22 20 74 61 62 PLACE INTO " tab
7330: 6c 65 6e 61 6d 65 20 22 20 28 20 22 20 28 73 74 lename " ( " (st
7340: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7350: 20 28 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 (map car fields
7360: 29 20 22 2c 22 29 20 22 20 29 20 22 0a 09 09 09 ) ",") " ) "....
7370: 09 20 20 20 22 20 56 41 4c 55 45 53 20 28 20 22 . " VALUES ( "
7380: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7390: 65 72 73 65 20 28 6d 61 6b 65 2d 6c 69 73 74 20 erse (make-list
73a0: 6e 75 6d 2d 66 69 65 6c 64 73 20 22 3f 22 29 20 num-fields "?")
73b0: 22 2c 22 29 20 22 20 29 3b 22 29 29 0a 09 09 20 ",") " );"))...
73c0: 28 66 72 6f 6d 64 61 74 20 20 20 20 27 28 29 29 (fromdat '())
73d0: 0a 09 09 20 28 66 72 6f 6d 64 61 74 73 20 20 20 ... (fromdats
73e0: 27 28 29 29 0a 09 09 20 28 74 6f 74 72 65 63 6f '())... (totreco
73f0: 72 64 73 20 30 29 0a 09 09 20 28 62 61 74 63 68 rds 0)... (batch
7400: 2d 6c 65 6e 20 20 31 30 30 29 20 3b 3b 20 28 73 -len 100) ;; (s
7410: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f tring->number (o
7420: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
7430: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
7440: 79 6e 63 22 20 22 62 61 74 63 68 73 69 7a 65 22 ync" "batchsize"
7450: 29 20 22 31 30 30 22 29 29 29 0a 09 09 20 28 74 ) "100")))... (t
7460: 6f 64 61 74 20 20 20 20 20 20 28 6d 61 6b 65 2d odat (make-
7470: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 20 hash-table))...
7480: 28 63 6f 75 6e 74 20 20 20 20 20 20 30 29 0a 20 (count 0).
7490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
74a0: 28 66 69 65 6c 64 2d 6e 61 6d 65 73 20 28 6d 61 (field-names (ma
74b0: 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 0a 20 p car fields)).
74c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
74d0: 28 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 (delay-handicap
74e0: 20 30 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 3e 0) ;; (string->
74f0: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
7500: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
7510: 69 67 64 61 74 2a 20 22 73 79 6e 63 22 20 22 64 igdat* "sync" "d
7520: 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 29 20 elay-handicap")
7530: 22 30 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 "0"))).
7540: 20 20 20 20 20 20 20 20 29 0a 0a 09 20 20 20 20 )...
7550: 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 66 69 ;; set up the fi
7560: 65 6c 64 2d 3e 6e 75 6d 20 74 61 62 6c 65 0a 09 eld->num table..
7570: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 (for-each..
7580: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 69 65 (lambda (fie
7590: 6c 64 29 0a 09 20 20 20 20 20 20 20 28 68 61 73 ld).. (has
75a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 69 65 h-table-set! fie
75b0: 6c 64 2d 3e 6e 75 6d 20 66 69 65 6c 64 20 63 6f ld->num field co
75c0: 75 6e 74 29 0a 09 20 20 20 20 20 20 20 28 73 65 unt).. (se
75d0: 74 21 20 63 6f 75 6e 74 20 28 2b 20 63 6f 75 6e t! count (+ coun
75e0: 74 20 31 29 29 29 0a 09 20 20 20 20 20 66 69 65 t 1))).. fie
75f0: 6c 64 73 29 0a 0a 09 20 20 20 20 3b 3b 20 72 65 lds)... ;; re
7600: 61 64 20 74 68 65 20 73 6f 75 72 63 65 20 74 61 ad the source ta
7610: 62 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ble.
7620: 3b 3b 20 73 74 6f 72 65 20 61 20 6c 69 73 74 20 ;; store a list
7630: 6f 66 20 61 6c 6c 20 72 6f 77 73 20 69 6e 20 74 of all rows in t
7640: 68 65 20 74 61 62 6c 65 20 69 6e 20 66 72 6f 6d he table in from
7650: 64 61 74 2c 20 75 70 20 74 6f 20 62 61 74 63 68 dat, up to batch
7660: 2d 6c 65 6e 2e 0a 20 20 20 20 20 20 20 20 20 20 -len..
7670: 20 20 3b 3b 20 54 68 65 6e 20 61 64 64 20 66 72 ;; Then add fr
7680: 6f 6d 64 61 74 20 74 6f 20 74 68 65 20 66 72 6f omdat to the fro
7690: 6d 64 61 74 73 20 6c 69 73 74 2c 20 63 6c 65 61 mdats list, clea
76a0: 72 20 66 72 6f 6d 64 61 74 20 61 6e 64 20 72 65 r fromdat and re
76b0: 70 65 61 74 2e 0a 09 20 20 20 20 28 73 71 6c 69 peat... (sqli
76c0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
76d0: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
76e0: 61 20 2e 20 62 29 0a 09 20 20 20 20 20 20 20 28 a . b).. (
76f0: 73 65 74 21 20 66 72 6f 6d 64 61 74 20 28 63 6f set! fromdat (co
7700: 6e 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 ns (apply vector
7710: 20 61 20 62 29 20 66 72 6f 6d 64 61 74 29 29 0a a b) fromdat)).
7720: 09 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 . (if (> (
7730: 6c 65 6e 67 74 68 20 66 72 6f 6d 64 61 74 29 20 length fromdat)
7740: 62 61 74 63 68 2d 6c 65 6e 29 0a 09 09 20 20 20 batch-len)...
7750: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 (begin... (s
7760: 65 74 21 20 66 72 6f 6d 64 61 74 73 20 28 63 6f et! fromdats (co
7770: 6e 73 20 66 72 6f 6d 64 61 74 20 66 72 6f 6d 64 ns fromdat fromd
7780: 61 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 ats))... (se
7790: 74 21 20 66 72 6f 6d 64 61 74 20 20 27 28 29 29 t! fromdat '())
77a0: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 6f ... (set! to
77b0: 74 72 65 63 6f 72 64 73 20 28 2b 20 74 6f 74 72 trecords (+ totr
77c0: 65 63 6f 72 64 73 20 31 29 29 29 0a 20 20 20 20 ecords 1))).
77d0: 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 ).
77e0: 20 20 20 20 20 20 20 20 20 20 29 0a 09 20 20 20 )..
77f0: 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 (dbr:dbdat-dbh
7800: 20 66 72 6f 6d 64 62 29 0a 09 20 20 20 20 20 66 fromdb).. f
7810: 75 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 20 ull-sel)..
7820: 20 20 20 20 20 20 20 3b 3b 20 43 6f 75 6e 74 20 ;; Count
7830: 6c 65 73 73 20 74 68 61 6e 20 62 61 74 63 68 2d less than batch-
7840: 6c 65 6e 20 61 73 20 61 20 72 65 63 6f 72 64 0a len as a record.
7850: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
7860: 20 28 3e 20 28 6c 65 6e 67 74 68 20 66 72 6f 6d (> (length from
7870: 64 61 74 29 20 30 29 0a 20 20 20 20 20 20 20 20 dat) 0).
7880: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 74 (set! t
7890: 6f 74 72 65 63 6f 72 64 73 20 28 2b 20 74 6f 74 otrecords (+ tot
78a0: 72 65 63 6f 72 64 73 20 31 29 29 29 0a 0a 09 20 records 1)))...
78b0: 20 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 72 65 ;; tack on re
78c0: 6d 61 69 6e 69 6e 67 20 72 65 63 6f 72 64 73 20 maining records
78d0: 69 6e 20 66 72 6f 6d 64 61 74 0a 09 20 20 20 20 in fromdat..
78e0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
78f0: 66 72 6f 6d 64 61 74 29 29 0a 09 09 28 73 65 74 fromdat))...(set
7900: 21 20 66 72 6f 6d 64 61 74 73 20 28 63 6f 6e 73 ! fromdats (cons
7910: 20 66 72 6f 6d 64 61 74 20 66 72 6f 6d 64 61 74 fromdat fromdat
7920: 73 29 29 29 0a 0a 09 20 20 20 20 28 73 71 6c 69 s)))... (sqli
7930: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
7940: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
7950: 61 20 2e 20 62 29 0a 09 20 20 20 20 20 20 20 28 a . b).. (
7960: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
7970: 74 6f 64 61 74 20 61 20 28 61 70 70 6c 79 20 76 todat a (apply v
7980: 65 63 74 6f 72 20 61 20 62 29 29 29 0a 09 20 20 ector a b)))..
7990: 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 (dbr:dbdat-db
79a0: 68 20 74 6f 64 62 29 0a 09 20 20 20 20 20 66 75 h todb).. fu
79b0: 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 20 20 ll-sel)..
79c0: 20 20 20 20 20 28 77 68 65 6e 20 28 61 6e 64 20 (when (and
79d0: 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 20 28 delay-handicap (
79e0: 3e 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 > delay-handicap
79f0: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
7a00: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
7a10: 2d 65 72 72 20 22 69 6d 70 6f 73 69 6e 67 20 73 -err "imposing s
7a20: 79 6e 74 68 65 74 69 63 20 73 79 6e 63 20 64 65 ynthetic sync de
7a30: 6c 61 79 20 6f 66 20 22 64 65 6c 61 79 2d 68 61 lay of "delay-ha
7a40: 6e 64 69 63 61 70 22 20 73 65 63 6f 6e 64 73 20 ndicap" seconds
7a50: 73 69 6e 63 65 20 73 79 6e 63 2f 64 65 6c 61 79 since sync/delay
7a60: 2d 68 61 6e 64 69 63 61 70 20 69 73 20 63 6f 6e -handicap is con
7a70: 66 69 67 75 72 65 64 22 29 0a 20 20 20 20 20 20 figured").
7a80: 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
7a90: 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 68 61 6e sleep! delay-han
7aa0: 64 69 63 61 70 29 0a 20 20 20 20 20 20 20 20 20 dicap).
7ab0: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
7ac0: 6e 74 2d 65 72 72 20 22 73 79 6e 74 68 65 74 69 nt-err "syntheti
7ad0: 63 20 73 79 6e 63 20 64 65 6c 61 79 20 6f 66 20 c sync delay of
7ae0: 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 "delay-handicap"
7af0: 20 73 65 63 6f 6e 64 73 20 63 6f 6d 70 6c 65 74 seconds complet
7b00: 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ed").
7b10: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 ).
7b20: 20 0a 09 20 20 20 20 3b 3b 20 66 69 72 73 74 20 .. ;; first
7b30: 70 61 73 73 20 69 6d 70 6c 65 6d 65 6e 74 61 74 pass implementat
7b40: 69 6f 6e 2c 20 6a 75 73 74 20 69 6e 73 65 72 74 ion, just insert
7b50: 20 61 6c 6c 20 63 68 61 6e 67 65 64 20 72 6f 77 all changed row
7b60: 73 0a 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 s... (for-eac
7b70: 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 h .. (lambda
7b80: 20 28 74 61 72 67 64 62 29 0a 09 20 20 20 20 20 (targdb)..
7b90: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
7ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
7bb0: 72 3a 64 62 64 61 74 2d 64 62 68 20 74 61 72 67 r:dbdat-dbh targ
7bc0: 64 62 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 db)).
7bd0: 20 20 20 20 20 20 20 20 20 20 20 28 64 72 70 2d (drp-
7be0: 74 72 69 67 67 65 72 20 20 20 20 20 20 20 20 28 trigger (
7bf0: 69 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 if (member "last
7c00: 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e _update" field-n
7c10: 61 6d 65 73 29 0a 09 09 09 09 09 20 20 20 20 20 ames)......
7c20: 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 (db:drop-trigge
7c30: 72 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 20 r db tablename)
7c40: 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 ...... #f))
7c50: 0a 09 09 20 20 20 20 20 20 28 68 61 73 2d 6c 61 ... (has-la
7c60: 73 74 2d 75 70 64 61 74 65 20 20 20 20 28 6d 65 st-update (me
7c70: 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 mber "last_updat
7c80: 65 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 29 29 e" field-names))
7c90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7ca0: 20 20 20 20 20 20 20 28 69 73 2d 74 72 69 67 67 (is-trigg
7cb0: 65 72 2d 64 72 6f 70 70 65 64 20 28 69 66 20 68 er-dropped (if h
7cc0: 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 0a 20 as-last-update.
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
7d00: 3a 69 73 2d 74 72 69 67 67 65 72 2d 64 72 6f 70 :is-trigger-drop
7d10: 70 65 64 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 ped db tablename
7d20: 29 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 29 )...... #f)
7d30: 29 20 0a 09 09 20 20 20 20 20 20 28 73 74 6d 74 ) ... (stmt
7d40: 68 20 20 28 73 71 6c 69 74 65 33 3a 70 72 65 70 h (sqlite3:prep
7d50: 61 72 65 20 64 62 20 66 75 6c 6c 2d 69 6e 73 29 are db full-ins)
7d60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7d70: 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 (changed
7d80: 2d 72 6f 77 73 20 30 29 29 0a 09 09 20 28 66 6f -rows 0))... (fo
7d90: 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 r-each... (lamb
7da0: 64 61 20 28 66 72 6f 6d 64 61 74 2d 6c 73 74 29 da (fromdat-lst)
7db0: 0a 09 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ... (sqlite3:
7dc0: 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e with-transaction
7dd0: 0a 09 09 20 20 20 20 20 64 62 0a 09 09 20 20 20 ... db...
7de0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 (lambda ()...
7df0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
7e00: 3b 3b 20 0a 09 09 09 28 6c 61 6d 62 64 61 20 28 ;; ....(lambda (
7e10: 66 72 6f 6d 72 6f 77 29 0a 09 09 09 20 20 28 6c fromrow).... (l
7e20: 65 74 2a 20 28 28 61 20 20 20 20 28 76 65 63 74 et* ((a (vect
7e30: 6f 72 2d 72 65 66 20 66 72 6f 6d 72 6f 77 20 30 or-ref fromrow 0
7e40: 29 29 0a 09 09 09 09 20 28 63 75 72 72 20 28 68 ))..... (curr (h
7e50: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7e60: 66 61 75 6c 74 20 74 6f 64 61 74 20 61 20 23 66 fault todat a #f
7e70: 29 29 0a 09 09 09 09 20 28 73 61 6d 65 20 23 74 ))..... (same #t
7e80: 29 29 0a 09 09 09 20 20 20 20 28 6c 65 74 20 6c )).... (let l
7e90: 6f 6f 70 20 28 28 69 20 30 29 29 0a 09 09 09 20 oop ((i 0))....
7ea0: 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f (if (or (no
7eb0: 74 20 63 75 72 72 29 0a 09 09 09 09 20 20 20 20 t curr).....
7ec0: 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 (not (equal? (
7ed0: 76 65 63 74 6f 72 2d 72 65 66 20 66 72 6f 6d 72 vector-ref fromr
7ee0: 6f 77 20 69 29 28 76 65 63 74 6f 72 2d 72 65 66 ow i)(vector-ref
7ef0: 20 63 75 72 72 20 69 29 29 29 29 0a 09 09 09 09 curr i)))).....
7f00: 20 20 28 73 65 74 21 20 73 61 6d 65 20 23 66 29 (set! same #f)
7f10: 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 ).... (if (
7f20: 61 6e 64 20 73 61 6d 65 0a 09 09 09 09 20 20 20 and same.....
7f30: 20 20 20 20 28 3c 20 69 20 28 2d 20 6e 75 6d 2d (< i (- num-
7f40: 66 69 65 6c 64 73 20 31 29 29 29 0a 09 09 09 09 fields 1))).....
7f50: 20 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 29 (loop (+ i 1))
7f60: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6e )).... (if (n
7f70: 6f 74 20 73 61 6d 65 29 0a 09 09 09 09 28 62 65 ot same).....(be
7f80: 67 69 6e 0a 09 09 09 09 20 20 28 61 70 70 6c 79 gin..... (apply
7f90: 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 sqlite3:execute
7fa0: 20 73 74 6d 74 68 20 28 76 65 63 74 6f 72 2d 3e stmth (vector->
7fb0: 6c 69 73 74 20 66 72 6f 6d 72 6f 77 29 29 0a 09 list fromrow))..
7fc0: 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
7fd0: 2d 73 65 74 21 20 6e 75 6d 72 65 63 73 20 74 61 -set! numrecs ta
7fe0: 62 6c 65 6e 61 6d 65 20 28 2b 20 31 20 28 68 61 blename (+ 1 (ha
7ff0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
8000: 61 75 6c 74 20 6e 75 6d 72 65 63 73 20 74 61 62 ault numrecs tab
8010: 6c 65 6e 61 6d 65 20 30 29 29 29 0a 20 20 20 20 lename 0))).
8020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
8040: 65 74 21 20 63 68 61 6e 67 65 64 2d 72 6f 77 73 et! changed-rows
8050: 20 28 2b 20 63 68 61 6e 67 65 64 2d 72 6f 77 73 (+ changed-rows
8060: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
8070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8080: 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 ).
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 ).
80b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80c0: 20 29 29 0a 09 09 09 66 72 6f 6d 64 61 74 2d 6c ))....fromdat-l
80d0: 73 74 29 29 29 29 0a 09 09 20 20 66 72 6f 6d 64 st))))... fromd
80e0: 61 74 73 29 0a 0a 09 09 20 28 73 71 6c 69 74 65 ats).... (sqlite
80f0: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 73 74 6d 74 3:finalize! stmt
8100: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
8110: 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 (if (member
8120: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 66 69 "last_update" fi
8130: 65 6c 64 2d 6e 61 6d 65 73 29 0a 20 20 20 20 20 eld-names).
8140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8150: 64 62 3a 63 72 65 61 74 65 2d 74 72 69 67 67 65 db:create-trigge
8160: 72 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 29 29 r db tablename))
8170: 29 29 0a 09 20 20 20 20 20 28 61 70 70 65 6e 64 )).. (append
8180: 20 28 6c 69 73 74 20 74 6f 64 62 29 20 73 6c 61 (list todb) sla
8190: 76 65 2d 64 62 73 29 0a 20 20 20 20 20 20 20 20 ve-dbs).
81a0: 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 29 ). )
81b0: 0a 20 20 20 20 20 20 20 20 29 0a 09 74 62 6c 73 . )..tbls
81c0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
81d0: 28 72 75 6e 74 69 6d 65 20 20 20 20 20 20 28 2d (runtime (-
81e0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
81f0: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
8200: 6d 65 29 29 0a 09 20 20 20 20 20 20 28 73 68 6f me)).. (sho
8210: 75 6c 64 2d 70 72 69 6e 74 20 28 6f 72 20 3b 3b uld-print (or ;;
8220: 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f (debug:debug-mo
8230: 64 65 20 31 32 29 0a 09 09 09 20 20 20 20 20 28 de 12).... (
8240: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
8250: 2d 70 72 69 6e 74 20 31 32 30 20 22 64 62 20 73 -print 120 "db s
8260: 79 6e 63 22 29 0a 09 09 09 20 20 20 20 20 28 3e ync").... (>
8270: 20 72 75 6e 74 69 6d 65 20 35 30 30 29 29 29 29 runtime 500))))
8280: 20 3b 3b 20 6c 6f 77 20 61 6e 64 20 68 69 67 68 ;; low and high
8290: 20 73 79 6e 63 20 74 69 6d 65 73 20 74 72 65 61 sync times trea
82a0: 74 65 64 20 61 73 20 73 65 70 61 72 61 74 65 2e ted as separate.
82b0: 0a 09 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 .. (for-each ..
82c0: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 29 0a 09 (lambda (dat)..
82d0: 20 20 20 20 28 6c 65 74 20 28 28 74 62 6c 6e 61 (let ((tblna
82e0: 6d 65 20 28 63 61 72 20 64 61 74 29 29 0a 09 09 me (car dat))...
82f0: 20 20 28 63 6f 75 6e 74 20 20 20 28 63 64 72 20 (count (cdr
8300: 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 73 dat))).. (s
8310: 65 74 21 20 74 6f 74 2d 63 6f 75 6e 74 20 28 2b et! tot-count (+
8320: 20 74 6f 74 2d 63 6f 75 6e 74 20 63 6f 75 6e 74 tot-count count
8330: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8340: 20 29 29 20 0a 09 20 20 28 73 6f 72 74 20 28 68 )) .. (sort (h
8350: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
8360: 20 6e 75 6d 72 65 63 73 29 28 6c 61 6d 62 64 61 numrecs)(lambda
8370: 20 28 61 20 62 29 28 3e 20 28 63 64 72 20 61 29 (a b)(> (cdr a)
8380: 28 63 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 (cdr b)))))).
8390: 20 20 20 20 74 6f 74 2d 63 6f 75 6e 74 29 29 29 tot-count)))
83a0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
83b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
83f0: 74 72 69 67 67 65 72 20 73 65 74 75 70 2f 74 61 trigger setup/ta
8400: 6b 65 64 6f 77 6e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d kedown.;;=======
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: 0a 28 64 65 66 69 6e 65 20 64 62 3a 74 72 69 67 .(define db:trig
8460: 67 65 72 2d 6c 69 73 74 20 0a 20 20 20 20 20 28 ger-list . (
8470: 6c 69 73 74 20 28 6c 69 73 74 20 22 75 70 64 61 list (list "upda
8480: 74 65 5f 72 75 6e 73 5f 74 72 69 67 67 65 72 22 te_runs_trigger"
8490: 20 20 22 43 52 45 41 54 45 20 54 52 49 47 47 45 "CREATE TRIGGE
84a0: 52 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 R IF NOT EXISTS
84b0: 75 70 64 61 74 65 5f 72 75 6e 73 5f 74 72 69 67 update_runs_trig
84c0: 67 65 72 20 41 46 54 45 52 20 55 50 44 41 54 45 ger AFTER UPDATE
84d0: 20 4f 4e 20 72 75 6e 73 0a 20 20 20 20 20 20 20 ON runs.
84e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84f0: 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 FOR EACH R
8500: 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 OW.
8510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8520: 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 BEGIN .
8530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8540: 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 UPDATE
8550: 20 72 75 6e 73 20 53 45 54 20 6c 61 73 74 5f 75 runs SET last_u
8560: 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 pdate=(strftime(
8570: 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 '%s','now')).
8580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85a0: 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b WHERE id=old.id;
85b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
85c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85d0: 45 4e 44 3b 22 20 29 20 0a 09 20 20 20 28 6c 69 END;" ) .. (li
85e0: 73 74 20 22 75 70 64 61 74 65 5f 72 75 6e 5f 73 st "update_run_s
85f0: 74 61 74 73 5f 74 72 69 67 67 65 72 22 20 20 22 tats_trigger" "
8600: 43 52 45 41 54 45 20 54 52 49 47 47 45 52 20 20 CREATE TRIGGER
8610: 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 70 IF NOT EXISTS up
8620: 64 61 74 65 5f 72 75 6e 5f 73 74 61 74 73 5f 74 date_run_stats_t
8630: 72 69 67 67 65 72 20 41 46 54 45 52 20 55 50 44 rigger AFTER UPD
8640: 41 54 45 20 4f 4e 20 72 75 6e 5f 73 74 61 74 73 ATE ON run_stats
8650: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f FO
8670: 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 R EACH ROW.
8680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8690: 20 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 BEGIN
86a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86c0: 20 20 55 50 44 41 54 45 20 72 75 6e 5f 73 74 61 UPDATE run_sta
86d0: 74 73 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 ts SET last_upda
86e0: 74 65 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 te=(strftime('%s
86f0: 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 ','now')).
8700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8710: 20 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 WHE
8720: 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 RE id=old.id;.
8730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8740: 20 20 20 20 20 20 20 20 20 20 20 20 20 45 4e 44 END
8750: 3b 22 20 29 0a 09 20 20 20 28 6c 69 73 74 20 22 ;" ).. (list "
8760: 75 70 64 61 74 65 5f 74 65 73 74 73 5f 74 72 69 update_tests_tri
8770: 67 67 65 72 22 20 20 22 43 52 45 41 54 45 20 54 gger" "CREATE T
8780: 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 RIGGER IF NOT E
8790: 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 XISTS update_tes
87a0: 74 73 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 ts_trigger AFTER
87b0: 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 74 73 UPDATE ON tests
87c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
87d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f FO
87e0: 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 R EACH ROW.
87f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8800: 20 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 BEGIN
8810: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8830: 20 20 55 50 44 41 54 45 20 74 65 73 74 73 20 53 UPDATE tests S
8840: 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 ET last_update=(
8850: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
8860: 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 ow')).
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8880: 20 20 20 20 20 20 20 20 20 57 48 45 52 45 20 69 WHERE i
8890: 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 d=old.id;.
88a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88b0: 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 END;" )
88c0: 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 64 61 .. (list "upda
88d0: 74 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 te_teststeps_tri
88e0: 67 67 65 72 22 20 20 22 43 52 45 41 54 45 20 54 gger" "CREATE T
88f0: 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 RIGGER IF NOT E
8900: 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 XISTS update_tes
8910: 74 73 74 65 70 73 5f 74 72 69 67 67 65 72 20 41 tsteps_trigger A
8920: 46 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 FTER UPDATE ON t
8930: 65 73 74 5f 73 74 65 70 73 0a 20 20 20 20 20 20 est_steps.
8940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8950: 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 FOR EACH
8960: 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 ROW.
8970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8980: 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 BEGIN .
8990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89a0: 20 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 UPDAT
89b0: 45 20 74 65 73 74 5f 73 74 65 70 73 20 53 45 54 E test_steps SET
89c0: 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 last_update=(st
89d0: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
89e0: 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ')).
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 57 48 45 52 45 20 69 64 3d WHERE id=
8a10: 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 old.id;.
8a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a30: 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 0a 09 END;" )..
8a40: 20 20 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 (list "update
8a50: 5f 74 65 73 74 5f 64 61 74 61 5f 74 72 69 67 67 _test_data_trigg
8a60: 65 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 er" "CREATE TRI
8a70: 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 58 49 GGER IF NOT EXI
8a80: 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 74 5f STS update_test_
8a90: 64 61 74 61 5f 74 72 69 67 67 65 72 20 41 46 54 data_trigger AFT
8aa0: 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 ER UPDATE ON tes
8ab0: 74 5f 64 61 74 61 0a 20 20 20 20 20 20 20 20 20 t_data.
8ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ad0: 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 4f 57 FOR EACH ROW
8ae0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b00: 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 20 20 BEGIN .
8b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b20: 20 20 20 20 20 20 20 20 55 50 44 41 54 45 20 74 UPDATE t
8b30: 65 73 74 5f 64 61 74 61 20 53 45 54 20 6c 61 73 est_data SET las
8b40: 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 t_update=(strfti
8b50: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a me('%s','now')).
8b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b80: 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e WHERE id=old.
8b90: 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 id;.
8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bb0: 20 20 20 45 4e 44 3b 22 20 29 29 29 0a 28 64 65 END;" ))).(de
8bc0: 66 69 6e 65 20 28 64 62 3a 69 73 2d 74 72 69 67 fine (db:is-trig
8bd0: 67 65 72 2d 64 72 6f 70 70 65 64 20 64 62 20 74 ger-dropped db t
8be0: 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a bl-name). (let*
8bf0: 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 ((trigger-name
8c00: 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d (if (equal? tbl-
8c10: 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 name "test_steps
8c20: 22 29 0a 09 09 09 20 20 20 22 75 70 64 61 74 65 ").... "update
8c30: 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 _teststeps_trigg
8c40: 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 er" .
8c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c60: 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 (conc "update_"
8c70: 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 tbl-name "_trigg
8c80: 65 72 22 29 29 29 0a 09 20 28 72 65 73 20 20 20 er"))).. (res
8c90: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
8ca0: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
8cb0: 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 h-row. (lamb
8cc0: 64 61 20 28 6e 61 6d 65 29 0a 20 20 20 20 20 20 da (name).
8cd0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 6e 61 6d (if (equal? nam
8ce0: 65 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 0a e trigger-name).
8cf0: 09 20 20 20 28 73 65 74 21 20 72 65 73 20 23 74 . (set! res #t
8d00: 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 20 ))). db .
8d10: 20 20 22 53 45 4c 45 43 54 20 6e 61 6d 65 20 46 "SELECT name F
8d20: 52 4f 4d 20 73 71 6c 69 74 65 5f 6d 61 73 74 65 ROM sqlite_maste
8d30: 72 20 57 48 45 52 45 20 74 79 70 65 20 3d 20 27 r WHERE type = '
8d40: 74 72 69 67 67 65 72 27 20 3b 22 29 0a 20 20 20 trigger' ;").
8d50: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
8d60: 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 65 72 (db:drop-trigger
8d70: 73 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 61 63 s db). (for-eac
8d80: 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 h. (lambda (ke
8d90: 79 29 20 0a 20 20 20 20 20 28 73 71 6c 69 74 65 y) . (sqlite
8da0: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
8db0: 6e 63 20 22 64 72 6f 70 20 74 72 69 67 67 65 72 nc "drop trigger
8dc0: 20 69 66 20 65 78 69 73 74 73 20 22 20 28 63 61 if exists " (ca
8dd0: 72 20 6b 65 79 29 29 29 29 0a 20 20 20 64 62 3a r key)))). db:
8de0: 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 0a 0a trigger-list))..
8df0: 28 64 65 66 69 6e 65 20 20 28 64 62 3a 64 72 6f (define (db:dro
8e00: 70 2d 74 72 69 67 67 65 72 20 64 62 20 74 62 6c p-trigger db tbl
8e10: 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 -name). (let* (
8e20: 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 28 69 (trigger-name (i
8e30: 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d 6e 61 f (equal? tbl-na
8e40: 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 22 29 me "test_steps")
8e50: 0a 09 09 09 20 20 20 22 75 70 64 61 74 65 5f 74 .... "update_t
8e60: 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 72 eststeps_trigger
8e70: 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 " .
8e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
8e90: 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 74 62 onc "update_" tb
8ea0: 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 65 72 l-name "_trigger
8eb0: 22 29 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ")))). (for-e
8ec0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
8ed0: 20 28 6b 65 79 29 20 0a 20 20 20 20 20 20 20 28 (key) . (
8ee0: 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 20 if (equal? (car
8ef0: 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e 61 6d key) trigger-nam
8f00: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 e). (s
8f10: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
8f20: 62 20 28 63 6f 6e 63 20 22 64 72 6f 70 20 74 72 b (conc "drop tr
8f30: 69 67 67 65 72 20 69 66 20 65 78 69 73 74 73 20 igger if exists
8f40: 22 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 29 29 " trigger-name))
8f50: 29 29 0a 20 20 20 20 20 64 62 3a 74 72 69 67 67 )). db:trigg
8f60: 65 72 2d 6c 69 73 74 29 29 29 0a 0a 28 64 65 66 er-list)))..(def
8f70: 69 6e 65 20 20 28 64 62 3a 63 72 65 61 74 65 2d ine (db:create-
8f80: 74 72 69 67 67 65 72 20 64 62 20 74 62 6c 2d 6e trigger db tbl-n
8f90: 61 6d 65 29 0a 20 20 20 20 20 20 28 6c 65 74 2a ame). (let*
8fa0: 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 ((trigger-name
8fb0: 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d (if (equal? tbl-
8fc0: 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 name "test_steps
8fd0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
8fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ff0: 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 74 65 "update_testste
9000: 70 73 5f 74 72 69 67 67 65 72 22 20 0a 20 20 20 ps_trigger" .
9010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9020: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
9030: 20 22 75 70 64 61 74 65 5f 22 20 74 62 6c 2d 6e "update_" tbl-n
9040: 61 6d 65 20 22 5f 74 72 69 67 67 65 72 22 29 29 ame "_trigger"))
9050: 29 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 )). (for-e
9060: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 ach (lambda (key
9070: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
9080: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 72 (if (equal? (car
9090: 20 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e 61 key) trigger-na
90a0: 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 me).
90b0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
90c0: 65 20 64 62 20 28 63 61 64 72 20 6b 65 79 29 29 e db (cadr key))
90d0: 29 29 0a 20 20 20 20 20 20 64 62 3a 74 72 69 67 )). db:trig
90e0: 67 65 72 2d 6c 69 73 74 29 29 29 20 0a 0a 3b 3b ger-list))) ..;;
90f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9130: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 64 62 20 61 63 63 ======.;; db acc
9140: 65 73 73 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d ess stuff.;;====
9150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9190: 3d 3d 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 ==..;; call with
91a0: 20 64 62 69 6e 69 74 3d 64 62 3a 69 6e 69 74 69 dbinit=db:initi
91b0: 61 6c 69 7a 65 2d 6d 61 69 6e 2d 64 62 0a 3b 3b alize-main-db.;;
91c0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6f 70 65 .(define (db:ope
91d0: 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 n-db dbstruct ru
91e0: 6e 2d 69 64 20 64 62 69 6e 69 74 29 0a 20 20 3b n-id dbinit). ;
91f0: 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a ; (mutex-lock! *
9200: 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 0a db-open-mutex*).
9210: 20 20 28 6c 65 74 2a 20 28 28 64 62 64 61 74 20 (let* ((dbdat
9220: 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 (dbfile:open-db
9230: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
9240: 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 20 20 dbinit))).
9250: 20 20 20 20 20 20 20 20 23 3b 28 63 61 73 65 20 #;(case
9260: 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6d (rmt:transport-m
9270: 6f 64 65 29 0a 09 09 20 20 28 28 68 74 74 70 29 ode)... ((http)
9280: 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 (dbfile:open-db
9290: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
92a0: 20 64 62 69 6e 69 74 29 29 0a 09 09 20 20 28 28 dbinit))... ((
92b0: 74 63 70 29 20 20 28 64 62 6d 6f 64 3a 6f 70 65 tcp) (dbmod:ope
92c0: 6e 2d 64 62 20 20 64 62 73 74 72 75 63 74 20 72 n-db dbstruct r
92d0: 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 29 0a 09 un-id dbinit))..
92e0: 09 20 20 28 65 6c 73 65 20 28 61 73 73 65 72 74 . (else (assert
92f0: 20 23 66 20 22 46 41 54 41 4c 3a 20 72 6d 74 3a #f "FATAL: rmt:
9300: 74 72 61 6e 73 70 6f 72 74 2d 6e 6f 64 65 20 6e transport-node n
9310: 6f 74 20 63 6f 72 72 65 63 74 20 76 61 6c 75 65 ot correct value
9320: 22 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d "(rmt:transport-
9330: 6d 6f 64 65 29 29 29 29 0a 20 20 20 20 28 73 65 mode)))). (se
9340: 74 21 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 t! *db-write-acc
9350: 65 73 73 2a 20 28 6e 6f 74 20 28 64 62 72 3a 64 ess* (not (dbr:d
9360: 62 64 61 74 2d 72 65 61 64 2d 6f 6e 6c 79 20 64 bdat-read-only d
9370: 62 64 61 74 29 29 29 0a 20 20 20 20 3b 3b 20 28 bdat))). ;; (
9380: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
9390: 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 0a 20 b-open-mutex*).
93a0: 20 20 20 64 62 64 61 74 29 29 0a 0a 28 64 65 66 dbdat))..(def
93b0: 69 6e 65 20 64 62 66 69 6c 65 3a 64 62 2d 69 6e ine dbfile:db-in
93c0: 69 74 2d 70 72 6f 63 20 28 6d 61 6b 65 2d 70 61 it-proc (make-pa
93d0: 72 61 6d 65 74 65 72 20 23 66 29 29 0a 0a 3b 3b rameter #f))..;;
93e0: 20 69 6e 20 78 6d 61 78 69 6d 61 20 74 68 69 73 in xmaxima this
93f0: 20 67 69 76 65 73 20 61 20 63 75 72 76 65 20 63 gives a curve c
9400: 6c 6f 73 65 20 74 6f 20 77 68 61 74 20 49 20 77 lose to what I w
9410: 61 6e 74 3a 0a 3b 3b 20 20 20 20 70 6c 6f 74 32 ant:.;; plot2
9420: 64 20 28 28 65 78 70 28 78 2f 31 2e 32 29 2d 31 d ((exp(x/1.2)-1
9430: 29 2f 33 30 30 2c 20 5b 78 2c 20 30 2c 20 31 30 )/300, [x, 0, 10
9440: 5d 29 24 0a 3b 3b 20 20 20 20 70 6c 6f 74 32 64 ])$.;; plot2d
9450: 20 28 28 65 78 70 28 78 2f 31 2e 35 29 2d 31 29 ((exp(x/1.5)-1)
9460: 2f 34 30 2c 20 5b 78 2c 20 30 2c 20 31 30 5d 29 /40, [x, 0, 10])
9470: 24 0a 3b 3b 20 20 20 20 70 6c 6f 74 32 64 20 28 $.;; plot2d (
9480: 28 65 78 70 28 78 2f 35 29 2d 31 29 2f 34 30 2c (exp(x/5)-1)/40,
9490: 20 5b 78 2c 20 30 2c 20 32 30 5d 29 24 0a 28 64 [x, 0, 20])$.(d
94a0: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 64 72 efine (dbfile:dr
94b0: 6f 6f 70 20 78 29 0a 20 20 28 2f 20 28 2d 20 28 oop x). (/ (- (
94c0: 65 78 70 20 28 2f 20 78 20 35 29 29 20 31 29 20 exp (/ x 5)) 1)
94d0: 34 30 29 29 0a 20 20 3b 3b 20 28 2a 20 6e 75 6d 40)). ;; (* num
94e0: 71 72 79 73 20 28 2f 20 31 20 28 71 69 66 2d 73 qrys (/ 1 (qif-s
94f0: 6c 6f 70 65 29 29 29 29 0a 0a 3b 3b 20 63 72 65 lope))))..;; cre
9500: 61 74 65 20 61 20 64 72 6f 70 70 69 6e 67 20 6e ate a dropping n
9510: 65 61 72 20 74 68 65 20 64 62 20 66 69 6c 65 20 ear the db file
9520: 69 6e 20 61 20 71 69 66 20 64 69 72 0a 3b 3b 20 in a qif dir.;;
9530: 75 73 65 20 63 6f 75 6e 74 20 6f 66 20 73 75 63 use count of suc
9540: 68 20 66 69 6c 65 73 20 74 6f 20 67 61 74 65 20 h files to gate
9550: 71 75 65 72 69 65 73 20 28 71 75 65 72 69 65 73 queries (queries
9560: 20 69 6e 20 66 6c 69 67 68 74 29 0a 3b 3b 0a 28 in flight).;;.(
9570: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 77 define (dbfile:w
9580: 61 69 74 2d 66 6f 72 2d 71 69 66 20 66 6e 61 6d ait-for-qif fnam
9590: 65 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 e run-id params)
95a0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 68 65 64 69 . (let* ((thedi
95b0: 72 20 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 r (pathname-dir
95c0: 65 63 74 6f 72 79 20 66 6e 61 6d 65 29 29 0a 09 ectory fname))..
95d0: 20 28 64 62 6e 75 6d 20 20 20 28 64 62 66 69 6c (dbnum (dbfil
95e0: 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 75 6d 20 e:run-id->dbnum
95f0: 72 75 6e 2d 69 64 29 29 0a 09 20 28 64 65 73 74 run-id)).. (dest
9600: 64 69 72 20 28 63 6f 6e 63 20 74 68 65 64 69 72 dir (conc thedir
9610: 22 2f 71 69 66 2d 22 64 62 6e 75 6d 29 29 0a 09 "/qif-"dbnum))..
9620: 20 28 75 6e 69 71 6e 20 20 20 28 67 65 74 2d 61 (uniqn (get-a
9630: 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 rea-path-signatu
9640: 72 65 20 28 63 6f 6e 63 20 64 62 6e 75 6d 20 70 re (conc dbnum p
9650: 61 72 61 6d 73 29 29 29 0a 09 20 28 63 72 75 6d arams))).. (crum
9660: 62 6e 20 20 28 63 6f 6e 63 20 64 65 73 74 64 69 bn (conc destdi
9670: 72 22 2f 22 28 63 75 72 72 65 6e 74 2d 73 65 63 r"/"(current-sec
9680: 6f 6e 64 73 29 22 2d 22 75 6e 69 71 6e 22 2e 22 onds)"-"uniqn"."
9690: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
96a0: 2d 69 64 29 29 29 29 0a 20 20 20 20 28 69 66 20 -id)))). (if
96b0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
96c0: 73 3f 20 64 65 73 74 64 69 72 29 29 28 63 72 65 s? destdir))(cre
96d0: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 ate-directory (c
96e0: 6f 6e 63 20 64 65 73 74 64 69 72 22 2f 61 74 74 onc destdir"/att
96f0: 69 63 22 29 20 23 74 29 29 0a 20 20 20 20 28 6c ic") #t)). (l
9700: 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 et loop ((count
9710: 30 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 0)). (let*
9720: 28 28 63 75 72 72 6c 6b 73 20 28 67 6c 6f 62 20 ((currlks (glob
9730: 28 63 6f 6e 63 20 64 65 73 74 64 69 72 22 2f 2a (conc destdir"/*
9740: 22 29 29 29 0a 09 20 20 20 20 20 28 6e 75 6d 71 "))).. (numq
9750: 72 79 73 20 28 6c 65 6e 67 74 68 20 63 75 72 72 rys (length curr
9760: 6c 6b 73 29 29 0a 09 20 20 20 20 20 28 64 65 6c lks)).. (del
9770: 61 79 76 61 6c 20 28 63 6f 6e 64 20 3b 3b 20 64 ayval (cond ;; d
9780: 6f 20 61 20 64 72 6f 6f 70 69 73 68 20 63 75 72 o a droopish cur
9790: 76 65 0a 09 09 09 28 28 3e 20 6e 75 6d 71 72 79 ve....((> numqry
97a0: 73 20 32 35 29 0a 09 09 09 20 28 66 6f 72 2d 65 s 25).... (for-e
97b0: 61 63 68 0a 09 09 09 20 20 28 6c 61 6d 62 64 61 ach.... (lambda
97c0: 20 28 66 29 0a 09 09 09 20 20 20 20 28 69 66 20 (f).... (if
97d0: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
97e0: 65 63 6f 6e 64 73 29 0a 09 09 09 09 20 20 20 20 econds).....
97f0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
9800: 69 6f 6e 73 0a 09 09 09 09 09 20 20 65 78 6e 0a ions...... exn.
9810: 09 09 09 09 09 28 63 75 72 72 65 6e 74 2d 73 65 .....(current-se
9820: 63 6f 6e 64 73 29 20 3b 3b 20 66 69 6c 65 20 69 conds) ;; file i
9830: 73 20 6c 69 6b 65 6c 79 20 67 6f 6e 65 2c 20 6a s likely gone, j
9840: 75 73 74 20 66 61 6b 65 20 6f 75 74 0a 09 09 09 ust fake out....
9850: 09 09 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 ..(file-modifica
9860: 74 69 6f 6e 2d 74 69 6d 65 20 66 29 29 29 0a 09 tion-time f)))..
9870: 09 09 09 20 20 20 28 6b 65 65 70 2d 61 67 65 2d ... (keep-age-
9880: 70 61 72 61 6d 29 29 0a 09 09 09 09 28 6c 65 74 param)).....(let
9890: 2a 20 28 28 62 61 73 65 64 69 72 20 28 70 61 74 * ((basedir (pat
98a0: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
98b0: 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 f))..... (
98c0: 66 69 6c 65 6e 20 20 20 28 70 61 74 68 6e 61 6d filen (pathnam
98d0: 65 2d 66 69 6c 65 20 66 29 29 0a 09 09 09 09 20 e-file f)).....
98e0: 20 20 20 20 20 20 28 64 65 73 74 66 20 20 20 28 (destf (
98f0: 63 6f 6e 63 20 62 61 73 65 64 69 72 22 2f 61 74 conc basedir"/at
9900: 74 69 63 2f 22 66 69 6c 65 6e 29 29 29 0a 09 09 tic/"filen)))...
9910: 09 09 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e .. (dbfile:prin
9920: 74 2d 65 72 72 20 22 4d 6f 76 69 6e 67 20 71 69 t-err "Moving qi
9930: 66 20 66 69 6c 65 20 22 66 22 20 6f 6c 64 65 72 f file "f" older
9940: 20 74 68 61 6e 20 31 30 20 73 65 63 6f 6e 64 73 than 10 seconds
9950: 20 74 6f 20 22 64 65 73 74 66 29 0a 09 09 09 09 to "destf).....
9960: 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d 66 69 6c ;; (delete-fil
9970: 65 2a 20 66 29 0a 09 09 09 09 20 20 28 68 61 6e e* f)..... (han
9980: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
9990: 09 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 09 ... exn....
99a0: 09 20 20 20 20 23 74 0a 09 09 09 09 20 20 20 20 . #t.....
99b0: 28 66 69 6c 65 2d 6d 6f 76 65 20 66 20 64 65 73 (file-move f des
99c0: 74 66 20 23 74 29 29 29 29 29 0a 09 09 09 20 20 tf #t)))))....
99d0: 63 75 72 72 6c 6b 73 29 0a 09 09 09 20 34 29 0a currlks).... 4).
99e0: 09 09 09 28 28 3e 20 6e 75 6d 71 72 79 73 20 30 ...((> numqrys 0
99f0: 29 20 20 28 64 62 66 69 6c 65 3a 64 72 6f 6f 70 ) (dbfile:droop
9a00: 20 6e 75 6d 71 72 79 73 29 29 20 3b 3b 20 73 6c numqrys)) ;; sl
9a10: 6f 70 65 20 6f 66 20 31 2f 31 30 30 0a 09 09 09 ope of 1/100....
9a20: 28 65 6c 73 65 20 23 66 29 29 29 29 0a 09 28 69 (else #f))))..(i
9a30: 66 20 28 61 6e 64 20 64 65 6c 61 79 76 61 6c 0a f (and delayval.
9a40: 09 09 20 28 3c 20 63 6f 75 6e 74 20 35 29 29 0a .. (< count 5)).
9a50: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
9a60: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
9a70: 21 20 64 65 6c 61 79 76 61 6c 29 0a 09 20 20 20 ! delayval)..
9a80: 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e (loop (+ coun
9a90: 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 28 77 t 1)))))). (w
9aa0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
9ab0: 6c 65 20 63 72 75 6d 62 6e 0a 20 20 20 20 20 20 le crumbn.
9ac0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 70 72 69 (lambda ()..(pri
9ad0: 6e 74 20 66 6e 61 6d 65 22 20 72 75 6e 2d 69 64 nt fname" run-id
9ae0: 3d 22 72 75 6e 2d 69 64 22 20 70 61 72 61 6d 73 ="run-id" params
9af0: 3d 22 70 61 72 61 6d 73 29 0a 09 29 29 0a 20 20 ="params)..)).
9b00: 20 20 63 72 75 6d 62 6e 29 29 0a 0a 28 64 65 66 crumbn))..(def
9b10: 69 6e 65 20 6e 6f 2d 63 6f 6e 64 69 74 69 6f 6e ine no-condition
9b20: 2d 64 62 2d 77 69 74 68 2d 64 62 20 28 6d 61 6b -db-with-db (mak
9b30: 65 2d 70 61 72 61 6d 65 74 65 72 20 23 74 29 29 e-parameter #t))
9b40: 0a 0a 3b 3b 20 28 64 62 3a 77 69 74 68 2d 64 62 ..;; (db:with-db
9b50: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
9b60: 20 73 71 6c 69 74 65 33 3a 65 78 65 63 20 22 73 sqlite3:exec "s
9b70: 65 6c 65 63 74 20 62 6c 61 68 20 66 67 72 6f 6d elect blah fgrom
9b80: 20 62 6c 61 7a 3b 22 29 0a 3b 3b 20 72 2f 77 20 blaz;").;; r/w
9b90: 69 73 20 61 20 66 6c 61 67 20 74 6f 20 69 6e 64 is a flag to ind
9ba0: 69 63 61 74 65 20 69 66 20 74 68 65 20 64 62 20 icate if the db
9bb0: 69 73 20 6d 6f 64 69 66 69 65 64 20 62 79 20 74 is modified by t
9bc0: 68 69 73 20 71 75 65 72 79 20 23 74 20 3d 20 79 his query #t = y
9bd0: 65 73 2c 20 23 66 20 3d 20 6e 6f 0a 3b 3b 0a 28 es, #f = no.;;.(
9be0: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 77 define (dbfile:w
9bf0: 69 74 68 2d 64 62 20 64 62 73 74 72 75 63 74 20 ith-db dbstruct
9c00: 72 75 6e 2d 69 64 20 72 2f 77 20 70 72 6f 63 20 run-id r/w proc
9c10: 70 61 72 61 6d 73 29 0a 20 20 28 61 73 73 65 72 params). (asser
9c20: 74 20 64 62 73 74 72 75 63 74 20 22 46 41 54 41 t dbstruct "FATA
9c30: 4c 3a 20 64 62 3a 77 69 74 68 2d 64 62 20 63 61 L: db:with-db ca
9c40: 6c 6c 65 64 20 77 69 74 68 20 64 62 73 74 72 75 lled with dbstru
9c50: 63 74 20 22 23 66 29 0a 20 20 28 61 73 73 65 72 ct "#f). (asser
9c60: 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 3f t (dbr:dbstruct?
9c70: 20 64 62 73 74 72 75 63 74 29 20 22 46 41 54 41 dbstruct) "FATA
9c80: 4c 3a 20 64 62 73 74 72 75 63 74 20 69 73 20 22 L: dbstruct is "
9c90: 64 62 73 74 72 75 63 74 29 0a 20 20 28 6c 65 74 dbstruct). (let
9ca0: 2a 20 28 28 75 73 65 2d 6d 75 74 65 78 20 28 3e * ((use-mutex (>
9cb0: 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 *api-process-re
9cc0: 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 32 35 29 quest-count* 25)
9cd0: 29 20 3b 3b 20 72 69 73 6b 20 6f 66 20 64 62 20 ) ;; risk of db
9ce0: 63 6f 72 72 75 70 74 69 6f 6e 0a 09 20 28 68 61 corruption.. (ha
9cf0: 76 65 2d 73 74 72 75 63 74 20 28 64 62 72 3a 64 ve-struct (dbr:d
9d00: 62 73 74 72 75 63 74 3f 20 64 62 73 74 72 75 63 bstruct? dbstruc
9d10: 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 62 t)). (db
9d20: 64 61 74 20 20 20 20 20 28 69 66 20 68 61 76 65 dat (if have
9d30: 2d 73 74 72 75 63 74 20 20 20 20 20 20 20 20 20 -struct
9d40: 20 20 20 20 20 20 20 3b 3b 20 74 68 69 73 20 73 ;; this s
9d50: 74 75 66 66 20 6a 75 73 74 20 61 6c 6c 6f 77 73 tuff just allows
9d60: 20 75 73 20 74 6f 20 63 61 6c 6c 20 77 69 74 68 us to call with
9d70: 20 61 20 64 62 20 68 61 6e 64 6c 65 20 64 69 72 a db handle dir
9d80: 65 63 74 6c 79 0a 09 09 09 28 64 62 3a 6f 70 65 ectly....(db:ope
9d90: 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 n-db dbstruct ru
9da0: 6e 2d 69 64 20 28 64 62 66 69 6c 65 3a 64 62 2d n-id (dbfile:db-
9db0: 69 6e 69 74 2d 70 72 6f 63 29 29 20 3b 3b 20 28 init-proc)) ;; (
9dc0: 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 62 dbfile:get-subdb
9dd0: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
9de0: 29 0a 09 09 09 23 66 29 29 0a 09 20 28 64 62 20 )....#f)).. (db
9df0: 20 20 20 20 20 20 20 28 69 66 20 68 61 76 65 2d (if have-
9e00: 73 74 72 75 63 74 20 20 20 20 20 20 20 20 20 20 struct
9e10: 20 20 20 20 20 20 3b 3b 20 74 68 69 73 20 73 74 ;; this st
9e20: 75 66 66 20 6a 75 73 74 20 61 6c 6c 6f 77 73 20 uff just allows
9e30: 75 73 20 74 6f 20 63 61 6c 6c 20 77 69 74 68 20 us to call with
9e40: 61 20 64 62 20 68 61 6e 64 6c 65 20 64 69 72 65 a db handle dire
9e50: 63 74 6c 79 0a 09 09 09 28 64 62 72 3a 64 62 64 ctly....(dbr:dbd
9e60: 61 74 2d 64 62 68 20 64 62 64 61 74 29 0a 09 09 at-dbh dbdat)...
9e70: 09 64 62 73 74 72 75 63 74 29 29 0a 09 20 28 66 .dbstruct)).. (f
9e80: 6e 61 6d 65 20 20 20 20 20 28 69 66 20 64 62 64 name (if dbd
9e90: 61 74 0a 09 09 09 28 64 62 72 3a 64 62 64 61 74 at....(dbr:dbdat
9ea0: 2d 64 62 66 69 6c 65 20 64 62 64 61 74 29 0a 09 -dbfile dbdat)..
9eb0: 09 09 22 6e 6f 66 69 6c 65 6e 61 6d 65 61 76 61 .."nofilenameava
9ec0: 69 6c 61 62 6c 65 22 29 29 0a 09 20 28 6a 66 69 ilable")).. (jfi
9ed0: 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 66 6e 61 le (conc fna
9ee0: 6d 65 22 2d 6a 6f 75 72 6e 61 6c 22 29 29 0a 09 me"-journal"))..
9ef0: 20 28 71 72 79 70 72 6f 63 20 20 20 28 6c 61 6d (qryproc (lam
9f00: 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 28 bda ()... (
9f10: 69 66 20 75 73 65 2d 6d 75 74 65 78 20 28 6d 75 if use-mutex (mu
9f20: 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 77 69 tex-lock! *db-wi
9f30: 74 68 2d 64 62 2d 6d 75 74 65 78 2a 29 29 0a 09 th-db-mutex*))..
9f40: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
9f50: 73 20 28 61 70 70 6c 79 20 70 72 6f 63 20 64 62 s (apply proc db
9f60: 64 61 74 20 64 62 20 70 61 72 61 6d 73 29 29 29 dat db params)))
9f70: 20 3b 3b 20 74 68 65 20 61 63 74 75 61 6c 20 63 ;; the actual c
9f80: 61 6c 6c 20 69 73 20 68 65 72 65 2e 0a 09 09 09 all is here.....
9f90: 28 69 66 20 75 73 65 2d 6d 75 74 65 78 20 28 6d (if use-mutex (m
9fa0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 utex-unlock! *db
9fb0: 2d 77 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 29 -with-db-mutex*)
9fc0: 29 0a 09 09 09 3b 3b 20 28 69 66 20 28 76 65 63 )....;; (if (vec
9fd0: 74 6f 72 3f 20 64 62 73 74 72 75 63 74 29 28 64 tor? dbstruct)(d
9fe0: 62 3a 64 6f 6e 65 2d 77 69 74 68 20 64 62 73 74 b:done-with dbst
9ff0: 72 75 63 74 20 72 75 6e 2d 69 64 20 72 2f 77 29 ruct run-id r/w)
a000: 29 0a 09 09 09 28 69 66 20 64 62 64 61 74 0a 09 )....(if dbdat..
a010: 09 09 20 20 20 20 28 64 62 66 69 6c 65 3a 61 64 .. (dbfile:ad
a020: 64 2d 64 62 64 61 74 20 64 62 73 74 72 75 63 74 d-dbdat dbstruct
a030: 20 72 75 6e 2d 69 64 20 64 62 64 61 74 29 29 0a run-id dbdat)).
a040: 09 09 09 3b 3b 20 28 64 65 6c 65 74 65 2d 66 69 ...;; (delete-fi
a050: 6c 65 2a 20 63 72 75 6d 62 66 69 6c 65 29 0a 09 le* crumbfile)..
a060: 09 09 72 65 73 29 29 29 29 0a 0a 20 20 20 20 28 ..res)))).. (
a070: 61 73 73 65 72 74 20 28 73 71 6c 69 74 65 33 3a assert (sqlite3:
a080: 64 61 74 61 62 61 73 65 3f 20 64 62 29 20 22 46 database? db) "F
a090: 41 54 41 4c 3a 20 64 62 3a 77 69 74 68 2d 64 62 ATAL: db:with-db
a0a0: 2c 20 64 62 20 69 73 20 6e 6f 74 20 61 20 64 61 , db is not a da
a0b0: 74 61 62 61 73 65 2c 20 64 62 3d 22 64 62 22 2c tabase, db="db",
a0c0: 20 66 6e 61 6d 65 3d 22 66 6e 61 6d 65 29 0a 20 fname="fname).
a0d0: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
a0e0: 73 74 73 3f 20 6a 66 69 6c 65 29 0a 09 28 62 65 sts? jfile)..(be
a0f0: 67 69 6e 0a 09 20 20 28 64 62 66 69 6c 65 3a 70 gin.. (dbfile:p
a100: 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 rint-err "INFO:
a110: 22 6a 66 69 6c 65 22 20 65 78 69 73 74 73 2c 20 "jfile" exists,
a120: 64 65 6c 61 79 69 6e 67 20 74 6f 20 72 65 64 75 delaying to redu
a130: 63 65 20 64 61 74 61 62 61 73 65 20 6c 6f 61 64 ce database load
a140: 22 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c ").. (thread-sl
a150: 65 65 70 21 20 30 2e 32 29 29 29 0a 20 20 20 20 eep! 0.2))).
a160: 28 69 66 20 28 61 6e 64 20 75 73 65 2d 6d 75 74 (if (and use-mut
a170: 65 78 0a 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e ex.. (common
a180: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
a190: 20 31 32 30 20 22 6f 76 65 72 2d 35 30 2d 70 61 120 "over-50-pa
a1a0: 72 61 6c 6c 65 6c 2d 61 70 69 2d 72 65 71 75 65 rallel-api-reque
a1b0: 73 74 73 22 29 29 0a 09 28 64 62 66 69 6c 65 3a sts"))..(dbfile:
a1c0: 70 72 69 6e 74 2d 65 72 72 20 2a 61 70 69 2d 70 print-err *api-p
a1d0: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
a1e0: 6f 75 6e 74 2a 20 22 20 70 61 72 61 6c 6c 65 6c ount* " parallel
a1f0: 20 61 70 69 20 72 65 71 75 65 73 74 73 20 62 65 api requests be
a200: 69 6e 67 20 70 72 6f 63 65 73 73 65 64 20 69 6e ing processed in
a210: 20 70 72 6f 63 65 73 73 20 22 0a 09 09 09 20 20 process "....
a220: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
a230: 2d 69 64 29 29 29 20 3b 3b 20 20 22 2c 20 74 68 -id))) ;; ", th
a240: 72 6f 74 74 6c 69 6e 67 20 61 63 63 65 73 73 22 rottling access"
a250: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 2d 63 )). (if (no-c
a260: 6f 6e 64 69 74 69 6f 6e 2d 64 62 2d 77 69 74 68 ondition-db-with
a270: 2d 64 62 29 0a 09 28 71 72 79 70 72 6f 63 29 0a -db)..(qryproc).
a280: 09 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 .(condition-case
a290: 0a 09 20 28 71 72 79 70 72 6f 63 29 0a 09 20 28 .. (qryproc).. (
a2a0: 65 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 0a 09 exn (io-error)..
a2b0: 20 20 20 20 20 20 28 64 62 3a 67 65 6e 65 72 69 (db:generi
a2c0: 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 74 c-error-printout
a2d0: 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 69 2f 6f exn "ERROR: i/o
a2e0: 20 65 72 72 6f 72 20 77 69 74 68 20 22 20 66 6e error with " fn
a2f0: 61 6d 65 20 22 2e 20 43 68 65 63 6b 20 70 65 72 ame ". Check per
a300: 6d 69 73 73 69 6f 6e 73 2c 20 64 69 73 6b 20 73 missions, disk s
a310: 70 61 63 65 20 65 74 63 2e 20 61 6e 64 20 74 72 pace etc. and tr
a320: 79 20 61 67 61 69 6e 2e 22 29 29 0a 09 20 28 65 y again.")).. (e
a330: 78 6e 20 28 63 6f 72 72 75 70 74 29 0a 09 20 20 xn (corrupt)..
a340: 20 20 20 20 28 64 62 3a 67 65 6e 65 72 69 63 2d (db:generic-
a350: 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 error-printout e
a360: 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 xn "ERROR: datab
a370: 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 69 73 ase " fname " is
a380: 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 corrupt. Repair
a390: 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 it to proceed."
a3a0: 29 29 0a 09 20 28 65 78 6e 20 28 62 75 73 79 29 )).. (exn (busy)
a3b0: 0a 09 20 20 20 20 20 20 28 64 62 3a 67 65 6e 65 .. (db:gene
a3c0: 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f ric-error-printo
a3d0: 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 ut exn "ERROR: d
a3e0: 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 0a atabase " fname.
a3f0: 09 09 09 09 09 20 22 20 69 73 20 6c 6f 63 6b 65 ..... " is locke
a400: 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 20 74 d. Try copying t
a410: 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 o another locati
a420: 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 on, remove origi
a430: 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 61 63 nal and copy bac
a440: 6b 2e 22 29 29 0a 09 20 28 65 78 6e 20 28 70 65 k.")).. (exn (pe
a450: 72 6d 69 73 73 69 6f 6e 29 28 64 62 3a 67 65 6e rmission)(db:gen
a460: 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 eric-error-print
a470: 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 out exn "ERROR:
a480: 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 database " fname
a490: 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 72 6d " has some perm
a4a0: 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d 2e issions problem.
a4b0: 22 29 29 0a 09 20 28 65 78 6e 20 28 29 0a 09 20 ")).. (exn ()..
a4c0: 20 20 20 20 20 28 64 62 3a 67 65 6e 65 72 69 63 (db:generic
a4d0: 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 74 20 -error-printout
a4e0: 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e 6b 6e exn "ERROR: Unkn
a4f0: 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 20 64 own error with d
a500: 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 atabase " fname
a510: 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 09 09 " message: "....
a520: 09 09 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 .. ((condition-p
a530: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
a540: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
a550: 65 78 6e 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d exn)))))))..;;==
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 3d 3d 3d 3d 3d 3d 3d ================
a5a0: 3d 3d 3d 3d 0a 3b 3b 20 61 6e 6f 74 68 65 72 20 ====.;; another
a5b0: 61 74 74 65 6d 70 74 20 61 74 20 61 20 74 72 61 attempt at a tra
a5c0: 6e 73 61 63 74 69 6f 6e 69 7a 65 64 20 71 75 65 nsactionized que
a5d0: 75 65 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ue.;;===========
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
a620: 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 2a 74 ;; ;; (define *t
a630: 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 ransaction-queue
a640: 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 s* (make-hash-ta
a650: 62 6c 65 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 0a ble)).;; ;; ;; .
a660: 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 ;; ;; ;; (define
a670: 20 28 64 62 3a 67 65 74 2d 71 75 65 75 65 20 72 (db:get-queue r
a680: 75 6e 2d 69 64 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 un-id).;; ;; ;;
a690: 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 68 (let* ((res (h
a6a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
a6b0: 66 61 75 6c 74 20 2a 74 72 61 6e 73 61 63 74 69 fault *transacti
a6c0: 6f 6e 2d 71 75 65 75 65 73 2a 20 72 75 6e 2d 69 on-queues* run-i
a6d0: 64 20 23 66 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b d #f))).;; ;; ;;
a6e0: 20 20 20 20 20 28 69 66 20 72 65 73 0a 3b 3b 20 (if res.;;
a6f0: 3b 3b 20 3b 3b 20 09 72 65 73 0a 3b 3b 20 3b 3b ;; ;; .res.;; ;;
a700: 20 3b 3b 20 09 28 6c 65 74 2a 20 28 28 6e 65 77 ;; .(let* ((new
a710: 71 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 29 29 q (make-queue)))
a720: 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 20 28 68 61 .;; ;; ;; . (ha
a730: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 sh-table-set! *t
a740: 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 ransaction-queue
a750: 73 2a 20 72 75 6e 2d 69 64 20 6e 65 77 71 29 0a s* run-id newq).
a760: 3b 3b 20 3b 3b 20 3b 3b 20 09 20 20 6e 65 77 71 ;; ;; ;; . newq
a770: 29 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 0a 3b )))).;; ;; ;; .;
a780: 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 ; ;; ;; (define
a790: 28 64 62 3a 61 64 64 2d 74 6f 2d 74 72 61 6e 73 (db:add-to-trans
a7a0: 61 63 74 69 6f 6e 2d 71 75 65 75 65 20 64 62 73 action-queue dbs
a7b0: 74 72 75 63 74 20 70 72 6f 63 20 70 61 72 61 6d truct proc param
a7c0: 73 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 28 6c s).;; ;; ;; (l
a7d0: 65 74 2a 20 28 28 6d 62 6f 78 20 28 6d 61 6b 65 et* ((mbox (make
a7e0: 2d 6d 61 69 6c 62 6f 78 29 29 0a 3b 3b 20 3b 3b -mailbox)).;; ;;
a7f0: 20 3b 3b 20 09 20 28 71 20 20 20 20 28 64 62 3a ;; . (q (db:
a800: 67 65 74 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 get-queue run-id
a810: 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 ))).;; ;; ;;
a820: 20 28 71 75 65 75 65 2d 61 64 64 21 20 2a 74 72 (queue-add! *tr
a830: 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 2a ansaction-queue*
a840: 20 28 6c 69 73 74 20 64 62 73 74 72 75 63 74 20 (list dbstruct
a850: 70 72 6f 63 20 6d 62 6f 78 29 29 0a 3b 3b 20 3b proc mbox)).;; ;
a860: 3b 20 3b 3b 20 20 20 20 20 28 6d 61 69 6c 62 6f ; ;; (mailbo
a870: 78 2d 72 65 63 65 69 76 65 20 6d 62 6f 78 29 29 x-receive mbox))
a880: 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 0a 3b 3b 20 3b ).;; ;; ;; .;; ;
a890: 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 ; ;; (define (db
a8a0: 3a 70 72 6f 63 65 73 73 2d 74 72 61 6e 73 61 63 :process-transac
a8b0: 74 69 6f 6e 2d 71 75 65 75 65 20 2a 64 62 73 74 tion-queue *dbst
a8c0: 72 75 63 74 2d 64 62 73 2a 29 0a 3b 3b 20 3b 3b ruct-dbs*).;; ;;
a8d0: 20 3b 3b 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ;; (for-each.
a8e0: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 28 6c 61 6d ;; ;; ;; (lam
a8f0: 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b 20 bda (run-id).;;
a900: 3b 3b 20 3b 3b 20 20 20 20 20 20 28 6c 65 74 2a ;; ;; (let*
a910: 20 28 28 71 20 28 68 61 73 68 2d 74 61 62 6c 65 ((q (hash-table
a920: 2d 72 65 66 20 2a 74 72 61 6e 73 61 63 74 69 6f -ref *transactio
a930: 6e 2d 71 75 65 75 65 2a 20 72 75 6e 2d 69 64 29 n-queue* run-id)
a940: 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 )).;; ;; ;;
a950: 20 20 20 3b 3b 20 77 69 74 68 2d 74 72 61 6e 73 ;; with-trans
a960: 61 63 74 69 6f 6e 0a 3b 3b 20 3b 3b 20 3b 3b 20 action.;; ;; ;;
a970: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 64 62 ;; db
a980: 73 74 72 75 63 74 0a 3b 3b 20 3b 3b 20 3b 3b 20 struct.;; ;; ;;
a990: 20 20 20 20 20 20 20 3b 3b 20 70 6f 70 20 69 74 ;; pop it
a9a0: 65 6d 73 20 66 72 6f 6d 20 71 75 65 75 65 20 61 ems from queue a
a9b0: 6e 64 20 65 78 65 63 75 74 65 20 74 68 65 6d 2c nd execute them,
a9c0: 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 73 20 return results
a9d0: 76 69 61 20 6d 61 69 6c 62 6f 78 0a 3b 3b 20 3b via mailbox.;; ;
a9e0: 3b 20 3b 3b 20 20 20 20 20 20 20 20 71 0a 3b 3b ; ;; q.;;
a9f0: 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b ;; ;; ;;
aa00: 20 70 6f 70 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 pop .;; ;; ;;
aa10: 20 20 20 20 20 20 29 29 0a 3b 3b 20 3b 3b 20 3b )).;; ;; ;
aa20: 3b 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ; (hash-table
aa30: 2d 6b 65 79 73 20 2a 74 72 61 6e 73 61 63 74 69 -keys *transacti
aa40: 6f 6e 2d 71 75 65 75 65 73 2a 29 29 29 0a 0a 3b on-queues*)))..;
aa50: 3b 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 3d 3d 3d 3d ================
aa90: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 69 6c 65 20 =======.;; file
aaa0: 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d utils.;;========
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
aaf0: 3b 3b 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 3d 3d 3d ================
ab30: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6c 61 7a 79 ========.;; lazy
ab40: 2d 73 61 66 65 20 67 65 74 20 66 69 6c 65 20 6d -safe get file m
ab50: 6f 64 20 74 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 od time. on any
ab60: 65 72 72 6f 72 20 28 66 69 6c 65 20 6e 6f 74 20 error (file not
ab70: 65 78 69 73 74 69 6e 67 20 65 74 63 2e 29 20 72 existing etc.) r
ab80: 65 74 75 72 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 eturn 0.;;.(defi
ab90: 6e 65 20 28 64 62 66 69 6c 65 3a 6c 61 7a 79 2d ne (dbfile:lazy-
aba0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
abb0: 65 20 66 70 61 74 68 29 0a 20 20 28 68 61 6e 64 e fpath). (hand
abc0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
abd0: 20 20 20 20 65 78 6e 0a 20 20 20 20 28 62 65 67 exn. (beg
abe0: 69 6e 0a 20 20 20 20 20 20 28 64 62 66 69 6c 65 in. (dbfile
abf0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 46 61 69 6c :print-err "Fail
ac00: 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 69 66 69 ed to get modifi
ac10: 63 61 74 69 6f 6e 20 74 69 6d 65 20 66 6f 72 20 cation time for
ac20: 22 20 66 70 61 74 68 20 22 2c 20 74 72 65 61 74 " fpath ", treat
ac30: 69 6e 67 20 69 74 20 61 73 20 7a 65 72 6f 2e 20 ing it as zero.
ac40: 65 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 20 20 exn=" exn).
ac50: 20 30 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 0). (if (fil
ac60: 65 2d 65 78 69 73 74 73 3f 20 66 70 61 74 68 29 e-exists? fpath)
ac70: 0a 09 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 ..(file-modifica
ac80: 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 tion-time fpath)
ac90: 0a 09 30 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ..0)))..;;======
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ace0: 0a 3b 3b 20 66 69 6e 64 20 74 69 6d 65 73 74 61 .;; find timesta
acf0: 6d 70 20 6f 66 20 6e 65 77 65 73 74 20 66 69 6c mp of newest fil
ad00: 65 20 61 73 73 6f 63 69 61 74 65 64 20 77 69 74 e associated wit
ad10: 68 20 61 20 73 71 6c 69 74 65 20 64 62 20 66 69 h a sqlite db fi
ad20: 6c 65 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 le.(define (dbfi
ad30: 6c 65 3a 6c 61 7a 79 2d 73 71 6c 69 74 65 2d 64 le:lazy-sqlite-d
ad40: 62 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 b-modification-t
ad50: 69 6d 65 20 66 70 61 74 68 29 0a 20 20 28 6c 65 ime fpath). (le
ad60: 74 2a 20 28 28 67 6c 6f 62 2d 6c 69 73 74 20 28 t* ((glob-list (
ad70: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
ad80: 73 0a 09 09 09 65 78 6e 0a 09 09 20 20 20 20 20 s....exn...
ad90: 20 28 62 65 67 69 6e 0a 09 09 09 28 64 62 66 69 (begin....(dbfi
ada0: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 46 61 le:print-err "Fa
adb0: 69 6c 65 64 20 74 6f 20 67 6c 6f 62 20 22 20 66 iled to glob " f
adc0: 70 61 74 68 20 22 2a 2c 20 65 78 6e 3d 22 20 65 path "*, exn=" e
add0: 78 6e 29 0a 09 09 09 60 28 2c 28 63 6f 6e 63 20 xn)....`(,(conc
ade0: 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 2c 20 "/no/such/file,
adf0: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
ae00: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
ae10: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
ae20: 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 29 0a essage) exn)))).
ae30: 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 63 .. (glob (c
ae40: 6f 6e 63 20 66 70 61 74 68 20 22 2a 22 29 29 29 onc fpath "*")))
ae50: 29 0a 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 ). (file
ae60: 2d 6c 69 73 74 20 28 69 66 20 28 65 71 3f 20 30 -list (if (eq? 0
ae70: 20 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 6c 69 (length glob-li
ae80: 73 74 29 29 0a 09 09 09 27 28 22 2f 6e 6f 2f 73 st))....'("/no/s
ae90: 75 63 68 2f 66 69 6c 65 22 29 0a 09 09 09 67 6c uch/file")....gl
aea0: 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 61 70 ob-list))). (ap
aeb0: 70 6c 79 20 6d 61 78 0a 09 20 28 6d 61 70 0a 09 ply max.. (map..
aec0: 20 20 64 62 66 69 6c 65 3a 6c 61 7a 79 2d 6d 6f dbfile:lazy-mo
aed0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
aee0: 0a 09 20 20 66 69 6c 65 2d 6c 69 73 74 29 29 29 .. file-list)))
aef0: 29 0a 0a 3b 3b 20 64 6f 74 2d 6c 6f 63 6b 69 6e )..;; dot-lockin
af00: 67 20 65 67 67 20 73 65 65 6d 73 20 6e 6f 74 20 g egg seems not
af10: 74 6f 20 77 6f 72 6b 2c 20 75 73 69 6e 67 20 74 to work, using t
af20: 68 69 73 20 66 6f 72 20 6e 6f 77 0a 3b 3b 20 69 his for now.;; i
af30: 66 20 6c 6f 63 6b 20 69 73 20 6f 6c 64 65 72 20 f lock is older
af40: 74 68 61 6e 20 65 78 70 69 72 65 2d 74 69 6d 65 than expire-time
af50: 20 74 68 65 6e 20 72 65 6d 6f 76 65 20 69 74 20 then remove it
af60: 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 3b 3b and try again.;;
af70: 20 74 6f 20 67 65 74 20 74 68 65 20 6c 6f 63 6b to get the lock
af80: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 .;;.(define (dbf
af90: 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d ile:simple-file-
afa0: 6c 6f 63 6b 20 66 6e 61 6d 65 20 23 21 6b 65 79 lock fname #!key
afb0: 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 33 30 (expire-time 30
afc0: 30 29 29 0a 20 20 28 6c 65 74 20 28 28 66 6d 6f 0)). (let ((fmo
afd0: 64 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 d-time (handle-e
afe0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 xceptions...
aff0: 20 20 20 65 78 74 0a 09 09 20 20 20 20 20 28 63 ext... (c
b000: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a urrent-seconds).
b010: 09 09 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 .. (file-mod
b020: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
b030: 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 69 66 name)))). (if
b040: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
b050: 6e 61 6d 65 29 0a 09 28 69 66 20 28 3e 20 28 2d name)..(if (> (-
b060: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
b070: 73 29 20 66 6d 6f 64 2d 74 69 6d 65 29 20 65 78 s) fmod-time) ex
b080: 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 20 20 20 pire-time)..
b090: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 68 (begin.. (h
b0a0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
b0b0: 20 65 78 6e 20 23 66 20 28 64 65 6c 65 74 65 2d exn #f (delete-
b0c0: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 09 0a 09 file* fname))...
b0d0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 73 69 (dbfile:si
b0e0: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 mple-file-lock f
b0f0: 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 name expire-time
b100: 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 0a : expire-time)).
b110: 09 20 20 20 20 23 66 29 0a 09 28 6c 65 74 20 28 . #f)..(let (
b120: 28 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e (key-string (con
b130: 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 c (get-host-name
b140: 29 20 22 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 ) "-" (current-p
b150: 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 09 20 20 rocess-id)))..
b160: 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 20 (oup
b170: 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
b180: 65 20 66 6e 61 6d 65 29 29 29 0a 09 20 20 28 77 e fname))).. (w
b190: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
b1a0: 72 74 0a 09 20 20 20 20 20 20 6f 75 70 0a 09 20 rt.. oup..
b1b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
b1c0: 20 20 20 20 20 28 70 72 69 6e 74 20 6b 65 79 2d (print key-
b1d0: 73 74 72 69 6e 67 29 29 29 0a 09 20 20 28 63 6c string))).. (cl
b1e0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
b1f0: 6f 75 70 29 0a 09 20 20 23 3b 28 77 69 74 68 2d oup).. #;(with-
b200: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 output-to-file f
b210: 6e 61 6d 65 20 3b 3b 20 62 69 7a 61 72 72 65 2e name ;; bizarre.
b220: 20 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d with-output-to-
b230: 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 73 65 file does not se
b240: 65 6d 20 74 6f 20 62 65 20 63 6c 65 61 6e 69 6e em to be cleanin
b250: 67 20 75 70 20 61 66 74 65 72 20 69 74 73 65 6c g up after itsel
b260: 66 2e 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 f... (lambda
b270: 28 29 0a 09 20 20 28 70 72 69 6e 74 20 6b 65 79 ().. (print key
b280: 2d 73 74 72 69 6e 67 29 29 29 0a 09 20 20 28 74 -string))).. (t
b290: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
b2a0: 35 29 0a 09 20 20 28 69 66 20 28 66 69 6c 65 2d 5).. (if (file-
b2b0: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
b2c0: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
b2d0: 63 65 70 74 69 6f 6e 73 20 65 78 6e 0a 20 20 20 ceptions exn.
b2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 20 #f
b2f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b300: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
b310: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 m-file fname..
b320: 09 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 . (lambda ()...
b330: 20 20 20 20 28 65 71 75 61 6c 3f 20 6b 65 79 2d (equal? key-
b340: 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e string (read-lin
b350: 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 23 66 e))))).. #f
b360: 29 0a 20 20 20 20 20 20 20 29 0a 20 20 20 20 29 ). ). )
b370: 0a 20 20 29 0a 29 0a 0a 28 64 65 66 69 6e 65 20 . ).)..(define
b380: 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 (dbfile:simple-f
b390: 69 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 61 69 ile-lock-and-wai
b3a0: 74 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 t fname #!key (e
b3b0: 78 70 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 xpire-time 300))
b3c0: 0a 20 20 28 6c 65 74 20 28 28 65 6e 64 2d 74 69 . (let ((end-ti
b3d0: 6d 65 20 28 2b 20 65 78 70 69 72 65 2d 74 69 6d me (+ expire-tim
b3e0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
b3f0: 64 73 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 ds)))). (let
b400: 6c 6f 6f 70 20 28 28 67 6f 74 2d 6c 6f 63 6b 20 loop ((got-lock
b410: 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 (dbfile:simple-f
b420: 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 ile-lock fname e
b430: 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 xpire-time: expi
b440: 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 re-time))).
b450: 20 28 69 66 20 67 6f 74 2d 6c 6f 63 6b 0a 09 20 (if got-lock..
b460: 20 23 74 0a 09 20 20 28 69 66 20 28 3e 20 65 6e #t.. (if (> en
b470: 64 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d d-time (current-
b480: 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 20 20 seconds))..
b490: 20 28 62 65 67 69 6e 0a 09 09 28 74 68 72 65 61 (begin...(threa
b4a0: 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 09 28 6c d-sleep! 3)...(l
b4b0: 6f 6f 70 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 oop (dbfile:simp
b4c0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 le-file-lock fna
b4d0: 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 me expire-time:
b4e0: 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 0a 09 expire-time)))..
b4f0: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 28 #f)))))..(
b500: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 define (dbfile:s
b510: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
b520: 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 20 se-lock fname).
b530: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
b540: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
b550: 20 20 20 20 23 66 20 3b 3b 20 49 20 64 6f 6e 27 #f ;; I don'
b560: 74 20 72 65 61 6c 6c 79 20 63 61 72 65 20 77 68 t really care wh
b570: 79 20 74 68 69 73 20 66 61 69 6c 65 64 20 28 61 y this failed (a
b580: 74 20 6c 65 61 73 74 20 66 6f 72 20 6e 6f 77 29 t least for now)
b590: 0a 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c . (delete-fil
b5a0: 65 2a 20 66 6e 61 6d 65 29 29 29 0a 0a 28 64 65 e* fname)))..(de
b5b0: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 77 69 74 fine (dbfile:wit
b5c0: 68 2d 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f h-simple-file-lo
b5d0: 63 6b 20 66 6e 61 6d 65 20 70 72 6f 63 20 23 21 ck fname proc #!
b5e0: 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 key (expire-time
b5f0: 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 28 300)). (let ((
b600: 67 6f 74 6c 6f 63 6b 20 28 64 62 66 69 6c 65 3a gotlock (dbfile:
b610: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
b620: 2d 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 -and-wait fname
b630: 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 expire-time: exp
b640: 69 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 ire-time))).
b650: 28 69 66 20 67 6f 74 6c 6f 63 6b 0a 09 28 6c 65 (if gotlock..(le
b660: 74 20 28 28 72 65 73 20 28 70 72 6f 63 29 29 29 t ((res (proc)))
b670: 0a 09 20 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 .. (dbfile:simp
b680: 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d le-file-release-
b690: 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 09 20 20 72 lock fname).. r
b6a0: 65 73 29 0a 09 28 61 73 73 65 72 74 20 23 74 20 es)..(assert #t
b6b0: 22 46 41 54 41 4c 3a 20 73 69 6d 70 6c 65 20 66 "FATAL: simple f
b6c0: 69 6c 65 20 6c 6f 63 6b 20 6e 65 76 65 72 20 67 ile lock never g
b6d0: 6f 74 20 61 20 6c 6f 63 6b 2e 22 29 29 29 29 0a ot a lock.")))).
b6e0: 20 20 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 67 .(define (db:g
b6f0: 65 74 2d 63 61 63 68 65 2d 73 74 6d 74 68 20 64 et-cache-stmth d
b700: 62 64 61 74 20 64 62 20 73 74 6d 74 29 0a 20 20 bdat db stmt).
b710: 28 6c 65 74 2a 20 28 3b 3b 20 28 64 62 64 61 74 (let* (;; (dbdat
b720: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 67 (dbfile:g
b730: 65 74 2d 64 62 64 61 74 20 64 62 73 74 72 75 63 et-dbdat dbstruc
b740: 74 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 73 74 t run-id)).. (st
b750: 6d 74 2d 63 61 63 68 65 20 20 28 64 62 72 3a 64 mt-cache (dbr:d
b760: 62 64 61 74 2d 73 74 6d 74 2d 63 61 63 68 65 20 bdat-stmt-cache
b770: 64 62 64 61 74 29 29 0a 09 20 3b 3b 20 28 73 74 dbdat)).. ;; (st
b780: 6d 74 68 20 20 20 20 20 20 20 28 64 62 3a 68 6f mth (db:ho
b790: 68 2d 67 65 74 20 73 74 6d 74 2d 63 61 63 68 65 h-get stmt-cache
b7a0: 20 64 62 20 73 74 6d 74 29 29 0a 09 20 28 73 74 db stmt)).. (st
b7b0: 6d 74 68 20 20 20 20 20 20 20 28 68 61 73 68 2d mth (hash-
b7c0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
b7d0: 74 20 73 74 6d 74 2d 63 61 63 68 65 20 73 74 6d t stmt-cache stm
b7e0: 74 20 23 66 29 29 29 0a 20 20 20 20 28 6f 72 20 t #f))). (or
b7f0: 73 74 6d 74 68 0a 09 28 6c 65 74 2a 20 28 28 6e stmth..(let* ((n
b800: 65 77 73 74 6d 74 68 20 28 73 71 6c 69 74 65 33 ewstmth (sqlite3
b810: 3a 70 72 65 70 61 72 65 20 64 62 20 73 74 6d 74 :prepare db stmt
b820: 29 29 29 0a 09 20 20 3b 3b 20 28 64 62 3a 68 6f ))).. ;; (db:ho
b830: 68 2d 73 65 74 21 20 73 74 6d 74 2d 63 61 63 68 h-set! stmt-cach
b840: 65 20 64 62 20 73 74 6d 74 20 6e 65 77 73 74 6d e db stmt newstm
b850: 74 68 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 th).. (hash-tab
b860: 6c 65 2d 73 65 74 21 20 73 74 6d 74 2d 63 61 63 le-set! stmt-cac
b870: 68 65 20 73 74 6d 74 20 6e 65 77 73 74 6d 74 68 he stmt newstmth
b880: 29 0a 09 20 20 6e 65 77 73 74 6d 74 68 29 29 29 ).. newstmth)))
b890: 29 0a 0a 0a 0a 29 0a )....).