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 29 0a 0a 3b 3b 20 4e 4f 54 45 3a db. )..;; NOTE:
0840: 20 4e 65 65 64 20 6f 6e 65 20 64 62 72 3a 73 75 Need one dbr:su
0850: 62 64 62 20 70 65 72 20 6d 61 69 6e 2e 64 62 2c bdb per main.db,
0860: 20 31 2e 64 62 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 1.db ....;;.(de
0870: 66 73 74 72 75 63 74 20 64 62 72 3a 73 75 62 64 fstruct dbr:subd
0880: 62 0a 20 20 28 64 62 6e 61 6d 65 20 20 20 20 20 b. (dbname
0890: 20 23 66 29 20 3b 3b 20 2e 6d 65 67 61 74 65 73 #f) ;; .megates
08a0: 74 2f 31 2e 64 62 0a 20 20 28 6d 74 64 62 66 69 t/1.db. (mtdbfi
08b0: 6c 65 20 20 20 20 23 66 29 20 3b 3b 20 6d 74 72 le #f) ;; mtr
08c0: 61 68 2f 2e 6d 65 67 61 74 65 73 74 2f 31 2e 64 ah/.megatest/1.d
08d0: 62 0a 20 20 28 6d 74 64 62 64 61 74 20 20 20 20 b. (mtdbdat
08e0: 20 23 66 29 20 3b 3b 20 6f 6e 6c 79 20 6e 65 65 #f) ;; only nee
08f0: 64 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 66 d one of these f
0900: 6f 72 20 73 79 6e 63 69 6e 67 0a 20 20 3b 3b 20 or syncing. ;;
0910: 28 64 62 64 61 74 73 20 20 20 20 20 20 28 6d 61 (dbdats (ma
0920: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
0930: 20 3b 3b 20 69 64 20 3d 3e 20 64 62 64 61 74 20 ;; id => dbdat
0940: 0a 20 20 28 74 6d 70 64 62 66 69 6c 65 20 20 20 . (tmpdbfile
0950: 23 66 29 20 3b 3b 20 2f 74 6d 70 2f 2e 2e 2e 2f #f) ;; /tmp/.../
0960: 2e 6d 65 67 61 74 65 73 74 2f 31 2e 64 62 0a 20 .megatest/1.db.
0970: 20 3b 3b 20 28 72 65 66 6e 64 62 66 69 6c 65 20 ;; (refndbfile
0980: 20 23 66 29 20 3b 3b 20 2f 74 6d 70 2f 2e 2e 2e #f) ;; /tmp/...
0990: 2f 2e 6d 65 67 61 74 65 73 74 2f 31 2e 64 62 5f /.megatest/1.db_
09a0: 72 65 66 0a 20 20 28 64 62 73 74 61 63 6b 20 20 ref. (dbstack
09b0: 20 20 20 28 6d 61 6b 65 2d 73 74 61 63 6b 29 29 (make-stack))
09c0: 20 3b 3b 20 73 74 61 63 6b 20 66 6f 72 20 74 6d ;; stack for tm
09d0: 70 20 64 62 72 3a 64 62 64 61 74 2c 0a 20 20 28 p dbr:dbdat,. (
09e0: 68 6f 6d 65 68 6f 73 74 20 20 20 20 23 66 29 20 homehost #f)
09f0: 3b 3b 20 6e 6f 74 20 75 73 65 64 20 79 65 74 0a ;; not used yet.
0a00: 20 20 28 6f 6e 2d 68 6f 6d 65 68 6f 73 74 20 23 (on-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 72 65 61 64 2d 6f 6e 6c 79 20 et. (read-only
0a30: 20 20 23 66 29 0a 20 20 28 6c 61 73 74 2d 73 79 #f). (last-sy
0a40: 6e 63 20 20 20 30 29 0a 20 20 28 6c 61 73 74 2d nc 0). (last-
0a50: 77 72 69 74 65 20 20 28 63 75 72 72 65 6e 74 2d write (current-
0a60: 73 65 63 6f 6e 64 73 29 29 0a 20 20 29 20 20 20 seconds)). )
0a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0a80: 67 6f 61 6c 20 69 73 20 74 6f 20 63 6f 6e 76 65 goal is to conve
0a90: 72 67 65 20 6f 6e 20 6f 6e 65 20 73 74 72 75 63 rge on one struc
0aa0: 74 20 66 6f 72 20 61 6e 20 61 72 65 61 20 62 75 t for an area bu
0ab0: 74 20 66 6f 72 20 6e 6f 77 20 69 74 20 69 73 20 t for now it is
0ac0: 74 6f 6f 20 63 6f 6e 66 75 73 69 6e 67 0a 0a 3b too confusing..;
0ad0: 3b 20 6e 65 65 64 20 74 6f 20 6b 65 65 70 20 64 ; need to keep d
0ae0: 62 68 61 6e 64 6c 65 73 20 61 6e 64 20 63 61 63 bhandles and cac
0af0: 68 65 64 20 73 74 61 74 65 6d 65 6e 74 73 20 74 hed statements t
0b00: 6f 67 65 74 68 65 72 0a 28 64 65 66 73 74 72 75 ogether.(defstru
0b10: 63 74 20 64 62 72 3a 64 62 64 61 74 0a 20 20 28 ct dbr:dbdat. (
0b20: 64 62 66 69 6c 65 20 20 20 20 20 20 23 66 29 0a dbfile #f).
0b30: 20 20 28 64 62 68 20 20 20 20 20 20 20 20 20 23 (dbh #
0b40: 66 29 20 20 20 20 0a 20 20 28 73 74 6d 74 2d 63 f) . (stmt-c
0b50: 61 63 68 65 20 20 28 6d 61 6b 65 2d 68 61 73 68 ache (make-hash
0b60: 2d 74 61 62 6c 65 29 29 0a 20 20 28 72 65 61 64 -table)). (read
0b70: 2d 6f 6e 6c 79 20 20 20 23 66 29 0a 20 20 28 62 -only #f). (b
0b80: 69 72 74 68 2d 73 65 63 20 20 20 28 63 75 72 72 irth-sec (curr
0b90: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 0a ent-seconds)))..
0ba0: 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 63 (define *dbstruc
0bb0: 74 2d 64 62 73 2a 20 23 66 29 0a 28 64 65 66 69 t-dbs* #f).(defi
0bc0: 6e 65 20 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 ne *db-open-mute
0bd0: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
0be0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 .(define *db-acc
0bf0: 65 73 73 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 ess-mutex* (make
0c00: 2d 6d 75 74 65 78 29 29 20 3b 3b 20 75 73 65 64 -mutex)) ;; used
0c10: 20 69 6e 20 63 6f 6d 6d 6f 6e 2e 73 63 6d 0a 28 in common.scm.(
0c20: 64 65 66 69 6e 65 20 2a 6e 6f 2d 73 79 6e 63 2d define *no-sync-
0c30: 64 62 2a 20 20 20 23 66 29 0a 28 64 65 66 69 6e db* #f).(defin
0c40: 65 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 e *db-sync-in-pr
0c50: 6f 67 72 65 73 73 2a 20 23 66 29 0a 28 64 65 66 ogress* #f).(def
0c60: 69 6e 65 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d ine *db-with-db-
0c70: 6d 75 74 65 78 2a 20 20 20 20 28 6d 61 6b 65 2d mutex* (make-
0c80: 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 mutex)).(define
0c90: 2a 6d 61 78 2d 61 70 69 2d 70 72 6f 63 65 73 73 *max-api-process
0ca0: 2d 72 65 71 75 65 73 74 73 2a 20 30 29 0a 28 64 -requests* 0).(d
0cb0: 65 66 69 6e 65 20 2a 61 70 69 2d 70 72 6f 63 65 efine *api-proce
0cc0: 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 ss-request-count
0cd0: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 * 0).(define *db
0ce0: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 2a 20 20 -write-access*
0cf0: 20 20 20 23 74 29 0a 28 64 65 66 69 6e 65 20 2a #t).(define *
0d00: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 db-last-sync*
0d10: 20 20 20 20 20 30 29 20 20 20 20 20 20 20 20 20 0)
0d20: 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 ;; last
0d30: 74 69 6d 65 20 74 68 65 20 73 79 6e 63 20 74 6f time the sync to
0d40: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 68 61 70 megatest.db hap
0d50: 70 65 6e 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 pened.(define *d
0d60: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
0d70: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex)
0d80: 29 20 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 63 ) ;; protec
0d90: 74 20 61 63 63 65 73 73 20 74 6f 20 2a 64 62 2d t access to *db-
0da0: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
0db0: 2a 2c 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 *, *db-last-sync
0dc0: 2a 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 67 *..(define (db:g
0dd0: 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 eneric-error-pri
0de0: 6e 74 6f 75 74 20 65 78 6e 20 2e 20 6d 65 73 73 ntout exn . mess
0df0: 61 67 65 29 0a 20 20 28 70 72 69 6e 74 2d 63 61 age). (print-ca
0e00: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
0e10: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
0e20: 20 28 61 70 70 6c 79 20 64 62 66 69 6c 65 3a 70 (apply dbfile:p
0e30: 72 69 6e 74 2d 65 72 72 20 6d 65 73 73 61 67 65 rint-err message
0e40: 29 0a 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e ). (dbfile:prin
0e50: 74 2d 65 72 72 0a 20 20 20 20 22 2c 20 65 72 72 t-err. ", err
0e60: 6f 72 3a 20 22 20 20 20 20 20 28 28 63 6f 6e 64 or: " ((cond
0e70: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0e80: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
0e90: 73 73 61 67 65 29 20 20 20 65 78 6e 29 0a 20 20 ssage) exn).
0ea0: 20 20 22 2c 20 61 72 67 75 6d 65 6e 74 73 3a 20 ", arguments:
0eb0: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
0ec0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
0ed0: 27 65 78 6e 20 27 61 72 67 75 6d 65 6e 74 73 29 'exn 'arguments)
0ee0: 20 65 78 6e 29 0a 20 20 20 20 22 2c 20 6c 6f 63 exn). ", loc
0ef0: 61 74 69 6f 6e 3a 20 22 20 20 28 28 63 6f 6e 64 ation: " ((cond
0f00: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0f10: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6c 6f ccessor 'exn 'lo
0f20: 63 61 74 69 6f 6e 29 20 20 65 78 6e 29 0a 20 20 cation) exn).
0f30: 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 ))..(define (d
0f40: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 6b 65 bfile:run-id->ke
0f50: 79 20 72 75 6e 2d 69 64 29 0a 20 20 28 6f 72 20 y run-id). (or
0f60: 72 75 6e 2d 69 64 20 27 6d 61 69 6e 29 29 0a 0a run-id 'main))..
0f70: 28 64 65 66 69 6e 65 20 28 64 62 3a 73 61 66 65 (define (db:safe
0f80: 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 ly-close-sqlite3
0f90: 2d 64 62 20 64 62 20 73 74 6d 74 2d 63 61 63 68 -db db stmt-cach
0fa0: 65 20 23 21 6b 65 79 20 28 74 72 79 2d 6e 75 6d e #!key (try-num
0fb0: 20 33 29 29 0a 20 20 28 69 66 20 28 3c 3d 20 74 3)). (if (<= t
0fc0: 72 79 2d 6e 75 6d 20 30 29 0a 20 20 20 20 20 20 ry-num 0).
0fd0: 23 66 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 #f. (handle
0fe0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 65 -exceptions.. e
0ff0: 78 6e 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 xn..(begin.. (p
1000: 72 69 6e 74 20 22 41 74 74 65 6d 70 74 20 74 6f rint "Attempt to
1010: 20 73 61 66 65 6c 79 20 63 6c 6f 73 65 20 73 71 safely close sq
1020: 6c 69 74 65 33 20 64 62 20 66 61 69 6c 65 64 2e lite3 db failed.
1030: 20 54 72 79 69 6e 67 20 61 67 61 69 6e 2e 20 65 Trying again. e
1040: 78 6e 3d 22 20 65 78 6e 29 0a 09 20 20 28 74 68 xn=" exn).. (th
1050: 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 read-sleep! 3)..
1060: 20 20 28 73 71 6c 69 74 65 33 3a 69 6e 74 65 72 (sqlite3:inter
1070: 72 75 70 74 21 20 64 62 29 0a 09 20 20 28 64 62 rupt! db).. (db
1080: 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 :safely-close-sq
1090: 6c 69 74 65 33 2d 64 62 20 64 62 20 73 74 6d 74 lite3-db db stmt
10a0: 2d 63 61 63 68 65 20 74 72 79 2d 6e 75 6d 3a 20 -cache try-num:
10b0: 28 2d 20 74 72 79 2d 6e 75 6d 20 31 29 29 29 0a (- try-num 1))).
10c0: 09 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 .(if (sqlite3:da
10d0: 74 61 62 61 73 65 3f 20 64 62 29 0a 09 20 20 20 tabase? db)..
10e0: 20 28 6c 65 74 2a 20 28 28 73 74 6d 74 73 20 28 (let* ((stmts (
10f0: 61 6e 64 20 73 74 6d 74 2d 63 61 63 68 65 20 28 and stmt-cache (
1100: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1110: 65 66 61 75 6c 74 20 73 74 6d 74 2d 63 61 63 68 efault stmt-cach
1120: 65 20 64 62 20 23 66 29 29 29 29 0a 09 20 20 20 e db #f))))..
1130: 20 20 20 28 69 66 20 73 74 6d 74 73 20 28 6d 61 (if stmts (ma
1140: 70 20 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 p sqlite3:finali
1150: 7a 65 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ze! (hash-table-
1160: 76 61 6c 75 65 73 20 73 74 6d 74 73 29 29 29 0a values stmts))).
1170: 09 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a . (sqlite3:
1180: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 20 finalize! db)..
1190: 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 20 #t).
11a0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
11b0: 20 20 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 (dbfile
11c0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 :print-err "db:s
11d0: 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 afely-close-sqli
11e0: 74 65 33 2d 64 62 3a 20 22 20 64 62 20 22 20 69 te3-db: " db " i
11f0: 73 20 6e 6f 74 20 61 6e 20 73 71 6c 69 74 65 33 s not an sqlite3
1200: 20 64 62 22 29 0a 09 20 20 20 20 20 23 66 0a 20 db").. #f.
1210: 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 ).
1220: 20 20 20 20 20 29 29 29 29 0a 0a 3b 3b 20 63 6c ))))..;; cl
1230: 6f 73 65 20 61 6c 6c 20 6f 70 65 6e 65 64 20 72 ose all opened r
1240: 75 6e 2d 69 64 20 64 62 73 0a 28 64 65 66 69 6e un-id dbs.(defin
1250: 65 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 e (db:close-all
1260: 64 62 73 74 72 75 63 74 29 0a 20 20 28 69 66 20 dbstruct). (if
1270: 28 64 62 72 3a 64 62 73 74 72 75 63 74 3f 20 64 (dbr:dbstruct? d
1280: 62 73 74 72 75 63 74 29 0a 3b 3b 20 28 68 61 6e bstruct).;; (han
1290: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b dle-exceptions.;
12a0: 3b 20 09 20 20 65 78 6e 0a 3b 3b 20 09 20 20 28 ; . exn.;; . (
12b0: 62 65 67 69 6e 0a 3b 3b 20 09 20 20 20 20 28 64 begin.;; . (d
12c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
12d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
12e0: 22 57 41 52 4e 49 4e 47 3a 20 46 69 6e 61 6c 69 "WARNING: Finali
12f0: 7a 69 6e 67 20 66 61 69 6c 65 64 2c 20 22 20 20 zing failed, "
1300: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
1310: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
1320: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
1330: 29 20 22 2c 20 6e 6f 74 65 20 2d 20 65 78 6e 3d ) ", note - exn=
1340: 22 20 65 78 6e 29 0a 3b 3b 20 09 20 20 20 20 28 " exn).;; . (
1350: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
1360: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1370: 72 74 2a 29 29 0a 09 3b 3b 20 28 64 62 3a 73 79 rt*))..;; (db:sy
1380: 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 74 72 nc-touched dbstr
1390: 75 63 74 20 30 20 66 6f 72 63 65 2d 73 79 6e 63 uct 0 force-sync
13a0: 3a 20 23 74 29 20 3b 3b 20 4e 4f 2e 20 44 6f 20 : #t) ;; NO. Do
13b0: 6e 6f 74 20 64 6f 20 74 68 69 73 20 68 65 72 65 not do this here
13c0: 2e 20 49 6e 73 74 65 61 64 20 77 65 20 72 65 6c . Instead we rel
13d0: 79 20 6f 6e 20 61 20 73 65 72 76 65 72 20 74 6f y on a server to
13e0: 20 62 65 20 73 74 61 72 74 65 64 20 77 68 65 6e be started when
13f0: 20 74 68 65 72 65 20 61 72 65 20 77 72 69 74 65 there are write
1400: 73 2c 20 65 76 65 6e 20 69 66 20 74 68 65 20 73 s, even if the s
1410: 65 72 76 65 72 20 69 74 73 65 6c 66 20 69 73 20 erver itself is
1420: 6e 6f 74 20 67 6f 69 6e 67 20 74 6f 20 62 65 20 not going to be
1430: 75 73 65 64 20 61 73 20 61 20 73 65 72 76 65 72 used as a server
1440: 2e 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 .. (let*
1450: 28 28 73 75 62 64 62 73 20 20 20 20 20 28 68 61 ((subdbs (ha
1460: 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 sh-table-values
1470: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 73 75 (dbr:dbstruct-su
1480: 62 64 62 73 20 64 62 73 74 72 75 63 74 29 29 29 bdbs dbstruct)))
1490: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
14a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 73 75 62 64 (lambda (subd
14b0: 62 29 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 b).. (let* (
14c0: 28 74 64 62 73 20 20 20 20 20 20 20 28 73 74 61 (tdbs (sta
14d0: 63 6b 2d 3e 6c 69 73 74 20 28 64 62 72 3a 73 75 ck->list (dbr:su
14e0: 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 bdb-dbstack subd
14f0: 62 29 29 29 0a 09 09 20 20 20 20 28 6d 74 64 62 b)))... (mtdb
1500: 64 61 74 20 20 20 20 28 64 62 72 3a 64 62 64 61 dat (dbr:dbda
1510: 74 2d 64 62 68 20 28 64 62 72 3a 73 75 62 64 62 t-dbh (dbr:subdb
1520: 2d 6d 74 64 62 64 61 74 20 73 75 62 64 62 29 29 -mtdbdat subdb))
1530: 29 0a 09 09 20 20 20 20 23 3b 28 72 64 62 20 20 )... #;(rdb
1540: 20 20 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 (dbr:dbdat
1550: 2d 64 62 68 20 28 64 62 72 3a 73 75 62 64 62 2d -dbh (dbr:subdb-
1560: 72 65 66 6e 64 62 20 73 75 62 64 62 29 29 29 29 refndb subdb))))
1570: 0a 09 09 20 20 20 20 0a 09 20 20 20 20 20 20 20 ... ..
1580: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 64 62 (map (lambda (db
1590: 64 61 74 29 0a 09 09 20 20 20 20 20 20 28 6c 65 dat)... (le
15a0: 74 2a 20 28 28 73 74 6d 74 2d 63 61 63 68 65 20 t* ((stmt-cache
15b0: 28 64 62 72 3a 64 62 64 61 74 2d 73 74 6d 74 2d (dbr:dbdat-stmt-
15c0: 63 61 63 68 65 20 64 62 64 61 74 29 29 0a 09 09 cache dbdat))...
15d0: 09 20 20 20 20 20 28 64 62 68 20 20 20 20 20 20 . (dbh
15e0: 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 (dbr:dbdat-dbh
15f0: 20 20 20 20 20 20 20 20 64 62 64 61 74 29 29 29 dbdat)))
1600: 0a 09 09 09 28 64 62 3a 73 61 66 65 6c 79 2d 63 ....(db:safely-c
1610: 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 lose-sqlite3-db
1620: 64 62 68 20 73 74 6d 74 2d 63 61 63 68 65 29 29 dbh stmt-cache))
1630: 29 0a 09 09 20 20 20 20 74 64 62 73 29 0a 09 20 )... tdbs)..
1640: 20 20 20 20 20 20 28 64 62 3a 73 61 66 65 6c 79 (db:safely
1650: 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 -close-sqlite3-d
1660: 62 20 6d 74 64 62 64 61 74 20 28 64 62 72 3a 64 b mtdbdat (dbr:d
1670: 62 64 61 74 2d 73 74 6d 74 2d 63 61 63 68 65 20 bdat-stmt-cache
1680: 20 28 64 62 72 3a 73 75 62 64 62 2d 6d 74 64 62 (dbr:subdb-mtdb
1690: 64 61 74 20 73 75 62 64 62 29 29 29 20 0a 20 20 dat subdb))) .
16a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
16b0: 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 (if (sqlite3:dat
16c0: 61 62 61 73 65 3f 20 6d 64 62 29 20 28 73 71 6c abase? mdb) (sql
16d0: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6d ite3:finalize! m
16e0: 64 62 29 29 0a 09 20 20 20 20 20 20 20 23 3b 28 db)).. #;(
16f0: 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d db:safely-close-
1700: 73 71 6c 69 74 65 33 2d 64 62 20 72 64 62 20 23 sqlite3-db rdb #
1710: 66 29 29 29 20 3b 3b 20 73 74 6d 74 2d 63 61 63 f))) ;; stmt-cac
1720: 68 65 29 29 29 29 29 20 3b 3b 20 28 69 66 20 28 he))))) ;; (if (
1730: 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 sqlite3:database
1740: 3f 20 72 64 62 29 20 28 73 71 6c 69 74 65 33 3a ? rdb) (sqlite3:
1750: 66 69 6e 61 6c 69 7a 65 21 20 72 64 62 29 29 29 finalize! rdb)))
1760: 29 29 29 0a 09 20 20 20 73 75 62 64 62 73 29 0a ))).. subdbs).
1770: 20 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 #t.
1780: 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
1790: 20 20 20 20 23 66 0a 20 20 29 0a 29 0a 0a 3b 3b #f. ).)..;;
17a0: 20 3b 3b 20 73 65 74 20 75 70 20 61 20 73 69 6e ;; set up a sin
17b0: 67 6c 65 20 64 62 20 28 65 2e 67 2e 20 6d 61 69 gle db (e.g. mai
17c0: 6e 2e 64 62 2c 20 31 2e 64 62 20 2e 2e 2e 20 65 n.db, 1.db ... e
17d0: 74 63 2e 29 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 tc.).;; ;;.;; (d
17e0: 65 66 69 6e 65 20 28 64 62 3a 73 65 74 75 70 2d efine (db:setup-
17f0: 64 62 20 64 62 73 74 72 75 63 74 20 61 72 65 61 db dbstruct area
1800: 70 61 74 68 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 path run-id).;;
1810: 20 20 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 (let* ((dbname
1820: 20 20 20 28 64 62 3a 72 75 6e 2d 69 64 2d 3e 64 (db:run-id->d
1830: 62 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 0a 3b bname run-id)).;
1840: 3b 20 09 20 28 64 62 73 74 72 75 63 74 20 28 68 ; . (dbstruct (h
1850: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1860: 66 61 75 6c 74 20 64 62 73 74 72 75 63 74 73 20 fault dbstructs
1870: 64 62 6e 61 6d 65 20 23 66 29 29 29 0a 3b 3b 20 dbname #f))).;;
1880: 20 20 20 20 28 69 66 20 64 62 73 74 72 75 63 74 (if dbstruct
1890: 0a 3b 3b 20 09 64 62 73 74 72 75 63 74 0a 3b 3b .;; .dbstruct.;;
18a0: 20 09 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 .(let* ((dbstru
18b0: 63 74 2d 6e 65 77 20 28 6d 61 6b 65 2d 64 62 72 ct-new (make-dbr
18c0: 3a 64 62 73 74 72 75 63 74 29 29 29 0a 3b 3b 20 :dbstruct))).;;
18d0: 09 20 20 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 . (db:open-db d
18e0: 62 73 74 72 75 63 74 2d 6e 65 77 20 72 75 6e 2d bstruct-new run-
18f0: 69 64 20 61 72 65 61 70 61 74 68 3a 20 61 72 65 id areapath: are
1900: 61 70 61 74 68 20 64 6f 2d 73 79 6e 63 3a 20 23 apath do-sync: #
1910: 74 29 0a 3b 3b 20 09 20 20 28 68 61 73 68 2d 74 t).;; . (hash-t
1920: 61 62 6c 65 2d 73 65 74 21 20 64 62 73 74 72 75 able-set! dbstru
1930: 63 74 73 20 64 62 6e 61 6d 65 20 64 62 73 74 72 cts dbname dbstr
1940: 75 63 74 2d 6e 65 77 29 0a 3b 3b 20 09 20 20 64 uct-new).;; . d
1950: 62 73 74 72 75 63 74 2d 6e 65 77 29 29 29 29 0a bstruct-new)))).
1960: 20 20 20 20 0a 3b 3b 20 3b 20 52 65 74 75 72 6e .;; ; Return
1970: 73 20 74 68 65 20 64 62 64 61 74 20 66 6f 72 20 s the dbdat for
1980: 61 20 70 61 72 74 69 63 75 6c 61 72 20 64 62 66 a particular dbf
1990: 69 6c 65 20 69 6e 73 69 64 65 20 74 68 65 20 61 ile inside the a
19a0: 72 65 61 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 rea.;; ;;.;; (de
19b0: 66 69 6e 65 20 28 64 62 72 3a 64 62 73 74 72 75 fine (dbr:dbstru
19c0: 63 74 2d 67 65 74 2d 64 62 64 61 74 20 64 62 73 ct-get-dbdat dbs
19d0: 74 72 75 63 74 20 64 62 66 69 6c 65 29 0a 3b 3b truct dbfile).;;
19e0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
19f0: 65 66 2f 64 65 66 61 75 6c 74 20 28 64 62 72 3a ef/default (dbr:
1a00: 64 62 73 74 72 75 63 74 2d 64 62 64 61 74 73 20 dbstruct-dbdats
1a10: 64 62 73 74 72 75 63 74 29 20 64 62 66 69 6c 65 dbstruct) dbfile
1a20: 20 23 66 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 #f)).;; .;; (de
1a30: 66 69 6e 65 20 28 64 62 72 3a 64 62 73 74 72 75 fine (dbr:dbstru
1a40: 63 74 2d 64 62 64 61 74 2d 70 75 74 21 20 64 62 ct-dbdat-put! db
1a50: 73 74 72 75 63 74 20 64 62 66 69 6c 65 20 64 62 struct dbfile db
1a60: 29 0a 3b 3b 20 20 20 28 68 61 73 68 2d 74 61 62 ).;; (hash-tab
1a70: 6c 65 2d 73 65 74 21 20 28 64 62 72 3a 64 62 73 le-set! (dbr:dbs
1a80: 74 72 75 63 74 2d 64 62 64 61 74 73 20 64 62 73 truct-dbdats dbs
1a90: 74 72 75 63 74 29 20 64 62 66 69 6c 65 20 64 62 truct) dbfile db
1aa0: 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e )).;; .;; (defin
1ab0: 65 20 28 64 62 3a 72 75 6e 2d 69 64 2d 3e 66 69 e (db:run-id->fi
1ac0: 72 73 74 2d 6e 75 6d 20 72 75 6e 2d 69 64 29 0a rst-num run-id).
1ad0: 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 20 28 ;; (let* ((s (
1ae0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 72 number->string r
1af0: 75 6e 2d 69 64 29 29 0a 3b 3b 20 09 20 28 6c 20 un-id)).;; . (l
1b00: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
1b10: 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 75 62 73 ))).;; (subs
1b20: 74 72 69 6e 67 20 73 20 28 2d 20 6c 20 31 29 20 tring s (- l 1)
1b30: 6c 29 29 29 0a 0a 3b 3b 20 31 32 33 34 20 3d 3e l)))..;; 1234 =>
1b40: 20 34 2f 31 32 33 34 2e 64 62 0a 3b 3b 20 20 20 4/1234.db.;;
1b50: 23 66 20 3d 3e 20 30 2f 6d 61 69 6e 2e 64 62 0a #f => 0/main.db.
1b60: 3b 3b 20 20 20 28 61 62 61 6e 64 6f 6e 65 64 20 ;; (abandoned
1b70: 74 68 65 20 69 64 65 61 20 6f 66 20 6e 75 6d 2f the idea of num/
1b80: 64 62 29 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 db).;; .(define
1b90: 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e (dbfile:run-id->
1ba0: 70 61 74 68 20 61 70 61 74 68 20 72 75 6e 2d 69 path apath run-i
1bb0: 64 29 0a 20 20 28 63 6f 6e 63 20 61 70 61 74 68 d). (conc apath
1bc0: 22 2f 22 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 "/"(dbfile:run-i
1bd0: 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 d->dbname run-id
1be0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 )))..(define (db
1bf0: 3a 64 62 6e 61 6d 65 2d 3e 70 61 74 68 20 61 70 :dbname->path ap
1c00: 61 74 68 20 64 62 6e 61 6d 65 29 0a 20 20 28 63 ath dbname). (c
1c10: 6f 6e 63 20 61 70 61 74 68 22 2f 22 64 62 6e 61 onc apath"/"dbna
1c20: 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 me))..(define (d
1c30: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 bfile:run-id->db
1c40: 6e 75 6d 20 72 75 6e 2d 69 64 29 0a 20 20 28 63 num run-id). (c
1c50: 6f 6e 64 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f ond. ((number?
1c60: 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 28 6d 6f run-id). (mo
1c70: 64 75 6c 6f 20 72 75 6e 2d 69 64 20 28 6e 75 6d dulo run-id (num
1c80: 2d 72 75 6e 2d 64 62 73 29 29 29 0a 20 20 20 28 -run-dbs))). (
1c90: 28 6e 6f 74 20 72 75 6e 2d 69 64 29 20 22 6d 61 (not run-id) "ma
1ca0: 69 6e 22 29 20 20 20 3b 3b 20 30 20 6f 72 20 6d in") ;; 0 or m
1cb0: 61 69 6e 3f 0a 20 20 20 28 65 6c 73 65 20 72 75 ain?. (else ru
1cc0: 6e 2d 69 64 29 29 29 0a 0a 3b 3b 20 50 4f 54 45 n-id)))..;; POTE
1cd0: 4e 54 49 41 4c 20 42 55 47 3a 20 74 68 69 73 20 NTIAL BUG: this
1ce0: 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 63 implementation c
1cf0: 6f 75 6c 64 20 70 72 6f 64 75 63 65 20 61 20 64 ould produce a d
1d00: 62 20 66 69 6c 65 20 69 66 20 72 75 6e 2d 69 64 b file if run-id
1d10: 20 69 73 20 6e 65 69 74 68 65 72 20 23 66 20 6f is neither #f o
1d20: 72 20 61 20 6e 75 6d 62 65 72 0a 28 64 65 66 69 r a number.(defi
1d30: 6e 65 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 ne (dbfile:run-i
1d40: 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 d->dbname run-id
1d50: 29 0a 20 20 28 63 6f 6e 63 20 22 2e 6d 65 67 61 ). (conc ".mega
1d60: 74 65 73 74 2f 22 28 64 62 66 69 6c 65 3a 72 75 test/"(dbfile:ru
1d70: 6e 2d 69 64 2d 3e 64 62 6e 75 6d 20 72 75 6e 2d n-id->dbnum run-
1d80: 69 64 29 22 2e 64 62 22 29 29 0a 0a 3b 3b 20 4d id)".db"))..;; M
1d90: 61 6b 65 20 74 68 65 20 64 62 73 74 72 75 63 74 ake the dbstruct
1da0: 2c 20 73 65 74 75 70 20 75 70 20 61 75 78 69 6c , setup up auxil
1db0: 6c 61 72 79 20 64 62 27 73 20 61 6e 64 20 63 61 lary db's and ca
1dc0: 6c 6c 20 66 6f 72 20 6d 61 69 6e 20 64 62 20 61 ll for main db a
1dd0: 74 20 6c 65 61 73 74 20 6f 6e 63 65 0a 3b 3b 0a t least once.;;.
1de0: 3b 3b 20 63 61 6c 6c 65 64 20 69 6e 20 68 74 74 ;; called in htt
1df0: 70 2d 74 72 61 6e 73 70 6f 72 74 20 61 6e 64 20 p-transport and
1e00: 72 65 70 6c 69 63 61 74 65 64 20 69 6e 20 72 6d replicated in rm
1e10: 74 2e 73 63 6d 20 66 6f 72 20 2a 6c 6f 63 61 6c t.scm for *local
1e20: 2a 20 61 63 63 65 73 73 2e 20 0a 3b 3b 0a 28 64 * access. .;;.(d
1e30: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 65 efine (dbfile:se
1e40: 74 75 70 20 64 6f 2d 73 79 6e 63 20 61 72 65 61 tup do-sync area
1e50: 70 61 74 68 20 74 6d 70 70 61 74 68 29 0a 20 20 path tmppath).
1e60: 28 63 6f 6e 64 0a 20 20 20 28 2a 64 62 73 74 72 (cond. (*dbstr
1e70: 75 63 74 2d 64 62 73 2a 0a 20 20 20 20 28 64 62 uct-dbs*. (db
1e80: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
1e90: 57 41 52 4e 49 4e 47 3a 20 64 62 66 69 6c 65 3a WARNING: dbfile:
1ea0: 73 65 74 75 70 20 63 61 6c 6c 65 64 20 77 68 65 setup called whe
1eb0: 6e 20 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a n *dbstruct-dbs*
1ec0: 20 69 73 20 61 6c 72 65 61 64 79 20 69 6e 69 74 is already init
1ed0: 69 61 6c 69 7a 65 64 22 29 0a 20 20 20 20 2a 64 ialized"). *d
1ee0: 62 73 74 72 75 63 74 2d 64 62 73 2a 29 20 3b 3b bstruct-dbs*) ;;
1ef0: 20 54 4f 44 4f 3a 20 77 68 65 6e 20 6d 75 6c 74 TODO: when mult
1f00: 69 70 6c 65 20 61 72 65 61 73 20 61 72 65 20 73 iple areas are s
1f10: 75 70 70 6f 72 74 65 64 2c 20 74 68 69 73 20 6f upported, this o
1f20: 70 74 69 6d 69 7a 61 74 69 6f 6e 20 77 69 6c 6c ptimization will
1f30: 20 62 65 20 61 20 68 61 7a 61 72 64 0a 20 20 20 be a hazard.
1f40: 28 65 6c 73 65 0a 20 20 20 20 28 6c 65 74 2a 20 (else. (let*
1f50: 28 28 64 62 73 74 72 75 63 74 20 28 6d 61 6b 65 ((dbstruct (make
1f60: 2d 64 62 72 3a 64 62 73 74 72 75 63 74 29 29 29 -dbr:dbstruct)))
1f70: 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 . (set! *db
1f80: 73 74 72 75 63 74 2d 64 62 73 2a 20 64 62 73 74 struct-dbs* dbst
1f90: 72 75 63 74 29 0a 20 20 20 20 20 20 28 64 62 72 ruct). (dbr
1fa0: 3a 64 62 73 74 72 75 63 74 2d 61 72 65 61 70 61 :dbstruct-areapa
1fb0: 74 68 2d 73 65 74 21 20 64 62 73 74 72 75 63 74 th-set! dbstruct
1fc0: 20 61 72 65 61 70 61 74 68 29 0a 20 20 20 20 20 areapath).
1fd0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 (dbr:dbstruct-t
1fe0: 6d 70 70 61 74 68 2d 73 65 74 21 20 20 64 62 73 mppath-set! dbs
1ff0: 74 72 75 63 74 20 74 6d 70 70 61 74 68 29 0a 20 truct tmppath).
2000: 20 20 20 20 20 64 62 73 74 72 75 63 74 29 29 29 dbstruct)))
2010: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 )..(define (dbfi
2020: 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 le:get-subdb dbs
2030: 74 72 75 63 74 20 72 75 6e 2d 69 64 29 0a 20 20 truct run-id).
2040: 28 6c 65 74 2a 20 28 28 64 62 66 6e 61 6d 65 20 (let* ((dbfname
2050: 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e (dbfile:run-id->
2060: 64 62 6e 61 6d 65 20 72 75 6e 2d 69 64 29 29 29 dbname run-id)))
2070: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
2080: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 64 62 -ref/default (db
2090: 72 3a 64 62 73 74 72 75 63 74 2d 73 75 62 64 62 r:dbstruct-subdb
20a0: 73 20 64 62 73 74 72 75 63 74 29 20 64 62 66 6e s dbstruct) dbfn
20b0: 61 6d 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 ame #f)))..(defi
20c0: 6e 65 20 28 64 62 66 69 6c 65 3a 73 65 74 2d 73 ne (dbfile:set-s
20d0: 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 ubdb dbstruct ru
20e0: 6e 2d 69 64 20 73 75 62 64 62 29 0a 20 20 28 68 n-id subdb). (h
20f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
2100: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 73 75 62 dbr:dbstruct-sub
2110: 64 62 73 20 64 62 73 74 72 75 63 74 29 20 28 64 dbs dbstruct) (d
2120: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 bfile:run-id->db
2130: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 73 75 62 name run-id) sub
2140: 64 62 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 db))..;; (define
2150: 20 2a 64 62 66 69 6c 65 3a 6e 75 6d 2d 68 61 6e *dbfile:num-han
2160: 64 6c 65 73 2d 69 6e 2d 75 73 65 2a 20 30 29 0a dles-in-use* 0).
2170: 0a 3b 3b 20 47 65 74 2f 6f 70 65 6e 20 61 20 64 .;; Get/open a d
2180: 61 74 61 62 61 73 65 2e 0a 3b 3b 0a 3b 3b 20 20 atabase..;;.;;
2190: 20 20 4e 4f 54 45 3a 20 6d 6f 73 74 20 75 73 61 NOTE: most usa
21a0: 67 65 20 73 68 6f 75 6c 64 20 63 61 6c 6c 20 64 ge should call d
21b0: 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 74 6f bfile:open-db to
21c0: 20 67 65 74 20 61 20 64 62 64 61 74 0a 3b 3b 0a get a dbdat.;;.
21d0: 3b 3b 20 20 20 20 69 66 20 72 75 6e 2d 69 64 20 ;; if run-id
21e0: 3d 3e 20 67 65 74 20 72 75 6e 20 73 70 65 63 69 => get run speci
21f0: 66 69 63 20 64 62 0a 3b 3b 20 20 20 20 69 66 20 fic db.;; if
2200: 23 66 20 20 20 20 20 3d 3e 20 67 65 74 20 6d 61 #f => get ma
2210: 69 6e 20 64 62 0a 3b 3b 20 20 20 20 69 66 20 72 in db.;; if r
2220: 75 6e 2d 69 64 20 69 73 20 61 20 73 74 72 69 6e un-id is a strin
2230: 67 20 74 72 65 61 74 20 69 74 20 61 73 20 61 20 g treat it as a
2240: 66 69 6c 65 6e 61 6d 65 20 2d 20 44 4f 4e 27 54 filename - DON'T
2250: 20 75 73 65 20 74 68 69 73 20 2d 20 77 65 27 6c use this - we'l
2260: 6c 20 67 65 74 20 72 69 64 20 6f 66 20 69 74 2e l get rid of it.
2270: 0a 3b 3b 20 20 20 20 69 66 20 64 62 20 61 6c 72 .;; if db alr
2280: 65 61 64 79 20 6f 70 65 6e 20 2d 20 72 65 74 75 eady open - retu
2290: 72 6e 20 69 6e 6d 65 6d 0a 3b 3b 20 20 20 20 69 rn inmem.;; i
22a0: 66 20 64 62 20 6e 6f 74 20 6f 70 65 6e 2c 20 6f f db not open, o
22b0: 70 65 6e 20 69 6e 6d 65 6d 2c 20 72 75 6e 64 62 pen inmem, rundb
22c0: 20 61 6e 64 20 73 79 6e 63 20 74 68 65 6e 20 72 and sync then r
22d0: 65 74 75 72 6e 20 69 6e 6d 65 6d 0a 3b 3b 20 20 eturn inmem.;;
22e0: 20 20 69 6e 75 73 65 20 67 65 74 73 20 73 65 74 inuse gets set
22f0: 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 66 automatically f
2300: 6f 72 20 72 75 6e 64 62 27 73 0a 3b 3b 0a 28 64 or rundb's.;;.(d
2310: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 67 65 efine (dbfile:ge
2320: 74 2d 64 62 64 61 74 20 64 62 73 74 72 75 63 74 t-dbdat dbstruct
2330: 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a run-id). (let*
2340: 20 28 28 73 75 62 64 62 20 28 64 62 66 69 6c 65 ((subdb (dbfile
2350: 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 :get-subdb dbstr
2360: 75 63 74 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 uct run-id))).
2370: 20 20 28 69 66 20 28 73 74 61 63 6b 2d 65 6d 70 (if (stack-emp
2380: 74 79 3f 20 28 64 62 72 3a 73 75 62 64 62 2d 64 ty? (dbr:subdb-d
2390: 62 73 74 61 63 6b 20 73 75 62 64 62 29 29 0a 09 bstack subdb))..
23a0: 23 66 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 #f..(begin.. (s
23b0: 74 61 63 6b 2d 70 6f 70 21 20 28 64 62 72 3a 73 tack-pop! (dbr:s
23c0: 75 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 ubdb-dbstack sub
23d0: 64 62 29 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 db))))))..;; ret
23e0: 75 72 6e 20 61 20 70 72 65 76 69 6f 75 73 6c 79 urn a previously
23f0: 20 6f 70 65 6e 65 64 20 64 62 20 68 61 6e 64 6c opened db handl
2400: 65 20 74 6f 20 74 68 65 20 73 74 61 63 6b 20 6f e to the stack o
2410: 66 20 61 76 61 69 6c 61 62 6c 65 20 68 61 6e 64 f available hand
2420: 6c 65 73 0a 28 64 65 66 69 6e 65 20 28 64 62 66 les.(define (dbf
2430: 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 62 ile:add-dbdat db
2440: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 struct run-id db
2450: 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 dat). (let* ((s
2460: 75 62 64 62 20 28 64 62 66 69 6c 65 3a 67 65 74 ubdb (dbfile:get
2470: 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 20 -subdb dbstruct
2480: 72 75 6e 2d 69 64 29 29 0a 09 20 28 64 62 73 74 run-id)).. (dbst
2490: 6b 20 28 64 62 72 3a 73 75 62 64 62 2d 64 62 73 k (dbr:subdb-dbs
24a0: 74 61 63 6b 20 73 75 62 64 62 29 29 0a 09 20 28 tack subdb)).. (
24b0: 63 6f 75 6e 74 20 28 73 74 61 63 6b 2d 63 6f 75 count (stack-cou
24c0: 6e 74 20 64 62 73 74 6b 29 29 29 0a 20 20 20 20 nt dbstk))).
24d0: 28 69 66 20 28 3e 20 63 6f 75 6e 74 20 31 35 29 (if (> count 15)
24e0: 0a 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d ..(dbfile:print-
24f0: 65 72 72 20 22 57 41 52 4e 49 4e 47 3a 20 73 74 err "WARNING: st
2500: 61 63 6b 20 66 6f 72 20 22 72 75 6e 2d 69 64 22 ack for "run-id"
2510: 2e 64 62 20 69 73 20 22 63 6f 75 6e 74 22 2e 22 .db is "count"."
2520: 29 29 0a 20 20 20 20 28 73 74 61 63 6b 2d 70 75 )). (stack-pu
2530: 73 68 21 20 64 62 73 74 6b 20 64 62 64 61 74 29 sh! dbstk dbdat)
2540: 0a 20 20 20 20 64 62 64 61 74 29 29 0a 0a 3b 3b . dbdat))..;;
2550: 20 73 65 74 20 75 70 20 61 20 73 75 62 64 62 0a set up a subdb.
2560: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 ;;.(define (dbfi
2570: 6c 65 3a 69 6e 69 74 2d 73 75 62 64 62 20 64 62 le:init-subdb db
2580: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 69 6e struct run-id in
2590: 69 74 2d 70 72 6f 63 29 0a 20 20 28 6c 65 74 2a it-proc). (let*
25a0: 20 28 28 64 62 6e 61 6d 65 20 20 20 20 28 64 62 ((dbname (db
25b0: 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e file:run-id->dbn
25c0: 61 6d 65 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 ame run-id)).. (
25d0: 61 72 65 61 70 61 74 68 20 20 28 64 62 72 3a 64 areapath (dbr:d
25e0: 62 73 74 72 75 63 74 2d 61 72 65 61 70 61 74 68 bstruct-areapath
25f0: 20 64 62 73 74 72 75 63 74 29 29 0a 09 20 28 74 dbstruct)).. (t
2600: 6d 70 70 61 74 68 20 20 20 28 64 62 72 3a 64 62 mppath (dbr:db
2610: 73 74 72 75 63 74 2d 74 6d 70 70 61 74 68 20 20 struct-tmppath
2620: 64 62 73 74 72 75 63 74 29 29 0a 09 20 28 6d 74 dbstruct)).. (mt
2630: 64 62 70 61 74 68 20 20 28 64 62 66 69 6c 65 3a dbpath (dbfile:
2640: 72 75 6e 2d 69 64 2d 3e 70 61 74 68 20 61 72 65 run-id->path are
2650: 61 70 61 74 68 20 72 75 6e 2d 69 64 29 29 0a 09 apath run-id))..
2660: 20 28 74 6d 70 64 62 70 61 74 68 20 28 64 62 66 (tmpdbpath (dbf
2670: 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 74 68 ile:run-id->path
2680: 20 74 6d 70 70 61 74 68 20 72 75 6e 2d 69 64 29 tmppath run-id)
2690: 29 0a 09 20 28 6d 74 64 62 64 61 74 20 20 20 28 ).. (mtdbdat (
26a0: 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 6c 69 dbfile:open-sqli
26b0: 74 65 33 2d 64 62 20 6d 74 64 62 70 61 74 68 20 te3-db mtdbpath
26c0: 69 6e 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d 6d init-proc sync-m
26d0: 6f 64 65 3a 20 30 20 6a 6f 75 72 6e 61 6c 2d 6d ode: 0 journal-m
26e0: 6f 64 65 3a 20 23 66 29 29 20 3b 3b 20 22 57 41 ode: #f)) ;; "WA
26f0: 4c 22 29 29 0a 09 20 28 6e 65 77 73 75 62 64 62 L")).. (newsubdb
2700: 20 20 28 6d 61 6b 65 2d 64 62 72 3a 73 75 62 64 (make-dbr:subd
2710: 62 20 64 62 6e 61 6d 65 3a 20 20 20 20 64 62 6e b dbname: dbn
2720: 61 6d 65 0a 09 09 09 09 20 20 20 20 6d 74 64 62 ame..... mtdb
2730: 66 69 6c 65 3a 20 20 6d 74 64 62 70 61 74 68 0a file: mtdbpath.
2740: 09 09 09 09 20 20 20 20 74 6d 70 64 62 66 69 6c .... tmpdbfil
2750: 65 3a 20 74 6d 70 64 62 70 61 74 68 0a 09 09 09 e: tmpdbpath....
2760: 09 20 20 20 20 6d 74 64 62 64 61 74 3a 20 20 20 . mtdbdat:
2770: 6d 74 64 62 64 61 74 29 29 29 0a 20 20 20 20 28 mtdbdat))). (
2780: 64 62 66 69 6c 65 3a 73 65 74 2d 73 75 62 64 62 dbfile:set-subdb
2790: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
27a0: 20 6e 65 77 73 75 62 64 62 29 0a 20 20 20 20 6e newsubdb). n
27b0: 65 77 73 75 62 64 62 29 29 20 3b 3b 20 72 65 74 ewsubdb)) ;; ret
27c0: 75 72 6e 20 74 68 65 20 6e 65 77 20 73 75 62 64 urn the new subd
27d0: 62 20 2d 20 62 75 74 20 73 68 6f 75 6c 64 6e 27 b - but shouldn'
27e0: 74 20 72 65 61 6c 6c 79 20 75 73 65 20 69 74 0a t really use it.
27f0: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 64 62 64 61 .;; returns dbda
2800: 74 20 77 69 74 68 20 64 62 68 20 61 6e 64 20 64 t with dbh and d
2810: 62 66 69 6c 65 70 61 74 68 0a 3b 3b 0a 3b 3b 20 bfilepath.;;.;;
2820: 4e 4f 54 45 3a 20 74 68 65 20 68 61 6e 64 6c 65 NOTE: the handle
2830: 20 69 73 20 6f 6e 20 2f 74 6d 70 20 64 62 20 66 is on /tmp db f
2840: 69 6c 65 21 0a 3b 3b 0a 3b 3b 20 20 31 2e 20 69 ile!.;;.;; 1. i
2850: 66 20 6e 65 65 64 65 64 20 73 65 74 75 70 20 74 f needed setup t
2860: 68 65 20 73 75 62 64 62 20 66 6f 72 20 74 68 65 he subdb for the
2870: 20 67 69 76 65 6e 20 72 75 6e 2d 69 64 0a 3b 3b given run-id.;;
2880: 20 20 32 2e 20 69 66 20 74 68 65 72 65 20 69 73 2. if there is
2890: 20 6e 6f 20 65 78 69 73 74 69 6e 67 20 64 62 20 no existing db
28a0: 68 61 6e 64 6c 65 20 69 6e 20 74 68 65 20 73 74 handle in the st
28b0: 61 63 6b 0a 3b 3b 20 20 20 20 20 63 72 65 61 74 ack.;; creat
28c0: 65 20 61 20 6e 65 77 20 68 61 6e 64 6c 65 20 61 e a new handle a
28d0: 6e 64 20 72 65 74 75 72 6e 20 69 74 20 28 64 6f nd return it (do
28e0: 20 4e 4f 54 20 61 64 64 0a 3b 3b 20 20 20 20 20 NOT add.;;
28f0: 69 74 20 74 6f 20 74 68 65 20 73 74 61 63 6b 29 it to the stack)
2900: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 ..;;.(define (db
2910: 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 64 62 73 file:open-db dbs
2920: 74 72 75 63 74 20 72 75 6e 2d 69 64 20 69 6e 69 truct run-id ini
2930: 74 2d 70 72 6f 63 29 0a 20 20 28 6c 65 74 2a 20 t-proc). (let*
2940: 28 28 73 75 62 64 62 20 28 64 62 66 69 6c 65 3a ((subdb (dbfile:
2950: 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 get-subdb dbstru
2960: 63 74 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 ct run-id))).
2970: 20 28 69 66 20 28 6e 6f 74 20 73 75 62 64 62 29 (if (not subdb)
2980: 20 3b 3b 20 6e 6f 74 20 79 65 74 20 64 65 66 69 ;; not yet defi
2990: 6e 65 64 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 ned..(begin.. (
29a0: 64 62 66 69 6c 65 3a 69 6e 69 74 2d 73 75 62 64 dbfile:init-subd
29b0: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
29c0: 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a 09 20 20 d init-proc)..
29d0: 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 62 20 (dbfile:open-db
29e0: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
29f0: 69 6e 69 74 2d 70 72 6f 63 29 29 0a 09 28 6c 65 init-proc))..(le
2a00: 74 2a 20 28 28 64 62 64 61 74 20 28 64 62 66 69 t* ((dbdat (dbfi
2a10: 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 64 62 73 le:get-dbdat dbs
2a20: 74 72 75 63 74 20 72 75 6e 2d 69 64 29 29 29 0a truct run-id))).
2a30: 09 20 20 28 69 66 20 64 62 64 61 74 0a 09 20 20 . (if dbdat..
2a40: 20 20 20 20 64 62 64 61 74 0a 09 20 20 20 20 20 dbdat..
2a50: 20 28 6c 65 74 2a 20 28 28 74 6d 70 70 61 74 68 (let* ((tmppath
2a60: 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 (dbr:dbstruct
2a70: 2d 74 6d 70 70 61 74 68 20 20 64 62 73 74 72 75 -tmppath dbstru
2a80: 63 74 29 29 0a 09 09 20 20 20 20 20 28 74 6d 70 ct))... (tmp
2a90: 64 62 70 61 74 68 20 28 64 62 66 69 6c 65 3a 72 dbpath (dbfile:r
2aa0: 75 6e 2d 69 64 2d 3e 70 61 74 68 20 74 6d 70 70 un-id->path tmpp
2ab0: 61 74 68 20 72 75 6e 2d 69 64 29 29 0a 09 09 20 ath run-id))...
2ac0: 20 20 20 20 28 64 62 64 61 74 20 20 20 20 20 28 (dbdat (
2ad0: 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 6c 69 dbfile:open-sqli
2ae0: 74 65 33 2d 64 62 20 74 6d 70 64 62 70 61 74 68 te3-db tmpdbpath
2af0: 20 69 6e 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d init-proc sync-
2b00: 6d 6f 64 65 3a 20 30 20 6a 6f 75 72 6e 61 6c 2d mode: 0 journal-
2b10: 6d 6f 64 65 3a 20 22 57 41 4c 22 29 29 29 0a 09 mode: "WAL")))..
2b20: 09 3b 3b 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e .;; the followin
2b30: 67 20 6c 69 6e 65 20 73 68 6f 72 74 2d 63 69 72 g line short-cir
2b40: 63 75 69 74 73 20 74 68 65 20 22 6f 6e 65 20 64 cuits the "one d
2b50: 62 20 68 61 6e 64 6c 65 20 70 65 72 20 74 68 72 b handle per thr
2b60: 65 61 64 22 20 6d 6f 64 65 6c 0a 09 09 3b 3b 20 ead" model...;;
2b70: 0a 09 09 3b 3b 20 28 64 62 66 69 6c 65 3a 61 64 ...;; (dbfile:ad
2b80: 64 2d 64 62 64 61 74 20 64 62 73 74 72 75 63 74 d-dbdat dbstruct
2b90: 20 72 75 6e 2d 69 64 20 64 62 64 61 74 29 0a 09 run-id dbdat)..
2ba0: 09 3b 3b 0a 09 09 64 62 64 61 74 29 29 29 29 29 .;;...dbdat)))))
2bb0: 29 0a 20 20 20 20 0a 3b 3b 20 43 4f 4d 42 49 4e ). .;; COMBIN
2bc0: 45 20 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 E dbfile:open-sq
2bd0: 6c 69 74 65 2d 64 62 20 61 6e 64 20 64 62 66 69 lite-db and dbfi
2be0: 6c 65 3a 6c 6f 63 6b 2d 63 72 65 61 74 65 2d 6f le:lock-create-o
2bf0: 70 65 6e 0a 3b 3b 0a 0a 3b 3b 20 74 68 69 73 20 pen.;;..;; this
2c00: 73 74 75 66 66 20 69 73 20 66 6f 72 20 69 6e 69 stuff is for ini
2c10: 74 69 61 6c 20 64 65 62 75 67 67 69 6e 67 2c 20 tial debugging,
2c20: 70 6c 65 61 73 65 20 72 65 6d 6f 76 65 20 69 74 please remove it
2c30: 20 77 68 65 6e 0a 3b 3b 20 74 68 69 73 20 63 6f when.;; this co
2c40: 64 65 20 73 74 61 62 69 6c 69 7a 65 73 0a 28 64 de stabilizes.(d
2c50: 65 66 69 6e 65 20 2a 64 62 6f 70 65 6e 73 2a 20 efine *dbopens*
2c60: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2c70: 29 29 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 )).(define (dbfi
2c80: 6c 65 3a 69 6e 63 2d 64 62 2d 6f 70 65 6e 20 64 le:inc-db-open d
2c90: 62 66 69 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 bfile). (let* (
2ca0: 28 63 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e (curr-opens-coun
2cb0: 74 20 28 2b 20 28 68 61 73 68 2d 74 61 62 6c 65 t (+ (hash-table
2cc0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 -ref/default *db
2cd0: 6f 70 65 6e 73 2a 20 64 62 66 69 6c 65 20 30 29 opens* dbfile 0)
2ce0: 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 1))). (if (a
2cf0: 6e 64 20 28 3e 20 63 75 72 72 2d 6f 70 65 6e 73 nd (> curr-opens
2d00: 2d 63 6f 75 6e 74 20 31 29 20 3b 3b 20 74 68 69 -count 1) ;; thi
2d10: 73 20 73 68 6f 75 6c 64 20 4e 4f 54 20 62 65 20 s should NOT be
2d20: 68 61 70 70 65 6e 69 6e 67 0a 09 20 20 20 20 20 happening..
2d30: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
2d40: 65 2d 70 72 69 6e 74 20 31 35 20 22 64 62 2d 6f e-print 15 "db-o
2d50: 70 65 6e 73 22 29 29 0a 09 28 64 62 66 69 6c 65 pens"))..(dbfile
2d60: 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f :print-err "INFO
2d70: 3a 20 64 62 20 22 64 62 66 69 6c 65 22 20 68 61 : db "dbfile" ha
2d80: 73 20 62 65 65 6e 20 6f 70 65 6e 65 64 20 22 63 s been opened "c
2d90: 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 22 urr-opens-count"
2da0: 20 74 69 6d 65 73 21 22 29 29 0a 20 20 20 20 28 times!")). (
2db0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
2dc0: 2a 64 62 6f 70 65 6e 73 2a 20 64 62 66 69 6c 65 *dbopens* dbfile
2dd0: 20 63 75 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e curr-opens-coun
2de0: 74 29 0a 20 20 20 20 63 75 72 72 2d 6f 70 65 6e t). curr-open
2df0: 73 2d 63 6f 75 6e 74 29 29 0a 0a 3b 3b 20 4f 70 s-count))..;; Op
2e00: 65 6e 20 74 68 65 20 63 6c 61 73 73 69 63 20 6d en the classic m
2e10: 65 67 61 74 65 73 74 2e 64 62 20 66 69 6c 65 20 egatest.db file
2e20: 28 64 65 66 61 75 6c 74 73 20 74 6f 20 6f 70 65 (defaults to ope
2e30: 6e 20 69 6e 20 74 6f 70 70 61 74 68 29 0a 3b 3b n in toppath).;;
2e40: 0a 3b 3b 20 20 20 4e 4f 54 45 3a 20 72 65 74 75 .;; NOTE: retu
2e50: 72 6e 73 20 61 20 64 62 64 61 74 20 6e 6f 74 20 rns a dbdat not
2e60: 61 20 64 62 73 74 72 75 63 74 21 0a 3b 3b 0a 28 a dbstruct!.;;.(
2e70: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 6f define (dbfile:o
2e80: 70 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 64 pen-sqlite3-db d
2e90: 62 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 20 bpath init-proc
2ea0: 23 21 6b 65 79 20 28 73 79 6e 63 2d 6d 6f 64 65 #!key (sync-mode
2eb0: 20 30 29 28 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 0)(journal-mode
2ec0: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
2ed0: 64 62 65 78 69 73 74 73 20 20 20 20 20 28 66 69 dbexists (fi
2ee0: 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 61 74 le-exists? dbpat
2ef0: 68 29 29 0a 09 20 28 77 72 69 74 65 2d 61 63 63 h)).. (write-acc
2f00: 65 73 73 20 28 66 69 6c 65 2d 77 72 69 74 65 2d ess (file-write-
2f10: 61 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 29 access? dbpath))
2f20: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 .. (db
2f30: 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 (dbfile:cautiou
2f40: 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 s-open-database
2f50: 64 62 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 dbpath init-proc
2f60: 20 73 79 6e 63 2d 6d 6f 64 65 20 6a 6f 75 72 6e sync-mode journ
2f70: 61 6c 2d 6d 6f 64 65 29 29 29 0a 20 20 20 20 28 al-mode))). (
2f80: 64 62 66 69 6c 65 3a 69 6e 63 2d 64 62 2d 6f 70 dbfile:inc-db-op
2f90: 65 6e 20 64 62 70 61 74 68 29 0a 20 20 20 20 3b en dbpath). ;
2fa0: 3b 20 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 29 ; (init-proc db)
2fb0: 0a 20 20 20 20 28 6d 61 6b 65 2d 64 62 72 3a 64 . (make-dbr:d
2fc0: 62 64 61 74 20 64 62 66 69 6c 65 3a 20 64 62 70 bdat dbfile: dbp
2fd0: 61 74 68 20 64 62 68 3a 20 64 62 20 72 65 61 64 ath dbh: db read
2fe0: 2d 6f 6e 6c 79 3a 20 28 6e 6f 74 20 77 72 69 74 -only: (not writ
2ff0: 65 2d 61 63 63 65 73 73 29 29 29 29 0a 0a 28 64 e-access))))..(d
3000: 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 70 72 efine (dbfile:pr
3010: 69 6e 74 2d 61 6e 64 2d 65 78 69 74 20 2e 20 70 int-and-exit . p
3020: 61 72 61 6d 73 29 0a 20 20 28 77 69 74 68 2d 6f arams). (with-o
3030: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 0a 20 20 utput-to-port.
3040: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 65 72 72 (current-err
3050: 6f 72 2d 70 6f 72 74 29 0a 20 20 20 20 28 6c 61 or-port). (la
3060: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 61 mbda (). (a
3070: 70 70 6c 79 20 70 72 69 6e 74 20 70 61 72 61 6d pply print param
3080: 73 29 29 29 0a 20 20 28 65 78 69 74 20 31 29 29 s))). (exit 1))
3090: 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 64 . .(define (d
30a0: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
30b0: 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 77 69 74 . params). (wit
30c0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
30d0: 0a 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d . (current-
30e0: 65 72 72 6f 72 2d 70 6f 72 74 29 0a 20 20 20 20 error-port).
30f0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
3100: 20 28 61 70 70 6c 79 20 70 72 69 6e 74 20 70 61 (apply print pa
3110: 72 61 6d 73 29 29 29 29 0a 0a 28 64 65 66 69 6e rams))))..(defin
3120: 65 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 6f e (dbfile:cautio
3130: 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 us-open-database
3140: 20 66 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 fname init-proc
3150: 20 73 79 6e 63 2d 6d 6f 64 65 20 6a 6f 75 72 6e sync-mode journ
3160: 61 6c 2d 6d 6f 64 65 20 23 21 6f 70 74 69 6f 6e al-mode #!option
3170: 61 6c 20 28 74 72 69 65 73 2d 6c 65 66 74 20 35 al (tries-left 5
3180: 30 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 00)). (let* ((b
3190: 75 73 79 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 usy-file (conc
31a0: 66 6e 61 6d 65 20 22 2d 6a 6f 75 72 6e 61 6c 22 fname "-journal"
31b0: 29 29 0a 09 20 28 64 65 6c 61 79 2d 74 69 6d 65 )).. (delay-time
31c0: 20 28 2a 20 28 2d 20 35 31 20 74 72 69 65 73 2d (* (- 51 tries-
31d0: 6c 65 66 74 29 20 31 2e 31 29 29 0a 20 20 20 20 left) 1.1)).
31e0: 20 20 09 20 28 77 72 69 74 65 2d 61 63 63 65 73 . (write-acces
31f0: 73 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 s (file-write-ac
3200: 63 65 73 73 3f 20 66 6e 61 6d 65 29 29 0a 20 20 cess? fname)).
3210: 20 20 20 20 20 20 20 28 64 69 72 2d 61 63 63 65 (dir-acce
3220: 73 73 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ss (file-write-a
3230: 63 63 65 73 73 3f 20 28 70 61 74 68 6e 61 6d 65 ccess? (pathname
3240: 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 -directory fname
3250: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 ))). (re
3260: 74 72 79 20 20 20 20 20 20 28 6c 61 6d 62 64 61 try (lambda
3270: 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 74 68 ()... (th
3280: 72 65 61 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 read-sleep! dela
3290: 79 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 20 20 y-time)...
32a0: 20 28 69 66 20 28 3e 20 74 72 69 65 73 2d 6c 65 (if (> tries-le
32b0: 66 74 20 30 29 0a 09 09 09 20 20 20 28 64 62 66 ft 0).... (dbf
32c0: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
32d0: 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 n-database fname
32e0: 20 69 6e 69 74 2d 70 72 6f 63 0a 09 09 09 09 09 init-proc......
32f0: 09 09 20 20 73 79 6e 63 2d 6d 6f 64 65 20 6a 6f .. sync-mode jo
3300: 75 72 6e 61 6c 2d 6d 6f 64 65 0a 09 09 09 09 09 urnal-mode......
3310: 09 09 20 20 28 2d 20 74 72 69 65 73 2d 6c 65 66 .. (- tries-lef
3320: 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 28 61 t 1)))))). (a
3330: 73 73 65 72 74 20 28 3e 3d 20 74 72 69 65 73 2d ssert (>= tries-
3340: 6c 65 66 74 20 30 29 20 28 63 6f 6e 63 20 22 46 left 0) (conc "F
3350: 41 54 41 4c 3a 20 74 6f 6f 20 6d 61 6e 79 20 61 ATAL: too many a
3360: 74 74 65 6d 70 74 73 20 69 6e 20 64 62 66 69 6c ttempts in dbfil
3370: 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d e:cautious-open-
3380: 64 61 74 61 62 61 73 65 20 6f 66 20 22 66 6e 61 database of "fna
3390: 6d 65 22 2c 20 67 69 76 69 6e 67 20 75 70 2e 22 me", giving up."
33a0: 29 29 0a 20 20 20 20 0a 20 20 20 20 28 69 66 20 )). . (if
33b0: 28 61 6e 64 20 28 66 69 6c 65 2d 77 72 69 74 65 (and (file-write
33c0: 2d 61 63 63 65 73 73 3f 20 66 6e 61 6d 65 29 0a -access? fname).
33d0: 09 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 . (file-exis
33e0: 74 73 3f 20 62 75 73 79 2d 66 69 6c 65 29 29 0a ts? busy-file)).
33f0: 09 28 62 65 67 69 6e 0a 09 20 20 28 69 66 20 28 .(begin.. (if (
3400: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
3410: 2d 70 72 69 6e 74 20 31 32 30 20 62 75 73 79 2d -print 120 busy-
3420: 66 69 6c 65 29 0a 09 20 20 20 20 20 20 28 64 62 file).. (db
3430: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
3440: 49 4e 46 4f 3a 20 64 62 66 69 6c 65 3a 63 61 75 INFO: dbfile:cau
3450: 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 tious-open-datab
3460: 61 73 65 3a 20 6a 6f 75 72 6e 61 6c 20 66 69 6c ase: journal fil
3470: 65 20 22 0a 09 09 09 09 62 75 73 79 2d 66 69 6c e ".....busy-fil
3480: 65 22 20 65 78 69 73 74 73 2c 20 74 72 79 69 6e e" exists, tryin
3490: 67 20 61 67 61 69 6e 20 69 6e 20 66 65 77 20 73 g again in few s
34a0: 65 63 6f 6e 64 73 2e 22 29 29 0a 09 20 20 28 74 econds.")).. (t
34b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
34c0: 09 20 20 28 69 66 20 28 65 71 3f 20 74 72 69 65 . (if (eq? trie
34d0: 73 2d 6c 65 66 74 20 32 29 0a 09 20 20 20 20 20 s-left 2)..
34e0: 20 28 62 65 67 69 6e 0a 09 20 20 09 28 64 62 66 (begin.. .(dbf
34f0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 ile:print-err "I
3500: 4e 46 4f 3a 20 66 6f 72 63 69 6e 67 20 6a 6f 75 NFO: forcing jou
3510: 72 6e 61 6c 20 72 6f 6c 6c 75 70 20 22 62 75 73 rnal rollup "bus
3520: 79 2d 66 69 6c 65 29 0a 09 20 20 09 28 64 62 66 y-file).. .(dbf
3530: 69 6c 65 3a 62 72 75 74 65 2d 66 6f 72 63 65 2d ile:brute-force-
3540: 73 61 6c 76 61 67 65 2d 64 62 20 66 6e 61 6d 65 salvage-db fname
3550: 29 29 29 0a 09 20 20 28 64 62 66 69 6c 65 3a 63 ))).. (dbfile:c
3560: 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 autious-open-dat
3570: 61 62 61 73 65 20 66 6e 61 6d 65 20 69 6e 69 74 abase fname init
3580: 2d 70 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 65 20 -proc sync-mode
3590: 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 20 28 2d 20 journal-mode (-
35a0: 74 72 69 65 73 2d 6c 65 66 74 20 31 29 29 29 0a tries-left 1))).
35b0: 09 0a 09 28 6c 65 74 2a 20 28 28 72 65 73 75 6c ...(let* ((resul
35c0: 74 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 t (condition-cas
35d0: 65 0a 09 09 20 20 20 20 20 20 20 20 28 69 66 20 e... (if
35e0: 64 69 72 2d 61 63 63 65 73 73 0a 09 09 09 20 20 dir-access....
35f0: 20 20 28 64 62 66 69 6c 65 3a 77 69 74 68 2d 73 (dbfile:with-s
3600: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 0a imple-file-lock.
3610: 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 66 6e ... (conc fn
3620: 61 6d 65 20 22 2e 6c 6f 63 6b 22 29 0a 09 09 09 ame ".lock")....
3630: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
3640: 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
3650: 28 28 64 62 2d 65 78 69 73 74 73 20 28 66 69 6c ((db-exists (fil
3660: 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 e-exists? fname)
3670: 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 62 20 )..... (db
3680: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
3690: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e open-database fn
36a0: 61 6d 65 29 29 29 20 3b 3b 20 63 72 65 61 74 65 ame))) ;; create
36b0: 73 20 61 6e 20 65 6d 70 74 79 20 64 62 20 69 66 s an empty db if
36c0: 20 69 74 20 64 69 64 20 6e 6f 74 20 61 6c 72 65 it did not alre
36d0: 61 64 79 20 65 78 69 73 74 2e 0a 20 20 20 20 20 ady exist..
36e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 71 6c (sql
3700: 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 ite3:set-busy-ha
3710: 6e 64 6c 65 72 21 20 64 62 20 28 73 71 6c 69 74 ndler! db (sqlit
3720: 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d e3:make-busy-tim
3730: 65 6f 75 74 20 33 30 30 30 30 29 29 0a 09 09 09 eout 30000))....
3740: 09 20 28 69 66 20 73 79 6e 63 2d 6d 6f 64 65 0a . (if sync-mode.
3750: 09 09 09 09 20 20 20 20 20 28 73 71 6c 69 74 65 .... (sqlite
3760: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
3770: 6e 63 20 22 50 52 41 47 4d 41 20 73 79 6e 63 68 nc "PRAGMA synch
3780: 72 6f 6e 6f 75 73 20 3d 20 22 73 79 6e 63 2d 6d ronous = "sync-m
3790: 6f 64 65 22 3b 22 29 29 29 0a 09 09 09 09 20 28 ode";")))..... (
37a0: 69 66 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 0a if journal-mode.
37b0: 09 09 09 09 20 20 20 20 20 28 73 71 6c 69 74 65 .... (sqlite
37c0: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
37d0: 6e 63 20 22 50 52 41 47 4d 41 20 6a 6f 75 72 6e nc "PRAGMA journ
37e0: 61 6c 5f 6d 6f 64 65 20 3d 20 22 6a 6f 75 72 6e al_mode = "journ
37f0: 61 6c 2d 6d 6f 64 65 22 3b 22 29 29 29 0a 09 09 al-mode";")))...
3800: 09 09 20 28 69 66 20 28 61 6e 64 20 69 6e 69 74 .. (if (and init
3810: 2d 70 72 6f 63 20 28 6e 6f 74 20 64 62 2d 65 78 -proc (not db-ex
3820: 69 73 74 73 29 29 0a 09 09 09 09 20 20 20 20 20 ists)).....
3830: 28 69 6e 69 74 2d 70 72 6f 63 20 64 62 29 29 0a (init-proc db)).
3840: 09 09 09 09 20 64 62 29 29 29 0a 20 20 20 20 20 .... db))).
3850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3860: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
3870: 09 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 . (if (file
3880: 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 20 29 -exists? fname )
3890: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
38a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38b0: 20 20 20 28 6c 65 74 20 28 28 64 62 20 28 73 71 (let ((db (sq
38c0: 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 lite3:open-datab
38d0: 61 73 65 20 66 6e 61 6d 65 29 29 29 0a 09 09 09 ase fname)))....
38e0: 09 20 20 20 20 3b 3b 20 70 72 61 67 6d 61 73 20 . ;; pragmas
38f0: 73 79 6e 63 68 72 6f 6e 6f 75 73 20 6e 6f 74 20 synchronous not
3900: 6e 65 65 64 65 64 20 62 65 63 61 75 73 65 20 74 needed because t
3910: 68 69 73 20 64 62 20 69 73 20 75 73 65 64 20 72 his db is used r
3920: 65 61 64 2d 6f 6e 6c 79 0a 09 09 09 09 20 20 20 ead-only.....
3930: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ;; (sqlite3:exe
3940: 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 50 cute db (conc "P
3950: 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 RAGMA synchronou
3960: 73 20 3d 20 22 6d 6f 64 65 22 3b 22 29 0a 09 09 s = "mode";")...
3970: 09 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 73 .. (sqlite3:s
3980: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
3990: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b db (sqlite3:mak
39a0: 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 e-busy-timeout 3
39b0: 30 30 30 30 29 29 20 3b 3b 20 72 65 61 64 2d 6f 0000)) ;; read-o
39c0: 6e 6c 79 20 62 75 74 20 73 74 69 6c 6c 20 6e 65 nly but still ne
39d0: 65 64 20 74 69 6d 65 6f 75 74 0a 09 09 09 09 20 ed timeout.....
39e0: 20 20 20 64 62 20 29 0a 20 20 20 20 20 20 20 20 db ).
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a00: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
3a10: 20 22 66 69 6c 65 20 64 6f 65 73 6e 27 74 20 65 "file doesn't e
3a20: 78 69 73 74 3a 20 22 20 66 6e 61 6d 65 29 29 29 xist: " fname)))
3a30: 29 0a 09 09 09 28 65 78 6e 20 28 69 6f 2d 65 72 )....(exn (io-er
3a40: 72 6f 72 29 0a 09 09 09 20 20 20 20 20 28 64 62 ror).... (db
3a50: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 file:print-err e
3a60: 78 6e 20 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 xn "ERROR: i/o e
3a70: 72 72 6f 72 20 77 69 74 68 20 22 20 66 6e 61 6d rror with " fnam
3a80: 65 20 22 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 e ". Check permi
3a90: 73 73 69 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 ssions, disk spa
3aa0: 63 65 20 65 74 63 2e 20 61 6e 64 20 74 72 79 20 ce etc. and try
3ab0: 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 20 20 again.")....
3ac0: 20 28 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 (retry))....(ex
3ad0: 6e 20 28 63 6f 72 72 75 70 74 29 0a 09 09 09 20 n (corrupt)....
3ae0: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
3af0: 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f 52 t-err exn "ERROR
3b00: 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 : database " fna
3b10: 6d 65 20 22 20 69 73 20 63 6f 72 72 75 70 74 2e me " is corrupt.
3b20: 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 70 72 Repair it to pr
3b30: 6f 63 65 65 64 2e 22 29 0a 09 09 09 20 20 20 20 oceed.")....
3b40: 20 28 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 (retry))....(ex
3b50: 6e 20 28 62 75 73 79 29 0a 09 09 09 20 20 20 20 n (busy)....
3b60: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
3b70: 72 72 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 rr exn "ERROR: d
3b80: 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 0a atabase " fname.
3b90: 09 09 09 09 09 20 20 20 20 20 20 20 22 20 69 73 ..... " is
3ba0: 20 6c 6f 63 6b 65 64 2e 20 54 72 79 20 63 6f 70 locked. Try cop
3bb0: 79 69 6e 67 20 74 6f 20 61 6e 6f 74 68 65 72 20 ying to another
3bc0: 6c 6f 63 61 74 69 6f 6e 2c 20 72 65 6d 6f 76 65 location, remove
3bd0: 20 6f 72 69 67 69 6e 61 6c 20 61 6e 64 20 63 6f original and co
3be0: 70 79 20 62 61 63 6b 2e 22 29 0a 09 09 09 20 20 py back.")....
3bf0: 20 20 20 28 72 65 74 72 79 29 29 0a 09 09 09 28 (retry))....(
3c00: 65 78 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e 29 exn (permission)
3c10: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
3c20: 72 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 r exn "ERROR: da
3c30: 74 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 tabase " fname "
3c40: 20 68 61 73 20 73 6f 6d 65 20 70 65 72 6d 69 73 has some permis
3c50: 73 69 6f 6e 73 20 70 72 6f 62 6c 65 6d 2e 22 29 sions problem.")
3c60: 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 .... (retry)
3c70: 29 0a 09 09 09 28 65 78 6e 20 28 29 0a 09 09 09 )....(exn ()....
3c80: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
3c90: 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f nt-err exn "ERRO
3ca0: 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 6f 72 R: Unknown error
3cb0: 20 77 69 74 68 20 64 61 74 61 62 61 73 65 20 22 with database "
3cc0: 20 66 6e 61 6d 65 20 22 20 6d 65 73 73 61 67 65 fname " message
3cd0: 3a 20 22 0a 09 09 09 09 09 20 20 20 20 20 20 20 : "......
3ce0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
3cf0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
3d00: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
3d10: 29 29 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 )).... (retr
3d20: 79 29 29 29 29 29 0a 09 20 20 72 65 73 75 6c 74 y))))).. result
3d30: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 ))))..(define (d
3d40: 62 66 69 6c 65 3a 62 72 75 74 65 2d 66 6f 72 63 bfile:brute-forc
3d50: 65 2d 73 61 6c 76 61 67 65 2d 64 62 20 66 6e 61 e-salvage-db fna
3d60: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 61 me). (let* ((ba
3d70: 63 6b 75 70 66 6e 61 6d 65 20 28 63 6f 6e 63 20 ckupfname (conc
3d80: 66 6e 61 6d 65 22 2d 22 28 63 75 72 72 65 6e 74 fname"-"(current
3d90: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 2e 62 61 -process-id)".ba
3da0: 6b 22 29 29 0a 09 20 28 63 6d 64 20 28 63 6f 6e k")).. (cmd (con
3db0: 63 20 22 63 70 20 22 66 6e 61 6d 65 22 20 22 62 c "cp "fname" "b
3dc0: 61 63 6b 75 70 66 6e 61 6d 65 22 3b 6d 76 20 22 ackupfname";mv "
3dd0: 66 6e 61 6d 65 22 20 22 28 63 6f 6e 63 20 66 6e fname" "(conc fn
3de0: 61 6d 65 20 22 2e 64 65 6c 6d 65 3b 22 29 0a 09 ame ".delme;")..
3df0: 09 20 20 20 20 22 63 70 20 22 62 61 63 6b 75 70 . "cp "backup
3e00: 66 6e 61 6d 65 22 20 22 66 6e 61 6d 65 29 29 29 fname" "fname)))
3e10: 0a 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 . (dbfile:pri
3e20: 6e 74 2d 65 72 72 20 22 57 41 52 4e 49 4e 47 3a nt-err "WARNING:
3e30: 20 61 74 74 65 6d 70 74 69 6e 67 20 72 65 63 6f attempting reco
3e40: 76 65 72 79 20 6f 66 20 66 69 6c 65 20 22 66 6e very of file "fn
3e50: 61 6d 65 22 20 62 79 20 72 75 6e 6e 69 6e 67 20 ame" by running
3e60: 63 6f 6d 6d 61 6e 64 73 3a 5c 6e 22 0a 09 09 20 commands:\n"...
3e70: 20 20 20 20 20 22 20 20 22 63 6d 64 29 0a 20 20 " "cmd).
3e80: 20 20 28 73 79 73 74 65 6d 20 63 6d 64 29 29 29 (system cmd)))
3e90: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 ...(define (dbfi
3ea0: 6c 65 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d le:open-no-sync-
3eb0: 64 62 20 64 62 70 61 74 68 29 0a 20 20 28 69 66 db dbpath). (if
3ec0: 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 0a 20 20 *no-sync-db*.
3ed0: 20 20 20 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a *no-sync-db*
3ee0: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
3ef0: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
3f00: 69 73 74 73 3f 20 64 62 70 61 74 68 29 29 0a 09 ists? dbpath))..
3f10: 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 (create-dire
3f20: 63 74 6f 72 79 20 64 62 70 61 74 68 20 23 74 29 ctory dbpath #t)
3f30: 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d )..(let* ((dbnam
3f40: 65 20 20 20 20 28 63 6f 6e 63 20 64 62 70 61 74 e (conc dbpat
3f50: 68 20 22 2f 6e 6f 2d 73 79 6e 63 2e 64 62 22 29 h "/no-sync.db")
3f60: 29 0a 09 20 20 20 20 20 20 20 28 64 62 2d 65 78 ).. (db-ex
3f70: 69 73 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 ists (file-exist
3f80: 73 3f 20 64 62 6e 61 6d 65 29 29 0a 09 20 20 20 s? dbname))..
3f90: 20 20 20 20 28 69 6e 69 74 2d 70 72 6f 63 20 28 (init-proc (
3fa0: 6c 61 6d 62 64 61 20 28 64 62 29 0a 09 09 09 20 lambda (db)....
3fb0: 20 20 20 28 69 66 20 28 6e 6f 74 20 64 62 2d 65 (if (not db-e
3fc0: 78 69 73 74 73 29 0a 09 09 09 09 28 62 65 67 69 xists).....(begi
3fd0: 6e 0a 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 n..... (sqlite3
3fe0: 3a 65 78 65 63 75 74 65 20 64 62 20 22 43 52 45 :execute db "CRE
3ff0: 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 ATE TABLE IF NOT
4000: 20 45 58 49 53 54 53 20 6e 6f 5f 73 79 6e 63 5f EXISTS no_sync_
4010: 6d 65 74 61 64 61 74 20 28 76 61 72 20 54 45 58 metadat (var TEX
4020: 54 2c 76 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 T,val TEXT, CONS
4030: 54 52 41 49 4e 54 20 6e 6f 5f 73 79 6e 63 5f 6d TRAINT no_sync_m
4040: 65 74 61 64 61 74 5f 63 6f 6e 73 74 72 61 69 6e etadat_constrain
4050: 74 20 55 4e 49 51 55 45 20 28 76 61 72 29 29 3b t UNIQUE (var));
4060: 22 29 29 0a 09 09 09 09 29 29 29 0a 09 20 20 20 ")).....)))..
4070: 20 20 20 20 28 64 62 20 20 20 20 20 20 20 20 28 (db (
4080: 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d dbfile:cautious-
4090: 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 open-database db
40a0: 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 30 name init-proc 0
40b0: 20 22 57 41 4c 22 29 29 29 20 3b 3b 20 28 73 71 "WAL"))) ;; (sq
40c0: 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 lite3:open-datab
40d0: 61 73 65 20 64 62 6e 61 6d 65 29 29 29 0a 09 20 ase dbname)))..
40e0: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ;; (sqlite3:exe
40f0: 63 75 74 65 20 64 62 20 22 50 52 41 47 4d 41 20 cute db "PRAGMA
4100: 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 30 3b synchronous = 0;
4110: 22 29 0a 09 20 20 3b 3b 20 28 73 71 6c 69 74 65 ").. ;; (sqlite
4120: 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 3:set-busy-handl
4130: 65 72 21 20 64 62 20 28 73 71 6c 69 74 65 33 3a er! db (sqlite3:
4140: 6d 61 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 make-busy-timeou
4150: 74 20 31 33 36 30 30 30 29 29 20 3b 3b 20 64 6f t 136000)) ;; do
4160: 6e 65 20 69 6e 20 63 61 75 74 69 6f 75 73 2d 6f ne in cautious-o
4170: 70 65 6e 2d 64 61 74 61 62 61 73 65 0a 09 20 20 pen-database..
4180: 28 73 65 74 21 20 2a 6e 6f 2d 73 79 6e 63 2d 64 (set! *no-sync-d
4190: 62 2a 20 64 62 29 0a 09 20 20 64 62 29 29 29 29 b* db).. db))))
41a0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f ..(define (db:no
41b0: 2d 73 79 6e 63 2d 73 65 74 20 64 62 20 76 61 72 -sync-set db var
41c0: 20 76 61 6c 29 0a 20 20 28 73 71 6c 69 74 65 33 val). (sqlite3
41d0: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
41e0: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
41f0: 4e 54 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 NTO no_sync_meta
4200: 64 61 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 dat (var,val) VA
4210: 4c 55 45 53 20 28 3f 2c 3f 29 3b 22 20 76 61 72 LUES (?,?);" var
4220: 20 76 61 6c 29 29 0a 0a 28 64 65 66 69 6e 65 20 val))..(define
4230: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 (db:no-sync-del!
4240: 20 64 62 20 76 61 72 29 0a 20 20 28 73 71 6c 69 db var). (sqli
4250: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
4260: 44 45 4c 45 54 45 20 46 52 4f 4d 20 6e 6f 5f 73 DELETE FROM no_s
4270: 79 6e 63 5f 6d 65 74 61 64 61 74 20 57 48 45 52 ync_metadat WHER
4280: 45 20 76 61 72 3d 3f 3b 22 20 76 61 72 29 29 0a E var=?;" var)).
4290: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d .(define (db:no-
42a0: 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 sync-get/default
42b0: 20 64 62 20 76 61 72 20 64 65 66 61 75 6c 74 29 db var default)
42c0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 64 65 . (let ((res de
42d0: 66 61 75 6c 74 29 29 0a 20 20 20 20 28 73 71 6c fault)). (sql
42e0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
42f0: 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 w. (lambda (
4300: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
4310: 21 20 72 65 73 20 76 61 6c 29 29 0a 20 20 20 20 ! res val)).
4320: 20 64 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 db. "SELECT
4330: 20 76 61 6c 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e val FROM no_syn
4340: 63 5f 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 c_metadat WHERE
4350: 76 61 72 3d 3f 3b 22 0a 20 20 20 20 20 76 61 72 var=?;". var
4360: 29 0a 20 20 20 20 28 69 66 20 72 65 73 0a 20 20 ). (if res.
4370: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new
4380: 72 65 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f res (if (string?
4390: 20 72 65 73 29 0a 09 09 09 20 20 28 73 74 72 69 res).... (stri
43a0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 0a ng->number res).
43b0: 09 09 09 20 20 23 66 29 29 29 0a 20 20 20 20 20 ... #f))).
43c0: 20 20 20 20 20 28 69 66 20 6e 65 77 72 65 73 0a (if newres.
43d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 ne
43e0: 77 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 wres.
43f0: 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 res)).
4400: 20 72 65 73 29 29 29 0a 0a 3b 3b 20 74 72 61 6e res)))..;; tran
4410: 73 61 63 74 69 6f 6e 20 70 72 6f 74 65 63 74 65 saction protecte
4420: 64 20 6c 6f 63 6b 20 61 71 75 69 73 69 74 69 6f d lock aquisitio
4430: 6e 0a 3b 3b 20 65 69 74 68 65 72 3a 0a 3b 3b 20 n.;; either:.;;
4440: 20 20 20 66 61 69 6c 73 20 20 20 20 72 65 74 75 fails retu
4450: 72 6e 73 20 20 28 23 66 20 2e 20 6c 6f 63 6b 2d rns (#f . lock-
4460: 63 72 65 61 74 69 6f 6e 2d 74 69 6d 65 29 0a 3b creation-time).;
4470: 3b 20 20 20 20 73 75 63 63 65 65 64 73 20 28 72 ; succeeds (r
4480: 65 74 75 72 6e 73 20 28 23 74 20 2e 20 6c 6f 63 eturns (#t . loc
4490: 6b 2d 63 72 65 61 74 69 6f 6e 2d 74 69 6d 65 29 k-creation-time)
44a0: 0a 3b 3b 20 75 73 65 20 28 64 62 3a 6e 6f 2d 73 .;; use (db:no-s
44b0: 79 6e 63 2d 64 65 6c 21 20 64 62 20 6b 65 79 6e ync-del! db keyn
44c0: 61 6d 65 29 20 74 6f 20 72 65 6c 65 61 73 65 20 ame) to release
44d0: 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 the lock.;;.(def
44e0: 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d ine (db:no-sync-
44f0: 67 65 74 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e get-lock db keyn
4500: 61 6d 65 29 0a 20 20 28 73 71 6c 69 74 65 33 3a ame). (sqlite3:
4510: 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e with-transaction
4520: 0a 20 20 20 64 62 0a 20 20 20 28 6c 61 6d 62 64 . db. (lambd
4530: 61 20 28 29 0a 20 20 20 20 20 28 63 6f 6e 64 69 a (). (condi
4540: 74 69 6f 6e 2d 63 61 73 65 0a 09 20 28 6c 65 74 tion-case.. (let
4550: 2a 20 28 28 63 75 72 72 2d 76 61 6c 20 28 64 62 * ((curr-val (db
4560: 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 :no-sync-get/def
4570: 61 75 6c 74 20 64 62 20 6b 65 79 6e 61 6d 65 20 ault db keyname
4580: 23 66 29 29 29 0a 09 20 20 20 28 69 66 20 63 75 #f))).. (if cu
4590: 72 72 2d 76 61 6c 0a 09 20 20 20 20 20 20 20 60 rr-val.. `
45a0: 28 23 66 20 2e 20 2c 63 75 72 72 2d 76 61 6c 29 (#f . ,curr-val)
45b0: 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 ;; (sqlite3:f
45c0: 69 72 73 74 2d 72 65 73 75 6c 74 20 64 62 20 22 irst-result db "
45d0: 53 45 4c 45 43 54 20 76 61 6c 20 46 52 4f 4d 20 SELECT val FROM
45e0: 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 no_sync_metadat
45f0: 57 48 45 52 45 20 76 61 72 3d 3f 3b 22 20 6b 65 WHERE var=?;" ke
4600: 79 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 yname))..
4610: 28 6c 65 74 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 (let ((lock-time
4620: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
4630: 73 29 29 29 0a 09 09 20 28 73 71 6c 69 74 65 33 s)))... (sqlite3
4640: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
4650: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
4660: 4e 54 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 NTO no_sync_meta
4670: 64 61 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 dat (var,val) VA
4680: 4c 55 45 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e LUES(?,?);" keyn
4690: 61 6d 65 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 ame lock-time)..
46a0: 09 20 60 28 23 74 20 2e 20 2c 6c 6f 63 6b 2d 74 . `(#t . ,lock-t
46b0: 69 6d 65 29 29 29 29 0a 20 20 20 20 20 20 20 28 ime)))). (
46c0: 65 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 20 20 exn (io-error)
46d0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
46e0: 72 20 22 45 52 52 4f 52 3a 20 69 2f 6f 20 65 72 r "ERROR: i/o er
46f0: 72 6f 72 20 77 69 74 68 20 6e 6f 2d 73 79 6e 63 ror with no-sync
4700: 20 64 62 2e 20 43 68 65 63 6b 20 70 65 72 6d 69 db. Check permi
4710: 73 73 69 6f 6e 73 2c 20 64 69 73 6b 20 73 70 61 ssions, disk spa
4720: 63 65 20 65 74 63 2e 20 61 6e 64 20 74 72 79 20 ce etc. and try
4730: 61 67 61 69 6e 2e 22 29 29 0a 20 20 20 20 20 20 again.")).
4740: 20 28 65 78 6e 20 28 63 6f 72 72 75 70 74 29 20 (exn (corrupt)
4750: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
4760: 65 72 72 20 22 45 52 52 4f 52 3a 20 64 61 74 61 err "ERROR: data
4770: 62 61 73 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 base no-sync db
4780: 69 73 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 is corrupt. Repa
4790: 69 72 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 ir it to proceed
47a0: 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 78 6e .")). (exn
47b0: 20 28 62 75 73 79 29 20 20 20 20 20 20 28 64 62 (busy) (db
47c0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
47d0: 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 ERROR: database
47e0: 6e 6f 2d 73 79 6e 63 20 64 62 20 69 73 20 6c 6f no-sync db is lo
47f0: 63 6b 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e cked. Try copyin
4800: 67 20 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 g to another loc
4810: 61 74 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 ation, remove or
4820: 69 67 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 iginal and copy
4830: 62 61 63 6b 2e 22 29 29 0a 20 20 20 20 20 20 20 back.")).
4840: 28 65 78 6e 20 28 70 65 72 6d 69 73 73 69 6f 6e (exn (permission
4850: 29 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 )(dbfile:print-e
4860: 72 72 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 rr "ERROR: datab
4870: 61 73 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 68 ase no-sync db h
4880: 61 73 20 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 as some permissi
4890: 6f 6e 73 20 70 72 6f 62 6c 65 6d 2e 22 29 29 0a ons problem.")).
48a0: 20 20 20 20 20 20 20 28 65 78 6e 20 28 29 20 3b (exn () ;
48b0: 3b 20 28 73 74 61 74 75 73 20 64 6f 6e 65 29 20 ; (status done)
48c0: 3b 3b 20 49 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 ;; I don't know
48d0: 68 6f 77 20 74 6f 20 64 65 74 65 63 74 20 73 74 how to detect st
48e0: 61 74 75 73 20 64 6f 6e 65 20 62 75 74 20 6e 6f atus done but no
48f0: 20 64 61 74 61 21 0a 09 20 20 20 20 28 64 62 66 data!.. (dbf
4900: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 ile:print-err "E
4910: 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 RROR: Unknown er
4920: 72 6f 72 20 77 69 74 68 20 64 61 74 61 62 61 73 ror with databas
4930: 65 20 6e 6f 2d 73 79 6e 63 20 64 62 20 6d 65 73 e no-sync db mes
4940: 73 61 67 65 3a 20 65 78 6e 3d 22 28 63 6f 6e 64 sage: exn="(cond
4950: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
4960: 22 2c 20 5c 6e 22 0a 09 09 09 20 20 20 20 20 20 ", \n"....
4970: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
4980: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
4990: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
49a0: 29 29 0a 09 20 20 20 20 60 28 23 66 20 2e 20 2c )).. `(#f . ,
49b0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
49c0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
49d0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (db:no-sync-get
49e0: 2d 6c 6f 63 6b 2d 74 69 6d 65 6f 75 74 20 64 62 -lock-timeout db
49f0: 20 6b 65 79 6e 61 6d 65 20 74 69 6d 65 6f 75 74 keyname timeout
4a00: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ). (let* ((lock
4a10: 64 61 74 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d dat (db:no-sync-
4a20: 67 65 74 2d 6c 6f 63 6b 20 64 62 20 6b 65 79 6e get-lock db keyn
4a30: 61 6d 65 29 29 29 0a 20 20 20 20 28 6d 61 74 63 ame))). (matc
4a40: 68 20 6c 6f 63 6b 64 61 74 0a 20 20 20 20 20 20 h lockdat.
4a50: 28 28 23 66 20 2e 20 6c 6f 63 6b 2d 74 69 6d 65 ((#f . lock-time
4a60: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 ). (if (>
4a70: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
4a80: 6e 64 73 29 20 28 69 66 20 28 73 74 72 69 6e 67 nds) (if (string
4a90: 3f 20 6c 6f 63 6b 2d 74 69 6d 65 29 28 73 74 72 ? lock-time)(str
4aa0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6c 6f 63 6b ing->number lock
4ab0: 2d 74 69 6d 65 29 6c 6f 63 6b 2d 74 69 6d 65 29 -time)lock-time)
4ac0: 29 20 74 69 6d 65 6f 75 74 29 0a 09 20 20 20 28 ) timeout).. (
4ad0: 6c 65 74 20 28 28 6c 6f 63 6b 2d 74 69 6d 65 20 let ((lock-time
4ae0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4af0: 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 64 65 ))).. ;; (de
4b00: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
4b10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4b20: 72 74 2a 20 22 64 62 3a 6e 6f 2d 73 79 6e 63 2d rt* "db:no-sync-
4b30: 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 get-lock keyname
4b40: 3d 22 20 6b 65 79 6e 61 6d 65 20 22 2c 20 6c 6f =" keyname ", lo
4b50: 63 6b 2d 74 69 6d 65 3d 22 20 6c 6f 63 6b 2d 74 ck-time=" lock-t
4b60: 69 6d 65 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e ime ", exn=" exn
4b70: 29 0a 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 ).. (sqlite3
4b80: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
4b90: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
4ba0: 4e 54 4f 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 NTO no_sync_meta
4bb0: 64 61 74 20 28 76 61 72 2c 76 61 6c 29 20 56 41 dat (var,val) VA
4bc0: 4c 55 45 53 28 3f 2c 3f 29 3b 22 20 6b 65 79 6e LUES(?,?);" keyn
4bd0: 61 6d 65 20 6c 6f 63 6b 2d 74 69 6d 65 29 0a 09 ame lock-time)..
4be0: 20 20 20 20 20 60 28 23 74 20 2e 20 2c 6c 6f 63 `(#t . ,loc
4bf0: 6b 2d 74 69 6d 65 29 29 0a 09 20 20 20 6c 6f 63 k-time)).. loc
4c00: 6b 64 61 74 29 29 0a 20 20 20 20 20 20 28 65 6c kdat)). (el
4c10: 73 65 20 6c 6f 63 6b 64 61 74 29 29 29 29 0a 0a se lockdat))))..
4c20: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 77 69 ;; NOTE: This wi
4c30: 6c 6c 20 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 ll steal the loc
4c40: 6b 20 61 66 74 65 72 20 74 69 6d 65 6f 75 74 20 k after timeout
4c50: 6f 66 20 77 61 69 74 69 6e 67 2e 0a 3b 3b 0a 28 of waiting..;;.(
4c60: 64 65 66 69 6e 65 20 28 64 62 3a 77 69 74 68 2d define (db:with-
4c70: 6e 6f 2d 73 79 6e 63 2d 6c 6f 63 6b 20 64 62 20 no-sync-lock db
4c80: 6b 65 79 6e 61 6d 65 20 74 69 6d 65 6f 75 74 20 keyname timeout
4c90: 70 72 6f 63 29 0a 20 20 28 6c 65 74 2a 20 28 28 proc). (let* ((
4ca0: 6c 6f 63 6b 64 61 74 20 20 28 64 62 3a 6e 6f 2d lockdat (db:no-
4cb0: 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 sync-get-lock-ti
4cc0: 6d 65 6f 75 74 20 64 62 20 6b 65 79 6e 61 6d 65 meout db keyname
4cd0: 29 29 0a 09 20 28 67 6f 74 6c 6f 63 6b 20 20 28 )).. (gotlock (
4ce0: 63 61 72 20 6c 6f 63 6b 64 61 74 29 29 0a 09 20 car lockdat))..
4cf0: 28 6c 6f 63 6b 74 69 6d 65 20 28 63 64 72 20 6c (locktime (cdr l
4d00: 6f 63 6b 64 61 74 29 29 29 0a 20 20 20 20 28 69 ockdat))). (i
4d10: 66 20 67 6f 74 6c 6f 63 6b 0a 09 28 6c 65 74 20 f gotlock..(let
4d20: 28 28 72 65 73 20 28 70 72 6f 63 29 29 29 0a 09 ((res (proc)))..
4d30: 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 (db:no-sync-de
4d40: 6c 21 20 64 62 20 6b 65 79 6e 61 6d 65 29 0a 09 l! db keyname)..
4d50: 20 20 72 65 73 29 29 29 29 0a 20 20 0a 3b 3b 3d res)))). .;;=
4d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4da0: 3d 3d 3d 3d 3d 0a 3b 3b 20 73 79 6e 63 20 62 61 =====.;; sync ba
4db0: 63 6b 20 66 75 6e 63 74 69 6f 6e 73 20 70 75 6c ck functions pul
4dc0: 6c 65 64 20 66 72 6f 6d 20 64 62 2e 73 63 6d 0a led from db.scm.
4dd0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e10: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 ========..;; Get
4e20: 20 61 20 6c 6f 63 6b 20 66 72 6f 6d 20 74 68 65 a lock from the
4e30: 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 6f 72 20 no-sync-db for
4e40: 74 68 65 20 66 72 6f 6d 2d 64 62 2c 20 74 68 65 the from-db, the
4e50: 6e 20 64 65 6c 74 61 20 73 79 6e 63 20 74 68 65 n delta sync the
4e60: 20 66 72 6f 6d 2d 64 62 20 74 6f 20 74 68 65 20 from-db to the
4e70: 74 6f 2d 64 62 2c 20 6f 74 68 65 72 77 69 73 65 to-db, otherwise
4e80: 20 72 65 74 75 72 6e 20 23 66 0a 3b 3b 0a 28 64 return #f.;;.(d
4e90: 65 66 69 6e 65 20 28 64 62 3a 6c 6f 63 6b 2d 61 efine (db:lock-a
4ea0: 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 20 6e 6f nd-delta-sync no
4eb0: 2d 73 79 6e 63 2d 64 62 20 64 62 73 74 72 75 63 -sync-db dbstruc
4ec0: 74 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 t from-db-file r
4ed0: 75 6e 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 unid keys dbinit
4ee0: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 6f 74 ). (assert (not
4ef0: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
4f00: 67 72 65 73 73 2a 29 20 22 46 41 54 41 4c 3a 20 gress*) "FATAL:
4f10: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 73 79 6e 63 db:lock-and-sync
4f20: 20 63 61 6c 6c 65 64 20 77 68 69 6c 65 20 61 20 called while a
4f30: 73 79 6e 63 20 69 73 20 69 6e 20 70 72 6f 67 72 sync is in progr
4f40: 65 73 73 2e 22 29 0a 20 20 3b 3b 20 28 64 62 66 ess."). ;; (dbf
4f50: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 2a 64 ile:print-err *d
4f60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4f70: 20 22 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 "db:lock-and-de
4f80: 6c 74 61 2d 73 79 6e 63 22 29 0a 20 20 28 6c 65 lta-sync"). (le
4f90: 74 2a 20 28 28 6c 6f 63 6b 2d 66 69 6c 65 20 28 t* ((lock-file (
4fa0: 63 6f 6e 63 20 66 72 6f 6d 2d 64 62 2d 66 69 6c conc from-db-fil
4fb0: 65 20 22 2e 6c 6f 63 6b 22 29 29 29 0a 20 20 20 e ".lock"))).
4fc0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d (if (common:sim
4fd0: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f ple-file-lock lo
4fe0: 63 6b 2d 66 69 6c 65 29 0a 09 28 62 65 67 69 6e ck-file)..(begin
4ff0: 0a 09 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e .. (dbfile:prin
5000: 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 3a t-err "INFO: db:
5010: 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 lock-and-delta-s
5020: 79 6e 63 20 63 6f 70 79 69 6e 67 20 64 62 20 22 ync copying db "
5030: 72 75 6e 69 64 22 20 61 74 20 22 28 63 75 72 72 runid" at "(curr
5040: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds))..
5050: 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d (set! *db-sync-
5060: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 in-progress* #t)
5070: 0a 09 20 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 .. (db:sync-tou
5080: 63 68 65 64 20 64 62 73 74 72 75 63 74 20 72 75 ched dbstruct ru
5090: 6e 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 nid keys dbinit)
50a0: 0a 09 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 .. (set! *db-sy
50b0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 nc-in-progress*
50c0: 23 66 29 0a 09 20 20 28 64 65 6c 65 74 65 2d 66 #f).. (delete-f
50d0: 69 6c 65 2a 20 6c 6f 63 6b 2d 66 69 6c 65 29 0a ile* lock-file).
50e0: 09 20 20 23 74 29 0a 20 20 20 20 20 20 20 20 28 . #t). (
50f0: 62 65 67 69 6e 0a 09 20 20 28 69 66 20 28 63 6f begin.. (if (co
5100: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
5110: 72 69 6e 74 20 31 32 30 20 28 63 6f 6e 63 20 22 rint 120 (conc "
5120: 6e 6f 20 6c 6f 63 6b 20 22 66 72 6f 6d 2d 64 62 no lock "from-db
5130: 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 28 -file)).. (
5140: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
5150: 20 22 49 4e 46 4f 3a 20 63 6f 75 6c 64 20 6e 6f "INFO: could no
5160: 74 20 67 65 74 20 6c 6f 63 6b 20 66 6f 72 20 22 t get lock for "
5170: 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 22 2c from-db-file ",
5180: 20 73 79 6e 63 20 6c 69 6b 65 6c 79 20 69 6e 20 sync likely in
5190: 70 72 6f 67 72 65 73 73 2e 22 29 29 0a 09 20 20 progress."))..
51a0: 23 66 0a 09 20 20 29 29 29 29 0a 0a 3b 3b 20 3b #f.. ))))..;; ;
51b0: 3b 20 47 65 74 20 61 20 6c 6f 63 6b 20 66 72 6f ; Get a lock fro
51c0: 6d 20 74 68 65 20 6e 6f 2d 73 79 6e 63 2d 64 62 m the no-sync-db
51d0: 20 66 6f 72 20 74 68 65 20 66 72 6f 6d 2d 64 62 for the from-db
51e0: 2c 20 74 68 65 6e 20 64 65 6c 74 61 20 73 79 6e , then delta syn
51f0: 63 20 74 68 65 20 66 72 6f 6d 2d 64 62 20 74 6f c the from-db to
5200: 20 74 68 65 20 74 6f 2d 64 62 2c 20 6f 74 68 65 the to-db, othe
5210: 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 0a rwise return #f.
5220: 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ;; ;;.;; (define
5230: 20 28 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 (db:lock-and-de
5240: 6c 74 61 2d 73 79 6e 63 2d 6f 72 69 67 20 6e 6f lta-sync-orig no
5250: 2d 73 79 6e 63 2d 64 62 20 64 62 73 74 72 75 63 -sync-db dbstruc
5260: 74 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 72 t from-db-file r
5270: 75 6e 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 unid keys dbinit
5280: 29 0a 3b 3b 20 20 20 28 61 73 73 65 72 74 20 28 ).;; (assert (
5290: 6e 6f 74 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d not *db-sync-in-
52a0: 70 72 6f 67 72 65 73 73 2a 29 20 22 46 41 54 41 progress*) "FATA
52b0: 4c 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 73 L: db:lock-and-s
52c0: 79 6e 63 20 63 61 6c 6c 65 64 20 77 68 69 6c 65 ync called while
52d0: 20 61 20 73 79 6e 63 20 69 73 20 69 6e 20 70 72 a sync is in pr
52e0: 6f 67 72 65 73 73 2e 22 29 0a 3b 3b 20 20 20 3b ogress.").;; ;
52f0: 3b 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d ; (dbfile:print-
5300: 65 72 72 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 err *default-log
5310: 2d 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d -port* "db:lock-
5320: 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 22 29 and-delta-sync")
5330: 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f .;; (let* ((lo
5340: 63 6b 64 61 74 20 20 28 64 62 3a 6e 6f 2d 73 79 ckdat (db:no-sy
5350: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d 65 nc-get-lock-time
5360: 6f 75 74 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 66 out no-sync-db f
5370: 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 36 30 29 29 rom-db-file 60))
5380: 0a 3b 3b 20 09 20 28 67 6f 74 6c 6f 63 6b 20 20 .;; . (gotlock
5390: 28 63 61 72 20 6c 6f 63 6b 64 61 74 29 29 0a 3b (car lockdat)).;
53a0: 3b 20 09 20 28 6c 6f 63 6b 74 69 6d 65 20 28 63 ; . (locktime (c
53b0: 64 72 20 6c 6f 63 6b 64 61 74 29 29 29 0a 3b 3b dr lockdat))).;;
53c0: 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 ;; (debug:p
53d0: 72 69 6e 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 rint-info 3 *def
53e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
53f0: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 db:lock-and-delt
5400: 61 2d 73 79 6e 63 3a 20 67 6f 74 20 6c 6f 63 6b a-sync: got lock
5410: 3f 22 29 0a 3b 3b 20 20 20 20 20 0a 3b 3b 20 20 ?").;; .;;
5420: 20 20 20 28 69 66 20 67 6f 74 6c 6f 63 6b 0a 3b (if gotlock.;
5430: 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 ; .(begin.;;
5440: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 (dbfile:p
5450: 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 rint-err "INFO:
5460: 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 db:lock-and-delt
5470: 61 2d 73 79 6e 63 20 63 6f 70 79 69 6e 67 20 64 a-sync copying d
5480: 62 20 22 72 75 6e 69 64 22 20 61 74 20 22 28 63 b "runid" at "(c
5490: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
54a0: 0a 3b 3b 20 09 20 20 28 73 65 74 21 20 2a 64 62 .;; . (set! *db
54b0: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
54c0: 73 2a 20 23 74 29 0a 3b 3b 20 20 20 20 20 20 20 s* #t).;;
54d0: 20 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 (db:sync-tou
54e0: 63 68 65 64 20 64 62 73 74 72 75 63 74 20 72 75 ched dbstruct ru
54f0: 6e 69 64 20 6b 65 79 73 20 64 62 69 6e 69 74 29 nid keys dbinit)
5500: 0a 3b 3b 20 09 20 20 28 73 65 74 21 20 2a 64 62 .;; . (set! *db
5510: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5520: 73 2a 20 23 66 29 0a 3b 3b 20 09 20 20 28 64 62 s* #f).;; . (db
5530: 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 6e 6f :no-sync-del! no
5540: 2d 73 79 6e 63 2d 64 62 20 66 72 6f 6d 2d 64 62 -sync-db from-db
5550: 2d 66 69 6c 65 29 0a 3b 3b 20 09 20 20 23 74 29 -file).;; . #t)
5560: 0a 3b 3b 20 20 20 20 20 20 20 20 20 28 62 65 67 .;; (beg
5570: 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 in.;;
5580: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
5590: 72 20 22 45 52 52 4f 52 3a 20 63 6f 75 6c 64 20 r "ERROR: could
55a0: 6e 6f 74 20 67 65 74 20 6c 6f 63 6b 20 66 6f 72 not get lock for
55b0: 20 22 20 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 20 " from-db-file
55c0: 22 20 66 72 6f 6d 20 6e 6f 2d 73 79 6e 63 2d 64 " from no-sync-d
55d0: 62 22 29 0a 3b 3b 20 09 20 20 23 66 0a 3b 3b 20 b").;; . #f.;;
55e0: 20 20 20 20 20 20 20 20 29 29 29 29 0a 0a 3b 3b ))))..;;
55f0: 20 73 79 6e 63 20 72 75 6e 20 66 72 6f 6d 20 74 sync run from t
5600: 6d 70 20 64 69 73 6b 20 74 6f 20 6e 66 73 20 64 mp disk to nfs d
5610: 69 73 6b 20 69 66 20 74 6f 75 63 68 65 64 0a 3b isk if touched.;
5620: 3b 0a 3b 3b 20 63 61 6c 6c 20 77 69 74 68 20 64 ;.;; call with d
5630: 62 69 6e 69 74 3d 64 62 3a 69 6e 69 74 69 61 6c binit=db:initial
5640: 69 7a 65 2d 6d 61 69 6e 2d 64 62 0a 3b 3b 0a 28 ize-main-db.;;.(
5650: 64 65 66 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d define (db:sync-
5660: 74 6f 75 63 68 65 64 20 64 62 73 74 72 75 63 74 touched dbstruct
5670: 20 72 75 6e 2d 69 64 20 6b 65 79 73 20 23 21 6b run-id keys #!k
5680: 65 79 20 64 62 69 6e 69 74 20 28 66 6f 72 63 65 ey dbinit (force
5690: 2d 73 79 6e 63 20 23 66 29 29 0a 20 20 28 64 62 -sync #f)). (db
56a0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
56b0: 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 db:sync-touched
56c0: 53 79 6e 63 69 6e 67 3a 20 22 20 28 63 6f 6e 63 Syncing: " (conc
56d0: 20 28 69 66 20 72 75 6e 2d 69 64 20 72 75 6e 2d (if run-id run-
56e0: 69 64 20 22 6d 61 69 6e 22 29 20 22 2e 64 62 22 id "main") ".db"
56f0: 29 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 74 )). (let* (;; t
5700: 68 65 20 73 75 62 64 62 20 69 73 20 6e 65 65 64 he subdb is need
5710: 65 64 20 74 6f 20 61 63 63 65 73 73 20 74 68 65 ed to access the
5720: 20 6d 74 64 62 64 61 74 0a 09 20 28 73 75 62 64 mtdbdat.. (subd
5730: 62 20 20 20 20 20 28 6f 72 20 28 64 62 66 69 6c b (or (dbfil
5740: 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 e:get-subdb dbst
5750: 72 75 63 74 20 72 75 6e 2d 69 64 29 0a 09 09 09 ruct run-id)....
5760: 28 64 62 66 69 6c 65 3a 69 6e 69 74 2d 73 75 62 (dbfile:init-sub
5770: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
5780: 69 64 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 id dbinit))).
5790: 20 20 20 20 20 20 28 74 6d 70 64 62 66 69 6c 65 (tmpdbfile
57a0: 20 28 64 62 72 3a 73 75 62 64 62 2d 74 6d 70 64 (dbr:subdb-tmpd
57b0: 62 66 69 6c 65 20 73 75 62 64 62 29 29 0a 09 20 bfile subdb))..
57c0: 28 6d 74 64 62 20 20 20 20 20 20 28 64 62 72 3a (mtdb (dbr:
57d0: 73 75 62 64 62 2d 6d 74 64 62 64 61 74 20 73 75 subdb-mtdbdat su
57e0: 62 64 62 29 29 0a 20 20 20 20 20 20 20 20 20 28 bdb)). (
57f0: 74 6d 70 64 62 20 20 20 20 20 28 64 62 3a 6f 70 tmpdb (db:op
5800: 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 en-db dbstruct r
5810: 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 29 20 3b un-id dbinit)) ;
5820: 3b 20 73 71 6c 69 74 65 33 2d 64 62 20 74 6d 70 ; sqlite3-db tmp
5830: 64 62 66 69 6c 65 20 23 66 29 29 0a 09 20 28 73 dbfile #f)).. (s
5840: 74 61 72 74 2d 74 20 20 20 28 63 75 72 72 65 6e tart-t (curren
5850: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 t-seconds))).
5860: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
5870: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
5880: 65 78 2a 29 0a 20 20 20 20 28 6c 65 74 20 28 28 ex*). (let ((
5890: 75 70 64 61 74 65 5f 69 6e 66 6f 20 28 63 6f 6e update_info (con
58a0: 73 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 s "last_update"
58b0: 28 69 66 20 66 6f 72 63 65 2d 73 79 6e 63 20 30 (if force-sync 0
58c0: 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 *db-last-sync*)
58d0: 20 29 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 ))). (mute
58e0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 x-unlock! *db-mu
58f0: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 lti-sync-mutex*)
5900: 0a 20 20 20 20 20 20 28 64 62 3a 73 79 6e 63 2d . (db:sync-
5910: 74 61 62 6c 65 73 20 28 64 62 3a 73 79 6e 63 2d tables (db:sync-
5920: 61 6c 6c 2d 74 61 62 6c 65 73 2d 6c 69 73 74 20 all-tables-list
5930: 64 62 73 74 72 75 63 74 20 6b 65 79 73 29 20 75 dbstruct keys) u
5940: 70 64 61 74 65 5f 69 6e 66 6f 20 74 6d 70 64 62 pdate_info tmpdb
5950: 20 6d 74 64 62 29 29 0a 20 20 20 20 28 6d 75 74 mtdb)). (mut
5960: 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c ex-lock! *db-mul
5970: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a ti-sync-mutex*).
5980: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 (set! *db-la
5990: 73 74 2d 73 79 6e 63 2a 20 73 74 61 72 74 2d 74 st-sync* start-t
59a0: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d ). (set! *db-
59b0: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 last-access* sta
59c0: 72 74 2d 74 29 0a 20 20 20 20 28 6d 75 74 65 78 rt-t). (mutex
59d0: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c -unlock! *db-mul
59e0: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a ti-sync-mutex*).
59f0: 20 20 20 20 28 64 62 66 69 6c 65 3a 61 64 64 2d (dbfile:add-
5a00: 64 62 64 61 74 20 64 62 73 74 72 75 63 74 20 72 dbdat dbstruct r
5a10: 75 6e 2d 69 64 20 74 6d 70 64 62 29 0a 20 20 23 un-id tmpdb). #
5a20: 74 29 29 0a 0a 3b 3b 20 6a 75 73 74 20 74 65 73 t))..;; just tes
5a30: 74 73 2c 20 74 65 73 74 5f 73 74 65 70 73 20 61 ts, test_steps a
5a40: 6e 64 20 74 65 73 74 5f 64 61 74 61 20 74 61 62 nd test_data tab
5a50: 6c 65 73 0a 28 64 65 66 69 6e 65 20 64 62 3a 73 les.(define db:s
5a60: 79 6e 63 2d 74 65 73 74 73 2d 6f 6e 6c 79 0a 20 ync-tests-only.
5a70: 20 28 6c 69 73 74 0a 20 20 20 3b 3b 20 28 6c 69 (list. ;; (li
5a80: 73 74 20 22 73 74 72 73 22 0a 20 20 20 3b 3b 20 st "strs". ;;
5a90: 20 20 20 20 20 20 27 28 22 69 64 22 20 20 20 20 '("id"
5aa0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 #f).
5ab0: 3b 3b 20 20 20 20 20 20 20 27 28 22 73 74 72 22 ;; '("str"
5ac0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
5ad0: 0a 20 20 20 28 6c 69 73 74 20 22 74 65 73 74 73 . (list "tests
5ae0: 22 20 0a 09 20 27 28 22 69 64 22 20 20 20 20 20 " .. '("id"
5af0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
5b00: 22 72 75 6e 5f 69 64 22 20 20 20 20 20 20 20 20 "run_id"
5b10: 20 23 66 29 0a 09 20 27 28 22 74 65 73 74 6e 61 #f).. '("testna
5b20: 6d 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 me" #f)..
5b30: 27 28 22 68 6f 73 74 22 20 20 20 20 20 20 20 20 '("host"
5b40: 20 20 20 23 66 29 0a 09 20 27 28 22 63 70 75 6c #f).. '("cpul
5b50: 6f 61 64 22 20 20 20 20 20 20 20 20 23 66 29 0a oad" #f).
5b60: 09 20 27 28 22 64 69 73 6b 66 72 65 65 22 20 20 . '("diskfree"
5b70: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 75 6e #f).. '("un
5b80: 61 6d 65 22 20 20 20 20 20 20 20 20 20 20 23 66 ame" #f
5b90: 29 0a 09 20 27 28 22 72 75 6e 64 69 72 22 20 20 ).. '("rundir"
5ba0: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5bb0: 73 68 6f 72 74 64 69 72 22 20 20 20 20 20 20 20 shortdir"
5bc0: 23 66 29 0a 09 20 27 28 22 69 74 65 6d 5f 70 61 #f).. '("item_pa
5bd0: 74 68 22 20 20 20 20 20 20 23 66 29 0a 09 20 27 th" #f).. '
5be0: 28 22 73 74 61 74 65 22 20 20 20 20 20 20 20 20 ("state"
5bf0: 20 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 75 #f).. '("statu
5c00: 73 22 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 s" #f)..
5c10: 20 27 28 22 61 74 74 65 6d 70 74 6e 75 6d 22 20 '("attemptnum"
5c20: 20 20 20 20 23 66 29 0a 09 20 27 28 22 66 69 6e #f).. '("fin
5c30: 61 6c 5f 6c 6f 67 66 22 20 20 20 20 20 23 66 29 al_logf" #f)
5c40: 0a 09 20 27 28 22 6c 6f 67 64 61 74 22 20 20 20 .. '("logdat"
5c50: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 72 #f).. '("r
5c60: 75 6e 5f 64 75 72 61 74 69 6f 6e 22 20 20 20 23 un_duration" #
5c70: 66 29 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 22 f).. '("comment"
5c80: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
5c90: 22 65 76 65 6e 74 5f 74 69 6d 65 22 20 20 20 20 "event_time"
5ca0: 20 23 66 29 0a 09 20 27 28 22 66 61 69 6c 5f 63 #f).. '("fail_c
5cb0: 6f 75 6e 74 22 20 20 20 20 20 23 66 29 0a 09 20 ount" #f)..
5cc0: 27 28 22 70 61 73 73 5f 63 6f 75 6e 74 22 20 20 '("pass_count"
5cd0: 20 20 20 23 66 29 0a 09 20 27 28 22 61 72 63 68 #f).. '("arch
5ce0: 69 76 65 64 22 20 20 20 20 20 20 20 23 66 29 0a ived" #f).
5cf0: 20 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 '("last
5d00: 5f 75 70 64 61 74 65 22 20 20 20 20 23 66 29 29 _update" #f))
5d10: 0a 20 20 28 6c 69 73 74 20 22 74 65 73 74 5f 73 . (list "test_s
5d20: 74 65 70 73 22 0a 09 20 27 28 22 69 64 22 20 20 teps".. '("id"
5d30: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
5d40: 20 27 28 22 74 65 73 74 5f 69 64 22 20 20 20 20 '("test_id"
5d50: 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 74 65 #f).. '("ste
5d60: 70 6e 61 6d 65 22 20 20 20 20 20 20 20 23 66 29 pname" #f)
5d70: 0a 09 20 27 28 22 73 74 61 74 65 22 20 20 20 20 .. '("state"
5d80: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 #f).. '("s
5d90: 74 61 74 75 73 22 20 20 20 20 20 20 20 20 20 23 tatus" #
5da0: 66 29 0a 09 20 27 28 22 65 76 65 6e 74 5f 74 69 f).. '("event_ti
5db0: 6d 65 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 me" #f).. '(
5dc0: 22 63 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 "comment"
5dd0: 20 23 66 29 0a 09 20 27 28 22 6c 6f 67 66 69 6c #f).. '("logfil
5de0: 65 22 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 e" #f).
5df0: 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 75 '("last_u
5e00: 70 64 61 74 65 22 20 20 20 20 23 66 29 29 0a 20 pdate" #f)).
5e10: 20 20 28 6c 69 73 74 20 22 74 65 73 74 5f 64 61 (list "test_da
5e20: 74 61 22 0a 09 20 27 28 22 69 64 22 20 20 20 20 ta".. '("id"
5e30: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
5e40: 28 22 74 65 73 74 5f 69 64 22 20 20 20 20 20 20 ("test_id"
5e50: 20 20 23 66 29 0a 09 20 27 28 22 63 61 74 65 67 #f).. '("categ
5e60: 6f 72 79 22 20 20 20 20 20 20 20 23 66 29 0a 09 ory" #f)..
5e70: 20 27 28 22 76 61 72 69 61 62 6c 65 22 20 20 20 '("variable"
5e80: 20 20 20 20 23 66 29 0a 09 20 27 28 22 76 61 6c #f).. '("val
5e90: 75 65 22 20 20 20 20 20 20 20 20 20 20 23 66 29 ue" #f)
5ea0: 0a 09 20 27 28 22 65 78 70 65 63 74 65 64 22 20 .. '("expected"
5eb0: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 #f).. '("t
5ec0: 6f 6c 22 20 20 20 20 20 20 20 20 20 20 20 20 23 ol" #
5ed0: 66 29 0a 09 20 27 28 22 75 6e 69 74 73 22 20 20 f).. '("units"
5ee0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
5ef0: 22 63 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 "comment"
5f00: 20 23 66 29 0a 09 20 27 28 22 73 74 61 74 75 73 #f).. '("status
5f10: 22 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 " #f)..
5f20: 27 28 22 74 79 70 65 22 20 20 20 20 20 20 20 20 '("type"
5f30: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
5f40: 27 28 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 '("last_update"
5f50: 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 6e 65 #f))))..;; ne
5f60: 65 64 73 20 64 62 20 74 6f 20 67 65 74 20 6b 65 eds db to get ke
5f70: 79 73 2c 20 74 68 69 73 20 69 73 20 66 6f 72 20 ys, this is for
5f80: 73 79 6e 63 69 6e 67 20 61 6c 6c 20 74 61 62 6c syncing all tabl
5f90: 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 es.;;.(define (d
5fa0: 62 3a 73 79 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 b:sync-main-list
5fb0: 20 64 62 73 74 72 75 63 74 20 6b 65 79 73 29 0a dbstruct keys).
5fc0: 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 20 6b (let ((keys k
5fd0: 65 79 73 29 29 20 3b 3b 20 28 64 62 3a 67 65 74 eys)) ;; (db:get
5fe0: 2d 6b 65 79 73 20 64 62 73 74 72 75 63 74 29 29 -keys dbstruct))
5ff0: 29 0a 20 20 20 20 28 6c 69 73 74 0a 20 20 20 20 ). (list.
6000: 20 28 6c 69 73 74 20 22 6b 65 79 73 22 0a 09 20 (list "keys"..
6010: 20 20 27 28 22 69 64 22 20 20 20 20 20 20 20 20 '("id"
6020: 23 66 29 0a 09 20 20 20 27 28 22 66 69 65 6c 64 #f).. '("field
6030: 6e 61 6d 65 22 20 23 66 29 0a 09 20 20 20 27 28 name" #f).. '(
6040: 22 66 69 65 6c 64 74 79 70 65 22 20 23 66 29 29 "fieldtype" #f))
6050: 0a 20 20 20 20 20 28 6c 69 73 74 20 22 6d 65 74 . (list "met
6060: 61 64 61 74 22 20 27 28 22 76 61 72 22 20 23 66 adat" '("var" #f
6070: 29 20 27 28 22 76 61 6c 22 20 23 66 29 29 0a 20 ) '("val" #f)).
6080: 20 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 (append (lis
6090: 74 20 22 72 75 6e 73 22 20 0a 09 09 20 20 20 27 t "runs" ... '
60a0: 28 22 69 64 22 20 20 23 66 29 29 0a 09 20 20 20 ("id" #f))..
60b0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
60c0: 6b 29 28 6c 69 73 74 20 6b 20 23 66 29 29 0a 09 k)(list k #f))..
60d0: 09 20 20 28 61 70 70 65 6e 64 20 6b 65 79 73 0a . (append keys.
60e0: 09 09 09 20 20 28 6c 69 73 74 20 22 72 75 6e 6e ... (list "runn
60f0: 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 ame" "state" "st
6100: 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 atus" "owner" "e
6110: 76 65 6e 74 5f 74 69 6d 65 22 20 22 63 6f 6d 6d vent_time" "comm
6120: 65 6e 74 22 20 22 66 61 69 6c 5f 63 6f 75 6e 74 ent" "fail_count
6130: 22 20 22 70 61 73 73 5f 63 6f 75 6e 74 22 20 22 " "pass_count" "
6140: 63 6f 6e 74 6f 75 72 22 20 22 6c 61 73 74 5f 75 contour" "last_u
6150: 70 64 61 74 65 22 29 29 29 29 0a 20 20 20 20 20 pdate")))).
6160: 28 6c 69 73 74 20 22 61 72 63 68 69 76 65 5f 64 (list "archive_d
6170: 69 73 6b 73 22 0a 20 20 20 20 20 20 20 20 20 20 isks".
6180: 20 27 28 22 69 64 22 20 23 66 29 0a 20 20 20 20 '("id" #f).
6190: 20 20 20 20 20 20 20 27 28 22 61 72 63 68 69 76 '("archiv
61a0: 65 5f 61 72 65 61 5f 6e 61 6d 65 22 20 23 66 29 e_area_name" #f)
61b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 . '("
61c0: 64 69 73 6b 5f 70 61 74 68 22 20 23 66 29 0a 20 disk_path" #f).
61d0: 20 20 20 20 20 20 20 20 20 20 27 28 22 6c 61 73 '("las
61e0: 74 5f 64 66 22 20 23 66 29 0a 20 20 20 20 20 20 t_df" #f).
61f0: 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 66 5f '("last_df_
6200: 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 20 20 time" #f).
6210: 20 20 20 20 20 27 28 22 63 72 65 61 74 69 6f 6e '("creation
6220: 5f 74 69 6d 65 22 20 23 66 29 29 20 0a 0a 20 20 _time" #f)) ..
6230: 20 20 20 28 6c 69 73 74 20 22 61 72 63 68 69 76 (list "archiv
6240: 65 5f 62 6c 6f 63 6b 73 22 0a 20 20 20 20 20 20 e_blocks".
6250: 20 20 20 20 20 27 28 22 69 64 22 20 23 66 29 0a '("id" #f).
6260: 20 20 20 20 20 20 20 20 20 20 20 27 28 22 61 72 '("ar
6270: 63 68 69 76 65 5f 64 69 73 6b 5f 69 64 22 20 23 chive_disk_id" #
6280: 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 27 f) . '
6290: 28 22 64 69 73 6b 5f 70 61 74 68 22 20 23 66 29 ("disk_path" #f)
62a0: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 6c . '("l
62b0: 61 73 74 5f 64 75 22 20 23 66 29 0a 20 20 20 20 ast_du" #f).
62c0: 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 '("last_d
62d0: 75 5f 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 u_time" #f).
62e0: 20 20 20 20 20 20 20 27 28 22 63 72 65 61 74 69 '("creati
62f0: 6f 6e 5f 74 69 6d 65 22 20 23 66 29 29 20 0a 0a on_time" #f)) ..
6300: 20 20 20 20 20 28 6c 69 73 74 20 22 74 65 73 74 (list "test
6310: 5f 6d 65 74 61 22 0a 09 20 20 20 27 28 22 69 64 _meta".. '("id
6320: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 " #f
6330: 29 0a 09 20 20 20 27 28 22 74 65 73 74 6e 61 6d ).. '("testnam
6340: 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 e" #f)..
6350: 20 27 28 22 6f 77 6e 65 72 22 20 20 20 20 20 20 '("owner"
6360: 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 64 #f).. '("d
6370: 65 73 63 72 69 70 74 69 6f 6e 22 20 20 20 20 23 escription" #
6380: 66 29 0a 09 20 20 20 27 28 22 72 65 76 69 65 77 f).. '("review
6390: 65 64 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 ed" #f)..
63a0: 20 20 27 28 22 69 74 65 72 61 74 65 64 22 20 20 '("iterated"
63b0: 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 #f).. '("
63c0: 61 76 67 5f 72 75 6e 74 69 6d 65 22 20 20 20 20 avg_runtime"
63d0: 23 66 29 0a 09 20 20 20 27 28 22 61 76 67 5f 64 #f).. '("avg_d
63e0: 69 73 6b 22 20 20 20 20 20 20 20 23 66 29 0a 09 isk" #f)..
63f0: 20 20 20 27 28 22 74 61 67 73 22 20 20 20 20 20 '("tags"
6400: 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 #f).. '(
6410: 22 6a 6f 62 67 72 6f 75 70 22 20 20 20 20 20 20 "jobgroup"
6420: 20 23 66 29 29 0a 0a 0a 20 20 20 20 20 28 6c 69 #f))... (li
6430: 73 74 20 22 74 61 73 6b 73 5f 71 75 65 75 65 22 st "tasks_queue"
6440: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 69 . '("i
6450: 64 22 20 20 20 20 20 20 20 20 20 20 20 20 23 66 d" #f
6460: 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ). '("
6470: 61 63 74 69 6f 6e 22 20 20 20 20 20 20 20 20 23 action" #
6480: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
6490: 22 6f 77 6e 65 72 22 20 20 20 20 20 20 20 20 20 "owner"
64a0: 23 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 #f) .
64b0: 27 28 22 73 74 61 74 65 22 20 20 20 20 20 20 20 '("state"
64c0: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
64d0: 20 27 28 22 74 61 72 67 65 74 22 20 20 20 20 20 '("target"
64e0: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
64f0: 20 20 27 28 22 6e 61 6d 65 22 20 20 20 20 20 20 '("name"
6500: 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 #f).
6510: 20 20 20 27 28 22 74 65 73 74 70 61 74 74 22 20 '("testpatt"
6520: 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 #f).
6530: 20 20 20 20 27 28 22 6b 65 79 6c 6f 63 6b 22 20 '("keylock"
6540: 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 #f).
6550: 20 20 20 20 20 27 28 22 70 61 72 61 6d 73 22 20 '("params"
6560: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
6570: 20 20 20 20 20 20 27 28 22 63 72 65 61 74 69 6f '("creatio
6580: 6e 5f 74 69 6d 65 22 20 23 66 29 0a 20 20 20 20 n_time" #f).
6590: 20 20 20 20 20 20 20 27 28 22 65 78 65 63 75 74 '("execut
65a0: 69 6f 6e 5f 74 69 6d 65 22 20 23 66 29 29 0a 20 ion_time" #f)).
65b0: 20 20 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))..(define
65c0: 20 28 64 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 (db:sync-all-ta
65d0: 62 6c 65 73 2d 6c 69 73 74 20 64 62 73 74 72 75 bles-list dbstru
65e0: 63 74 20 6b 65 79 73 29 0a 20 20 28 61 70 70 65 ct keys). (appe
65f0: 6e 64 20 28 64 62 3a 73 79 6e 63 2d 6d 61 69 6e nd (db:sync-main
6600: 2d 6c 69 73 74 20 64 62 73 74 72 75 63 74 20 6b -list dbstruct k
6610: 65 79 73 29 0a 09 20 20 64 62 3a 73 79 6e 63 2d eys).. db:sync-
6620: 74 65 73 74 73 2d 6f 6e 6c 79 29 29 0a 0a 3b 3b tests-only))..;;
6630: 20 74 62 6c 73 20 69 73 20 28 20 28 22 74 61 62 tbls is ( ("tab
6640: 6c 65 6e 61 6d 65 22 20 28 20 22 66 69 65 6c 64 lename" ( "field
6650: 31 22 20 5b 23 66 7c 70 72 6f 63 31 5d 20 29 20 1" [#f|proc1] )
6660: 28 20 22 66 69 65 6c 64 32 22 20 5b 23 66 7c 70 ( "field2" [#f|p
6670: 72 6f 63 32 5d 20 29 20 2e 2e 2e 2e 20 29 20 29 roc2] ) .... ) )
6680: 0a 3b 3b 20 64 62 27 73 20 61 72 65 20 64 62 64 .;; db's are dbd
6690: 61 74 27 73 0a 3b 3b 0a 3b 3b 20 69 66 20 6c 61 at's.;;.;; if la
66a0: 73 74 2d 75 70 64 61 74 65 20 73 70 65 63 69 66 st-update specif
66b0: 69 65 64 20 28 22 66 69 65 6c 64 2d 6e 61 6d 65 ied ("field-name
66c0: 22 20 2e 20 74 69 6d 65 2d 69 6e 2d 73 65 63 6f " . time-in-seco
66d0: 6e 64 73 29 0a 3b 3b 20 20 20 20 74 68 65 6e 20 nds).;; then
66e0: 73 79 6e 63 20 6f 6e 6c 79 20 72 65 63 6f 72 64 sync only record
66f0: 73 20 77 68 65 72 65 20 66 69 65 6c 64 2d 6e 61 s where field-na
6700: 6d 65 20 3e 3d 20 74 69 6d 65 2d 69 6e 2d 73 65 me >= time-in-se
6710: 63 6f 6e 64 73 0a 3b 3b 20 20 20 20 49 46 46 20 conds.;; IFF
6720: 66 69 65 6c 64 2d 6e 61 6d 65 20 65 78 69 73 74 field-name exist
6730: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 s.;;.(define (db
6740: 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 74 62 6c :sync-tables tbl
6750: 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 66 72 s last-update fr
6760: 6f 6d 64 62 20 74 6f 64 62 20 2e 20 73 6c 61 76 omdb todb . slav
6770: 65 2d 64 62 73 29 0a 20 20 28 68 61 6e 64 6c 65 e-dbs). (handle
6780: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
6790: 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 xn. (begin.
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 45 58 43 45 50 54 49 4f 4e 3a err "EXCEPTION:
67c0: 20 64 61 74 61 62 61 73 65 20 70 72 6f 62 61 62 database probab
67d0: 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 6f 72 ly overloaded or
67e0: 20 75 6e 72 65 61 64 61 62 6c 65 20 69 6e 20 64 unreadable in d
67f0: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 2e 22 29 b:sync-tables.")
6800: 0a 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c . (print-cal
6810: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
6820: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
6830: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
6840: 2d 65 72 72 20 20 22 20 6d 65 73 73 61 67 65 3a -err " message:
6850: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
6860: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
6870: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
6880: 65 78 6e 29 29 0a 20 20 20 20 20 28 64 62 66 69 exn)). (dbfi
6890: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 65 le:print-err "e
68a0: 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
68b0: 3e 6c 69 73 74 20 65 78 6e 29 29 0a 20 20 20 20 >list exn)).
68c0: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
68d0: 72 72 20 20 22 20 73 74 61 74 75 73 3a 20 20 22 rr " status: "
68e0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
68f0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
6900: 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 29 sqlite3 'status)
6910: 20 65 78 6e 29 29 0a 20 20 20 20 20 28 64 62 66 exn)). (dbf
6920: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 ile:print-err "
6930: 20 73 72 63 20 64 62 3a 20 20 22 20 28 64 62 72 src db: " (dbr
6940: 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 66 72 :dbdat-dbfile fr
6950: 6f 6d 64 62 29 29 0a 20 20 20 20 20 28 66 6f 72 omdb)). (for
6960: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 64 -each (lambda (d
6970: 62 64 61 74 29 0a 09 09 20 28 6c 65 74 20 28 28 bdat)... (let ((
6980: 64 62 70 61 74 68 20 28 64 62 72 3a 64 62 64 61 dbpath (dbr:dbda
6990: 74 2d 64 62 66 69 6c 65 20 64 62 64 61 74 29 29 t-dbfile dbdat))
69a0: 29 0a 09 09 20 20 20 28 64 62 66 69 6c 65 3a 70 )... (dbfile:p
69b0: 72 69 6e 74 2d 65 72 72 20 20 22 20 64 62 70 61 rint-err " dbpa
69c0: 74 68 3a 20 20 22 20 64 62 70 61 74 68 29 0a 09 th: " dbpath)..
69d0: 09 20 20 20 28 69 66 20 23 74 20 3b 3b 20 28 6e . (if #t ;; (n
69e0: 6f 74 20 28 64 62 3a 72 65 70 61 69 72 2d 64 62 ot (db:repair-db
69f0: 20 64 62 64 61 74 29 29 0a 09 09 20 20 20 20 20 dbdat))...
6a00: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 64 62 (begin.... (db
6a10: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
6a20: 46 61 69 6c 65 64 20 74 6f 20 72 65 62 75 69 6c Failed to rebuil
6a30: 64 20 28 72 65 70 61 69 72 20 69 73 20 74 75 72 d (repair is tur
6a40: 6e 65 64 20 6f 66 66 29 20 22 20 64 62 70 61 74 ned off) " dbpat
6a50: 68 20 22 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 h ", exiting now
6a60: 2e 22 29 0a 09 09 09 20 28 65 78 69 74 29 29 29 .").... (exit)))
6a70: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 73 )).. (cons
6a80: 20 74 6f 64 62 20 73 6c 61 76 65 2d 64 62 73 29 todb slave-dbs)
6a90: 29 0a 20 20 20 20 20 0a 20 20 20 20 20 30 29 0a ). . 0).
6aa0: 0a 20 20 20 3b 3b 20 74 68 69 73 20 69 73 20 74 . ;; this is t
6ab0: 68 65 20 77 6f 72 6b 20 74 6f 20 62 65 20 64 6f he work to be do
6ac0: 6e 65 22 29 0a 20 20 20 28 63 6f 6e 64 0a 20 20 ne"). (cond.
6ad0: 20 20 28 28 6e 6f 74 20 66 72 6f 6d 64 62 29 20 ((not fromdb)
6ae0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
6af0: 72 20 20 22 57 41 52 4e 49 4e 47 3a 20 64 62 3a r "WARNING: db:
6b00: 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 6c 6c sync-tables call
6b10: 65 64 20 77 69 74 68 20 66 72 6f 6d 64 62 20 6d ed with fromdb m
6b20: 69 73 73 69 6e 67 22 29 0a 20 20 20 20 20 2d 31 issing"). -1
6b30: 29 0a 20 20 20 20 28 28 6e 6f 74 20 74 6f 64 62 ). ((not todb
6b40: 29 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e ) (dbfile:prin
6b50: 74 2d 65 72 72 20 20 22 57 41 52 4e 49 4e 47 3a t-err "WARNING:
6b60: 20 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 db:sync-tables
6b70: 63 61 6c 6c 65 64 20 77 69 74 68 20 74 6f 64 62 called with todb
6b80: 20 6d 69 73 73 69 6e 67 22 29 0a 20 20 20 20 20 missing").
6b90: 2d 32 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 -2). ((not (s
6ba0: 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f qlite3:database?
6bb0: 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 (dbr:dbdat-dbh
6bc0: 66 72 6f 6d 64 62 29 29 29 0a 20 20 20 20 20 28 fromdb))). (
6bd0: 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 dbfile:print-err
6be0: 20 22 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 "db:sync-tables
6bf0: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 66 72 6f called with fro
6c00: 6d 64 62 20 6e 6f 74 20 61 20 64 61 74 61 62 61 mdb not a databa
6c10: 73 65 20 22 20 66 72 6f 6d 64 62 29 0a 20 20 20 se " fromdb).
6c20: 2d 33 29 0a 20 20 20 20 28 28 6e 6f 74 20 28 73 -3). ((not (s
6c30: 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f qlite3:database?
6c40: 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 (dbr:dbdat-dbh
6c50: 74 6f 64 62 29 29 29 0a 20 20 20 20 20 28 64 62 todb))). (db
6c60: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
6c70: 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 db:sync-tables c
6c80: 61 6c 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 alled with todb
6c90: 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 20 22 not a database "
6ca0: 20 74 6f 64 62 29 0a 20 20 20 2d 34 29 0a 0a 20 todb). -4)..
6cb0: 20 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 ((not (file-w
6cc0: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 64 62 rite-access? (db
6cd0: 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 74 r:dbdat-dbfile t
6ce0: 6f 64 62 29 29 29 0a 20 20 20 20 20 28 64 62 66 odb))). (dbf
6cf0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 64 ile:print-err "d
6d00: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 61 b:sync-tables ca
6d10: 6c 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 6e lled with todb n
6d20: 6f 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 ot a read-only d
6d30: 61 74 61 62 61 73 65 20 22 20 74 6f 64 62 29 0a atabase " todb).
6d40: 20 20 20 20 20 2d 35 29 0a 20 20 20 20 28 28 6e -5). ((n
6d50: 6f 74 20 28 6e 75 6c 6c 3f 20 28 6c 65 74 20 28 ot (null? (let (
6d60: 28 72 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 2d (readonly-slave-
6d70: 64 62 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 dbs.
6d80: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
6d90: 74 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 ter.
6da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
6db0: 6d 62 64 61 20 28 64 62 64 61 74 29 0a 20 20 20 mbda (dbdat).
6dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6dd0: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 (not (fi
6de0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
6df0: 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 66 69 (dbr:dbdat-dbfi
6e00: 6c 65 20 74 6f 64 62 29 29 29 29 0a 20 20 20 20 le todb)))).
6e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e20: 20 20 20 20 20 73 6c 61 76 65 2d 64 62 73 29 29 slave-dbs))
6e30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6e40: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 (for-each.
6e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e60: 20 20 20 28 6c 61 6d 62 64 61 20 28 62 61 64 2d (lambda (bad-
6e70: 64 62 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 dbdat).
6e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
6e90: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
6ea0: 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 63 db:sync-tables c
6eb0: 61 6c 6c 65 64 20 77 69 74 68 20 74 6f 64 62 20 alled with todb
6ec0: 6e 6f 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 not a read-only
6ed0: 64 61 74 61 62 61 73 65 20 22 20 62 61 64 2d 64 database " bad-d
6ee0: 62 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 bdat)).
6ef0: 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 6f reado
6f00: 6e 6c 79 2d 73 6c 61 76 65 2d 64 62 73 29 0a 20 nly-slave-dbs).
6f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f20: 20 20 72 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 readonly-slave
6f30: 2d 64 62 73 29 29 29 20 2d 36 29 0a 20 20 20 20 -dbs))) -6).
6f40: 28 65 6c 73 65 0a 20 20 20 20 20 3b 3b 20 28 64 (else. ;; (d
6f50: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
6f60: 22 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 3a "db:sync-tables:
6f70: 20 61 72 67 73 20 61 72 65 20 67 6f 6f 64 22 29 args are good")
6f80: 0a 0a 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 .. (let ((st
6f90: 6d 74 73 20 20 20 20 20 20 20 28 6d 61 6b 65 2d mts (make-
6fa0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
6fb0: 74 61 62 6c 65 2d 66 69 65 6c 64 20 3d 3e 20 73 table-field => s
6fc0: 74 6d 74 0a 09 20 20 20 28 61 6c 6c 2d 73 74 6d tmt.. (all-stm
6fd0: 74 73 20 20 20 27 28 29 29 20 20 20 20 20 20 20 ts '())
6fe0: 20 20 20 20 20 20 20 3b 3b 20 28 20 28 20 73 74 ;; ( ( st
6ff0: 6d 74 31 20 76 61 6c 75 65 31 20 29 20 28 20 73 mt1 value1 ) ( s
7000: 74 6d 6c 32 20 76 61 6c 75 65 32 20 29 29 0a 09 tml2 value2 ))..
7010: 20 20 20 28 6e 75 6d 72 65 63 73 20 20 20 20 20 (numrecs
7020: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
7030: 29 29 0a 09 20 20 20 28 73 74 61 72 74 2d 74 69 )).. (start-ti
7040: 6d 65 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c me (current-mil
7050: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 liseconds))..
7060: 28 74 6f 74 2d 63 6f 75 6e 74 20 20 20 30 29 29 (tot-count 0))
7070: 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 . (for-eac
7080: 68 20 3b 3b 20 74 61 62 6c 65 0a 09 28 6c 61 6d h ;; table..(lam
7090: 62 64 61 20 28 74 61 62 6c 65 64 61 74 29 0a 09 bda (tabledat)..
70a0: 20 20 28 6c 65 74 2a 20 28 28 74 61 62 6c 65 6e (let* ((tablen
70b0: 61 6d 65 20 20 20 20 20 20 20 20 28 63 61 72 20 ame (car
70c0: 74 61 62 6c 65 64 61 74 29 29 0a 09 09 20 28 66 tabledat))... (f
70d0: 69 65 6c 64 73 20 20 20 20 20 20 20 20 20 20 20 ields
70e0: 28 63 64 72 20 74 61 62 6c 65 64 61 74 29 29 0a (cdr tabledat)).
70f0: 09 09 20 28 68 61 73 2d 6c 61 73 74 2d 75 70 64 .. (has-last-upd
7100: 61 74 65 20 20 28 6d 65 6d 62 65 72 20 22 6c 61 ate (member "la
7110: 73 74 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 st_update" field
7120: 73 29 29 0a 09 09 20 28 75 73 65 2d 6c 61 73 74 s))... (use-last
7130: 2d 75 70 64 61 74 65 20 20 28 63 6f 6e 64 0a 09 -update (cond..
7140: 09 09 09 20 20 20 20 28 28 61 6e 64 20 68 61 73 ... ((and has
7150: 2d 6c 61 73 74 2d 75 70 64 61 74 65 0a 09 09 09 -last-update....
7160: 09 09 20 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 .. (member "las
7170: 74 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 73 t_update" fields
7180: 29 29 0a 09 09 09 09 20 20 20 20 20 23 74 29 20 ))..... #t)
7190: 3b 3b 20 69 66 20 67 69 76 65 6e 20 61 20 6e 75 ;; if given a nu
71a0: 6d 62 65 72 2c 20 6a 75 73 74 20 75 73 65 20 69 mber, just use i
71b0: 74 20 66 6f 72 20 61 6c 6c 20 66 69 65 6c 64 73 t for all fields
71c0: 0a 09 09 09 09 20 20 20 20 28 28 6e 75 6d 62 65 ..... ((numbe
71d0: 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 20 r? last-update)
71e0: 23 66 29 20 3b 3b 20 69 66 20 6e 6f 74 20 6d 61 #f) ;; if not ma
71f0: 74 63 68 65 64 20 66 69 72 73 74 20 65 6e 74 72 tched first entr
7200: 79 20 74 68 65 6e 20 69 67 6e 6f 72 65 20 6c 61 y then ignore la
7210: 73 74 2d 75 70 64 61 74 65 20 66 6f 72 20 74 68 st-update for th
7220: 69 73 20 74 61 62 6c 65 0a 09 09 09 09 20 20 20 is table.....
7230: 20 28 28 61 6e 64 20 28 70 61 69 72 3f 20 6c 61 ((and (pair? la
7240: 73 74 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 st-update)......
7250: 20 20 28 6d 65 6d 62 65 72 20 28 63 61 72 20 6c (member (car l
7260: 61 73 74 2d 75 70 64 61 74 65 29 20 20 20 20 3b ast-update) ;
7270: 3b 20 6c 61 73 74 2d 75 70 64 61 74 65 20 66 69 ; last-update fi
7280: 65 6c 64 20 6e 61 6d 65 0a 09 09 09 09 09 09 20 eld name.......
7290: 20 28 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 (map car fields
72a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
72b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72c0: 20 20 20 20 20 20 20 20 20 20 20 20 23 74 29 0a #t).
72d0: 09 09 09 09 20 20 20 20 28 28 61 6e 64 20 6c 61 .... ((and la
72e0: 73 74 2d 75 70 64 61 74 65 20 28 6e 6f 74 20 28 st-update (not (
72f0: 70 61 69 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 pair? last-updat
7300: 65 29 29 20 28 6e 6f 74 20 28 6e 75 6d 62 65 72 e)) (not (number
7310: 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 ? last-update)))
7320: 0a 09 09 09 09 20 20 20 20 20 28 64 62 66 69 6c ..... (dbfil
7330: 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 45 52 e:print-err "ER
7340: 52 4f 52 3a 20 70 61 72 61 6d 65 74 65 72 20 6c ROR: parameter l
7350: 61 73 74 2d 75 70 64 61 74 65 20 66 6f 72 20 64 ast-update for d
7360: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 6d 75 b:sync-tables mu
7370: 73 74 20 62 65 20 61 20 70 61 69 72 20 6f 72 20 st be a pair or
7380: 61 20 6e 75 6d 62 65 72 2c 20 72 65 63 65 69 76 a number, receiv
7390: 65 64 3a 20 22 20 6c 61 73 74 2d 75 70 64 61 74 ed: " last-updat
73a0: 65 29 3b 3b 20 66 6f 75 6e 64 20 69 6e 20 66 69 e);; found in fi
73b0: 65 6c 64 73 0a 09 09 09 09 20 20 20 20 20 23 66 elds..... #f
73c0: 29 0a 09 09 09 09 20 20 20 20 28 65 6c 73 65 0a )..... (else.
73d0: 09 09 09 09 20 20 20 20 20 23 66 29 29 29 0a 09 .... #f)))..
73e0: 09 20 28 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 . (last-update-v
73f0: 61 6c 75 65 20 28 69 66 20 75 73 65 2d 6c 61 73 alue (if use-las
7400: 74 2d 75 70 64 61 74 65 20 3b 3b 20 6e 6f 20 6e t-update ;; no n
7410: 65 65 64 20 74 6f 20 63 68 65 63 6b 20 66 6f 72 eed to check for
7420: 20 68 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 has-last-update
7430: 20 2d 20 69 74 20 69 73 20 61 6c 72 65 61 64 79 - it is already
7440: 20 61 63 63 6f 75 6e 74 65 64 20 66 6f 72 0a 09 accounted for..
7450: 09 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f ....(if (number?
7460: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 09 09 last-update)...
7470: 09 09 09 20 20 20 20 6c 61 73 74 2d 75 70 64 61 ... last-upda
7480: 74 65 0a 09 09 09 09 09 20 20 20 20 28 63 64 72 te...... (cdr
7490: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 09 last-update))..
74a0: 09 09 09 09 23 66 29 29 0a 09 09 20 28 6c 61 73 ....#f))... (las
74b0: 74 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 28 t-update-field (
74c0: 69 66 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 if use-last-upda
74d0: 74 65 0a 09 09 09 09 09 28 69 66 20 28 6e 75 6d te......(if (num
74e0: 62 65 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 ber? last-update
74f0: 29 0a 09 09 09 09 09 20 20 20 20 22 6c 61 73 74 )...... "last
7500: 5f 75 70 64 61 74 65 22 0a 09 09 09 09 09 20 20 _update"......
7510: 20 20 28 63 61 72 20 6c 61 73 74 2d 75 70 64 61 (car last-upda
7520: 74 65 29 29 0a 09 09 09 09 09 23 66 29 29 0a 09 te))......#f))..
7530: 09 20 28 6e 75 6d 2d 66 69 65 6c 64 73 20 28 6c . (num-fields (l
7540: 65 6e 67 74 68 20 66 69 65 6c 64 73 29 29 0a 09 ength fields))..
7550: 09 20 28 66 69 65 6c 64 2d 3e 6e 75 6d 20 28 6d . (field->num (m
7560: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
7570: 0a 09 09 20 28 6e 75 6d 2d 3e 66 69 65 6c 64 20 ... (num->field
7580: 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 28 6d (apply vector (m
7590: 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 29 ap car fields)))
75a0: 20 3b 3b 20 42 42 48 45 52 45 0a 09 09 20 28 66 ;; BBHERE... (f
75b0: 75 6c 6c 2d 73 65 6c 20 20 20 28 63 6f 6e 63 20 ull-sel (conc
75c0: 22 53 45 4c 45 43 54 20 22 20 28 73 74 72 69 6e "SELECT " (strin
75d0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
75e0: 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 20 22 ap car fields) "
75f0: 2c 22 29 20 0a 09 09 09 09 20 20 20 22 20 46 52 ,") ..... " FR
7600: 4f 4d 20 22 20 74 61 62 6c 65 6e 61 6d 65 20 28 OM " tablename (
7610: 69 66 20 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 if use-last-upda
7620: 74 65 20 3b 3b 20 61 70 70 6c 79 20 6c 61 73 74 te ;; apply last
7630: 2d 75 70 64 61 74 65 20 63 72 69 74 65 72 69 61 -update criteria
7640: 0a 09 09 09 09 09 09 09 20 20 28 63 6f 6e 63 20 ........ (conc
7650: 22 20 57 48 45 52 45 20 22 20 6c 61 73 74 2d 75 " WHERE " last-u
7660: 70 64 61 74 65 2d 66 69 65 6c 64 20 22 20 3e 3d pdate-field " >=
7670: 20 22 20 6c 61 73 74 2d 75 70 64 61 74 65 2d 76 " last-update-v
7680: 61 6c 75 65 29 0a 09 09 09 09 09 09 09 20 20 22 alue)........ "
7690: 22 29 0a 09 09 09 09 20 20 20 22 3b 22 29 29 0a ")..... ";")).
76a0: 09 09 20 28 66 75 6c 6c 2d 69 6e 73 20 20 20 28 .. (full-ins (
76b0: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
76c0: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 22 20 74 REPLACE INTO " t
76d0: 61 62 6c 65 6e 61 6d 65 20 22 20 28 20 22 20 28 ablename " ( " (
76e0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
76f0: 73 65 20 28 6d 61 70 20 63 61 72 20 66 69 65 6c se (map car fiel
7700: 64 73 29 20 22 2c 22 29 20 22 20 29 20 22 0a 09 ds) ",") " ) "..
7710: 09 09 09 20 20 20 22 20 56 41 4c 55 45 53 20 28 ... " VALUES (
7720: 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 " (string-inter
7730: 73 70 65 72 73 65 20 28 6d 61 6b 65 2d 6c 69 73 sperse (make-lis
7740: 74 20 6e 75 6d 2d 66 69 65 6c 64 73 20 22 3f 22 t num-fields "?"
7750: 29 20 22 2c 22 29 20 22 20 29 3b 22 29 29 0a 09 ) ",") " );"))..
7760: 09 20 28 66 72 6f 6d 64 61 74 20 20 20 20 27 28 . (fromdat '(
7770: 29 29 0a 09 09 20 28 66 72 6f 6d 64 61 74 73 20 ))... (fromdats
7780: 20 20 27 28 29 29 0a 09 09 20 28 74 6f 74 72 65 '())... (totre
7790: 63 6f 72 64 73 20 30 29 0a 09 09 20 28 62 61 74 cords 0)... (bat
77a0: 63 68 2d 6c 65 6e 20 20 31 30 30 29 20 3b 3b 20 ch-len 100) ;;
77b0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
77c0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
77d0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
77e0: 22 73 79 6e 63 22 20 22 62 61 74 63 68 73 69 7a "sync" "batchsiz
77f0: 65 22 29 20 22 31 30 30 22 29 29 29 0a 09 09 20 e") "100")))...
7800: 28 74 6f 64 61 74 20 20 20 20 20 20 28 6d 61 6b (todat (mak
7810: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
7820: 09 20 28 63 6f 75 6e 74 20 20 20 20 20 20 30 29 . (count 0)
7830: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7840: 20 20 28 66 69 65 6c 64 2d 6e 61 6d 65 73 20 28 (field-names (
7850: 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 map car fields))
7860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7870: 20 20 28 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 (delay-handica
7880: 70 20 20 30 29 20 3b 3b 20 28 73 74 72 69 6e 67 p 0) ;; (string
7890: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f ->number (or (co
78a0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
78b0: 6e 66 69 67 64 61 74 2a 20 22 73 79 6e 63 22 20 nfigdat* "sync"
78c0: 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 "delay-handicap"
78d0: 29 20 22 30 22 29 29 29 0a 20 20 20 20 20 20 20 ) "0"))).
78e0: 20 20 20 20 20 20 20 20 20 20 29 0a 0a 09 20 20 )...
78f0: 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 ;; set up the
7900: 66 69 65 6c 64 2d 3e 6e 75 6d 20 74 61 62 6c 65 field->num table
7910: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a .. (for-each.
7920: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 . (lambda (f
7930: 69 65 6c 64 29 0a 09 20 20 20 20 20 20 20 28 68 ield).. (h
7940: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 ash-table-set! f
7950: 69 65 6c 64 2d 3e 6e 75 6d 20 66 69 65 6c 64 20 ield->num field
7960: 63 6f 75 6e 74 29 0a 09 20 20 20 20 20 20 20 28 count).. (
7970: 73 65 74 21 20 63 6f 75 6e 74 20 28 2b 20 63 6f set! count (+ co
7980: 75 6e 74 20 31 29 29 29 0a 09 20 20 20 20 20 66 unt 1))).. f
7990: 69 65 6c 64 73 29 0a 0a 09 20 20 20 20 3b 3b 20 ields)... ;;
79a0: 72 65 61 64 20 74 68 65 20 73 6f 75 72 63 65 20 read the source
79b0: 74 61 62 6c 65 0a 20 20 20 20 20 20 20 20 20 20 table.
79c0: 20 20 3b 3b 20 73 74 6f 72 65 20 61 20 6c 69 73 ;; store a lis
79d0: 74 20 6f 66 20 61 6c 6c 20 72 6f 77 73 20 69 6e t of all rows in
79e0: 20 74 68 65 20 74 61 62 6c 65 20 69 6e 20 66 72 the table in fr
79f0: 6f 6d 64 61 74 2c 20 75 70 20 74 6f 20 62 61 74 omdat, up to bat
7a00: 63 68 2d 6c 65 6e 2e 0a 20 20 20 20 20 20 20 20 ch-len..
7a10: 20 20 20 20 3b 3b 20 54 68 65 6e 20 61 64 64 20 ;; Then add
7a20: 66 72 6f 6d 64 61 74 20 74 6f 20 74 68 65 20 66 fromdat to the f
7a30: 72 6f 6d 64 61 74 73 20 6c 69 73 74 2c 20 63 6c romdats list, cl
7a40: 65 61 72 20 66 72 6f 6d 64 61 74 20 61 6e 64 20 ear fromdat and
7a50: 72 65 70 65 61 74 2e 0a 09 20 20 20 20 28 73 71 repeat... (sq
7a60: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
7a70: 6f 77 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 ow.. (lambda
7a80: 20 28 61 20 2e 20 62 29 0a 09 20 20 20 20 20 20 (a . b)..
7a90: 20 28 73 65 74 21 20 66 72 6f 6d 64 61 74 20 28 (set! fromdat (
7aa0: 63 6f 6e 73 20 28 61 70 70 6c 79 20 76 65 63 74 cons (apply vect
7ab0: 6f 72 20 61 20 62 29 20 66 72 6f 6d 64 61 74 29 or a b) fromdat)
7ac0: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 3e ).. (if (>
7ad0: 20 28 6c 65 6e 67 74 68 20 66 72 6f 6d 64 61 74 (length fromdat
7ae0: 29 20 62 61 74 63 68 2d 6c 65 6e 29 0a 09 09 20 ) batch-len)...
7af0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
7b00: 28 73 65 74 21 20 66 72 6f 6d 64 61 74 73 20 28 (set! fromdats (
7b10: 63 6f 6e 73 20 66 72 6f 6d 64 61 74 20 66 72 6f cons fromdat fro
7b20: 6d 64 61 74 73 29 29 0a 09 09 20 20 20 20 20 28 mdats))... (
7b30: 73 65 74 21 20 66 72 6f 6d 64 61 74 20 20 27 28 set! fromdat '(
7b40: 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 ))... (set!
7b50: 74 6f 74 72 65 63 6f 72 64 73 20 28 2b 20 74 6f totrecords (+ to
7b60: 74 72 65 63 6f 72 64 73 20 31 29 29 29 0a 20 20 trecords 1))).
7b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 ).
7b80: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 20 )..
7b90: 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d 64 (dbr:dbdat-d
7ba0: 62 68 20 66 72 6f 6d 64 62 29 0a 09 20 20 20 20 bh fromdb)..
7bb0: 20 66 75 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 full-sel)..
7bc0: 20 20 20 20 20 20 20 20 20 3b 3b 20 43 6f 75 6e ;; Coun
7bd0: 74 20 6c 65 73 73 20 74 68 61 6e 20 62 61 74 63 t less than batc
7be0: 68 2d 6c 65 6e 20 61 73 20 61 20 72 65 63 6f 72 h-len as a recor
7bf0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 d. (
7c00: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 66 72 if (> (length fr
7c10: 6f 6d 64 61 74 29 20 30 29 0a 20 20 20 20 20 20 omdat) 0).
7c20: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
7c30: 20 74 6f 74 72 65 63 6f 72 64 73 20 28 2b 20 74 totrecords (+ t
7c40: 6f 74 72 65 63 6f 72 64 73 20 31 29 29 29 0a 0a otrecords 1)))..
7c50: 09 20 20 20 20 3b 3b 20 74 61 63 6b 20 6f 6e 20 . ;; tack on
7c60: 72 65 6d 61 69 6e 69 6e 67 20 72 65 63 6f 72 64 remaining record
7c70: 73 20 69 6e 20 66 72 6f 6d 64 61 74 0a 09 20 20 s in fromdat..
7c80: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
7c90: 3f 20 66 72 6f 6d 64 61 74 29 29 0a 09 09 28 73 ? fromdat))...(s
7ca0: 65 74 21 20 66 72 6f 6d 64 61 74 73 20 28 63 6f et! fromdats (co
7cb0: 6e 73 20 66 72 6f 6d 64 61 74 20 66 72 6f 6d 64 ns fromdat fromd
7cc0: 61 74 73 29 29 29 0a 0a 09 20 20 20 20 28 73 71 ats)))... (sq
7cd0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
7ce0: 6f 77 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 ow.. (lambda
7cf0: 20 28 61 20 2e 20 62 29 0a 09 20 20 20 20 20 20 (a . b)..
7d00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
7d10: 21 20 74 6f 64 61 74 20 61 20 28 61 70 70 6c 79 ! todat a (apply
7d20: 20 76 65 63 74 6f 72 20 61 20 62 29 29 29 0a 09 vector a b)))..
7d30: 20 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 2d (dbr:dbdat-
7d40: 64 62 68 20 74 6f 64 62 29 0a 09 20 20 20 20 20 dbh todb)..
7d50: 66 75 6c 6c 2d 73 65 6c 29 0a 0a 20 20 20 20 20 full-sel)..
7d60: 20 20 20 20 20 20 20 28 77 68 65 6e 20 28 61 6e (when (an
7d70: 64 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 d delay-handicap
7d80: 20 28 3e 20 64 65 6c 61 79 2d 68 61 6e 64 69 63 (> delay-handic
7d90: 61 70 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 ap 0)).
7da0: 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 (dbfile:pri
7db0: 6e 74 2d 65 72 72 20 22 69 6d 70 6f 73 69 6e 67 nt-err "imposing
7dc0: 20 73 79 6e 74 68 65 74 69 63 20 73 79 6e 63 20 synthetic sync
7dd0: 64 65 6c 61 79 20 6f 66 20 22 64 65 6c 61 79 2d delay of "delay-
7de0: 68 61 6e 64 69 63 61 70 22 20 73 65 63 6f 6e 64 handicap" second
7df0: 73 20 73 69 6e 63 65 20 73 79 6e 63 2f 64 65 6c s since sync/del
7e00: 61 79 2d 68 61 6e 64 69 63 61 70 20 69 73 20 63 ay-handicap is c
7e10: 6f 6e 66 69 67 75 72 65 64 22 29 0a 20 20 20 20 onfigured").
7e20: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
7e30: 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 2d 68 d-sleep! delay-h
7e40: 61 6e 64 69 63 61 70 29 0a 20 20 20 20 20 20 20 andicap).
7e50: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 (dbfile:p
7e60: 72 69 6e 74 2d 65 72 72 20 22 73 79 6e 74 68 65 rint-err "synthe
7e70: 74 69 63 20 73 79 6e 63 20 64 65 6c 61 79 20 6f tic sync delay o
7e80: 66 20 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 f "delay-handica
7e90: 70 22 20 73 65 63 6f 6e 64 73 20 63 6f 6d 70 6c p" seconds compl
7ea0: 65 74 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 eted").
7eb0: 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 ).
7ec0: 20 20 20 0a 09 20 20 20 20 3b 3b 20 66 69 72 73 .. ;; firs
7ed0: 74 20 70 61 73 73 20 69 6d 70 6c 65 6d 65 6e 74 t pass implement
7ee0: 61 74 69 6f 6e 2c 20 6a 75 73 74 20 69 6e 73 65 ation, just inse
7ef0: 72 74 20 61 6c 6c 20 63 68 61 6e 67 65 64 20 72 rt all changed r
7f00: 6f 77 73 0a 0a 09 20 20 20 20 28 66 6f 72 2d 65 ows... (for-e
7f10: 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 ach .. (lamb
7f20: 64 61 20 28 74 61 72 67 64 62 29 0a 09 20 20 20 da (targdb)..
7f30: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 (let* ((db
7f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7f50: 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 74 61 dbr:dbdat-dbh ta
7f60: 72 67 64 62 29 29 0a 20 20 20 20 20 20 20 20 20 rgdb)).
7f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 72 (dr
7f80: 70 2d 74 72 69 67 67 65 72 20 20 20 20 20 20 20 p-trigger
7f90: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 22 6c 61 (if (member "la
7fa0: 73 74 5f 75 70 64 61 74 65 22 20 66 69 65 6c 64 st_update" field
7fb0: 2d 6e 61 6d 65 73 29 0a 09 09 09 09 09 20 20 20 -names)......
7fc0: 20 20 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 (db:drop-trig
7fd0: 67 65 72 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 ger db tablename
7fe0: 29 20 0a 09 09 09 09 09 20 20 20 20 20 20 23 66 ) ...... #f
7ff0: 29 29 0a 09 09 20 20 20 20 20 20 28 68 61 73 2d ))... (has-
8000: 6c 61 73 74 2d 75 70 64 61 74 65 20 20 20 20 28 last-update (
8010: 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 70 64 member "last_upd
8020: 61 74 65 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 ate" field-names
8030: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8040: 20 20 20 20 20 20 20 20 20 28 69 73 2d 74 72 69 (is-tri
8050: 67 67 65 72 2d 64 72 6f 70 70 65 64 20 28 69 66 gger-dropped (if
8060: 20 68 61 73 2d 6c 61 73 74 2d 75 70 64 61 74 65 has-last-update
8070: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8080: 20 20 20 20 20 20 20 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 28 (
80a0: 64 62 3a 69 73 2d 74 72 69 67 67 65 72 2d 64 72 db:is-trigger-dr
80b0: 6f 70 70 65 64 20 64 62 20 74 61 62 6c 65 6e 61 opped db tablena
80c0: 6d 65 29 0a 09 09 09 09 09 20 20 20 20 20 20 23 me)...... #
80d0: 66 29 29 20 0a 09 09 20 20 20 20 20 20 28 73 74 f)) ... (st
80e0: 6d 74 68 20 20 28 73 71 6c 69 74 65 33 3a 70 72 mth (sqlite3:pr
80f0: 65 70 61 72 65 20 64 62 20 66 75 6c 6c 2d 69 6e epare db full-in
8100: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
8110: 20 20 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 (chang
8120: 65 64 2d 72 6f 77 73 20 30 29 29 0a 09 09 20 28 ed-rows 0))... (
8130: 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 for-each... (la
8140: 6d 62 64 61 20 28 66 72 6f 6d 64 61 74 2d 6c 73 mbda (fromdat-ls
8150: 74 29 0a 09 09 20 20 20 20 28 73 71 6c 69 74 65 t)... (sqlite
8160: 33 3a 77 69 74 68 2d 74 72 61 6e 73 61 63 74 69 3:with-transacti
8170: 6f 6e 0a 09 09 20 20 20 20 20 64 62 0a 09 09 20 on... db...
8180: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
8190: 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 . (for-eac
81a0: 68 20 3b 3b 20 0a 09 09 09 28 6c 61 6d 62 64 61 h ;; ....(lambda
81b0: 20 28 66 72 6f 6d 72 6f 77 29 0a 09 09 09 20 20 (fromrow)....
81c0: 28 6c 65 74 2a 20 28 28 61 20 20 20 20 28 76 65 (let* ((a (ve
81d0: 63 74 6f 72 2d 72 65 66 20 66 72 6f 6d 72 6f 77 ctor-ref fromrow
81e0: 20 30 29 29 0a 09 09 09 09 20 28 63 75 72 72 20 0))..... (curr
81f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
8200: 64 65 66 61 75 6c 74 20 74 6f 64 61 74 20 61 20 default todat a
8210: 23 66 29 29 0a 09 09 09 09 20 28 73 61 6d 65 20 #f))..... (same
8220: 23 74 29 29 0a 09 09 09 20 20 20 20 28 6c 65 74 #t)).... (let
8230: 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 09 09 loop ((i 0))...
8240: 09 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 . (if (or (
8250: 6e 6f 74 20 63 75 72 72 29 0a 09 09 09 09 20 20 not curr).....
8260: 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (not (equal?
8270: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 66 72 6f (vector-ref fro
8280: 6d 72 6f 77 20 69 29 28 76 65 63 74 6f 72 2d 72 mrow i)(vector-r
8290: 65 66 20 63 75 72 72 20 69 29 29 29 29 0a 09 09 ef curr i))))...
82a0: 09 09 20 20 28 73 65 74 21 20 73 61 6d 65 20 23 .. (set! same #
82b0: 66 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 f)).... (if
82c0: 20 28 61 6e 64 20 73 61 6d 65 0a 09 09 09 09 20 (and same.....
82d0: 20 20 20 20 20 20 28 3c 20 69 20 28 2d 20 6e 75 (< i (- nu
82e0: 6d 2d 66 69 65 6c 64 73 20 31 29 29 29 0a 09 09 m-fields 1)))...
82f0: 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 .. (loop (+ i 1
8300: 29 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 )))).... (if
8310: 28 6e 6f 74 20 73 61 6d 65 29 0a 09 09 09 09 28 (not same).....(
8320: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 61 70 70 begin..... (app
8330: 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ly sqlite3:execu
8340: 74 65 20 73 74 6d 74 68 20 28 76 65 63 74 6f 72 te stmth (vector
8350: 2d 3e 6c 69 73 74 20 66 72 6f 6d 72 6f 77 29 29 ->list fromrow))
8360: 0a 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 ..... (hash-tab
8370: 6c 65 2d 73 65 74 21 20 6e 75 6d 72 65 63 73 20 le-set! numrecs
8380: 74 61 62 6c 65 6e 61 6d 65 20 28 2b 20 31 20 28 tablename (+ 1 (
8390: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
83a0: 65 66 61 75 6c 74 20 6e 75 6d 72 65 63 73 20 74 efault numrecs t
83b0: 61 62 6c 65 6e 61 6d 65 20 30 29 29 29 0a 20 20 ablename 0))).
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83e0: 28 73 65 74 21 20 63 68 61 6e 67 65 64 2d 72 6f (set! changed-ro
83f0: 77 73 20 28 2b 20 63 68 61 6e 67 65 64 2d 72 6f ws (+ changed-ro
8400: 77 73 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 ws 1)).
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
8430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8440: 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 ).
8450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8460: 20 20 20 29 29 0a 09 09 09 66 72 6f 6d 64 61 74 ))....fromdat
8470: 2d 6c 73 74 29 29 29 29 0a 09 09 20 20 66 72 6f -lst))))... fro
8480: 6d 64 61 74 73 29 0a 0a 09 09 20 28 73 71 6c 69 mdats).... (sqli
8490: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 73 74 te3:finalize! st
84a0: 6d 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 mth).
84b0: 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 (if (membe
84c0: 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 r "last_update"
84d0: 66 69 65 6c 64 2d 6e 61 6d 65 73 29 0a 20 20 20 field-names).
84e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84f0: 20 28 64 62 3a 63 72 65 61 74 65 2d 74 72 69 67 (db:create-trig
8500: 67 65 72 20 64 62 20 74 61 62 6c 65 6e 61 6d 65 ger db tablename
8510: 29 29 29 29 0a 09 20 20 20 20 20 28 61 70 70 65 )))).. (appe
8520: 6e 64 20 28 6c 69 73 74 20 74 6f 64 62 29 20 73 nd (list todb) s
8530: 6c 61 76 65 2d 64 62 73 29 0a 20 20 20 20 20 20 lave-dbs).
8540: 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 ).
8550: 20 29 0a 20 20 20 20 20 20 20 20 29 0a 09 74 62 ). )..tb
8560: 6c 73 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a ls). (let*
8570: 20 28 28 72 75 6e 74 69 6d 65 20 20 20 20 20 20 ((runtime
8580: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
8590: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
85a0: 74 69 6d 65 29 29 0a 09 20 20 20 20 20 20 28 73 time)).. (s
85b0: 68 6f 75 6c 64 2d 70 72 69 6e 74 20 28 6f 72 20 hould-print (or
85c0: 3b 3b 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d ;; (debug:debug-
85d0: 6d 6f 64 65 20 31 32 29 0a 09 09 09 20 20 20 20 mode 12)....
85e0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
85f0: 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 64 62 se-print 120 "db
8600: 20 73 79 6e 63 22 29 0a 09 09 09 20 20 20 20 20 sync")....
8610: 28 3e 20 72 75 6e 74 69 6d 65 20 35 30 30 29 29 (> runtime 500))
8620: 29 29 20 3b 3b 20 6c 6f 77 20 61 6e 64 20 68 69 )) ;; low and hi
8630: 67 68 20 73 79 6e 63 20 74 69 6d 65 73 20 74 72 gh sync times tr
8640: 65 61 74 65 64 20 61 73 20 73 65 70 61 72 61 74 eated as separat
8650: 65 2e 0a 09 20 28 66 6f 72 2d 65 61 63 68 20 0a e... (for-each .
8660: 09 20 20 28 6c 61 6d 62 64 61 20 28 64 61 74 29 . (lambda (dat)
8670: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 62 6c .. (let ((tbl
8680: 6e 61 6d 65 20 28 63 61 72 20 64 61 74 29 29 0a name (car dat)).
8690: 09 09 20 20 28 63 6f 75 6e 74 20 20 20 28 63 64 .. (count (cd
86a0: 72 20 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 r dat)))..
86b0: 28 73 65 74 21 20 74 6f 74 2d 63 6f 75 6e 74 20 (set! tot-count
86c0: 28 2b 20 74 6f 74 2d 63 6f 75 6e 74 20 63 6f 75 (+ tot-count cou
86d0: 6e 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nt)).
86e0: 20 20 20 29 29 20 0a 09 20 20 28 73 6f 72 74 20 )) .. (sort
86f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
8700: 73 74 20 6e 75 6d 72 65 63 73 29 28 6c 61 6d 62 st numrecs)(lamb
8710: 64 61 20 28 61 20 62 29 28 3e 20 28 63 64 72 20 da (a b)(> (cdr
8720: 61 29 28 63 64 72 20 62 29 29 29 29 29 29 0a 20 a)(cdr b)))))).
8730: 20 20 20 20 20 20 74 6f 74 2d 63 6f 75 6e 74 29 tot-count)
8740: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
8750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
8790: 3b 20 74 72 69 67 67 65 72 20 73 65 74 75 70 2f ; trigger setup/
87a0: 74 61 6b 65 64 6f 77 6e 0a 3b 3b 3d 3d 3d 3d 3d takedown.;;=====
87b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87f0: 3d 0a 0a 28 64 65 66 69 6e 65 20 64 62 3a 74 72 =..(define db:tr
8800: 69 67 67 65 72 2d 6c 69 73 74 20 0a 20 20 20 20 igger-list .
8810: 20 28 6c 69 73 74 20 28 6c 69 73 74 20 22 75 70 (list (list "up
8820: 64 61 74 65 5f 72 75 6e 73 5f 74 72 69 67 67 65 date_runs_trigge
8830: 72 22 20 20 22 43 52 45 41 54 45 20 54 52 49 47 r" "CREATE TRIG
8840: 47 45 52 20 49 46 20 4e 4f 54 20 45 58 49 53 54 GER IF NOT EXIST
8850: 53 20 75 70 64 61 74 65 5f 72 75 6e 73 5f 74 72 S update_runs_tr
8860: 69 67 67 65 72 20 41 46 54 45 52 20 55 50 44 41 igger AFTER UPDA
8870: 54 45 20 4f 4e 20 72 75 6e 73 0a 20 20 20 20 20 TE ON runs.
8880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8890: 20 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 FOR EACH
88a0: 20 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 ROW.
88b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88c0: 20 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 BEGIN .
88d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88e0: 20 20 20 20 20 20 20 20 20 20 20 20 55 50 44 41 UPDA
88f0: 54 45 20 72 75 6e 73 20 53 45 54 20 6c 61 73 74 TE runs SET last
8900: 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d _update=(strftim
8910: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 e('%s','now')).
8920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8940: 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 WHERE id=old.i
8950: 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d;.
8960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8970: 20 20 45 4e 44 3b 22 20 29 20 0a 09 20 20 20 28 END;" ) .. (
8980: 6c 69 73 74 20 22 75 70 64 61 74 65 5f 72 75 6e list "update_run
8990: 5f 73 74 61 74 73 5f 74 72 69 67 67 65 72 22 20 _stats_trigger"
89a0: 20 22 43 52 45 41 54 45 20 54 52 49 47 47 45 52 "CREATE TRIGGER
89b0: 20 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 IF NOT EXISTS
89c0: 75 70 64 61 74 65 5f 72 75 6e 5f 73 74 61 74 73 update_run_stats
89d0: 5f 74 72 69 67 67 65 72 20 41 46 54 45 52 20 55 _trigger AFTER U
89e0: 50 44 41 54 45 20 4f 4e 20 72 75 6e 5f 73 74 61 PDATE ON run_sta
89f0: 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ts.
8a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a10: 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 FOR EACH ROW.
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 20 20 20 20 20 42 45 47 49 BEGI
8a40: 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 N .
8a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a60: 20 20 20 20 55 50 44 41 54 45 20 72 75 6e 5f 73 UPDATE run_s
8a70: 74 61 74 73 20 53 45 54 20 6c 61 73 74 5f 75 70 tats SET last_up
8a80: 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 27 date=(strftime('
8a90: 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 %s','now')).
8aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 57 W
8ac0: 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a HERE id=old.id;.
8ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45 E
8af0: 4e 44 3b 22 20 29 0a 09 20 20 20 28 6c 69 73 74 ND;" ).. (list
8b00: 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 5f 74 "update_tests_t
8b10: 72 69 67 67 65 72 22 20 20 22 43 52 45 41 54 45 rigger" "CREATE
8b20: 20 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 TRIGGER IF NOT
8b30: 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 EXISTS update_t
8b40: 65 73 74 73 5f 74 72 69 67 67 65 72 20 41 46 54 ests_trigger AFT
8b50: 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 65 73 ER UPDATE ON tes
8b60: 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ts.
8b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b80: 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 FOR EACH ROW.
8b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 42 45 47 49 BEGI
8bb0: 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 N .
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 20 20 20 20 55 50 44 41 54 45 20 74 65 73 74 73 UPDATE tests
8be0: 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 SET last_update
8bf0: 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c =(strftime('%s',
8c00: 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 'now')).
8c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c20: 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 45 WHERE
8c30: 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 id=old.id;.
8c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c50: 20 20 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 END;"
8c60: 20 29 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 ).. (list "up
8c70: 64 61 74 65 5f 74 65 73 74 73 74 65 70 73 5f 74 date_teststeps_t
8c80: 72 69 67 67 65 72 22 20 20 22 43 52 45 41 54 45 rigger" "CREATE
8c90: 20 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 TRIGGER IF NOT
8ca0: 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 EXISTS update_t
8cb0: 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 65 72 eststeps_trigger
8cc0: 20 41 46 54 45 52 20 55 50 44 41 54 45 20 4f 4e AFTER UPDATE ON
8cd0: 20 74 65 73 74 5f 73 74 65 70 73 0a 20 20 20 20 test_steps.
8ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cf0: 20 20 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 FOR EAC
8d00: 48 20 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 H ROW.
8d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d20: 20 20 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 BEGIN .
8d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 55 50 44 UPD
8d50: 41 54 45 20 74 65 73 74 5f 73 74 65 70 73 20 53 ATE test_steps S
8d60: 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 ET last_update=(
8d70: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
8d80: 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 ow')).
8d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8da0: 20 20 20 20 20 20 20 20 20 57 48 45 52 45 20 69 WHERE i
8db0: 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 d=old.id;.
8dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dd0: 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 END;" )
8de0: 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 64 61 .. (list "upda
8df0: 74 65 5f 74 65 73 74 5f 64 61 74 61 5f 74 72 69 te_test_data_tri
8e00: 67 67 65 72 22 20 20 22 43 52 45 41 54 45 20 54 gger" "CREATE T
8e10: 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 45 RIGGER IF NOT E
8e20: 58 49 53 54 53 20 75 70 64 61 74 65 5f 74 65 73 XISTS update_tes
8e30: 74 5f 64 61 74 61 5f 74 72 69 67 67 65 72 20 41 t_data_trigger A
8e40: 46 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 74 FTER UPDATE ON t
8e50: 65 73 74 5f 64 61 74 61 0a 20 20 20 20 20 20 20 est_data.
8e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e70: 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 52 FOR EACH R
8e80: 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 OW.
8e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ea0: 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 20 BEGIN .
8eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ec0: 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 45 UPDATE
8ed0: 20 74 65 73 74 5f 64 61 74 61 20 53 45 54 20 6c test_data SET l
8ee0: 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 66 ast_update=(strf
8ef0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
8f00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f20: 20 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f 6c WHERE id=ol
8f30: 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 20 d.id;.
8f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f50: 20 20 20 20 20 45 4e 44 3b 22 20 29 29 29 0a 28 END;" ))).(
8f60: 64 65 66 69 6e 65 20 28 64 62 3a 69 73 2d 74 72 define (db:is-tr
8f70: 69 67 67 65 72 2d 64 72 6f 70 70 65 64 20 64 62 igger-dropped db
8f80: 20 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 tbl-name). (le
8f90: 74 2a 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d t* ((trigger-nam
8fa0: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 e (if (equal? tb
8fb0: 6c 2d 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 l-name "test_ste
8fc0: 70 73 22 29 0a 09 09 09 20 20 20 22 75 70 64 61 ps").... "upda
8fd0: 74 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 te_teststeps_tri
8fe0: 67 67 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 gger" .
8ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9000: 20 20 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f (conc "update_
9010: 22 20 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 " tbl-name "_tri
9020: 67 67 65 72 22 29 29 29 0a 09 20 28 72 65 73 20 gger"))).. (res
9030: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 #f)).
9040: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
9050: 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 ach-row. (la
9060: 6d 62 64 61 20 28 6e 61 6d 65 29 0a 20 20 20 20 mbda (name).
9070: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 6e (if (equal? n
9080: 61 6d 65 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 ame trigger-name
9090: 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 ).. (set! res
90a0: 23 74 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 #t))). db .
90b0: 20 20 20 20 22 53 45 4c 45 43 54 20 6e 61 6d 65 "SELECT name
90c0: 20 46 52 4f 4d 20 73 71 6c 69 74 65 5f 6d 61 73 FROM sqlite_mas
90d0: 74 65 72 20 57 48 45 52 45 20 74 79 70 65 20 3d ter WHERE type =
90e0: 20 27 74 72 69 67 67 65 72 27 20 3b 22 29 0a 20 'trigger' ;").
90f0: 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e res))..(defin
9100: 65 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 e (db:drop-trigg
9110: 65 72 73 20 64 62 29 0a 20 20 28 66 6f 72 2d 65 ers db). (for-e
9120: 61 63 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ach. (lambda (
9130: 6b 65 79 29 20 0a 20 20 20 20 20 28 73 71 6c 69 key) . (sqli
9140: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 te3:execute db (
9150: 63 6f 6e 63 20 22 64 72 6f 70 20 74 72 69 67 67 conc "drop trigg
9160: 65 72 20 69 66 20 65 78 69 73 74 73 20 22 20 28 er if exists " (
9170: 63 61 72 20 6b 65 79 29 29 29 29 0a 20 20 20 64 car key)))). d
9180: 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 74 29 29 b:trigger-list))
9190: 0a 0a 28 64 65 66 69 6e 65 20 20 28 64 62 3a 64 ..(define (db:d
91a0: 72 6f 70 2d 74 72 69 67 67 65 72 20 64 62 20 74 rop-trigger db t
91b0: 62 6c 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a bl-name). (let*
91c0: 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d 65 20 ((trigger-name
91d0: 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 6c 2d (if (equal? tbl-
91e0: 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 70 73 name "test_steps
91f0: 22 29 0a 09 09 09 20 20 20 22 75 70 64 61 74 65 ").... "update
9200: 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 67 _teststeps_trigg
9210: 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 er" .
9220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9230: 28 63 6f 6e 63 20 22 75 70 64 61 74 65 5f 22 20 (conc "update_"
9240: 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 tbl-name "_trigg
9250: 65 72 22 29 29 29 29 0a 20 20 20 20 28 66 6f 72 er")))). (for
9260: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
9270: 64 61 20 28 6b 65 79 29 20 0a 20 20 20 20 20 20 da (key) .
9280: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 61 (if (equal? (ca
9290: 72 20 6b 65 79 29 20 74 72 69 67 67 65 72 2d 6e r key) trigger-n
92a0: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
92b0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
92c0: 20 64 62 20 28 63 6f 6e 63 20 22 64 72 6f 70 20 db (conc "drop
92d0: 74 72 69 67 67 65 72 20 69 66 20 65 78 69 73 74 trigger if exist
92e0: 73 20 22 20 74 72 69 67 67 65 72 2d 6e 61 6d 65 s " trigger-name
92f0: 29 29 29 29 0a 20 20 20 20 20 64 62 3a 74 72 69 )))). db:tri
9300: 67 67 65 72 2d 6c 69 73 74 29 29 29 0a 0a 28 64 gger-list)))..(d
9310: 65 66 69 6e 65 20 20 28 64 62 3a 63 72 65 61 74 efine (db:creat
9320: 65 2d 74 72 69 67 67 65 72 20 64 62 20 74 62 6c e-trigger db tbl
9330: 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 6c 65 -name). (le
9340: 74 2a 20 28 28 74 72 69 67 67 65 72 2d 6e 61 6d t* ((trigger-nam
9350: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 74 62 e (if (equal? tb
9360: 6c 2d 6e 61 6d 65 20 22 74 65 73 74 5f 73 74 65 l-name "test_ste
9370: 70 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ps").
9380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9390: 20 20 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 "update_tests
93a0: 74 65 70 73 5f 74 72 69 67 67 65 72 22 20 0a 20 teps_trigger" .
93b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
93d0: 6e 63 20 22 75 70 64 61 74 65 5f 22 20 74 62 6c nc "update_" tbl
93e0: 2d 6e 61 6d 65 20 22 5f 74 72 69 67 67 65 72 22 -name "_trigger"
93f0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 66 6f 72 )))). (for
9400: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
9410: 65 79 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ey) .
9420: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 (if (equal? (c
9430: 61 72 20 6b 65 79 29 20 74 72 69 67 67 65 72 2d ar key) trigger-
9440: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 name).
9450: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
9460: 75 74 65 20 64 62 20 28 63 61 64 72 20 6b 65 79 ute db (cadr key
9470: 29 29 29 29 0a 20 20 20 20 20 20 64 62 3a 74 72 )))). db:tr
9480: 69 67 67 65 72 2d 6c 69 73 74 29 29 29 20 0a 0a igger-list))) ..
9490: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
94a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 64 62 20 61 ========.;; db a
94e0: 63 63 65 73 73 20 73 74 75 66 66 0a 3b 3b 3d 3d ccess stuff.;;==
94f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9530: 3d 3d 3d 3d 0a 0a 3b 3b 20 63 61 6c 6c 20 77 69 ====..;; call wi
9540: 74 68 20 64 62 69 6e 69 74 3d 64 62 3a 69 6e 69 th dbinit=db:ini
9550: 74 69 61 6c 69 7a 65 2d 6d 61 69 6e 2d 64 62 0a tialize-main-db.
9560: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6f ;;.(define (db:o
9570: 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 pen-db dbstruct
9580: 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 0a 20 run-id dbinit).
9590: 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ;; (mutex-lock!
95a0: 20 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a *db-open-mutex*
95b0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 64 61 ). (let* ((dbda
95c0: 74 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 64 t (dbfile:open-d
95d0: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
95e0: 64 20 64 62 69 6e 69 74 29 29 29 0a 20 20 20 20 d dbinit))).
95f0: 20 20 20 20 20 20 20 20 20 20 23 3b 28 63 61 73 #;(cas
9600: 65 20 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 e (rmt:transport
9610: 2d 6d 6f 64 65 29 0a 09 09 20 20 28 28 68 74 74 -mode)... ((htt
9620: 70 29 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d p) (dbfile:open-
9630: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
9640: 69 64 20 64 62 69 6e 69 74 29 29 0a 09 09 20 20 id dbinit))...
9650: 28 28 74 63 70 29 20 20 28 64 62 6d 6f 64 3a 6f ((tcp) (dbmod:o
9660: 70 65 6e 2d 64 62 20 20 64 62 73 74 72 75 63 74 pen-db dbstruct
9670: 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 29 run-id dbinit))
9680: 0a 09 09 20 20 28 65 6c 73 65 20 28 61 73 73 65 ... (else (asse
9690: 72 74 20 23 66 20 22 46 41 54 41 4c 3a 20 72 6d rt #f "FATAL: rm
96a0: 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6e 6f 64 65 t:transport-node
96b0: 20 6e 6f 74 20 63 6f 72 72 65 63 74 20 76 61 6c not correct val
96c0: 75 65 22 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 ue"(rmt:transpor
96d0: 74 2d 6d 6f 64 65 29 29 29 29 0a 20 20 20 20 28 t-mode)))). (
96e0: 73 65 74 21 20 2a 64 62 2d 77 72 69 74 65 2d 61 set! *db-write-a
96f0: 63 63 65 73 73 2a 20 28 6e 6f 74 20 28 64 62 72 ccess* (not (dbr
9700: 3a 64 62 64 61 74 2d 72 65 61 64 2d 6f 6e 6c 79 :dbdat-read-only
9710: 20 64 62 64 61 74 29 29 29 0a 20 20 20 20 3b 3b dbdat))). ;;
9720: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
9730: 2a 64 62 2d 6f 70 65 6e 2d 6d 75 74 65 78 2a 29 *db-open-mutex*)
9740: 0a 20 20 20 20 64 62 64 61 74 29 29 0a 0a 28 64 . dbdat))..(d
9750: 65 66 69 6e 65 20 64 62 66 69 6c 65 3a 64 62 2d efine dbfile:db-
9760: 69 6e 69 74 2d 70 72 6f 63 20 28 6d 61 6b 65 2d init-proc (make-
9770: 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 0a 0a parameter #f))..
9780: 3b 3b 20 69 6e 20 78 6d 61 78 69 6d 61 20 74 68 ;; in xmaxima th
9790: 69 73 20 67 69 76 65 73 20 61 20 63 75 72 76 65 is gives a curve
97a0: 20 63 6c 6f 73 65 20 74 6f 20 77 68 61 74 20 49 close to what I
97b0: 20 77 61 6e 74 3a 0a 3b 3b 20 20 20 20 70 6c 6f want:.;; plo
97c0: 74 32 64 20 28 28 65 78 70 28 78 2f 31 2e 32 29 t2d ((exp(x/1.2)
97d0: 2d 31 29 2f 33 30 30 2c 20 5b 78 2c 20 30 2c 20 -1)/300, [x, 0,
97e0: 31 30 5d 29 24 0a 3b 3b 20 20 20 20 70 6c 6f 74 10])$.;; plot
97f0: 32 64 20 28 28 65 78 70 28 78 2f 31 2e 35 29 2d 2d ((exp(x/1.5)-
9800: 31 29 2f 34 30 2c 20 5b 78 2c 20 30 2c 20 31 30 1)/40, [x, 0, 10
9810: 5d 29 24 0a 3b 3b 20 20 20 20 70 6c 6f 74 32 64 ])$.;; plot2d
9820: 20 28 28 65 78 70 28 78 2f 35 29 2d 31 29 2f 34 ((exp(x/5)-1)/4
9830: 30 2c 20 5b 78 2c 20 30 2c 20 32 30 5d 29 24 0a 0, [x, 0, 20])$.
9840: 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a (define (dbfile:
9850: 64 72 6f 6f 70 20 78 29 0a 20 20 28 2f 20 28 2d droop x). (/ (-
9860: 20 28 65 78 70 20 28 2f 20 78 20 35 29 29 20 31 (exp (/ x 5)) 1
9870: 29 20 34 30 29 29 0a 20 20 3b 3b 20 28 2a 20 6e ) 40)). ;; (* n
9880: 75 6d 71 72 79 73 20 28 2f 20 31 20 28 71 69 66 umqrys (/ 1 (qif
9890: 2d 73 6c 6f 70 65 29 29 29 29 0a 0a 3b 3b 20 63 -slope))))..;; c
98a0: 72 65 61 74 65 20 61 20 64 72 6f 70 70 69 6e 67 reate a dropping
98b0: 20 6e 65 61 72 20 74 68 65 20 64 62 20 66 69 6c near the db fil
98c0: 65 20 69 6e 20 61 20 71 69 66 20 64 69 72 0a 3b e in a qif dir.;
98d0: 3b 20 75 73 65 20 63 6f 75 6e 74 20 6f 66 20 73 ; use count of s
98e0: 75 63 68 20 66 69 6c 65 73 20 74 6f 20 67 61 74 uch files to gat
98f0: 65 20 71 75 65 72 69 65 73 20 28 71 75 65 72 69 e queries (queri
9900: 65 73 20 69 6e 20 66 6c 69 67 68 74 29 0a 3b 3b es in flight).;;
9910: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
9920: 3a 77 61 69 74 2d 66 6f 72 2d 71 69 66 20 66 6e :wait-for-qif fn
9930: 61 6d 65 20 72 75 6e 2d 69 64 20 70 61 72 61 6d ame run-id param
9940: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 68 65 s). (let* ((the
9950: 64 69 72 20 20 28 70 61 74 68 6e 61 6d 65 2d 64 dir (pathname-d
9960: 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 29 29 irectory fname))
9970: 0a 09 20 28 64 62 6e 75 6d 20 20 20 28 64 62 66 .. (dbnum (dbf
9980: 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 75 ile:run-id->dbnu
9990: 6d 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 64 65 m run-id)).. (de
99a0: 73 74 64 69 72 20 28 63 6f 6e 63 20 74 68 65 64 stdir (conc thed
99b0: 69 72 22 2f 71 69 66 2d 22 64 62 6e 75 6d 29 29 ir"/qif-"dbnum))
99c0: 0a 09 20 28 75 6e 69 71 6e 20 20 20 28 67 65 74 .. (uniqn (get
99d0: 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 -area-path-signa
99e0: 74 75 72 65 20 28 63 6f 6e 63 20 64 62 6e 75 6d ture (conc dbnum
99f0: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 28 63 72 params))).. (cr
9a00: 75 6d 62 6e 20 20 28 63 6f 6e 63 20 64 65 73 74 umbn (conc dest
9a10: 64 69 72 22 2f 22 28 63 75 72 72 65 6e 74 2d 73 dir"/"(current-s
9a20: 65 63 6f 6e 64 73 29 22 2d 22 75 6e 69 71 6e 22 econds)"-"uniqn"
9a30: 2e 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 ."(current-proce
9a40: 73 73 2d 69 64 29 29 29 29 0a 20 20 20 20 28 69 ss-id)))). (i
9a50: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
9a60: 73 74 73 3f 20 64 65 73 74 64 69 72 29 29 28 63 sts? destdir))(c
9a70: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
9a80: 28 63 6f 6e 63 20 64 65 73 74 64 69 72 22 2f 61 (conc destdir"/a
9a90: 74 74 69 63 22 29 20 23 74 29 29 0a 20 20 20 20 ttic") #t)).
9aa0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e (let loop ((coun
9ab0: 74 20 30 29 29 0a 20 20 20 20 20 20 28 6c 65 74 t 0)). (let
9ac0: 2a 20 28 28 63 75 72 72 6c 6b 73 20 28 67 6c 6f * ((currlks (glo
9ad0: 62 20 28 63 6f 6e 63 20 64 65 73 74 64 69 72 22 b (conc destdir"
9ae0: 2f 2a 22 29 29 29 0a 09 20 20 20 20 20 28 6e 75 /*"))).. (nu
9af0: 6d 71 72 79 73 20 28 6c 65 6e 67 74 68 20 63 75 mqrys (length cu
9b00: 72 72 6c 6b 73 29 29 0a 09 20 20 20 20 20 28 64 rrlks)).. (d
9b10: 65 6c 61 79 76 61 6c 20 28 63 6f 6e 64 20 3b 3b elayval (cond ;;
9b20: 20 64 6f 20 61 20 64 72 6f 6f 70 69 73 68 20 63 do a droopish c
9b30: 75 72 76 65 0a 09 09 09 28 28 3e 20 6e 75 6d 71 urve....((> numq
9b40: 72 79 73 20 32 35 29 0a 09 09 09 20 28 66 6f 72 rys 25).... (for
9b50: 2d 65 61 63 68 0a 09 09 09 20 20 28 6c 61 6d 62 -each.... (lamb
9b60: 64 61 20 28 66 29 0a 09 09 09 20 20 20 20 28 69 da (f).... (i
9b70: 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
9b80: 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 09 20 20 -seconds).....
9b90: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
9ba0: 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 65 78 ptions...... ex
9bb0: 6e 0a 09 09 09 09 09 28 63 75 72 72 65 6e 74 2d n......(current-
9bc0: 73 65 63 6f 6e 64 73 29 20 3b 3b 20 66 69 6c 65 seconds) ;; file
9bd0: 20 69 73 20 6c 69 6b 65 6c 79 20 67 6f 6e 65 2c is likely gone,
9be0: 20 6a 75 73 74 20 66 61 6b 65 20 6f 75 74 0a 09 just fake out..
9bf0: 09 09 09 09 28 66 69 6c 65 2d 6d 6f 64 69 66 69 ....(file-modifi
9c00: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 29 29 29 cation-time f)))
9c10: 0a 09 09 09 09 20 20 20 28 6b 65 65 70 2d 61 67 ..... (keep-ag
9c20: 65 2d 70 61 72 61 6d 29 29 0a 09 09 09 09 28 6c e-param)).....(l
9c30: 65 74 2a 20 28 28 62 61 73 65 64 69 72 20 28 70 et* ((basedir (p
9c40: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
9c50: 79 20 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 y f)).....
9c60: 20 28 66 69 6c 65 6e 20 20 20 28 70 61 74 68 6e (filen (pathn
9c70: 61 6d 65 2d 66 69 6c 65 20 66 29 29 0a 09 09 09 ame-file f))....
9c80: 09 20 20 20 20 20 20 20 28 64 65 73 74 66 20 20 . (destf
9c90: 20 28 63 6f 6e 63 20 62 61 73 65 64 69 72 22 2f (conc basedir"/
9ca0: 61 74 74 69 63 2f 22 66 69 6c 65 6e 29 29 29 0a attic/"filen))).
9cb0: 09 09 09 09 20 20 28 64 62 66 69 6c 65 3a 70 72 .... (dbfile:pr
9cc0: 69 6e 74 2d 65 72 72 20 22 4d 6f 76 69 6e 67 20 int-err "Moving
9cd0: 71 69 66 20 66 69 6c 65 20 22 66 22 20 6f 6c 64 qif file "f" old
9ce0: 65 72 20 74 68 61 6e 20 31 30 20 73 65 63 6f 6e er than 10 secon
9cf0: 64 73 20 74 6f 20 22 64 65 73 74 66 29 0a 09 09 ds to "destf)...
9d00: 09 09 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d 66 .. ;; (delete-f
9d10: 69 6c 65 2a 20 66 29 0a 09 09 09 09 20 20 28 68 ile* f)..... (h
9d20: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
9d30: 0a 09 09 09 09 20 20 20 20 20 20 65 78 6e 0a 09 ..... exn..
9d40: 09 09 09 20 20 20 20 23 74 0a 09 09 09 09 20 20 ... #t.....
9d50: 20 20 28 66 69 6c 65 2d 6d 6f 76 65 20 66 20 64 (file-move f d
9d60: 65 73 74 66 20 23 74 29 29 29 29 29 0a 09 09 09 estf #t)))))....
9d70: 20 20 63 75 72 72 6c 6b 73 29 0a 09 09 09 20 34 currlks).... 4
9d80: 29 0a 09 09 09 28 28 3e 20 6e 75 6d 71 72 79 73 )....((> numqrys
9d90: 20 30 29 20 20 28 64 62 66 69 6c 65 3a 64 72 6f 0) (dbfile:dro
9da0: 6f 70 20 6e 75 6d 71 72 79 73 29 29 20 3b 3b 20 op numqrys)) ;;
9db0: 73 6c 6f 70 65 20 6f 66 20 31 2f 31 30 30 0a 09 slope of 1/100..
9dc0: 09 09 28 65 6c 73 65 20 23 66 29 29 29 29 0a 09 ..(else #f))))..
9dd0: 28 69 66 20 28 61 6e 64 20 64 65 6c 61 79 76 61 (if (and delayva
9de0: 6c 0a 09 09 20 28 3c 20 63 6f 75 6e 74 20 35 29 l... (< count 5)
9df0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
9e00: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
9e10: 65 70 21 20 64 65 6c 61 79 76 61 6c 29 0a 09 20 ep! delayval)..
9e20: 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f (loop (+ co
9e30: 75 6e 74 20 31 29 29 29 29 29 29 0a 20 20 20 20 unt 1)))))).
9e40: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
9e50: 66 69 6c 65 20 63 72 75 6d 62 6e 0a 20 20 20 20 file crumbn.
9e60: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 70 (lambda ()..(p
9e70: 72 69 6e 74 20 66 6e 61 6d 65 22 20 72 75 6e 2d rint fname" run-
9e80: 69 64 3d 22 72 75 6e 2d 69 64 22 20 70 61 72 61 id="run-id" para
9e90: 6d 73 3d 22 70 61 72 61 6d 73 29 0a 09 29 29 0a ms="params)..)).
9ea0: 20 20 20 20 63 72 75 6d 62 6e 29 29 0a 0a 28 64 crumbn))..(d
9eb0: 65 66 69 6e 65 20 6e 6f 2d 63 6f 6e 64 69 74 69 efine no-conditi
9ec0: 6f 6e 2d 64 62 2d 77 69 74 68 2d 64 62 20 28 6d on-db-with-db (m
9ed0: 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 23 74 ake-parameter #t
9ee0: 29 29 0a 0a 3b 3b 20 28 64 62 3a 77 69 74 68 2d ))..;; (db:with-
9ef0: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
9f00: 69 64 20 73 71 6c 69 74 65 33 3a 65 78 65 63 20 id sqlite3:exec
9f10: 22 73 65 6c 65 63 74 20 62 6c 61 68 20 66 67 72 "select blah fgr
9f20: 6f 6d 20 62 6c 61 7a 3b 22 29 0a 3b 3b 20 72 2f om blaz;").;; r/
9f30: 77 20 69 73 20 61 20 66 6c 61 67 20 74 6f 20 69 w is a flag to i
9f40: 6e 64 69 63 61 74 65 20 69 66 20 74 68 65 20 64 ndicate if the d
9f50: 62 20 69 73 20 6d 6f 64 69 66 69 65 64 20 62 79 b is modified by
9f60: 20 74 68 69 73 20 71 75 65 72 79 20 23 74 20 3d this query #t =
9f70: 20 79 65 73 2c 20 23 66 20 3d 20 6e 6f 0a 3b 3b yes, #f = no.;;
9f80: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
9f90: 3a 77 69 74 68 2d 64 62 20 64 62 73 74 72 75 63 :with-db dbstruc
9fa0: 74 20 72 75 6e 2d 69 64 20 72 2f 77 20 70 72 6f t run-id r/w pro
9fb0: 63 20 70 61 72 61 6d 73 29 0a 20 20 28 61 73 73 c params). (ass
9fc0: 65 72 74 20 64 62 73 74 72 75 63 74 20 22 46 41 ert dbstruct "FA
9fd0: 54 41 4c 3a 20 64 62 3a 77 69 74 68 2d 64 62 20 TAL: db:with-db
9fe0: 63 61 6c 6c 65 64 20 77 69 74 68 20 64 62 73 74 called with dbst
9ff0: 72 75 63 74 20 22 23 66 29 0a 20 20 28 61 73 73 ruct "#f). (ass
a000: 65 72 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 ert (dbr:dbstruc
a010: 74 3f 20 64 62 73 74 72 75 63 74 29 20 22 46 41 t? dbstruct) "FA
a020: 54 41 4c 3a 20 64 62 73 74 72 75 63 74 20 69 73 TAL: dbstruct is
a030: 20 22 64 62 73 74 72 75 63 74 29 0a 20 20 28 6c "dbstruct). (l
a040: 65 74 2a 20 28 28 75 73 65 2d 6d 75 74 65 78 20 et* ((use-mutex
a050: 28 3e 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d (> *api-process-
a060: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 32 request-count* 2
a070: 35 29 29 20 3b 3b 20 72 69 73 6b 20 6f 66 20 64 5)) ;; risk of d
a080: 62 20 63 6f 72 72 75 70 74 69 6f 6e 0a 09 20 28 b corruption.. (
a090: 68 61 76 65 2d 73 74 72 75 63 74 20 28 64 62 72 have-struct (dbr
a0a0: 3a 64 62 73 74 72 75 63 74 3f 20 64 62 73 74 72 :dbstruct? dbstr
a0b0: 75 63 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 uct)). (
a0c0: 64 62 64 61 74 20 20 20 20 20 28 69 66 20 68 61 dbdat (if ha
a0d0: 76 65 2d 73 74 72 75 63 74 20 20 20 20 20 20 20 ve-struct
a0e0: 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 69 73 ;; this
a0f0: 20 73 74 75 66 66 20 6a 75 73 74 20 61 6c 6c 6f stuff just allo
a100: 77 73 20 75 73 20 74 6f 20 63 61 6c 6c 20 77 69 ws us to call wi
a110: 74 68 20 61 20 64 62 20 68 61 6e 64 6c 65 20 64 th a db handle d
a120: 69 72 65 63 74 6c 79 0a 09 09 09 28 64 62 3a 6f irectly....(db:o
a130: 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 pen-db dbstruct
a140: 72 75 6e 2d 69 64 20 28 64 62 66 69 6c 65 3a 64 run-id (dbfile:d
a150: 62 2d 69 6e 69 74 2d 70 72 6f 63 29 29 20 3b 3b b-init-proc)) ;;
a160: 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 (dbfile:get-sub
a170: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
a180: 69 64 29 0a 09 09 09 23 66 29 29 0a 09 20 28 64 id)....#f)).. (d
a190: 62 20 20 20 20 20 20 20 20 28 69 66 20 68 61 76 b (if hav
a1a0: 65 2d 73 74 72 75 63 74 20 20 20 20 20 20 20 20 e-struct
a1b0: 20 20 20 20 20 20 20 20 3b 3b 20 74 68 69 73 20 ;; this
a1c0: 73 74 75 66 66 20 6a 75 73 74 20 61 6c 6c 6f 77 stuff just allow
a1d0: 73 20 75 73 20 74 6f 20 63 61 6c 6c 20 77 69 74 s us to call wit
a1e0: 68 20 61 20 64 62 20 68 61 6e 64 6c 65 20 64 69 h a db handle di
a1f0: 72 65 63 74 6c 79 0a 09 09 09 28 64 62 72 3a 64 rectly....(dbr:d
a200: 62 64 61 74 2d 64 62 68 20 64 62 64 61 74 29 0a bdat-dbh dbdat).
a210: 09 09 09 64 62 73 74 72 75 63 74 29 29 0a 09 20 ...dbstruct))..
a220: 28 66 6e 61 6d 65 20 20 20 20 20 28 69 66 20 64 (fname (if d
a230: 62 64 61 74 0a 09 09 09 28 64 62 72 3a 64 62 64 bdat....(dbr:dbd
a240: 61 74 2d 64 62 66 69 6c 65 20 64 62 64 61 74 29 at-dbfile dbdat)
a250: 0a 09 09 09 22 6e 6f 66 69 6c 65 6e 61 6d 65 61 ...."nofilenamea
a260: 76 61 69 6c 61 62 6c 65 22 29 29 0a 09 20 28 6a vailable")).. (j
a270: 66 69 6c 65 20 20 20 20 20 28 63 6f 6e 63 20 66 file (conc f
a280: 6e 61 6d 65 22 2d 6a 6f 75 72 6e 61 6c 22 29 29 name"-journal"))
a290: 0a 09 20 28 71 72 79 70 72 6f 63 20 20 20 28 6c .. (qryproc (l
a2a0: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 ambda ()...
a2b0: 20 28 69 66 20 75 73 65 2d 6d 75 74 65 78 20 28 (if use-mutex (
a2c0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
a2d0: 77 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 29 29 with-db-mutex*))
a2e0: 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
a2f0: 72 65 73 20 28 61 70 70 6c 79 20 70 72 6f 63 20 res (apply proc
a300: 64 62 64 61 74 20 64 62 20 70 61 72 61 6d 73 29 dbdat db params)
a310: 29 29 20 3b 3b 20 74 68 65 20 61 63 74 75 61 6c )) ;; the actual
a320: 20 63 61 6c 6c 20 69 73 20 68 65 72 65 2e 0a 09 call is here...
a330: 09 09 28 69 66 20 75 73 65 2d 6d 75 74 65 78 20 ..(if use-mutex
a340: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
a350: 64 62 2d 77 69 74 68 2d 64 62 2d 6d 75 74 65 78 db-with-db-mutex
a360: 2a 29 29 0a 09 09 09 3b 3b 20 28 69 66 20 28 76 *))....;; (if (v
a370: 65 63 74 6f 72 3f 20 64 62 73 74 72 75 63 74 29 ector? dbstruct)
a380: 28 64 62 3a 64 6f 6e 65 2d 77 69 74 68 20 64 62 (db:done-with db
a390: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 72 2f struct run-id r/
a3a0: 77 29 29 0a 09 09 09 28 69 66 20 64 62 64 61 74 w))....(if dbdat
a3b0: 0a 09 09 09 20 20 20 20 28 64 62 66 69 6c 65 3a .... (dbfile:
a3c0: 61 64 64 2d 64 62 64 61 74 20 64 62 73 74 72 75 add-dbdat dbstru
a3d0: 63 74 20 72 75 6e 2d 69 64 20 64 62 64 61 74 29 ct run-id dbdat)
a3e0: 29 0a 09 09 09 3b 3b 20 28 64 65 6c 65 74 65 2d )....;; (delete-
a3f0: 66 69 6c 65 2a 20 63 72 75 6d 62 66 69 6c 65 29 file* crumbfile)
a400: 0a 09 09 09 72 65 73 29 29 29 29 0a 0a 20 20 20 ....res))))..
a410: 20 28 61 73 73 65 72 74 20 28 73 71 6c 69 74 65 (assert (sqlite
a420: 33 3a 64 61 74 61 62 61 73 65 3f 20 64 62 29 20 3:database? db)
a430: 22 46 41 54 41 4c 3a 20 64 62 3a 77 69 74 68 2d "FATAL: db:with-
a440: 64 62 2c 20 64 62 20 69 73 20 6e 6f 74 20 61 20 db, db is not a
a450: 64 61 74 61 62 61 73 65 2c 20 64 62 3d 22 64 62 database, db="db
a460: 22 2c 20 66 6e 61 6d 65 3d 22 66 6e 61 6d 65 29 ", fname="fname)
a470: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
a480: 78 69 73 74 73 3f 20 6a 66 69 6c 65 29 0a 09 28 xists? jfile)..(
a490: 62 65 67 69 6e 0a 09 20 20 28 64 62 66 69 6c 65 begin.. (dbfile
a4a0: 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f :print-err "INFO
a4b0: 3a 20 22 6a 66 69 6c 65 22 20 65 78 69 73 74 73 : "jfile" exists
a4c0: 2c 20 64 65 6c 61 79 69 6e 67 20 74 6f 20 72 65 , delaying to re
a4d0: 64 75 63 65 20 64 61 74 61 62 61 73 65 20 6c 6f duce database lo
a4e0: 61 64 22 29 0a 09 20 20 28 74 68 72 65 61 64 2d ad").. (thread-
a4f0: 73 6c 65 65 70 21 20 30 2e 32 29 29 29 0a 20 20 sleep! 0.2))).
a500: 20 20 28 69 66 20 28 61 6e 64 20 75 73 65 2d 6d (if (and use-m
a510: 75 74 65 78 0a 09 20 20 20 20 20 28 63 6f 6d 6d utex.. (comm
a520: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
a530: 6e 74 20 31 32 30 20 22 6f 76 65 72 2d 35 30 2d nt 120 "over-50-
a540: 70 61 72 61 6c 6c 65 6c 2d 61 70 69 2d 72 65 71 parallel-api-req
a550: 75 65 73 74 73 22 29 29 0a 09 28 64 62 66 69 6c uests"))..(dbfil
a560: 65 3a 70 72 69 6e 74 2d 65 72 72 20 2a 61 70 69 e:print-err *api
a570: 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 -process-request
a580: 2d 63 6f 75 6e 74 2a 20 22 20 70 61 72 61 6c 6c -count* " parall
a590: 65 6c 20 61 70 69 20 72 65 71 75 65 73 74 73 20 el api requests
a5a0: 62 65 69 6e 67 20 70 72 6f 63 65 73 73 65 64 20 being processed
a5b0: 69 6e 20 70 72 6f 63 65 73 73 20 22 0a 09 09 09 in process "....
a5c0: 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 (current-proce
a5d0: 73 73 2d 69 64 29 29 29 20 3b 3b 20 20 22 2c 20 ss-id))) ;; ",
a5e0: 74 68 72 6f 74 74 6c 69 6e 67 20 61 63 63 65 73 throttling acces
a5f0: 73 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f s")). (if (no
a600: 2d 63 6f 6e 64 69 74 69 6f 6e 2d 64 62 2d 77 69 -condition-db-wi
a610: 74 68 2d 64 62 29 0a 09 28 71 72 79 70 72 6f 63 th-db)..(qryproc
a620: 29 0a 09 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 )..(condition-ca
a630: 73 65 0a 09 20 28 71 72 79 70 72 6f 63 29 0a 09 se.. (qryproc)..
a640: 20 28 65 78 6e 20 28 69 6f 2d 65 72 72 6f 72 29 (exn (io-error)
a650: 0a 09 20 20 20 20 20 20 28 64 62 3a 67 65 6e 65 .. (db:gene
a660: 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f ric-error-printo
a670: 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 69 ut exn "ERROR: i
a680: 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 20 22 20 /o error with "
a690: 66 6e 61 6d 65 20 22 2e 20 43 68 65 63 6b 20 70 fname ". Check p
a6a0: 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 69 73 6b ermissions, disk
a6b0: 20 73 70 61 63 65 20 65 74 63 2e 20 61 6e 64 20 space etc. and
a6c0: 74 72 79 20 61 67 61 69 6e 2e 22 29 29 0a 09 20 try again."))..
a6d0: 28 65 78 6e 20 28 63 6f 72 72 75 70 74 29 0a 09 (exn (corrupt)..
a6e0: 20 20 20 20 20 20 28 64 62 3a 67 65 6e 65 72 69 (db:generi
a6f0: 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 74 c-error-printout
a700: 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 64 61 74 exn "ERROR: dat
a710: 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 abase " fname "
a720: 69 73 20 63 6f 72 72 75 70 74 2e 20 52 65 70 61 is corrupt. Repa
a730: 69 72 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 ir it to proceed
a740: 2e 22 29 29 0a 09 20 28 65 78 6e 20 28 62 75 73 .")).. (exn (bus
a750: 79 29 0a 09 20 20 20 20 20 20 28 64 62 3a 67 65 y).. (db:ge
a760: 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e neric-error-prin
a770: 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 3a tout exn "ERROR:
a780: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
a790: 65 0a 09 09 09 09 09 20 22 20 69 73 20 6c 6f 63 e...... " is loc
a7a0: 6b 65 64 2e 20 54 72 79 20 63 6f 70 79 69 6e 67 ked. Try copying
a7b0: 20 74 6f 20 61 6e 6f 74 68 65 72 20 6c 6f 63 61 to another loca
a7c0: 74 69 6f 6e 2c 20 72 65 6d 6f 76 65 20 6f 72 69 tion, remove ori
a7d0: 67 69 6e 61 6c 20 61 6e 64 20 63 6f 70 79 20 62 ginal and copy b
a7e0: 61 63 6b 2e 22 29 29 0a 09 20 28 65 78 6e 20 28 ack.")).. (exn (
a7f0: 70 65 72 6d 69 73 73 69 6f 6e 29 28 64 62 3a 67 permission)(db:g
a800: 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 72 69 eneric-error-pri
a810: 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 4f 52 ntout exn "ERROR
a820: 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 : database " fna
a830: 6d 65 20 22 20 68 61 73 20 73 6f 6d 65 20 70 65 me " has some pe
a840: 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c 65 rmissions proble
a850: 6d 2e 22 29 29 0a 09 20 28 65 78 6e 20 28 29 0a m.")).. (exn ().
a860: 09 20 20 20 20 20 20 28 64 62 3a 67 65 6e 65 72 . (db:gener
a870: 69 63 2d 65 72 72 6f 72 2d 70 72 69 6e 74 6f 75 ic-error-printou
a880: 74 20 65 78 6e 20 22 45 52 52 4f 52 3a 20 55 6e t exn "ERROR: Un
a890: 6b 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 known error with
a8a0: 20 64 61 74 61 62 61 73 65 20 22 20 66 6e 61 6d database " fnam
a8b0: 65 20 22 20 6d 65 73 73 61 67 65 3a 20 22 0a 09 e " message: "..
a8c0: 09 09 09 09 20 28 28 63 6f 6e 64 69 74 69 6f 6e .... ((condition
a8d0: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
a8e0: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
a8f0: 29 20 65 78 6e 29 29 29 29 29 29 29 0a 0a 3b 3b ) exn)))))))..;;
a900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a940: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 61 6e 6f 74 68 65 ======.;; anothe
a950: 72 20 61 74 74 65 6d 70 74 20 61 74 20 61 20 74 r attempt at a t
a960: 72 61 6e 73 61 63 74 69 6f 6e 69 7a 65 64 20 71 ransactionized q
a970: 75 65 75 65 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ueue.;;=========
a980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
a9c0: 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 ; ;; ;; (define
a9d0: 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 *transaction-que
a9e0: 75 65 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d ues* (make-hash-
a9f0: 74 61 62 6c 65 29 29 0a 3b 3b 20 3b 3b 20 3b 3b table)).;; ;; ;;
aa00: 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 .;; ;; ;; (defi
aa10: 6e 65 20 28 64 62 3a 67 65 74 2d 71 75 65 75 65 ne (db:get-queue
aa20: 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 3b 3b 20 3b run-id).;; ;; ;
aa30: 3b 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 ; (let* ((res
aa40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
aa50: 64 65 66 61 75 6c 74 20 2a 74 72 61 6e 73 61 63 default *transac
aa60: 74 69 6f 6e 2d 71 75 65 75 65 73 2a 20 72 75 6e tion-queues* run
aa70: 2d 69 64 20 23 66 29 29 29 0a 3b 3b 20 3b 3b 20 -id #f))).;; ;;
aa80: 3b 3b 20 20 20 20 20 28 69 66 20 72 65 73 0a 3b ;; (if res.;
aa90: 3b 20 3b 3b 20 3b 3b 20 09 72 65 73 0a 3b 3b 20 ; ;; ;; .res.;;
aaa0: 3b 3b 20 3b 3b 20 09 28 6c 65 74 2a 20 28 28 6e ;; ;; .(let* ((n
aab0: 65 77 71 20 28 6d 61 6b 65 2d 71 75 65 75 65 29 ewq (make-queue)
aac0: 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 20 28 )).;; ;; ;; . (
aad0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
aae0: 2a 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 *transaction-que
aaf0: 75 65 73 2a 20 72 75 6e 2d 69 64 20 6e 65 77 71 ues* run-id newq
ab00: 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 20 6e 65 ).;; ;; ;; . ne
ab10: 77 71 29 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 wq)))).;; ;; ;;
ab20: 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e .;; ;; ;; (defin
ab30: 65 20 28 64 62 3a 61 64 64 2d 74 6f 2d 74 72 61 e (db:add-to-tra
ab40: 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 20 64 nsaction-queue d
ab50: 62 73 74 72 75 63 74 20 70 72 6f 63 20 70 61 72 bstruct proc par
ab60: 61 6d 73 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 ams).;; ;; ;;
ab70: 28 6c 65 74 2a 20 28 28 6d 62 6f 78 20 28 6d 61 (let* ((mbox (ma
ab80: 6b 65 2d 6d 61 69 6c 62 6f 78 29 29 0a 3b 3b 20 ke-mailbox)).;;
ab90: 3b 3b 20 3b 3b 20 09 20 28 71 20 20 20 20 28 64 ;; ;; . (q (d
aba0: 62 3a 67 65 74 2d 71 75 65 75 65 20 72 75 6e 2d b:get-queue run-
abb0: 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 id))).;; ;; ;;
abc0: 20 20 20 28 71 75 65 75 65 2d 61 64 64 21 20 2a (queue-add! *
abd0: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 transaction-queu
abe0: 65 2a 20 28 6c 69 73 74 20 64 62 73 74 72 75 63 e* (list dbstruc
abf0: 74 20 70 72 6f 63 20 6d 62 6f 78 29 29 0a 3b 3b t proc mbox)).;;
ac00: 20 3b 3b 20 3b 3b 20 20 20 20 20 28 6d 61 69 6c ;; ;; (mail
ac10: 62 6f 78 2d 72 65 63 65 69 76 65 20 6d 62 6f 78 box-receive mbox
ac20: 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 0a 3b 3b ))).;; ;; ;; .;;
ac30: 20 3b 3b 20 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;; ;; (define (
ac40: 64 62 3a 70 72 6f 63 65 73 73 2d 74 72 61 6e 73 db:process-trans
ac50: 61 63 74 69 6f 6e 2d 71 75 65 75 65 20 2a 64 62 action-queue *db
ac60: 73 74 72 75 63 74 2d 64 62 73 2a 29 0a 3b 3b 20 struct-dbs*).;;
ac70: 3b 3b 20 3b 3b 20 20 20 28 66 6f 72 2d 65 61 63 ;; ;; (for-eac
ac80: 68 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 28 6c h.;; ;; ;; (l
ac90: 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b ambda (run-id).;
aca0: 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 28 6c 65 ; ;; ;; (le
acb0: 74 2a 20 28 28 71 20 28 68 61 73 68 2d 74 61 62 t* ((q (hash-tab
acc0: 6c 65 2d 72 65 66 20 2a 74 72 61 6e 73 61 63 74 le-ref *transact
acd0: 69 6f 6e 2d 71 75 65 75 65 2a 20 72 75 6e 2d 69 ion-queue* run-i
ace0: 64 29 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 d))).;; ;; ;;
acf0: 20 20 20 20 20 3b 3b 20 77 69 74 68 2d 74 72 61 ;; with-tra
ad00: 6e 73 61 63 74 69 6f 6e 0a 3b 3b 20 3b 3b 20 3b nsaction.;; ;; ;
ad10: 3b 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ; ;;
ad20: 64 62 73 74 72 75 63 74 0a 3b 3b 20 3b 3b 20 3b dbstruct.;; ;; ;
ad30: 3b 20 20 20 20 20 20 20 20 3b 3b 20 70 6f 70 20 ; ;; pop
ad40: 69 74 65 6d 73 20 66 72 6f 6d 20 71 75 65 75 65 items from queue
ad50: 20 61 6e 64 20 65 78 65 63 75 74 65 20 74 68 65 and execute the
ad60: 6d 2c 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 m, return result
ad70: 73 20 76 69 61 20 6d 61 69 6c 62 6f 78 0a 3b 3b s via mailbox.;;
ad80: 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 71 0a ;; ;; q.
ad90: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 ;; ;; ;;
ada0: 3b 3b 20 70 6f 70 20 0a 3b 3b 20 3b 3b 20 3b 3b ;; pop .;; ;; ;;
adb0: 20 20 20 20 20 20 20 20 29 29 0a 3b 3b 20 3b 3b )).;; ;;
adc0: 20 3b 3b 20 20 20 20 28 68 61 73 68 2d 74 61 62 ;; (hash-tab
add0: 6c 65 2d 6b 65 79 73 20 2a 74 72 61 6e 73 61 63 le-keys *transac
ade0: 74 69 6f 6e 2d 71 75 65 75 65 73 2a 29 29 29 0a tion-queues*))).
adf0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
ae00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 69 6c =========.;; fil
ae40: 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d 3d e utils.;;======
ae50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae90: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
aea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 6c 61 ==========.;; la
aee0: 7a 79 2d 73 61 66 65 20 67 65 74 20 66 69 6c 65 zy-safe get file
aef0: 20 6d 6f 64 20 74 69 6d 65 2e 20 6f 6e 20 61 6e mod time. on an
af00: 79 20 65 72 72 6f 72 20 28 66 69 6c 65 20 6e 6f y error (file no
af10: 74 20 65 78 69 73 74 69 6e 67 20 65 74 63 2e 29 t existing etc.)
af20: 20 72 65 74 75 72 6e 20 30 0a 3b 3b 0a 28 64 65 return 0.;;.(de
af30: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 6c 61 7a fine (dbfile:laz
af40: 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 y-modification-t
af50: 69 6d 65 20 66 70 61 74 68 29 0a 20 20 28 68 61 ime fpath). (ha
af60: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
af70: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 28 62 exn. (b
af80: 65 67 69 6e 0a 20 20 20 20 20 20 28 64 62 66 69 egin. (dbfi
af90: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 46 61 le:print-err "Fa
afa0: 69 6c 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 69 iled to get modi
afb0: 66 69 63 61 74 69 6f 6e 20 74 69 6d 65 20 66 6f fication time fo
afc0: 72 20 22 20 66 70 61 74 68 20 22 2c 20 74 72 65 r " fpath ", tre
afd0: 61 74 69 6e 67 20 69 74 20 61 73 20 7a 65 72 6f ating it as zero
afe0: 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 . exn=" exn).
aff0: 20 20 20 30 29 0a 20 20 20 20 28 69 66 20 28 66 0). (if (f
b000: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 70 61 74 ile-exists? fpat
b010: 68 29 0a 09 28 66 69 6c 65 2d 6d 6f 64 69 66 69 h)..(file-modifi
b020: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 cation-time fpat
b030: 68 29 0a 09 30 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d h)..0)))..;;====
b040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b080: 3d 3d 0a 3b 3b 20 66 69 6e 64 20 74 69 6d 65 73 ==.;; find times
b090: 74 61 6d 70 20 6f 66 20 6e 65 77 65 73 74 20 66 tamp of newest f
b0a0: 69 6c 65 20 61 73 73 6f 63 69 61 74 65 64 20 77 ile associated w
b0b0: 69 74 68 20 61 20 73 71 6c 69 74 65 20 64 62 20 ith a sqlite db
b0c0: 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 64 62 file.(define (db
b0d0: 66 69 6c 65 3a 6c 61 7a 79 2d 73 71 6c 69 74 65 file:lazy-sqlite
b0e0: 2d 64 62 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e -db-modification
b0f0: 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 28 -time fpath). (
b100: 6c 65 74 2a 20 28 28 67 6c 6f 62 2d 6c 69 73 74 let* ((glob-list
b110: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
b120: 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 20 20 20 ons....exn...
b130: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 62 (begin....(db
b140: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
b150: 46 61 69 6c 65 64 20 74 6f 20 67 6c 6f 62 20 22 Failed to glob "
b160: 20 66 70 61 74 68 20 22 2a 2c 20 65 78 6e 3d 22 fpath "*, exn="
b170: 20 65 78 6e 29 0a 09 09 09 60 28 2c 28 63 6f 6e exn)....`(,(con
b180: 63 20 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 c "/no/such/file
b190: 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 , message: " ((c
b1a0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
b1b0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
b1c0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 'message) exn)))
b1d0: 29 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 )... (glob
b1e0: 28 63 6f 6e 63 20 66 70 61 74 68 20 22 2a 22 29 (conc fpath "*")
b1f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 69 ))). (fi
b200: 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 65 71 3f le-list (if (eq?
b210: 20 30 20 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 0 (length glob-
b220: 6c 69 73 74 29 29 0a 09 09 09 27 28 22 2f 6e 6f list))....'("/no
b230: 2f 73 75 63 68 2f 66 69 6c 65 22 29 0a 09 09 09 /such/file")....
b240: 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 glob-list))). (
b250: 61 70 70 6c 79 20 6d 61 78 0a 09 20 28 6d 61 70 apply max.. (map
b260: 0a 09 20 20 64 62 66 69 6c 65 3a 6c 61 7a 79 2d .. dbfile:lazy-
b270: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
b280: 65 20 0a 09 20 20 66 69 6c 65 2d 6c 69 73 74 29 e .. file-list)
b290: 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c 6f 63 6b )))..;; dot-lock
b2a0: 69 6e 67 20 65 67 67 20 73 65 65 6d 73 20 6e 6f ing egg seems no
b2b0: 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 69 6e 67 t to work, using
b2c0: 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 0a 3b 3b this for now.;;
b2d0: 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f 6c 64 65 if lock is olde
b2e0: 72 20 74 68 61 6e 20 65 78 70 69 72 65 2d 74 69 r than expire-ti
b2f0: 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 65 20 69 me then remove i
b300: 74 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a t and try again.
b310: 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 20 6c 6f ;; to get the lo
b320: 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 ck.;;.(define (d
b330: 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c bfile:simple-fil
b340: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 23 21 6b e-lock fname #!k
b350: 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 ey (expire-time
b360: 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 28 66 300)). (let ((f
b370: 6d 6f 64 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 mod-time (handle
b380: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 -exceptions...
b390: 20 20 20 20 20 65 78 74 0a 09 09 20 20 20 20 20 ext...
b3a0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
b3b0: 29 0a 09 09 20 20 20 20 20 28 66 69 6c 65 2d 6d )... (file-m
b3c0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
b3d0: 20 66 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 fname)))). (
b3e0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
b3f0: 20 66 6e 61 6d 65 29 0a 09 28 69 66 20 28 3e 20 fname)..(if (>
b400: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
b410: 6e 64 73 29 20 66 6d 6f 64 2d 74 69 6d 65 29 20 nds) fmod-time)
b420: 65 78 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 20 expire-time)..
b430: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
b440: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
b450: 6e 73 20 65 78 6e 20 23 66 20 28 64 65 6c 65 74 ns exn #f (delet
b460: 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 09 e-file* fname)).
b470: 0a 09 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a .. (dbfile:
b480: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
b490: 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 fname expire-ti
b4a0: 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 me: expire-time)
b4b0: 29 0a 09 20 20 20 20 23 66 29 0a 09 28 6c 65 74 ).. #f)..(let
b4c0: 20 28 28 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 ((key-string (c
b4d0: 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 onc (get-host-na
b4e0: 6d 65 29 20 22 2d 22 20 28 63 75 72 72 65 6e 74 me) "-" (current
b4f0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 09 -process-id)))..
b500: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
b510: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
b520: 69 6c 65 20 66 6e 61 6d 65 29 29 29 0a 09 20 20 ile fname)))..
b530: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
b540: 70 6f 72 74 0a 09 20 20 20 20 20 20 6f 75 70 0a port.. oup.
b550: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
b560: 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 6b 65 . (print ke
b570: 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 20 20 28 y-string))).. (
b580: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
b590: 74 20 6f 75 70 29 0a 09 20 20 23 3b 28 77 69 74 t oup).. #;(wit
b5a0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
b5b0: 20 66 6e 61 6d 65 20 3b 3b 20 62 69 7a 61 72 72 fname ;; bizarr
b5c0: 65 2e 20 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 e. with-output-t
b5d0: 6f 2d 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 o-file does not
b5e0: 73 65 65 6d 20 74 6f 20 62 65 20 63 6c 65 61 6e seem to be clean
b5f0: 69 6e 67 20 75 70 20 61 66 74 65 72 20 69 74 73 ing up after its
b600: 65 6c 66 2e 0a 09 20 20 20 20 28 6c 61 6d 62 64 elf... (lambd
b610: 61 20 28 29 0a 09 20 20 28 70 72 69 6e 74 20 6b a ().. (print k
b620: 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 20 20 ey-string)))..
b630: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
b640: 2e 32 35 29 0a 09 20 20 28 69 66 20 28 66 69 6c .25).. (if (fil
b650: 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 e-exists? fname)
b660: 0a 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d .. (handle-
b670: 65 78 63 65 70 74 69 6f 6e 73 20 65 78 6e 0a 20 exceptions exn.
b680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
b690: 66 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f .
b6a0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
b6b0: 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 rom-file fname..
b6c0: 20 20 09 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
b6d0: 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 6b 65 .. (equal? ke
b6e0: 79 2d 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c y-string (read-l
b6f0: 69 6e 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 ine)))))..
b700: 23 66 29 0a 20 20 20 20 20 20 20 29 0a 20 20 20 #f). ).
b710: 20 29 0a 20 20 29 0a 29 0a 0a 28 64 65 66 69 6e ). ).)..(defin
b720: 65 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 e (dbfile:simple
b730: 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 -file-lock-and-w
b740: 61 69 74 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 ait fname #!key
b750: 28 65 78 70 69 72 65 2d 74 69 6d 65 20 33 30 30 (expire-time 300
b760: 29 29 0a 20 20 28 6c 65 74 20 28 28 65 6e 64 2d )). (let ((end-
b770: 74 69 6d 65 20 28 2b 20 65 78 70 69 72 65 2d 74 time (+ expire-t
b780: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
b790: 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 6c 65 onds)))). (le
b7a0: 74 20 6c 6f 6f 70 20 28 28 67 6f 74 2d 6c 6f 63 t loop ((got-loc
b7b0: 6b 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 k (dbfile:simple
b7c0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 -file-lock fname
b7d0: 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 expire-time: ex
b7e0: 70 69 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 20 pire-time))).
b7f0: 20 20 20 28 69 66 20 67 6f 74 2d 6c 6f 63 6b 0a (if got-lock.
b800: 09 20 20 23 74 0a 09 20 20 28 69 66 20 28 3e 20 . #t.. (if (>
b810: 65 6e 64 2d 74 69 6d 65 20 28 63 75 72 72 65 6e end-time (curren
b820: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 t-seconds))..
b830: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 68 72 (begin...(thr
b840: 65 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 09 ead-sleep! 3)...
b850: 28 6c 6f 6f 70 20 28 64 62 66 69 6c 65 3a 73 69 (loop (dbfile:si
b860: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 mple-file-lock f
b870: 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 name expire-time
b880: 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 : expire-time)))
b890: 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 29 0a .. #f))))).
b8a0: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
b8b0: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
b8c0: 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 ease-lock fname)
b8d0: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
b8e0: 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a tions. exn.
b8f0: 20 20 20 20 20 20 23 66 20 3b 3b 20 49 20 64 6f #f ;; I do
b900: 6e 27 74 20 72 65 61 6c 6c 79 20 63 61 72 65 20 n't really care
b910: 77 68 79 20 74 68 69 73 20 66 61 69 6c 65 64 20 why this failed
b920: 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 6e 6f (at least for no
b930: 77 29 0a 20 20 20 20 28 64 65 6c 65 74 65 2d 66 w). (delete-f
b940: 69 6c 65 2a 20 66 6e 61 6d 65 29 29 29 0a 0a 28 ile* fname)))..(
b950: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 77 define (dbfile:w
b960: 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 6c 65 2d ith-simple-file-
b970: 6c 6f 63 6b 20 66 6e 61 6d 65 20 70 72 6f 63 20 lock fname proc
b980: 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 #!key (expire-ti
b990: 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 me 300)). (let
b9a0: 28 28 67 6f 74 6c 6f 63 6b 20 28 64 62 66 69 6c ((gotlock (dbfil
b9b0: 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f e:simple-file-lo
b9c0: 63 6b 2d 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d ck-and-wait fnam
b9d0: 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 e expire-time: e
b9e0: 78 70 69 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 xpire-time))).
b9f0: 20 20 28 69 66 20 67 6f 74 6c 6f 63 6b 0a 09 28 (if gotlock..(
ba00: 6c 65 74 20 28 28 72 65 73 20 28 70 72 6f 63 29 let ((res (proc)
ba10: 29 29 0a 09 20 20 28 64 62 66 69 6c 65 3a 73 69 )).. (dbfile:si
ba20: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
ba30: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 09 20 e-lock fname)..
ba40: 20 72 65 73 29 0a 09 28 61 73 73 65 72 74 20 23 res)..(assert #
ba50: 74 20 22 46 41 54 41 4c 3a 20 73 69 6d 70 6c 65 t "FATAL: simple
ba60: 20 66 69 6c 65 20 6c 6f 63 6b 20 6e 65 76 65 72 file lock never
ba70: 20 67 6f 74 20 61 20 6c 6f 63 6b 2e 22 29 29 29 got a lock.")))
ba80: 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 64 62 ). .(define (db
ba90: 3a 67 65 74 2d 63 61 63 68 65 2d 73 74 6d 74 68 :get-cache-stmth
baa0: 20 64 62 64 61 74 20 64 62 20 73 74 6d 74 29 0a dbdat db stmt).
bab0: 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 64 62 64 (let* (;; (dbd
bac0: 61 74 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 at (dbfile
bad0: 3a 67 65 74 2d 64 62 64 61 74 20 64 62 73 74 72 :get-dbdat dbstr
bae0: 75 63 74 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 uct run-id)).. (
baf0: 73 74 6d 74 2d 63 61 63 68 65 20 20 28 64 62 72 stmt-cache (dbr
bb00: 3a 64 62 64 61 74 2d 73 74 6d 74 2d 63 61 63 68 :dbdat-stmt-cach
bb10: 65 20 64 62 64 61 74 29 29 0a 09 20 3b 3b 20 28 e dbdat)).. ;; (
bb20: 73 74 6d 74 68 20 20 20 20 20 20 20 28 64 62 3a stmth (db:
bb30: 68 6f 68 2d 67 65 74 20 73 74 6d 74 2d 63 61 63 hoh-get stmt-cac
bb40: 68 65 20 64 62 20 73 74 6d 74 29 29 0a 09 20 28 he db stmt)).. (
bb50: 73 74 6d 74 68 20 20 20 20 20 20 20 28 68 61 73 stmth (has
bb60: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
bb70: 75 6c 74 20 73 74 6d 74 2d 63 61 63 68 65 20 73 ult stmt-cache s
bb80: 74 6d 74 20 23 66 29 29 29 0a 20 20 20 20 28 6f tmt #f))). (o
bb90: 72 20 73 74 6d 74 68 0a 09 28 6c 65 74 2a 20 28 r stmth..(let* (
bba0: 28 6e 65 77 73 74 6d 74 68 20 28 73 71 6c 69 74 (newstmth (sqlit
bbb0: 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 73 74 e3:prepare db st
bbc0: 6d 74 29 29 29 0a 09 20 20 3b 3b 20 28 64 62 3a mt))).. ;; (db:
bbd0: 68 6f 68 2d 73 65 74 21 20 73 74 6d 74 2d 63 61 hoh-set! stmt-ca
bbe0: 63 68 65 20 64 62 20 73 74 6d 74 20 6e 65 77 73 che db stmt news
bbf0: 74 6d 74 68 29 0a 09 20 20 28 68 61 73 68 2d 74 tmth).. (hash-t
bc00: 61 62 6c 65 2d 73 65 74 21 20 73 74 6d 74 2d 63 able-set! stmt-c
bc10: 61 63 68 65 20 73 74 6d 74 20 6e 65 77 73 74 6d ache stmt newstm
bc20: 74 68 29 0a 09 20 20 6e 65 77 73 74 6d 74 68 29 th).. newstmth)
bc30: 29 29 29 0a 0a 0a 0a 29 0a )))....).