0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 64 62 66 69 6c 65 29 29 0a 3b 3b unit dbfile)).;;
03a0: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
03b0: 64 65 62 75 67 70 72 69 6e 74 29 29 0a 28 64 65 debugprint)).(de
03c0: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d clare (uses comm
03d0: 6f 6e 6d 6f 64 29 29 0a 0a 28 6d 6f 64 75 6c 65 onmod))..(module
03e0: 20 64 62 66 69 6c 65 0a 09 2a 0a 09 0a 20 20 28 dbfile..*... (
03f0: 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 0a 09 20 import scheme..
0400: 20 63 68 69 63 6b 65 6e 0a 09 20 20 64 61 74 61 chicken.. data
0410: 2d 73 74 72 75 63 74 75 72 65 73 0a 09 20 20 65 -structures.. e
0420: 78 74 72 61 73 0a 09 20 20 6d 61 74 63 68 61 62 xtras.. matchab
0430: 6c 65 29 0a 20 20 0a 28 69 6d 70 6f 72 74 20 28 le). .(import (
0440: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0450: 71 6c 69 74 65 33 3a 29 0a 09 70 6f 73 69 78 20 qlite3:)..posix
0460: 74 79 70 65 64 2d 72 65 63 6f 72 64 73 20 73 72 typed-records sr
0470: 66 69 2d 31 38 20 73 72 66 69 2d 31 0a 09 73 72 fi-18 srfi-1..sr
0480: 66 69 2d 36 39 0a 09 73 74 61 63 6b 0a 09 66 69 fi-69..stack..fi
0490: 6c 65 73 0a 09 70 6f 72 74 73 0a 0a 09 63 6f 6d les..ports...com
04a0: 6d 6f 6e 6d 6f 64 0a 09 3b 3b 20 64 65 62 75 67 monmod..;; debug
04b0: 70 72 69 6e 74 0a 09 29 0a 0a 28 64 65 66 69 6e print..)..(defin
04c0: 65 20 6b 65 65 70 2d 61 67 65 2d 70 61 72 61 6d e keep-age-param
04d0: 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 (make-parameter
04e0: 20 31 30 29 29 20 3b 3b 20 71 69 66 20 66 69 6c 10)) ;; qif fil
04f0: 65 20 61 67 65 2c 20 69 66 20 6f 76 65 72 20 6d e age, if over m
0500: 6f 76 65 20 74 6f 20 61 74 74 69 63 0a 28 64 65 ove to attic.(de
0510: 66 69 6e 65 20 6e 75 6d 2d 72 75 6e 2d 64 62 73 fine num-run-dbs
0520: 20 20 20 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 (make-parame
0530: 74 65 72 20 31 30 29 29 20 20 20 20 20 3b 3b 20 ter 10)) ;;
0540: 6e 75 6d 62 65 72 20 6f 66 20 64 62 27 73 20 69 number of db's i
0550: 6e 20 2e 6d 65 67 61 74 65 73 74 0a 28 64 65 66 n .megatest.(def
0560: 69 6e 65 20 64 62 66 69 6c 65 3a 74 65 73 74 73 ine dbfile:tests
0570: 75 69 74 65 2d 6e 61 6d 65 20 28 6d 61 6b 65 2d uite-name (make-
0580: 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 0a 0a parameter #f))..
0590: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
05a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 45 ========.;; R E
05e0: 20 43 20 4f 20 52 20 44 20 53 0a 3b 3b 3d 3d 3d C O R D S.;;===
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0630: 3d 3d 3d 0a 0a 3b 3b 20 61 20 73 69 6e 67 6c 65 ===..;; a single
0640: 20 4d 65 67 61 74 65 73 74 20 61 72 65 61 20 77 Megatest area w
0650: 69 74 68 20 69 74 27 73 20 6d 75 6c 74 69 70 6c ith it's multipl
0660: 65 20 64 62 73 20 69 73 0a 3b 3b 20 6d 61 6e 61 e dbs is.;; mana
0670: 67 65 64 20 69 6e 20 61 20 64 62 73 74 72 75 63 ged in a dbstruc
0680: 74 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 t.;;.(defstruct
0690: 64 62 72 3a 64 62 73 74 72 75 63 74 0a 20 20 28 dbr:dbstruct. (
06a0: 61 72 65 61 70 61 74 68 20 20 23 66 29 0a 20 20 areapath #f).
06b0: 28 68 6f 6d 65 68 6f 73 74 20 20 23 66 29 0a 20 (homehost #f).
06c0: 20 28 74 6d 70 70 61 74 68 20 20 20 23 66 29 0a (tmppath #f).
06d0: 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 23 66 29 (read-only #f)
06e0: 0a 20 20 28 73 75 62 64 62 73 20 28 6d 61 6b 65 . (subdbs (make
06f0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
0700: 3b 3b 0a 20 20 3b 3b 20 66 6f 72 20 74 68 65 20 ;;. ;; for the
0710: 69 6e 6d 65 6d 20 61 70 70 72 6f 61 63 68 20 28 inmem approach (
0720: 73 65 65 20 64 62 6d 6f 64 2e 73 63 6d 29 0a 20 see dbmod.scm).
0730: 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 6e 65 20 ;; this is one
0740: 64 62 20 70 65 72 20 73 65 72 76 65 72 0a 20 20 db per server.
0750: 28 69 6e 6d 65 6d 20 20 20 20 20 23 66 29 20 20 (inmem #f)
0760: 3b 3b 20 68 61 6e 64 6c 65 20 66 6f 72 20 74 68 ;; handle for th
0770: 65 20 69 6e 20 6d 65 6d 6f 72 79 20 63 6f 70 79 e in memory copy
0780: 0a 20 20 28 64 62 66 69 6c 65 20 20 20 20 23 66 . (dbfile #f
0790: 29 20 20 3b 3b 20 70 61 74 68 20 74 6f 20 74 68 ) ;; path to th
07a0: 65 20 64 62 20 66 69 6c 65 20 6f 6e 20 64 69 73 e db file on dis
07b0: 6b 0a 20 20 28 6f 6e 64 69 73 6b 64 62 20 20 23 k. (ondiskdb #
07c0: 66 29 20 20 3b 3b 20 68 61 6e 64 6c 65 20 66 6f f) ;; handle fo
07d0: 72 20 74 68 65 20 6f 6e 2d 64 69 73 6b 20 66 69 r the on-disk fi
07e0: 6c 65 0a 20 20 28 64 62 64 61 74 20 20 20 20 20 le. (dbdat
07f0: 23 66 29 20 20 3b 3b 20 63 72 65 61 74 65 20 61 #f) ;; create a
0800: 20 64 62 64 61 74 20 66 6f 72 20 74 68 65 20 64 dbdat for the d
0810: 6f 77 6e 73 74 72 65 61 6d 20 63 61 6c 6c 73 20 ownstream calls
0820: 73 75 63 68 20 61 73 20 64 62 3a 77 69 74 68 2d such as db:with-
0830: 64 62 0a 20 20 28 6c 61 73 74 2d 75 70 64 61 74 db. (last-updat
0840: 65 20 30 29 0a 20 20 28 73 79 6e 63 62 61 63 6b e 0). (syncback
0850: 2d 70 72 6f 63 20 23 66 29 0a 20 20 29 0a 0a 3b -proc #f). )..;
0860: 3b 20 4e 4f 54 45 3a 20 4e 65 65 64 20 6f 6e 65 ; NOTE: Need one
0870: 20 64 62 72 3a 73 75 62 64 62 20 70 65 72 20 6d dbr:subdb per m
0880: 61 69 6e 2e 64 62 2c 20 31 2e 64 62 20 2e 2e 2e ain.db, 1.db ...
0890: 0a 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 64 .;;.(defstruct d
08a0: 62 72 3a 73 75 62 64 62 0a 20 20 28 64 62 6e 61 br:subdb. (dbna
08b0: 6d 65 20 20 20 20 20 20 23 66 29 20 3b 3b 20 2e me #f) ;; .
08c0: 6d 65 67 61 74 65 73 74 2f 31 2e 64 62 0a 20 20 megatest/1.db.
08d0: 28 6d 74 64 62 66 69 6c 65 20 20 20 20 23 66 29 (mtdbfile #f)
08e0: 20 3b 3b 20 6d 74 72 61 68 2f 2e 6d 65 67 61 74 ;; mtrah/.megat
08f0: 65 73 74 2f 31 2e 64 62 0a 20 20 28 6d 74 64 62 est/1.db. (mtdb
0900: 64 61 74 20 20 20 20 20 23 66 29 20 3b 3b 20 6f dat #f) ;; o
0910: 6e 6c 79 20 6e 65 65 64 20 6f 6e 65 20 6f 66 20 nly need one of
0920: 74 68 65 73 65 20 66 6f 72 20 73 79 6e 63 69 6e these for syncin
0930: 67 0a 20 20 3b 3b 20 28 64 62 64 61 74 73 20 20 g. ;; (dbdats
0940: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
0950: 61 62 6c 65 29 29 20 20 3b 3b 20 69 64 20 3d 3e able)) ;; id =>
0960: 20 64 62 64 61 74 20 0a 20 20 28 74 6d 70 64 62 dbdat . (tmpdb
0970: 66 69 6c 65 20 20 20 23 66 29 20 3b 3b 20 2f 74 file #f) ;; /t
0980: 6d 70 2f 2e 2e 2e 2f 2e 6d 65 67 61 74 65 73 74 mp/.../.megatest
0990: 2f 31 2e 64 62 0a 20 20 3b 3b 20 28 72 65 66 6e /1.db. ;; (refn
09a0: 64 62 66 69 6c 65 20 20 23 66 29 20 3b 3b 20 2f dbfile #f) ;; /
09b0: 74 6d 70 2f 2e 2e 2e 2f 2e 6d 65 67 61 74 65 73 tmp/.../.megates
09c0: 74 2f 31 2e 64 62 5f 72 65 66 0a 20 20 28 64 62 t/1.db_ref. (db
09d0: 73 74 61 63 6b 20 20 20 20 20 28 6d 61 6b 65 2d stack (make-
09e0: 73 74 61 63 6b 29 29 20 3b 3b 20 73 74 61 63 6b stack)) ;; stack
09f0: 20 66 6f 72 20 74 6d 70 20 64 62 72 3a 64 62 64 for tmp dbr:dbd
0a00: 61 74 2c 0a 20 20 28 68 6f 6d 65 68 6f 73 74 20 at,. (homehost
0a10: 20 20 20 23 66 29 20 3b 3b 20 6e 6f 74 20 75 73 #f) ;; not us
0a20: 65 64 20 79 65 74 0a 20 20 28 6f 6e 2d 68 6f 6d ed yet. (on-hom
0a30: 65 68 6f 73 74 20 23 66 29 20 3b 3b 20 6e 6f 74 ehost #f) ;; not
0a40: 20 75 73 65 64 20 79 65 74 0a 20 20 28 72 65 61 used yet. (rea
0a50: 64 2d 6f 6e 6c 79 20 20 20 23 66 29 0a 20 20 28 d-only #f). (
0a60: 6c 61 73 74 2d 73 79 6e 63 20 20 20 30 29 0a 20 last-sync 0).
0a70: 20 28 6c 61 73 74 2d 77 72 69 74 65 20 20 28 63 (last-write (c
0a80: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0a90: 0a 20 20 29 20 20 20 20 20 20 20 20 20 20 20 20 . )
0aa0: 20 20 20 20 3b 3b 20 67 6f 61 6c 20 69 73 20 74 ;; goal is t
0ab0: 6f 20 63 6f 6e 76 65 72 67 65 20 6f 6e 20 6f 6e o converge on on
0ac0: 65 20 73 74 72 75 63 74 20 66 6f 72 20 61 6e 20 e struct for an
0ad0: 61 72 65 61 20 62 75 74 20 66 6f 72 20 6e 6f 77 area but for now
0ae0: 20 69 74 20 69 73 20 74 6f 6f 20 63 6f 6e 66 75 it is too confu
0af0: 73 69 6e 67 0a 0a 3b 3b 20 6e 65 65 64 20 74 6f sing..;; need to
0b00: 20 6b 65 65 70 20 64 62 68 61 6e 64 6c 65 73 20 keep dbhandles
0b10: 61 6e 64 20 63 61 63 68 65 64 20 73 74 61 74 65 and cached state
0b20: 6d 65 6e 74 73 20 74 6f 67 65 74 68 65 72 0a 28 ments together.(
0b30: 64 65 66 73 74 72 75 63 74 20 64 62 72 3a 64 62 defstruct dbr:db
0b40: 64 61 74 0a 20 20 28 64 62 66 69 6c 65 20 20 20 dat. (dbfile
0b50: 20 20 20 23 66 29 0a 20 20 28 64 62 68 20 20 20 #f). (dbh
0b60: 20 20 20 20 20 20 23 66 29 20 20 20 20 0a 20 20 #f) .
0b70: 28 73 74 6d 74 2d 63 61 63 68 65 20 20 28 6d 61 (stmt-cache (ma
0b80: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0b90: 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 23 (read-only #
0ba0: 66 29 0a 20 20 28 62 69 72 74 68 2d 73 65 63 20 f). (birth-sec
0bb0: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
0bc0: 64 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a ds)))..(define *
0bd0: 64 62 73 74 72 75 63 74 2d 64 62 73 2a 20 23 66 dbstruct-dbs* #f
0be0: 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6f 70 ).(define *db-op
0bf0: 65 6e 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d en-mutex* (make-
0c00: 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 mutex)).(define
0c10: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
0c20: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 * (make-mutex))
0c30: 3b 3b 20 75 73 65 64 20 69 6e 20 63 6f 6d 6d 6f ;; used in commo
0c40: 6e 2e 73 63 6d 0a 28 64 65 66 69 6e 65 20 2a 6e n.scm.(define *n
0c50: 6f 2d 73 79 6e 63 2d 64 62 2a 20 20 20 23 66 29 o-sync-db* #f)
0c60: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 79 6e .(define *db-syn
0c70: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 c-in-progress* #
0c80: 66 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 f).(define *db-w
0c90: 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 20 20 20 ith-db-mutex*
0ca0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
0cb0: 64 65 66 69 6e 65 20 2a 6d 61 78 2d 61 70 69 2d define *max-api-
0cc0: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 73 process-requests
0cd0: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 61 70 * 0).(define *ap
0ce0: 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 i-process-reques
0cf0: 74 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 t-count* 0).(def
0d00: 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 ine *db-write-ac
0d10: 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a 28 64 cess* #t).(d
0d20: 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d 73 efine *db-last-s
0d30: 79 6e 63 2a 20 20 20 20 20 20 20 20 30 29 20 20 ync* 0)
0d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0d50: 3b 20 6c 61 73 74 20 74 69 6d 65 20 74 68 65 20 ; last time the
0d60: 73 79 6e 63 20 74 6f 20 6d 65 67 61 74 65 73 74 sync to megatest
0d70: 2e 64 62 20 68 61 70 70 65 6e 65 64 0a 28 64 65 .db happened.(de
0d80: 66 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 fine *db-multi-s
0d90: 79 6e 63 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 ync-mutex* (make
0da0: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 20 3b 3b -mutex)) ;;
0db0: 20 70 72 6f 74 65 63 74 20 61 63 63 65 73 73 20 protect access
0dc0: 74 6f 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 to *db-sync-in-p
0dd0: 72 6f 67 72 65 73 73 2a 2c 20 2a 64 62 2d 6c 61 rogress*, *db-la
0de0: 73 74 2d 73 79 6e 63 2a 0a 0a 28 64 65 66 69 6e st-sync*..(defin
0df0: 65 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 e (db:generic-er
0e00: 72 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e ror-printout exn
0e10: 20 2e 20 6d 65 73 73 61 67 65 29 0a 20 20 28 70 . message). (p
0e20: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
0e30: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
0e40: 6f 72 74 29 29 0a 20 20 28 61 70 70 6c 79 20 64 ort)). (apply d
0e50: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
0e60: 6d 65 73 73 61 67 65 29 0a 20 20 28 64 62 66 69 message). (dbfi
0e70: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 0a 20 20 20 le:print-err.
0e80: 20 22 2c 20 65 72 72 6f 72 3a 20 22 20 20 20 20 ", error: "
0e90: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
0ea0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
0eb0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 20 20 exn 'message)
0ec0: 65 78 6e 29 0a 20 20 20 20 22 2c 20 61 72 67 75 exn). ", argu
0ed0: 6d 65 6e 74 73 3a 20 22 20 28 28 63 6f 6e 64 69 ments: " ((condi
0ee0: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
0ef0: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 61 72 67 cessor 'exn 'arg
0f00: 75 6d 65 6e 74 73 29 20 65 78 6e 29 0a 20 20 20 uments) exn).
0f10: 20 22 2c 20 6c 6f 63 61 74 69 6f 6e 3a 20 22 20 ", location: "
0f20: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
0f30: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
0f40: 65 78 6e 20 27 6c 6f 63 61 74 69 6f 6e 29 20 20 exn 'location)
0f50: 65 78 6e 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 exn). ))..(de
0f60: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 72 75 6e fine (dbfile:run
0f70: 2d 69 64 2d 3e 6b 65 79 20 72 75 6e 2d 69 64 29 -id->key run-id)
0f80: 0a 20 20 28 6f 72 20 72 75 6e 2d 69 64 20 27 6d . (or run-id 'm
0f90: 61 69 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ain))..(define (
0fa0: 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d db:safely-close-
0fb0: 73 71 6c 69 74 65 33 2d 64 62 20 64 62 20 73 74 sqlite3-db db st
0fc0: 6d 74 2d 63 61 63 68 65 20 23 21 6b 65 79 20 28 mt-cache #!key (
0fd0: 74 72 79 2d 6e 75 6d 20 33 29 29 0a 20 20 28 69 try-num 3)). (i
0fe0: 66 20 28 3c 3d 20 74 72 79 2d 6e 75 6d 20 30 29 f (<= try-num 0)
0ff0: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
1000: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
1010: 6e 73 0a 09 20 20 65 78 6e 0a 09 28 62 65 67 69 ns.. exn..(begi
1020: 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 41 74 74 n.. (print "Att
1030: 65 6d 70 74 20 74 6f 20 73 61 66 65 6c 79 20 63 empt to safely c
1040: 6c 6f 73 65 20 73 71 6c 69 74 65 33 20 64 62 20 lose sqlite3 db
1050: 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 failed. Trying a
1060: 67 61 69 6e 2e 20 65 78 6e 3d 22 20 65 78 6e 29 gain. exn=" exn)
1070: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
1080: 70 21 20 33 29 0a 09 20 20 28 73 71 6c 69 74 65 p! 3).. (sqlite
1090: 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 29 3:interrupt! db)
10a0: 0a 09 20 20 28 64 62 3a 73 61 66 65 6c 79 2d 63 .. (db:safely-c
10b0: 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 20 lose-sqlite3-db
10c0: 64 62 20 73 74 6d 74 2d 63 61 63 68 65 20 74 72 db stmt-cache tr
10d0: 79 2d 6e 75 6d 3a 20 28 2d 20 74 72 79 2d 6e 75 y-num: (- try-nu
10e0: 6d 20 31 29 29 29 0a 09 28 69 66 20 28 73 71 6c m 1)))..(if (sql
10f0: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 ite3:database? d
1100: 62 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 b).. (let* ((
1110: 73 74 6d 74 73 20 28 61 6e 64 20 73 74 6d 74 2d stmts (and stmt-
1120: 63 61 63 68 65 20 28 68 61 73 68 2d 74 61 62 6c cache (hash-tabl
1130: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 74 e-ref/default st
1140: 6d 74 2d 63 61 63 68 65 20 64 62 20 23 66 29 29 mt-cache db #f))
1150: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 73 74 )).. (if st
1160: 6d 74 73 20 28 6d 61 70 20 73 71 6c 69 74 65 33 mts (map sqlite3
1170: 3a 66 69 6e 61 6c 69 7a 65 21 20 28 68 61 73 68 :finalize! (hash
1180: 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 73 74 -table-values st
1190: 6d 74 73 29 29 29 0a 09 20 20 20 20 20 20 28 73 mts))).. (s
11a0: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
11b0: 20 64 62 29 0a 09 20 20 20 20 20 20 23 74 29 0a db).. #t).
11c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
11d0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
11e0: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
11f0: 72 20 22 64 62 3a 73 61 66 65 6c 79 2d 63 6c 6f r "db:safely-clo
1200: 73 65 2d 73 71 6c 69 74 65 33 2d 64 62 3a 20 22 se-sqlite3-db: "
1210: 20 64 62 20 22 20 69 73 20 6e 6f 74 20 61 6e 20 db " is not an
1220: 73 71 6c 69 74 65 33 20 64 62 22 29 0a 09 20 20 sqlite3 db")..
1230: 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 #f.
1240: 20 20 29 0a 20 20 20 20 20 20 20 20 29 29 29 29 ). ))))
1250: 0a 0a 3b 3b 20 63 6c 6f 73 65 20 61 6c 6c 20 6f ..;; close all o
1260: 70 65 6e 65 64 20 72 75 6e 2d 69 64 20 64 62 73 pened run-id dbs
1270: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 63 6c 6f .(define (db:clo
1280: 73 65 2d 61 6c 6c 20 64 62 73 74 72 75 63 74 29 se-all dbstruct)
1290: 0a 20 20 28 69 66 20 28 64 62 72 3a 64 62 73 74 . (if (dbr:dbst
12a0: 72 75 63 74 3f 20 64 62 73 74 72 75 63 74 29 0a ruct? dbstruct).
12b0: 3b 3b 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 ;; (handle-excep
12c0: 74 69 6f 6e 73 0a 3b 3b 20 09 20 20 65 78 6e 0a tions.;; . exn.
12d0: 3b 3b 20 09 20 20 28 62 65 67 69 6e 0a 3b 3b 20 ;; . (begin.;;
12e0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
12f0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1300: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
1310: 20 46 69 6e 61 6c 69 7a 69 6e 67 20 66 61 69 6c Finalizing fail
1320: 65 64 2c 20 22 20 20 28 28 63 6f 6e 64 69 74 69 ed, " ((conditi
1330: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
1340: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
1350: 67 65 29 20 65 78 6e 29 20 22 2c 20 6e 6f 74 65 ge) exn) ", note
1360: 20 2d 20 65 78 6e 3d 22 20 65 78 6e 29 0a 3b 3b - exn=" exn).;;
1370: 20 09 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c . (print-cal
1380: 6c 2d 63 68 61 69 6e 20 2a 64 65 66 61 75 6c 74 l-chain *default
1390: 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 0a 09 3b 3b -log-port*))..;;
13a0: 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 (db:sync-touche
13b0: 64 20 64 62 73 74 72 75 63 74 20 30 20 66 6f 72 d dbstruct 0 for
13c0: 63 65 2d 73 79 6e 63 3a 20 23 74 29 20 3b 3b 20 ce-sync: #t) ;;
13d0: 4e 4f 2e 20 44 6f 20 6e 6f 74 20 64 6f 20 74 68 NO. Do not do th
13e0: 69 73 20 68 65 72 65 2e 20 49 6e 73 74 65 61 64 is here. Instead
13f0: 20 77 65 20 72 65 6c 79 20 6f 6e 20 61 20 73 65 we rely on a se
1400: 72 76 65 72 20 74 6f 20 62 65 20 73 74 61 72 74 rver to be start
1410: 65 64 20 77 68 65 6e 20 74 68 65 72 65 20 61 72 ed when there ar
1420: 65 20 77 72 69 74 65 73 2c 20 65 76 65 6e 20 69 e writes, even i
1430: 66 20 74 68 65 20 73 65 72 76 65 72 20 69 74 73 f the server its
1440: 65 6c 66 20 69 73 20 6e 6f 74 20 67 6f 69 6e 67 elf is not going
1450: 20 74 6f 20 62 65 20 75 73 65 64 20 61 73 20 61 to be used as a
1460: 20 73 65 72 76 65 72 2e 0a 20 20 20 20 20 20 20 server..
1470: 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 73 20 (let* ((subdbs
1480: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
1490: 76 61 6c 75 65 73 20 28 64 62 72 3a 64 62 73 74 values (dbr:dbst
14a0: 72 75 63 74 2d 73 75 62 64 62 73 20 64 62 73 74 ruct-subdbs dbst
14b0: 72 75 63 74 29 29 29 29 0a 09 20 20 28 66 6f 72 ruct)))).. (for
14c0: 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 -each.. (lambd
14d0: 61 20 28 73 75 62 64 62 29 0a 09 20 20 20 20 20 a (subdb)..
14e0: 28 6c 65 74 2a 20 28 28 74 64 62 73 20 20 20 20 (let* ((tdbs
14f0: 20 20 20 28 73 74 61 63 6b 2d 3e 6c 69 73 74 20 (stack->list
1500: 28 64 62 72 3a 73 75 62 64 62 2d 64 62 73 74 61 (dbr:subdb-dbsta
1510: 63 6b 20 73 75 62 64 62 29 29 29 0a 09 09 20 20 ck subdb)))...
1520: 20 20 28 6d 74 64 62 64 61 74 20 20 20 20 28 64 (mtdbdat (d
1530: 62 72 3a 64 62 64 61 74 2d 64 62 68 20 28 64 62 br:dbdat-dbh (db
1540: 72 3a 73 75 62 64 62 2d 6d 74 64 62 64 61 74 20 r:subdb-mtdbdat
1550: 73 75 62 64 62 29 29 29 0a 09 09 20 20 20 20 23 subdb)))... #
1560: 3b 28 72 64 62 20 20 20 20 20 20 20 20 28 64 62 ;(rdb (db
1570: 72 3a 64 62 64 61 74 2d 64 62 68 20 28 64 62 72 r:dbdat-dbh (dbr
1580: 3a 73 75 62 64 62 2d 72 65 66 6e 64 62 20 73 75 :subdb-refndb su
1590: 62 64 62 29 29 29 29 0a 09 09 20 20 20 20 0a 09 bdb))))... ..
15a0: 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
15b0: 62 64 61 20 28 64 62 64 61 74 29 0a 09 09 20 20 bda (dbdat)...
15c0: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 6d 74 (let* ((stmt
15d0: 2d 63 61 63 68 65 20 28 64 62 72 3a 64 62 64 61 -cache (dbr:dbda
15e0: 74 2d 73 74 6d 74 2d 63 61 63 68 65 20 64 62 64 t-stmt-cache dbd
15f0: 61 74 29 29 0a 09 09 09 20 20 20 20 20 28 64 62 at)).... (db
1600: 68 20 20 20 20 20 20 20 20 28 64 62 72 3a 64 62 h (dbr:db
1610: 64 61 74 2d 64 62 68 20 20 20 20 20 20 20 20 64 dat-dbh d
1620: 62 64 61 74 29 29 29 0a 09 09 09 28 64 62 3a 73 bdat)))....(db:s
1630: 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 6c 69 afely-close-sqli
1640: 74 65 33 2d 64 62 20 64 62 68 20 73 74 6d 74 2d te3-db dbh stmt-
1650: 63 61 63 68 65 29 29 29 0a 09 09 20 20 20 20 74 cache)))... t
1660: 64 62 73 29 0a 09 20 20 20 20 20 20 20 28 64 62 dbs).. (db
1670: 3a 73 61 66 65 6c 79 2d 63 6c 6f 73 65 2d 73 71 :safely-close-sq
1680: 6c 69 74 65 33 2d 64 62 20 6d 74 64 62 64 61 74 lite3-db mtdbdat
1690: 20 28 64 62 72 3a 64 62 64 61 74 2d 73 74 6d 74 (dbr:dbdat-stmt
16a0: 2d 63 61 63 68 65 20 20 28 64 62 72 3a 73 75 62 -cache (dbr:sub
16b0: 64 62 2d 6d 74 64 62 64 61 74 20 73 75 62 64 62 db-mtdbdat subdb
16c0: 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ))) .
16d0: 20 20 20 20 3b 3b 20 28 69 66 20 28 73 71 6c 69 ;; (if (sqli
16e0: 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 6d 64 te3:database? md
16f0: 62 29 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 b) (sqlite3:fina
1700: 6c 69 7a 65 21 20 6d 64 62 29 29 0a 09 20 20 20 lize! mdb))..
1710: 20 20 20 20 23 3b 28 64 62 3a 73 61 66 65 6c 79 #;(db:safely
1720: 2d 63 6c 6f 73 65 2d 73 71 6c 69 74 65 33 2d 64 -close-sqlite3-d
1730: 62 20 72 64 62 20 23 66 29 29 29 20 3b 3b 20 73 b rdb #f))) ;; s
1740: 74 6d 74 2d 63 61 63 68 65 29 29 29 29 29 20 3b tmt-cache))))) ;
1750: 3b 20 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 ; (if (sqlite3:d
1760: 61 74 61 62 61 73 65 3f 20 72 64 62 29 20 28 73 atabase? rdb) (s
1770: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
1780: 20 72 64 62 29 29 29 29 29 29 0a 09 20 20 20 73 rdb)))))).. s
1790: 75 62 64 62 73 29 0a 20 20 20 20 20 20 20 20 20 ubdbs).
17a0: 20 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 29 #t. )
17b0: 0a 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 20 . #f.
17c0: 29 0a 29 0a 0a 3b 3b 20 3b 3b 20 73 65 74 20 75 ).)..;; ;; set u
17d0: 70 20 61 20 73 69 6e 67 6c 65 20 64 62 20 28 65 p a single db (e
17e0: 2e 67 2e 20 6d 61 69 6e 2e 64 62 2c 20 31 2e 64 .g. main.db, 1.d
17f0: 62 20 2e 2e 2e 20 65 74 63 2e 29 0a 3b 3b 20 3b b ... etc.).;; ;
1800: 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 ;.;; (define (db
1810: 3a 73 65 74 75 70 2d 64 62 20 64 62 73 74 72 75 :setup-db dbstru
1820: 63 74 20 61 72 65 61 70 61 74 68 20 72 75 6e 2d ct areapath run-
1830: 69 64 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 id).;; (let* (
1840: 28 64 62 6e 61 6d 65 20 20 20 28 64 62 3a 72 75 (dbname (db:ru
1850: 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e n-id->dbname run
1860: 2d 69 64 29 29 0a 3b 3b 20 09 20 28 64 62 73 74 -id)).;; . (dbst
1870: 72 75 63 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ruct (hash-table
1880: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 64 62 73 -ref/default dbs
1890: 74 72 75 63 74 73 20 64 62 6e 61 6d 65 20 23 66 tructs dbname #f
18a0: 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 64 ))).;; (if d
18b0: 62 73 74 72 75 63 74 0a 3b 3b 20 09 64 62 73 74 bstruct.;; .dbst
18c0: 72 75 63 74 0a 3b 3b 20 09 28 6c 65 74 2a 20 28 ruct.;; .(let* (
18d0: 28 64 62 73 74 72 75 63 74 2d 6e 65 77 20 28 6d (dbstruct-new (m
18e0: 61 6b 65 2d 64 62 72 3a 64 62 73 74 72 75 63 74 ake-dbr:dbstruct
18f0: 29 29 29 0a 3b 3b 20 09 20 20 28 64 62 3a 6f 70 ))).;; . (db:op
1900: 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 2d 6e en-db dbstruct-n
1910: 65 77 20 72 75 6e 2d 69 64 20 61 72 65 61 70 61 ew run-id areapa
1920: 74 68 3a 20 61 72 65 61 70 61 74 68 20 64 6f 2d th: areapath do-
1930: 73 79 6e 63 3a 20 23 74 29 0a 3b 3b 20 09 20 20 sync: #t).;; .
1940: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
1950: 20 64 62 73 74 72 75 63 74 73 20 64 62 6e 61 6d dbstructs dbnam
1960: 65 20 64 62 73 74 72 75 63 74 2d 6e 65 77 29 0a e dbstruct-new).
1970: 3b 3b 20 09 20 20 64 62 73 74 72 75 63 74 2d 6e ;; . dbstruct-n
1980: 65 77 29 29 29 29 0a 20 20 20 20 0a 3b 3b 20 3b ew)))). .;; ;
1990: 20 52 65 74 75 72 6e 73 20 74 68 65 20 64 62 64 Returns the dbd
19a0: 61 74 20 66 6f 72 20 61 20 70 61 72 74 69 63 75 at for a particu
19b0: 6c 61 72 20 64 62 66 69 6c 65 20 69 6e 73 69 64 lar dbfile insid
19c0: 65 20 74 68 65 20 61 72 65 61 0a 3b 3b 20 3b 3b e the area.;; ;;
19d0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 72 .;; (define (dbr
19e0: 3a 64 62 73 74 72 75 63 74 2d 67 65 74 2d 64 62 :dbstruct-get-db
19f0: 64 61 74 20 64 62 73 74 72 75 63 74 20 64 62 66 dat dbstruct dbf
1a00: 69 6c 65 29 0a 3b 3b 20 20 20 28 68 61 73 68 2d ile).;; (hash-
1a10: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1a20: 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d t (dbr:dbstruct-
1a30: 64 62 64 61 74 73 20 64 62 73 74 72 75 63 74 29 dbdats dbstruct)
1a40: 20 64 62 66 69 6c 65 20 23 66 29 29 0a 3b 3b 20 dbfile #f)).;;
1a50: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 62 72 .;; (define (dbr
1a60: 3a 64 62 73 74 72 75 63 74 2d 64 62 64 61 74 2d :dbstruct-dbdat-
1a70: 70 75 74 21 20 64 62 73 74 72 75 63 74 20 64 62 put! dbstruct db
1a80: 66 69 6c 65 20 64 62 29 0a 3b 3b 20 20 20 28 68 file db).;; (h
1a90: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
1aa0: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 64 62 64 dbr:dbstruct-dbd
1ab0: 61 74 73 20 64 62 73 74 72 75 63 74 29 20 64 62 ats dbstruct) db
1ac0: 66 69 6c 65 20 64 62 29 29 0a 3b 3b 20 0a 3b 3b file db)).;; .;;
1ad0: 20 28 64 65 66 69 6e 65 20 28 64 62 3a 72 75 6e (define (db:run
1ae0: 2d 69 64 2d 3e 66 69 72 73 74 2d 6e 75 6d 20 72 -id->first-num r
1af0: 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 28 6c 65 74 un-id).;; (let
1b00: 2a 20 28 28 73 20 28 6e 75 6d 62 65 72 2d 3e 73 * ((s (number->s
1b10: 74 72 69 6e 67 20 72 75 6e 2d 69 64 29 29 0a 3b tring run-id)).;
1b20: 3b 20 09 20 28 6c 20 28 73 74 72 69 6e 67 2d 6c ; . (l (string-l
1b30: 65 6e 67 74 68 20 73 29 29 29 0a 3b 3b 20 20 20 ength s))).;;
1b40: 20 20 28 73 75 62 73 74 72 69 6e 67 20 73 20 28 (substring s (
1b50: 2d 20 6c 20 31 29 20 6c 29 29 29 0a 0a 3b 3b 20 - l 1) l)))..;;
1b60: 31 32 33 34 20 3d 3e 20 34 2f 31 32 33 34 2e 64 1234 => 4/1234.d
1b70: 62 0a 3b 3b 20 20 20 23 66 20 3d 3e 20 30 2f 6d b.;; #f => 0/m
1b80: 61 69 6e 2e 64 62 0a 3b 3b 20 20 20 28 61 62 61 ain.db.;; (aba
1b90: 6e 64 6f 6e 65 64 20 74 68 65 20 69 64 65 61 20 ndoned the idea
1ba0: 6f 66 20 6e 75 6d 2f 64 62 29 0a 3b 3b 20 0a 28 of num/db).;; .(
1bb0: 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 72 define (dbfile:r
1bc0: 75 6e 2d 69 64 2d 3e 70 61 74 68 20 61 70 61 74 un-id->path apat
1bd0: 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 63 6f 6e h run-id). (con
1be0: 63 20 61 70 61 74 68 22 2f 22 28 64 62 66 69 6c c apath"/"(dbfil
1bf0: 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 e:run-id->dbname
1c00: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
1c10: 69 6e 65 20 28 64 62 3a 64 62 6e 61 6d 65 2d 3e ine (db:dbname->
1c20: 70 61 74 68 20 61 70 61 74 68 20 64 62 6e 61 6d path apath dbnam
1c30: 65 29 0a 20 20 28 63 6f 6e 63 20 61 70 61 74 68 e). (conc apath
1c40: 22 2f 22 64 62 6e 61 6d 65 29 29 0a 0a 28 64 65 "/"dbname))..(de
1c50: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 72 75 6e fine (dbfile:run
1c60: 2d 69 64 2d 3e 64 62 6e 75 6d 20 72 75 6e 2d 69 -id->dbnum run-i
1c70: 64 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 d). (cond. ((
1c80: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 0a number? run-id).
1c90: 20 20 20 20 28 6d 6f 64 75 6c 6f 20 72 75 6e 2d (modulo run-
1ca0: 69 64 20 28 6e 75 6d 2d 72 75 6e 2d 64 62 73 29 id (num-run-dbs)
1cb0: 29 29 0a 20 20 20 28 28 6e 6f 74 20 72 75 6e 2d )). ((not run-
1cc0: 69 64 29 20 22 6d 61 69 6e 22 29 20 20 20 3b 3b id) "main") ;;
1cd0: 20 30 20 6f 72 20 6d 61 69 6e 3f 0a 20 20 20 28 0 or main?. (
1ce0: 65 6c 73 65 20 72 75 6e 2d 69 64 29 29 29 0a 0a else run-id)))..
1cf0: 3b 3b 20 50 4f 54 45 4e 54 49 41 4c 20 42 55 47 ;; POTENTIAL BUG
1d00: 3a 20 74 68 69 73 20 69 6d 70 6c 65 6d 65 6e 74 : this implement
1d10: 61 74 69 6f 6e 20 63 6f 75 6c 64 20 70 72 6f 64 ation could prod
1d20: 75 63 65 20 61 20 64 62 20 66 69 6c 65 20 69 66 uce a db file if
1d30: 20 72 75 6e 2d 69 64 20 69 73 20 6e 65 69 74 68 run-id is neith
1d40: 65 72 20 23 66 20 6f 72 20 61 20 6e 75 6d 62 65 er #f or a numbe
1d50: 72 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c r.(define (dbfil
1d60: 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 e:run-id->dbname
1d70: 20 72 75 6e 2d 69 64 29 0a 20 20 28 63 6f 6e 63 run-id). (conc
1d80: 20 22 2e 6d 65 67 61 74 65 73 74 2f 22 28 64 62 ".megatest/"(db
1d90: 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e file:run-id->dbn
1da0: 75 6d 20 72 75 6e 2d 69 64 29 22 2e 64 62 22 29 um run-id)".db")
1db0: 29 0a 0a 3b 3b 20 4d 61 6b 65 20 74 68 65 20 64 )..;; Make the d
1dc0: 62 73 74 72 75 63 74 2c 20 73 65 74 75 70 20 75 bstruct, setup u
1dd0: 70 20 61 75 78 69 6c 6c 61 72 79 20 64 62 27 73 p auxillary db's
1de0: 20 61 6e 64 20 63 61 6c 6c 20 66 6f 72 20 6d 61 and call for ma
1df0: 69 6e 20 64 62 20 61 74 20 6c 65 61 73 74 20 6f in db at least o
1e00: 6e 63 65 0a 3b 3b 0a 3b 3b 20 63 61 6c 6c 65 64 nce.;;.;; called
1e10: 20 69 6e 20 68 74 74 70 2d 74 72 61 6e 73 70 6f in http-transpo
1e20: 72 74 20 61 6e 64 20 72 65 70 6c 69 63 61 74 65 rt and replicate
1e30: 64 20 69 6e 20 72 6d 74 2e 73 63 6d 20 66 6f 72 d in rmt.scm for
1e40: 20 2a 6c 6f 63 61 6c 2a 20 61 63 63 65 73 73 2e *local* access.
1e50: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 .;;.(define (db
1e60: 66 69 6c 65 3a 73 65 74 75 70 20 64 6f 2d 73 79 file:setup do-sy
1e70: 6e 63 20 61 72 65 61 70 61 74 68 20 74 6d 70 70 nc areapath tmpp
1e80: 61 74 68 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 ath). (cond.
1e90: 28 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a 0a (*dbstruct-dbs*.
1ea0: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
1eb0: 74 2d 65 72 72 20 22 57 41 52 4e 49 4e 47 3a 20 t-err "WARNING:
1ec0: 64 62 66 69 6c 65 3a 73 65 74 75 70 20 63 61 6c dbfile:setup cal
1ed0: 6c 65 64 20 77 68 65 6e 20 2a 64 62 73 74 72 75 led when *dbstru
1ee0: 63 74 2d 64 62 73 2a 20 69 73 20 61 6c 72 65 61 ct-dbs* is alrea
1ef0: 64 79 20 69 6e 69 74 69 61 6c 69 7a 65 64 22 29 dy initialized")
1f00: 0a 20 20 20 20 2a 64 62 73 74 72 75 63 74 2d 64 . *dbstruct-d
1f10: 62 73 2a 29 20 3b 3b 20 54 4f 44 4f 3a 20 77 68 bs*) ;; TODO: wh
1f20: 65 6e 20 6d 75 6c 74 69 70 6c 65 20 61 72 65 61 en multiple area
1f30: 73 20 61 72 65 20 73 75 70 70 6f 72 74 65 64 2c s are supported,
1f40: 20 74 68 69 73 20 6f 70 74 69 6d 69 7a 61 74 69 this optimizati
1f50: 6f 6e 20 77 69 6c 6c 20 62 65 20 61 20 68 61 7a on will be a haz
1f60: 61 72 64 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 ard. (else.
1f70: 20 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 63 (let* ((dbstruc
1f80: 74 20 28 6d 61 6b 65 2d 64 62 72 3a 64 62 73 74 t (make-dbr:dbst
1f90: 72 75 63 74 29 29 29 0a 20 20 20 20 20 20 28 73 ruct))). (s
1fa0: 65 74 21 20 2a 64 62 73 74 72 75 63 74 2d 64 62 et! *dbstruct-db
1fb0: 73 2a 20 64 62 73 74 72 75 63 74 29 0a 20 20 20 s* dbstruct).
1fc0: 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 (dbr:dbstruct
1fd0: 2d 61 72 65 61 70 61 74 68 2d 73 65 74 21 20 64 -areapath-set! d
1fe0: 62 73 74 72 75 63 74 20 61 72 65 61 70 61 74 68 bstruct areapath
1ff0: 29 0a 20 20 20 20 20 20 28 64 62 72 3a 64 62 73 ). (dbr:dbs
2000: 74 72 75 63 74 2d 74 6d 70 70 61 74 68 2d 73 65 truct-tmppath-se
2010: 74 21 20 20 64 62 73 74 72 75 63 74 20 74 6d 70 t! dbstruct tmp
2020: 70 61 74 68 29 0a 20 20 20 20 20 20 64 62 73 74 path). dbst
2030: 72 75 63 74 29 29 29 29 0a 0a 28 64 65 66 69 6e ruct))))..(defin
2040: 65 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 e (dbfile:get-su
2050: 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e bdb dbstruct run
2060: 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 -id). (let* ((d
2070: 62 66 6e 61 6d 65 20 28 64 62 66 69 6c 65 3a 72 bfname (dbfile:r
2080: 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 un-id->dbname ru
2090: 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 68 61 73 n-id))). (has
20a0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
20b0: 75 6c 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 ult (dbr:dbstruc
20c0: 74 2d 73 75 62 64 62 73 20 64 62 73 74 72 75 63 t-subdbs dbstruc
20d0: 74 29 20 64 62 66 6e 61 6d 65 20 23 66 29 29 29 t) dbfname #f)))
20e0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c ..(define (dbfil
20f0: 65 3a 73 65 74 2d 73 75 62 64 62 20 64 62 73 74 e:set-subdb dbst
2100: 72 75 63 74 20 72 75 6e 2d 69 64 20 73 75 62 64 ruct run-id subd
2110: 62 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 b). (hash-table
2120: 2d 73 65 74 21 20 28 64 62 72 3a 64 62 73 74 72 -set! (dbr:dbstr
2130: 75 63 74 2d 73 75 62 64 62 73 20 64 62 73 74 72 uct-subdbs dbstr
2140: 75 63 74 29 20 28 64 62 66 69 6c 65 3a 72 75 6e uct) (dbfile:run
2150: 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d -id->dbname run-
2160: 69 64 29 20 73 75 62 64 62 29 29 0a 0a 3b 3b 20 id) subdb))..;;
2170: 28 64 65 66 69 6e 65 20 2a 64 62 66 69 6c 65 3a (define *dbfile:
2180: 6e 75 6d 2d 68 61 6e 64 6c 65 73 2d 69 6e 2d 75 num-handles-in-u
2190: 73 65 2a 20 30 29 0a 0a 3b 3b 20 47 65 74 2f 6f se* 0)..;; Get/o
21a0: 70 65 6e 20 61 20 64 61 74 61 62 61 73 65 2e 0a pen a database..
21b0: 3b 3b 0a 3b 3b 20 20 20 20 4e 4f 54 45 3a 20 6d ;;.;; NOTE: m
21c0: 6f 73 74 20 75 73 61 67 65 20 73 68 6f 75 6c 64 ost usage should
21d0: 20 63 61 6c 6c 20 64 62 66 69 6c 65 3a 6f 70 65 call dbfile:ope
21e0: 6e 2d 64 62 20 74 6f 20 67 65 74 20 61 20 64 62 n-db to get a db
21f0: 64 61 74 0a 3b 3b 0a 3b 3b 20 20 20 20 69 66 20 dat.;;.;; if
2200: 72 75 6e 2d 69 64 20 3d 3e 20 67 65 74 20 72 75 run-id => get ru
2210: 6e 20 73 70 65 63 69 66 69 63 20 64 62 0a 3b 3b n specific db.;;
2220: 20 20 20 20 69 66 20 23 66 20 20 20 20 20 3d 3e if #f =>
2230: 20 67 65 74 20 6d 61 69 6e 20 64 62 0a 3b 3b 20 get main db.;;
2240: 20 20 20 69 66 20 72 75 6e 2d 69 64 20 69 73 20 if run-id is
2250: 61 20 73 74 72 69 6e 67 20 74 72 65 61 74 20 69 a string treat i
2260: 74 20 61 73 20 61 20 66 69 6c 65 6e 61 6d 65 20 t as a filename
2270: 2d 20 44 4f 4e 27 54 20 75 73 65 20 74 68 69 73 - DON'T use this
2280: 20 2d 20 77 65 27 6c 6c 20 67 65 74 20 72 69 64 - we'll get rid
2290: 20 6f 66 20 69 74 2e 0a 3b 3b 20 20 20 20 69 66 of it..;; if
22a0: 20 64 62 20 61 6c 72 65 61 64 79 20 6f 70 65 6e db already open
22b0: 20 2d 20 72 65 74 75 72 6e 20 69 6e 6d 65 6d 0a - return inmem.
22c0: 3b 3b 20 20 20 20 69 66 20 64 62 20 6e 6f 74 20 ;; if db not
22d0: 6f 70 65 6e 2c 20 6f 70 65 6e 20 69 6e 6d 65 6d open, open inmem
22e0: 2c 20 72 75 6e 64 62 20 61 6e 64 20 73 79 6e 63 , rundb and sync
22f0: 20 74 68 65 6e 20 72 65 74 75 72 6e 20 69 6e 6d then return inm
2300: 65 6d 0a 3b 3b 20 20 20 20 69 6e 75 73 65 20 67 em.;; inuse g
2310: 65 74 73 20 73 65 74 20 61 75 74 6f 6d 61 74 69 ets set automati
2320: 63 61 6c 6c 79 20 66 6f 72 20 72 75 6e 64 62 27 cally for rundb'
2330: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 s.;;.(define (db
2340: 66 69 6c 65 3a 67 65 74 2d 64 62 64 61 74 20 64 file:get-dbdat d
2350: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 0a bstruct run-id).
2360: 20 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 20 (let* ((subdb
2370: 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 (dbfile:get-subd
2380: 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 b dbstruct run-i
2390: 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 d))). (if (st
23a0: 61 63 6b 2d 65 6d 70 74 79 3f 20 28 64 62 72 3a ack-empty? (dbr:
23b0: 73 75 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 subdb-dbstack su
23c0: 62 64 62 29 29 0a 09 23 66 0a 09 28 62 65 67 69 bdb))..#f..(begi
23d0: 6e 0a 09 20 20 28 73 74 61 63 6b 2d 70 6f 70 21 n.. (stack-pop!
23e0: 20 28 64 62 72 3a 73 75 62 64 62 2d 64 62 73 74 (dbr:subdb-dbst
23f0: 61 63 6b 20 73 75 62 64 62 29 29 29 29 29 29 0a ack subdb)))))).
2400: 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 70 72 65 .;; return a pre
2410: 76 69 6f 75 73 6c 79 20 6f 70 65 6e 65 64 20 64 viously opened d
2420: 62 20 68 61 6e 64 6c 65 20 74 6f 20 74 68 65 20 b handle to the
2430: 73 74 61 63 6b 20 6f 66 20 61 76 61 69 6c 61 62 stack of availab
2440: 6c 65 20 68 61 6e 64 6c 65 73 0a 28 64 65 66 69 le handles.(defi
2450: 6e 65 20 28 64 62 66 69 6c 65 3a 61 64 64 2d 64 ne (dbfile:add-d
2460: 62 64 61 74 20 64 62 73 74 72 75 63 74 20 72 75 bdat dbstruct ru
2470: 6e 2d 69 64 20 64 62 64 61 74 29 0a 20 20 28 6c n-id dbdat). (l
2480: 65 74 2a 20 28 28 73 75 62 64 62 20 28 64 62 66 et* ((subdb (dbf
2490: 69 6c 65 3a 67 65 74 2d 73 75 62 64 62 20 64 62 ile:get-subdb db
24a0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 29 29 0a struct run-id)).
24b0: 09 20 28 64 62 73 74 6b 20 28 64 62 72 3a 73 75 . (dbstk (dbr:su
24c0: 62 64 62 2d 64 62 73 74 61 63 6b 20 73 75 62 64 bdb-dbstack subd
24d0: 62 29 29 0a 09 20 28 63 6f 75 6e 74 20 28 73 74 b)).. (count (st
24e0: 61 63 6b 2d 63 6f 75 6e 74 20 64 62 73 74 6b 29 ack-count dbstk)
24f0: 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 63 6f )). (if (> co
2500: 75 6e 74 20 31 35 29 0a 09 28 64 62 66 69 6c 65 unt 15)..(dbfile
2510: 3a 70 72 69 6e 74 2d 65 72 72 20 22 57 41 52 4e :print-err "WARN
2520: 49 4e 47 3a 20 73 74 61 63 6b 20 66 6f 72 20 22 ING: stack for "
2530: 72 75 6e 2d 69 64 22 2e 64 62 20 69 73 20 22 63 run-id".db is "c
2540: 6f 75 6e 74 22 2e 22 29 29 0a 20 20 20 20 28 73 ount".")). (s
2550: 74 61 63 6b 2d 70 75 73 68 21 20 64 62 73 74 6b tack-push! dbstk
2560: 20 64 62 64 61 74 29 0a 20 20 20 20 64 62 64 61 dbdat). dbda
2570: 74 29 29 0a 0a 3b 3b 20 73 65 74 20 75 70 20 61 t))..;; set up a
2580: 20 73 75 62 64 62 0a 3b 3b 0a 28 64 65 66 69 6e subdb.;;.(defin
2590: 65 20 28 64 62 66 69 6c 65 3a 69 6e 69 74 2d 73 e (dbfile:init-s
25a0: 75 62 64 62 20 64 62 73 74 72 75 63 74 20 72 75 ubdb dbstruct ru
25b0: 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a n-id init-proc).
25c0: 20 20 28 6c 65 74 2a 20 28 28 64 62 6e 61 6d 65 (let* ((dbname
25d0: 20 20 20 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d (dbfile:run-
25e0: 69 64 2d 3e 64 62 6e 61 6d 65 20 72 75 6e 2d 69 id->dbname run-i
25f0: 64 29 29 0a 09 20 28 61 72 65 61 70 61 74 68 20 d)).. (areapath
2600: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 61 (dbr:dbstruct-a
2610: 72 65 61 70 61 74 68 20 64 62 73 74 72 75 63 74 reapath dbstruct
2620: 29 29 0a 09 20 28 74 6d 70 70 61 74 68 20 20 20 )).. (tmppath
2630: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d (dbr:dbstruct-tm
2640: 70 70 61 74 68 20 20 64 62 73 74 72 75 63 74 29 ppath dbstruct)
2650: 29 0a 09 20 28 6d 74 64 62 70 61 74 68 20 20 28 ).. (mtdbpath (
2660: 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 dbfile:run-id->p
2670: 61 74 68 20 61 72 65 61 70 61 74 68 20 72 75 6e ath areapath run
2680: 2d 69 64 29 29 0a 09 20 28 74 6d 70 64 62 70 61 -id)).. (tmpdbpa
2690: 74 68 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 th (dbfile:run-i
26a0: 64 2d 3e 70 61 74 68 20 74 6d 70 70 61 74 68 20 d->path tmppath
26b0: 72 75 6e 2d 69 64 29 29 0a 09 20 28 6d 74 64 62 run-id)).. (mtdb
26c0: 64 61 74 20 20 20 28 64 62 66 69 6c 65 3a 6f 70 dat (dbfile:op
26d0: 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 6d 74 en-sqlite3-db mt
26e0: 64 62 70 61 74 68 20 69 6e 69 74 2d 70 72 6f 63 dbpath init-proc
26f0: 20 73 79 6e 63 2d 6d 6f 64 65 3a 20 30 20 6a 6f sync-mode: 0 jo
2700: 75 72 6e 61 6c 2d 6d 6f 64 65 3a 20 23 66 29 29 urnal-mode: #f))
2710: 20 3b 3b 20 22 57 41 4c 22 29 29 0a 09 20 28 6e ;; "WAL")).. (n
2720: 65 77 73 75 62 64 62 20 20 28 6d 61 6b 65 2d 64 ewsubdb (make-d
2730: 62 72 3a 73 75 62 64 62 20 64 62 6e 61 6d 65 3a br:subdb dbname:
2740: 20 20 20 20 64 62 6e 61 6d 65 0a 09 09 09 09 20 dbname.....
2750: 20 20 20 6d 74 64 62 66 69 6c 65 3a 20 20 6d 74 mtdbfile: mt
2760: 64 62 70 61 74 68 0a 09 09 09 09 20 20 20 20 74 dbpath..... t
2770: 6d 70 64 62 66 69 6c 65 3a 20 74 6d 70 64 62 70 mpdbfile: tmpdbp
2780: 61 74 68 0a 09 09 09 09 20 20 20 20 6d 74 64 62 ath..... mtdb
2790: 64 61 74 3a 20 20 20 6d 74 64 62 64 61 74 29 29 dat: mtdbdat))
27a0: 29 0a 20 20 20 20 28 64 62 66 69 6c 65 3a 73 65 ). (dbfile:se
27b0: 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 74 t-subdb dbstruct
27c0: 20 72 75 6e 2d 69 64 20 6e 65 77 73 75 62 64 62 run-id newsubdb
27d0: 29 0a 20 20 20 20 6e 65 77 73 75 62 64 62 29 29 ). newsubdb))
27e0: 20 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 6e ;; return the n
27f0: 65 77 20 73 75 62 64 62 20 2d 20 62 75 74 20 73 ew subdb - but s
2800: 68 6f 75 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 houldn't really
2810: 75 73 65 20 69 74 0a 0a 3b 3b 20 72 65 74 75 72 use it..;; retur
2820: 6e 73 20 64 62 64 61 74 20 77 69 74 68 20 64 62 ns dbdat with db
2830: 68 20 61 6e 64 20 64 62 66 69 6c 65 70 61 74 68 h and dbfilepath
2840: 0a 3b 3b 0a 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 .;;.;; NOTE: the
2850: 20 68 61 6e 64 6c 65 20 69 73 20 6f 6e 20 2f 74 handle is on /t
2860: 6d 70 20 64 62 20 66 69 6c 65 21 0a 3b 3b 0a 3b mp db file!.;;.;
2870: 3b 20 20 31 2e 20 69 66 20 6e 65 65 64 65 64 20 ; 1. if needed
2880: 73 65 74 75 70 20 74 68 65 20 73 75 62 64 62 20 setup the subdb
2890: 66 6f 72 20 74 68 65 20 67 69 76 65 6e 20 72 75 for the given ru
28a0: 6e 2d 69 64 0a 3b 3b 20 20 32 2e 20 69 66 20 74 n-id.;; 2. if t
28b0: 68 65 72 65 20 69 73 20 6e 6f 20 65 78 69 73 74 here is no exist
28c0: 69 6e 67 20 64 62 20 68 61 6e 64 6c 65 20 69 6e ing db handle in
28d0: 20 74 68 65 20 73 74 61 63 6b 0a 3b 3b 20 20 20 the stack.;;
28e0: 20 20 63 72 65 61 74 65 20 61 20 6e 65 77 20 68 create a new h
28f0: 61 6e 64 6c 65 20 61 6e 64 20 72 65 74 75 72 6e andle and return
2900: 20 69 74 20 28 64 6f 20 4e 4f 54 20 61 64 64 0a it (do NOT add.
2910: 3b 3b 20 20 20 20 20 69 74 20 74 6f 20 74 68 65 ;; it to the
2920: 20 73 74 61 63 6b 29 2e 0a 3b 3b 0a 28 64 65 66 stack)..;;.(def
2930: 69 6e 65 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e ine (dbfile:open
2940: 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e -db dbstruct run
2950: 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 29 0a 20 -id init-proc).
2960: 20 28 6c 65 74 2a 20 28 28 73 75 62 64 62 20 28 (let* ((subdb (
2970: 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 64 62 dbfile:get-subdb
2980: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
2990: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
29a0: 20 73 75 62 64 62 29 20 3b 3b 20 6e 6f 74 20 79 subdb) ;; not y
29b0: 65 74 20 64 65 66 69 6e 65 64 0a 09 28 62 65 67 et defined..(beg
29c0: 69 6e 0a 09 20 20 28 64 62 66 69 6c 65 3a 69 6e in.. (dbfile:in
29d0: 69 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 63 it-subdb dbstruc
29e0: 74 20 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 t run-id init-pr
29f0: 6f 63 29 0a 09 20 20 28 64 62 66 69 6c 65 3a 6f oc).. (dbfile:o
2a00: 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 74 20 pen-db dbstruct
2a10: 72 75 6e 2d 69 64 20 69 6e 69 74 2d 70 72 6f 63 run-id init-proc
2a20: 29 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 64 61 ))..(let* ((dbda
2a30: 74 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 64 62 t (dbfile:get-db
2a40: 64 61 74 20 64 62 73 74 72 75 63 74 20 72 75 6e dat dbstruct run
2a50: 2d 69 64 29 29 29 0a 09 20 20 28 69 66 20 64 62 -id))).. (if db
2a60: 64 61 74 0a 09 20 20 20 20 20 20 64 62 64 61 74 dat.. dbdat
2a70: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
2a80: 74 6d 70 70 61 74 68 20 20 20 28 64 62 72 3a 64 tmppath (dbr:d
2a90: 62 73 74 72 75 63 74 2d 74 6d 70 70 61 74 68 20 bstruct-tmppath
2aa0: 20 64 62 73 74 72 75 63 74 29 29 0a 09 09 20 20 dbstruct))...
2ab0: 20 20 20 28 74 6d 70 64 62 70 61 74 68 20 28 64 (tmpdbpath (d
2ac0: 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e 70 61 bfile:run-id->pa
2ad0: 74 68 20 74 6d 70 70 61 74 68 20 72 75 6e 2d 69 th tmppath run-i
2ae0: 64 29 29 0a 09 09 20 20 20 20 20 28 64 62 64 61 d))... (dbda
2af0: 74 20 20 20 20 20 28 64 62 66 69 6c 65 3a 6f 70 t (dbfile:op
2b00: 65 6e 2d 73 71 6c 69 74 65 33 2d 64 62 20 74 6d en-sqlite3-db tm
2b10: 70 64 62 70 61 74 68 20 69 6e 69 74 2d 70 72 6f pdbpath init-pro
2b20: 63 20 73 79 6e 63 2d 6d 6f 64 65 3a 20 30 20 6a c sync-mode: 0 j
2b30: 6f 75 72 6e 61 6c 2d 6d 6f 64 65 3a 20 22 57 41 ournal-mode: "WA
2b40: 4c 22 29 29 29 0a 09 09 3b 3b 20 74 68 65 20 66 L")))...;; the f
2b50: 6f 6c 6c 6f 77 69 6e 67 20 6c 69 6e 65 20 73 68 ollowing line sh
2b60: 6f 72 74 2d 63 69 72 63 75 69 74 73 20 74 68 65 ort-circuits the
2b70: 20 22 6f 6e 65 20 64 62 20 68 61 6e 64 6c 65 20 "one db handle
2b80: 70 65 72 20 74 68 72 65 61 64 22 20 6d 6f 64 65 per thread" mode
2b90: 6c 0a 09 09 3b 3b 20 0a 09 09 3b 3b 20 28 64 62 l...;; ...;; (db
2ba0: 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 20 64 file:add-dbdat d
2bb0: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 bstruct run-id d
2bc0: 62 64 61 74 29 0a 09 09 3b 3b 0a 09 09 64 62 64 bdat)...;;...dbd
2bd0: 61 74 29 29 29 29 29 29 0a 20 20 20 20 0a 3b 3b at)))))). .;;
2be0: 20 43 4f 4d 42 49 4e 45 20 64 62 66 69 6c 65 3a COMBINE dbfile:
2bf0: 6f 70 65 6e 2d 73 71 6c 69 74 65 2d 64 62 20 61 open-sqlite-db a
2c00: 6e 64 20 64 62 66 69 6c 65 3a 6c 6f 63 6b 2d 63 nd dbfile:lock-c
2c10: 72 65 61 74 65 2d 6f 70 65 6e 0a 3b 3b 0a 0a 3b reate-open.;;..;
2c20: 3b 20 74 68 69 73 20 73 74 75 66 66 20 69 73 20 ; this stuff is
2c30: 66 6f 72 20 69 6e 69 74 69 61 6c 20 64 65 62 75 for initial debu
2c40: 67 67 69 6e 67 2c 20 70 6c 65 61 73 65 20 72 65 gging, please re
2c50: 6d 6f 76 65 20 69 74 20 77 68 65 6e 0a 3b 3b 20 move it when.;;
2c60: 74 68 69 73 20 63 6f 64 65 20 73 74 61 62 69 6c this code stabil
2c70: 69 7a 65 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 izes.(define *db
2c80: 6f 70 65 6e 73 2a 20 28 6d 61 6b 65 2d 68 61 73 opens* (make-has
2c90: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
2ca0: 65 20 28 64 62 66 69 6c 65 3a 69 6e 63 2d 64 62 e (dbfile:inc-db
2cb0: 2d 6f 70 65 6e 20 64 62 66 69 6c 65 29 0a 20 20 -open dbfile).
2cc0: 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 6f 70 65 (let* ((curr-ope
2cd0: 6e 73 2d 63 6f 75 6e 74 20 28 2b 20 28 68 61 73 ns-count (+ (has
2ce0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2cf0: 75 6c 74 20 2a 64 62 6f 70 65 6e 73 2a 20 64 62 ult *dbopens* db
2d00: 66 69 6c 65 20 30 29 20 31 29 29 29 0a 20 20 20 file 0) 1))).
2d10: 20 28 69 66 20 28 61 6e 64 20 28 3e 20 63 75 72 (if (and (> cur
2d20: 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 20 31 29 r-opens-count 1)
2d30: 20 3b 3b 20 74 68 69 73 20 73 68 6f 75 6c 64 20 ;; this should
2d40: 4e 4f 54 20 62 65 20 68 61 70 70 65 6e 69 6e 67 NOT be happening
2d50: 0a 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c .. (common:l
2d60: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 ow-noise-print 1
2d70: 35 20 22 64 62 2d 6f 70 65 6e 73 22 29 29 0a 09 5 "db-opens"))..
2d80: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
2d90: 72 20 22 49 4e 46 4f 3a 20 64 62 20 22 64 62 66 r "INFO: db "dbf
2da0: 69 6c 65 22 20 68 61 73 20 62 65 65 6e 20 6f 70 ile" has been op
2db0: 65 6e 65 64 20 22 63 75 72 72 2d 6f 70 65 6e 73 ened "curr-opens
2dc0: 2d 63 6f 75 6e 74 22 20 74 69 6d 65 73 21 22 29 -count" times!")
2dd0: 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ). (hash-tabl
2de0: 65 2d 73 65 74 21 20 2a 64 62 6f 70 65 6e 73 2a e-set! *dbopens*
2df0: 20 64 62 66 69 6c 65 20 63 75 72 72 2d 6f 70 65 dbfile curr-ope
2e00: 6e 73 2d 63 6f 75 6e 74 29 0a 20 20 20 20 63 75 ns-count). cu
2e10: 72 72 2d 6f 70 65 6e 73 2d 63 6f 75 6e 74 29 29 rr-opens-count))
2e20: 0a 0a 3b 3b 20 4f 70 65 6e 20 74 68 65 20 63 6c ..;; Open the cl
2e30: 61 73 73 69 63 20 6d 65 67 61 74 65 73 74 2e 64 assic megatest.d
2e40: 62 20 66 69 6c 65 20 28 64 65 66 61 75 6c 74 73 b file (defaults
2e50: 20 74 6f 20 6f 70 65 6e 20 69 6e 20 74 6f 70 70 to open in topp
2e60: 61 74 68 29 0a 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 ath).;;.;; NOT
2e70: 45 3a 20 72 65 74 75 72 6e 73 20 61 20 64 62 64 E: returns a dbd
2e80: 61 74 20 6e 6f 74 20 61 20 64 62 73 74 72 75 63 at not a dbstruc
2e90: 74 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 t!.;;.(define (d
2ea0: 62 66 69 6c 65 3a 6f 70 65 6e 2d 73 71 6c 69 74 bfile:open-sqlit
2eb0: 65 33 2d 64 62 20 64 62 70 61 74 68 20 69 6e 69 e3-db dbpath ini
2ec0: 74 2d 70 72 6f 63 20 23 21 6b 65 79 20 28 73 79 t-proc #!key (sy
2ed0: 6e 63 2d 6d 6f 64 65 20 30 29 28 6a 6f 75 72 6e nc-mode 0)(journ
2ee0: 61 6c 2d 6d 6f 64 65 20 23 66 29 29 0a 20 20 28 al-mode #f)). (
2ef0: 6c 65 74 2a 20 28 28 64 62 65 78 69 73 74 73 20 let* ((dbexists
2f00: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
2f10: 3f 20 64 62 70 61 74 68 29 29 0a 09 20 28 77 72 ? dbpath)).. (wr
2f20: 69 74 65 2d 61 63 63 65 73 73 20 28 66 69 6c 65 ite-access (file
2f30: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 -write-access? d
2f40: 62 70 61 74 68 29 29 0a 09 20 28 64 62 20 20 20 bpath)).. (db
2f50: 20 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a (dbfile:
2f60: 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 cautious-open-da
2f70: 74 61 62 61 73 65 20 64 62 70 61 74 68 20 69 6e tabase dbpath in
2f80: 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 it-proc sync-mod
2f90: 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 29 29 e journal-mode))
2fa0: 29 0a 20 20 20 20 28 64 62 66 69 6c 65 3a 69 6e ). (dbfile:in
2fb0: 63 2d 64 62 2d 6f 70 65 6e 20 64 62 70 61 74 68 c-db-open dbpath
2fc0: 29 0a 20 20 20 20 3b 3b 20 28 69 6e 69 74 2d 70 ). ;; (init-p
2fd0: 72 6f 63 20 64 62 29 0a 20 20 20 20 28 6d 61 6b roc db). (mak
2fe0: 65 2d 64 62 72 3a 64 62 64 61 74 20 64 62 66 69 e-dbr:dbdat dbfi
2ff0: 6c 65 3a 20 64 62 70 61 74 68 20 64 62 68 3a 20 le: dbpath dbh:
3000: 64 62 20 72 65 61 64 2d 6f 6e 6c 79 3a 20 28 6e db read-only: (n
3010: 6f 74 20 77 72 69 74 65 2d 61 63 63 65 73 73 29 ot write-access)
3020: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 )))..(define (db
3030: 66 69 6c 65 3a 70 72 69 6e 74 2d 61 6e 64 2d 65 file:print-and-e
3040: 78 69 74 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 xit . params).
3050: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
3060: 70 6f 72 74 0a 20 20 20 20 20 20 28 63 75 72 72 port. (curr
3070: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a ent-error-port).
3080: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 (lambda ().
3090: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e (apply prin
30a0: 74 20 70 61 72 61 6d 73 29 29 29 0a 20 20 28 65 t params))). (e
30b0: 78 69 74 20 31 29 29 0a 20 20 20 20 0a 28 64 65 xit 1)). .(de
30c0: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 70 72 69 fine (dbfile:pri
30d0: 6e 74 2d 65 72 72 20 2e 20 70 61 72 61 6d 73 29 nt-err . params)
30e0: 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
30f0: 74 6f 2d 70 6f 72 74 0a 20 20 20 20 20 20 28 63 to-port. (c
3100: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
3110: 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 t). (lambda (
3120: 29 0a 20 20 20 20 20 20 28 61 70 70 6c 79 20 70 ). (apply p
3130: 72 69 6e 74 20 70 61 72 61 6d 73 29 29 29 29 0a rint params)))).
3140: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
3150: 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 :cautious-open-d
3160: 61 74 61 62 61 73 65 20 66 6e 61 6d 65 20 69 6e atabase fname in
3170: 69 74 2d 70 72 6f 63 20 73 79 6e 63 2d 6d 6f 64 it-proc sync-mod
3180: 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 20 23 e journal-mode #
3190: 21 6f 70 74 69 6f 6e 61 6c 20 28 74 72 69 65 73 !optional (tries
31a0: 2d 6c 65 66 74 20 35 30 30 29 29 0a 20 20 28 6c -left 500)). (l
31b0: 65 74 2a 20 28 28 62 75 73 79 2d 66 69 6c 65 20 et* ((busy-file
31c0: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2d 6a (conc fname "-j
31d0: 6f 75 72 6e 61 6c 22 29 29 0a 09 20 28 64 65 6c ournal")).. (del
31e0: 61 79 2d 74 69 6d 65 20 28 2a 20 28 2d 20 35 31 ay-time (* (- 51
31f0: 20 74 72 69 65 73 2d 6c 65 66 74 29 20 31 2e 31 tries-left) 1.1
3200: 29 29 0a 20 20 20 20 20 20 09 20 28 77 72 69 74 )). . (writ
3210: 65 2d 61 63 63 65 73 73 20 28 66 69 6c 65 2d 77 e-access (file-w
3220: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 6e 61 rite-access? fna
3230: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 64 me)). (d
3240: 69 72 2d 61 63 63 65 73 73 20 28 66 69 6c 65 2d ir-access (file-
3250: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 70 write-access? (p
3260: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
3270: 79 20 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 y fname))).
3280: 20 20 20 20 28 72 65 74 72 79 20 20 20 20 20 20 (retry
3290: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
32a0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
32b0: 70 21 20 64 65 6c 61 79 2d 74 69 6d 65 29 0a 09 p! delay-time)..
32c0: 09 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 74 . (if (> t
32d0: 72 69 65 73 2d 6c 65 66 74 20 30 29 0a 09 09 09 ries-left 0)....
32e0: 20 20 20 28 64 62 66 69 6c 65 3a 63 61 75 74 69 (dbfile:cauti
32f0: 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 ous-open-databas
3300: 65 20 66 6e 61 6d 65 20 69 6e 69 74 2d 70 72 6f e fname init-pro
3310: 63 0a 09 09 09 09 09 09 09 20 20 73 79 6e 63 2d c........ sync-
3320: 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 mode journal-mod
3330: 65 0a 09 09 09 09 09 09 09 20 20 28 2d 20 74 72 e........ (- tr
3340: 69 65 73 2d 6c 65 66 74 20 31 29 29 29 29 29 29 ies-left 1))))))
3350: 0a 20 20 20 20 28 61 73 73 65 72 74 20 28 3e 3d . (assert (>=
3360: 20 74 72 69 65 73 2d 6c 65 66 74 20 30 29 20 28 tries-left 0) (
3370: 63 6f 6e 63 20 22 46 41 54 41 4c 3a 20 74 6f 6f conc "FATAL: too
3380: 20 6d 61 6e 79 20 61 74 74 65 6d 70 74 73 20 69 many attempts i
3390: 6e 20 64 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 n dbfile:cautiou
33a0: 73 2d 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 s-open-database
33b0: 6f 66 20 22 66 6e 61 6d 65 22 2c 20 67 69 76 69 of "fname", givi
33c0: 6e 67 20 75 70 2e 22 29 29 0a 20 20 20 20 0a 20 ng up.")). .
33d0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
33e0: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
33f0: 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 66 69 fname).. (fi
3400: 6c 65 2d 65 78 69 73 74 73 3f 20 62 75 73 79 2d le-exists? busy-
3410: 66 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 file))..(begin..
3420: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f (if (common:lo
3430: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 w-noise-print 12
3440: 30 20 62 75 73 79 2d 66 69 6c 65 29 0a 09 20 20 0 busy-file)..
3450: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
3460: 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 64 62 66 t-err "INFO: dbf
3470: 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f 70 65 ile:cautious-ope
3480: 6e 2d 64 61 74 61 62 61 73 65 3a 20 6a 6f 75 72 n-database: jour
3490: 6e 61 6c 20 66 69 6c 65 20 22 0a 09 09 09 09 62 nal file ".....b
34a0: 75 73 79 2d 66 69 6c 65 22 20 65 78 69 73 74 73 usy-file" exists
34b0: 2c 20 74 72 79 69 6e 67 20 61 67 61 69 6e 20 69 , trying again i
34c0: 6e 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 22 29 n few seconds.")
34d0: 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ).. (thread-sle
34e0: 65 70 21 20 31 29 0a 09 20 20 28 69 66 20 28 65 ep! 1).. (if (e
34f0: 71 3f 20 74 72 69 65 73 2d 6c 65 66 74 20 32 29 q? tries-left 2)
3500: 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
3510: 20 20 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 .(dbfile:print
3520: 2d 65 72 72 20 22 49 4e 46 4f 3a 20 66 6f 72 63 -err "INFO: forc
3530: 69 6e 67 20 6a 6f 75 72 6e 61 6c 20 72 6f 6c 6c ing journal roll
3540: 75 70 20 22 62 75 73 79 2d 66 69 6c 65 29 0a 09 up "busy-file)..
3550: 20 20 09 28 64 62 66 69 6c 65 3a 62 72 75 74 65 .(dbfile:brute
3560: 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 65 2d 64 -force-salvage-d
3570: 62 20 66 6e 61 6d 65 29 29 29 0a 09 20 20 28 64 b fname))).. (d
3580: 62 66 69 6c 65 3a 63 61 75 74 69 6f 75 73 2d 6f bfile:cautious-o
3590: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 pen-database fna
35a0: 6d 65 20 69 6e 69 74 2d 70 72 6f 63 20 73 79 6e me init-proc syn
35b0: 63 2d 6d 6f 64 65 20 6a 6f 75 72 6e 61 6c 2d 6d c-mode journal-m
35c0: 6f 64 65 20 28 2d 20 74 72 69 65 73 2d 6c 65 66 ode (- tries-lef
35d0: 74 20 31 29 29 29 0a 09 0a 09 28 6c 65 74 2a 20 t 1)))....(let*
35e0: 28 28 72 65 73 75 6c 74 20 28 63 6f 6e 64 69 74 ((result (condit
35f0: 69 6f 6e 2d 63 61 73 65 0a 09 09 20 20 20 20 20 ion-case...
3600: 20 20 20 28 69 66 20 64 69 72 2d 61 63 63 65 73 (if dir-acces
3610: 73 0a 09 09 09 20 20 20 20 28 64 62 66 69 6c 65 s.... (dbfile
3620: 3a 77 69 74 68 2d 73 69 6d 70 6c 65 2d 66 69 6c :with-simple-fil
3630: 65 2d 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 28 e-lock.... (
3640: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 6c 6f 63 conc fname ".loc
3650: 6b 22 29 0a 09 09 09 20 20 20 20 20 28 6c 61 6d k").... (lam
3660: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
3670: 20 28 6c 65 74 2a 20 28 28 64 62 2d 65 78 69 73 (let* ((db-exis
3680: 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ts (file-exists?
3690: 20 66 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 20 fname)).....
36a0: 20 20 20 28 64 62 20 20 20 20 20 20 20 20 28 73 (db (s
36b0: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
36c0: 62 61 73 65 20 66 6e 61 6d 65 29 29 29 20 3b 3b base fname))) ;;
36d0: 20 63 72 65 61 74 65 73 20 61 6e 20 65 6d 70 74 creates an empt
36e0: 79 20 64 62 20 69 66 20 69 74 20 64 69 64 20 6e y db if it did n
36f0: 6f 74 20 61 6c 72 65 61 64 79 20 65 78 69 73 74 ot already exist
3700: 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3720: 20 20 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d (sqlite3:set-
3730: 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 busy-handler! db
3740: 20 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 (sqlite3:make-b
3750: 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 30 30 30 usy-timeout 3000
3760: 30 29 29 0a 09 09 09 09 20 28 69 66 20 73 79 6e 0))..... (if syn
3770: 63 2d 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 20 c-mode.....
3780: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3790: 20 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 4d db (conc "PRAGM
37a0: 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d 20 A synchronous =
37b0: 22 73 79 6e 63 2d 6d 6f 64 65 22 3b 22 29 29 29 "sync-mode";")))
37c0: 0a 09 09 09 09 20 28 69 66 20 6a 6f 75 72 6e 61 ..... (if journa
37d0: 6c 2d 6d 6f 64 65 0a 09 09 09 09 20 20 20 20 20 l-mode.....
37e0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
37f0: 20 64 62 20 28 63 6f 6e 63 20 22 50 52 41 47 4d db (conc "PRAGM
3800: 41 20 6a 6f 75 72 6e 61 6c 5f 6d 6f 64 65 20 3d A journal_mode =
3810: 20 22 6a 6f 75 72 6e 61 6c 2d 6d 6f 64 65 22 3b "journal-mode";
3820: 22 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 61 ")))..... (if (a
3830: 6e 64 20 69 6e 69 74 2d 70 72 6f 63 20 28 6e 6f nd init-proc (no
3840: 74 20 64 62 2d 65 78 69 73 74 73 29 29 0a 09 09 t db-exists))...
3850: 09 09 20 20 20 20 20 28 69 6e 69 74 2d 70 72 6f .. (init-pro
3860: 63 20 64 62 29 29 0a 09 09 09 09 20 64 62 29 29 c db))..... db))
3870: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
3890: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 69 egin.... (i
38a0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
38b0: 66 6e 61 6d 65 20 29 0a 20 20 20 20 20 20 20 20 fname ).
38c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38d0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
38e0: 28 64 62 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 (db (sqlite3:ope
38f0: 6e 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 n-database fname
3900: 29 29 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 70 )))..... ;; p
3910: 72 61 67 6d 61 73 20 73 79 6e 63 68 72 6f 6e 6f ragmas synchrono
3920: 75 73 20 6e 6f 74 20 6e 65 65 64 65 64 20 62 65 us not needed be
3930: 63 61 75 73 65 20 74 68 69 73 20 64 62 20 69 73 cause this db is
3940: 20 75 73 65 64 20 72 65 61 64 2d 6f 6e 6c 79 0a used read-only.
3950: 09 09 09 09 20 20 20 20 3b 3b 20 28 73 71 6c 69 .... ;; (sqli
3960: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 te3:execute db (
3970: 63 6f 6e 63 20 22 50 52 41 47 4d 41 20 73 79 6e conc "PRAGMA syn
3980: 63 68 72 6f 6e 6f 75 73 20 3d 20 22 6d 6f 64 65 chronous = "mode
3990: 22 3b 22 29 0a 09 09 09 09 20 20 20 20 28 73 71 ";")..... (sq
39a0: 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 lite3:set-busy-h
39b0: 61 6e 64 6c 65 72 21 20 64 62 20 28 73 71 6c 69 andler! db (sqli
39c0: 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 2d 74 69 te3:make-busy-ti
39d0: 6d 65 6f 75 74 20 33 30 30 30 30 29 29 20 3b 3b meout 30000)) ;;
39e0: 20 72 65 61 64 2d 6f 6e 6c 79 20 62 75 74 20 73 read-only but s
39f0: 74 69 6c 6c 20 6e 65 65 64 20 74 69 6d 65 6f 75 till need timeou
3a00: 74 0a 09 09 09 09 20 20 20 20 64 62 20 29 0a 20 t..... db ).
3a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a30: 20 28 70 72 69 6e 74 20 22 66 69 6c 65 20 64 6f (print "file do
3a40: 65 73 6e 27 74 20 65 78 69 73 74 3a 20 22 20 66 esn't exist: " f
3a50: 6e 61 6d 65 29 29 29 29 0a 09 09 09 28 65 78 6e name))))....(exn
3a60: 20 28 69 6f 2d 65 72 72 6f 72 29 0a 09 09 09 20 (io-error)....
3a70: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
3a80: 74 2d 65 72 72 20 65 78 6e 20 22 45 52 52 4f 52 t-err exn "ERROR
3a90: 3a 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 : i/o error with
3aa0: 20 22 20 66 6e 61 6d 65 20 22 2e 20 43 68 65 63 " fname ". Chec
3ab0: 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 k permissions, d
3ac0: 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e 20 61 isk space etc. a
3ad0: 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 29 0a nd try again.").
3ae0: 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 ... (retry))
3af0: 0a 09 09 09 28 65 78 6e 20 28 63 6f 72 72 75 70 ....(exn (corrup
3b00: 74 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 69 t).... (dbfi
3b10: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 6e le:print-err exn
3b20: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
3b30: 65 20 22 20 66 6e 61 6d 65 20 22 20 69 73 20 63 e " fname " is c
3b40: 6f 72 72 75 70 74 2e 20 52 65 70 61 69 72 20 69 orrupt. Repair i
3b50: 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 22 29 0a t to proceed.").
3b60: 09 09 09 20 20 20 20 20 28 72 65 74 72 79 29 29 ... (retry))
3b70: 0a 09 09 09 28 65 78 6e 20 28 62 75 73 79 29 0a ....(exn (busy).
3b80: 09 09 09 20 20 20 20 20 28 64 62 66 69 6c 65 3a ... (dbfile:
3b90: 70 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 print-err exn "E
3ba0: 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 RROR: database "
3bb0: 20 66 6e 61 6d 65 0a 09 09 09 09 09 20 20 20 20 fname......
3bc0: 20 20 20 22 20 69 73 20 6c 6f 63 6b 65 64 2e 20 " is locked.
3bd0: 54 72 79 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 Try copying to a
3be0: 6e 6f 74 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c nother location,
3bf0: 20 72 65 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c remove original
3c00: 20 61 6e 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 and copy back."
3c10: 29 0a 09 09 09 20 20 20 20 20 28 72 65 74 72 79 ).... (retry
3c20: 29 29 0a 09 09 09 28 65 78 6e 20 28 70 65 72 6d ))....(exn (perm
3c30: 69 73 73 69 6f 6e 29 28 64 62 66 69 6c 65 3a 70 ission)(dbfile:p
3c40: 72 69 6e 74 2d 65 72 72 20 65 78 6e 20 22 45 52 rint-err exn "ER
3c50: 52 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 ROR: database "
3c60: 66 6e 61 6d 65 20 22 20 68 61 73 20 73 6f 6d 65 fname " has some
3c70: 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f permissions pro
3c80: 62 6c 65 6d 2e 22 29 0a 09 09 09 20 20 20 20 20 blem.")....
3c90: 28 72 65 74 72 79 29 29 0a 09 09 09 28 65 78 6e (retry))....(exn
3ca0: 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 62 66 ().... (dbf
3cb0: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 65 78 ile:print-err ex
3cc0: 6e 20 22 45 52 52 4f 52 3a 20 55 6e 6b 6e 6f 77 n "ERROR: Unknow
3cd0: 6e 20 65 72 72 6f 72 20 77 69 74 68 20 64 61 74 n error with dat
3ce0: 61 62 61 73 65 20 22 20 66 6e 61 6d 65 20 22 20 abase " fname "
3cf0: 6d 65 73 73 61 67 65 3a 20 22 0a 09 09 09 09 09 message: "......
3d00: 20 20 20 20 20 20 20 28 28 63 6f 6e 64 69 74 69 ((conditi
3d10: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
3d20: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
3d30: 67 65 29 20 65 78 6e 29 29 0a 09 09 09 20 20 20 ge) exn))....
3d40: 20 20 28 72 65 74 72 79 29 29 29 29 29 0a 09 20 (retry)))))..
3d50: 20 72 65 73 75 6c 74 29 29 29 29 0a 0a 28 64 65 result))))..(de
3d60: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 62 72 75 fine (dbfile:bru
3d70: 74 65 2d 66 6f 72 63 65 2d 73 61 6c 76 61 67 65 te-force-salvage
3d80: 2d 64 62 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 -db fname). (le
3d90: 74 2a 20 28 28 62 61 63 6b 75 70 66 6e 61 6d 65 t* ((backupfname
3da0: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 22 28 (conc fname"-"(
3db0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
3dc0: 69 64 29 22 2e 62 61 6b 22 29 29 0a 09 20 28 63 id)".bak")).. (c
3dd0: 6d 64 20 28 63 6f 6e 63 20 22 63 70 20 22 66 6e md (conc "cp "fn
3de0: 61 6d 65 22 20 22 62 61 63 6b 75 70 66 6e 61 6d ame" "backupfnam
3df0: 65 22 3b 6d 76 20 22 66 6e 61 6d 65 22 20 22 28 e";mv "fname" "(
3e00: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 64 65 6c conc fname ".del
3e10: 6d 65 3b 22 29 0a 09 09 20 20 20 20 22 63 70 20 me;")... "cp
3e20: 22 62 61 63 6b 75 70 66 6e 61 6d 65 22 20 22 66 "backupfname" "f
3e30: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 64 62 66 name))). (dbf
3e40: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 57 ile:print-err "W
3e50: 41 52 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 69 ARNING: attempti
3e60: 6e 67 20 72 65 63 6f 76 65 72 79 20 6f 66 20 66 ng recovery of f
3e70: 69 6c 65 20 22 66 6e 61 6d 65 22 20 62 79 20 72 ile "fname" by r
3e80: 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 73 3a unning commands:
3e90: 5c 6e 22 0a 09 09 20 20 20 20 20 20 22 20 20 22 \n"... " "
3ea0: 63 6d 64 29 0a 20 20 20 20 28 73 79 73 74 65 6d cmd). (system
3eb0: 20 63 6d 64 29 29 29 0a 0a 0a 28 64 65 66 69 6e cmd)))...(defin
3ec0: 65 20 28 64 62 66 69 6c 65 3a 6f 70 65 6e 2d 6e e (dbfile:open-n
3ed0: 6f 2d 73 79 6e 63 2d 64 62 20 64 62 70 61 74 68 o-sync-db dbpath
3ee0: 29 0a 20 20 28 69 66 20 2a 6e 6f 2d 73 79 6e 63 ). (if *no-sync
3ef0: 2d 64 62 2a 0a 20 20 20 20 20 20 2a 6e 6f 2d 73 -db*. *no-s
3f00: 79 6e 63 2d 64 62 2a 0a 20 20 20 20 20 20 28 62 ync-db*. (b
3f10: 65 67 69 6e 0a 09 28 69 66 20 28 6e 6f 74 20 28 egin..(if (not (
3f20: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 file-exists? dbp
3f30: 61 74 68 29 29 0a 09 20 20 20 20 28 63 72 65 61 ath)).. (crea
3f40: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 64 62 70 te-directory dbp
3f50: 61 74 68 20 23 74 29 29 0a 09 28 6c 65 74 2a 20 ath #t))..(let*
3f60: 28 28 64 62 6e 61 6d 65 20 20 20 20 28 63 6f 6e ((dbname (con
3f70: 63 20 64 62 70 61 74 68 20 22 2f 6e 6f 2d 73 79 c dbpath "/no-sy
3f80: 6e 63 2e 64 62 22 29 29 0a 09 20 20 20 20 20 20 nc.db"))..
3f90: 20 28 64 62 2d 65 78 69 73 74 73 20 28 66 69 6c (db-exists (fil
3fa0: 65 2d 65 78 69 73 74 73 3f 20 64 62 6e 61 6d 65 e-exists? dbname
3fb0: 29 29 0a 09 20 20 20 20 20 20 20 28 69 6e 69 74 )).. (init
3fc0: 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 64 -proc (lambda (d
3fd0: 62 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6e b).... (if (n
3fe0: 6f 74 20 64 62 2d 65 78 69 73 74 73 29 0a 09 09 ot db-exists)...
3ff0: 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 ..(begin..... (
4000: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
4010: 64 62 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 db "CREATE TABLE
4020: 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 6e IF NOT EXISTS n
4030: 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 20 28 o_sync_metadat (
4040: 76 61 72 20 54 45 58 54 2c 76 61 6c 20 54 45 58 var TEXT,val TEX
4050: 54 2c 20 43 4f 4e 53 54 52 41 49 4e 54 20 6e 6f T, CONSTRAINT no
4060: 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 5f 63 6f _sync_metadat_co
4070: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
4080: 28 76 61 72 29 29 3b 22 29 29 0a 09 09 09 09 29 (var));")).....)
4090: 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 20 20 )).. (db
40a0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 63 61 (dbfile:ca
40b0: 75 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 utious-open-data
40c0: 62 61 73 65 20 64 62 6e 61 6d 65 20 69 6e 69 74 base dbname init
40d0: 2d 70 72 6f 63 20 30 20 22 57 41 4c 22 29 29 29 -proc 0 "WAL")))
40e0: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 ;; (sqlite3:ope
40f0: 6e 2d 64 61 74 61 62 61 73 65 20 64 62 6e 61 6d n-database dbnam
4100: 65 29 29 29 0a 09 20 20 3b 3b 20 28 73 71 6c 69 e))).. ;; (sqli
4110: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
4120: 50 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f PRAGMA synchrono
4130: 75 73 20 3d 20 30 3b 22 29 0a 09 20 20 3b 3b 20 us = 0;").. ;;
4140: 28 73 71 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 (sqlite3:set-bus
4150: 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 73 y-handler! db (s
4160: 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 73 79 qlite3:make-busy
4170: 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 30 30 29 -timeout 136000)
4180: 29 20 3b 3b 20 64 6f 6e 65 20 69 6e 20 63 61 75 ) ;; done in cau
4190: 74 69 6f 75 73 2d 6f 70 65 6e 2d 64 61 74 61 62 tious-open-datab
41a0: 61 73 65 0a 09 20 20 28 73 65 74 21 20 2a 6e 6f ase.. (set! *no
41b0: 2d 73 79 6e 63 2d 64 62 2a 20 64 62 29 0a 09 20 -sync-db* db)..
41c0: 20 64 62 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 db))))..(define
41d0: 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 (db:no-sync-set
41e0: 20 64 62 20 76 61 72 20 76 61 6c 29 0a 20 20 28 db var val). (
41f0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
4200: 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 db "INSERT OR RE
4210: 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 79 PLACE INTO no_sy
4220: 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 2c nc_metadat (var,
4230: 76 61 6c 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f val) VALUES (?,?
4240: 29 3b 22 20 76 61 72 20 76 61 6c 29 29 0a 0a 28 );" var val))..(
4250: 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 79 define (db:no-sy
4260: 6e 63 2d 64 65 6c 21 20 64 62 20 76 61 72 29 0a nc-del! db var).
4270: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
4280: 74 65 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 te db "DELETE FR
4290: 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 OM no_sync_metad
42a0: 61 74 20 57 48 45 52 45 20 76 61 72 3d 3f 3b 22 at WHERE var=?;"
42b0: 20 76 61 72 29 29 0a 0a 28 64 65 66 69 6e 65 20 var))..(define
42c0: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f (db:no-sync-get/
42d0: 64 65 66 61 75 6c 74 20 64 62 20 76 61 72 20 64 default db var d
42e0: 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 efault). (let (
42f0: 28 72 65 73 20 64 65 66 61 75 6c 74 29 29 0a 20 (res default)).
4300: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
4310: 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c each-row. (l
4320: 61 6d 62 64 61 20 28 76 61 6c 29 0a 20 20 20 20 ambda (val).
4330: 20 20 20 28 73 65 74 21 20 72 65 73 20 76 61 6c (set! res val
4340: 29 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 )). db.
4350: 22 53 45 4c 45 43 54 20 76 61 6c 20 46 52 4f 4d "SELECT val FROM
4360: 20 6e 6f 5f 73 79 6e 63 5f 6d 65 74 61 64 61 74 no_sync_metadat
4370: 20 57 48 45 52 45 20 76 61 72 3d 3f 3b 22 0a 20 WHERE var=?;".
4380: 20 20 20 20 76 61 72 29 0a 20 20 20 20 28 69 66 var). (if
4390: 20 72 65 73 0a 20 20 20 20 20 20 20 20 28 6c 65 res. (le
43a0: 74 20 28 28 6e 65 77 72 65 73 20 28 69 66 20 28 t ((newres (if (
43b0: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 09 string? res)....
43c0: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
43d0: 72 20 72 65 73 29 0a 09 09 09 20 20 23 66 29 29 r res).... #f))
43e0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
43f0: 6e 65 77 72 65 73 0a 20 20 20 20 20 20 20 20 20 newres.
4400: 20 20 20 20 20 6e 65 77 72 65 73 0a 20 20 20 20 newres.
4410: 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 0a res)).
4420: 20 20 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a res)))..
4430: 3b 3b 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 70 ;; transaction p
4440: 72 6f 74 65 63 74 65 64 20 6c 6f 63 6b 20 61 71 rotected lock aq
4450: 75 69 73 69 74 69 6f 6e 0a 3b 3b 20 65 69 74 68 uisition.;; eith
4460: 65 72 3a 0a 3b 3b 20 20 20 20 66 61 69 6c 73 20 er:.;; fails
4470: 20 20 20 72 65 74 75 72 6e 73 20 20 28 23 66 20 returns (#f
4480: 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 6f 6e 2d . lock-creation-
4490: 74 69 6d 65 29 0a 3b 3b 20 20 20 20 73 75 63 63 time).;; succ
44a0: 65 65 64 73 20 28 72 65 74 75 72 6e 73 20 28 23 eeds (returns (#
44b0: 74 20 2e 20 6c 6f 63 6b 2d 63 72 65 61 74 69 6f t . lock-creatio
44c0: 6e 2d 74 69 6d 65 29 0a 3b 3b 20 75 73 65 20 28 n-time).;; use (
44d0: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 db:no-sync-del!
44e0: 64 62 20 6b 65 79 6e 61 6d 65 29 20 74 6f 20 72 db keyname) to r
44f0: 65 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b 0a elease the lock.
4500: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 6e ;;.(define (db:n
4510: 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 o-sync-get-lock
4520: 64 62 20 6b 65 79 6e 61 6d 65 29 0a 20 20 28 73 db keyname). (s
4530: 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 61 6e qlite3:with-tran
4540: 73 61 63 74 69 6f 6e 0a 20 20 20 64 62 0a 20 20 saction. db.
4550: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
4560: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 (condition-case
4570: 0a 09 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d .. (let* ((curr-
4580: 76 61 6c 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d val (db:no-sync-
4590: 67 65 74 2f 64 65 66 61 75 6c 74 20 64 62 20 6b get/default db k
45a0: 65 79 6e 61 6d 65 20 23 66 29 29 29 0a 09 20 20 eyname #f)))..
45b0: 20 28 69 66 20 63 75 72 72 2d 76 61 6c 0a 09 20 (if curr-val..
45c0: 20 20 20 20 20 20 60 28 23 66 20 2e 20 2c 63 75 `(#f . ,cu
45d0: 72 72 2d 76 61 6c 29 20 20 20 3b 3b 20 28 73 71 rr-val) ;; (sq
45e0: 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 65 73 75 lite3:first-resu
45f0: 6c 74 20 64 62 20 22 53 45 4c 45 43 54 20 76 61 lt db "SELECT va
4600: 6c 20 46 52 4f 4d 20 6e 6f 5f 73 79 6e 63 5f 6d l FROM no_sync_m
4610: 65 74 61 64 61 74 20 57 48 45 52 45 20 76 61 72 etadat WHERE var
4620: 3d 3f 3b 22 20 6b 65 79 6e 61 6d 65 29 29 0a 09 =?;" keyname))..
4630: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6c 6f (let ((lo
4640: 63 6b 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 ck-time (current
4650: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 20 28 -seconds)))... (
4660: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
4670: 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 db "INSERT OR RE
4680: 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 79 PLACE INTO no_sy
4690: 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 2c nc_metadat (var,
46a0: 76 61 6c 29 20 56 41 4c 55 45 53 28 3f 2c 3f 29 val) VALUES(?,?)
46b0: 3b 22 20 6b 65 79 6e 61 6d 65 20 6c 6f 63 6b 2d ;" keyname lock-
46c0: 74 69 6d 65 29 0a 09 09 20 60 28 23 74 20 2e 20 time)... `(#t .
46d0: 2c 6c 6f 63 6b 2d 74 69 6d 65 29 29 29 29 0a 20 ,lock-time)))).
46e0: 20 20 20 20 20 20 28 65 78 6e 20 28 69 6f 2d 65 (exn (io-e
46f0: 72 72 6f 72 29 20 20 28 64 62 66 69 6c 65 3a 70 rror) (dbfile:p
4700: 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 3a rint-err "ERROR:
4710: 20 69 2f 6f 20 65 72 72 6f 72 20 77 69 74 68 20 i/o error with
4720: 6e 6f 2d 73 79 6e 63 20 64 62 2e 20 43 68 65 63 no-sync db. Chec
4730: 6b 20 70 65 72 6d 69 73 73 69 6f 6e 73 2c 20 64 k permissions, d
4740: 69 73 6b 20 73 70 61 63 65 20 65 74 63 2e 20 61 isk space etc. a
4750: 6e 64 20 74 72 79 20 61 67 61 69 6e 2e 22 29 29 nd try again."))
4760: 0a 20 20 20 20 20 20 20 28 65 78 6e 20 28 63 6f . (exn (co
4770: 72 72 75 70 74 29 20 20 20 28 64 62 66 69 6c 65 rrupt) (dbfile
4780: 3a 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f :print-err "ERRO
4790: 52 3a 20 64 61 74 61 62 61 73 65 20 6e 6f 2d 73 R: database no-s
47a0: 79 6e 63 20 64 62 20 69 73 20 63 6f 72 72 75 70 ync db is corrup
47b0: 74 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 t. Repair it to
47c0: 70 72 6f 63 65 65 64 2e 22 29 29 0a 20 20 20 20 proceed.")).
47d0: 20 20 20 28 65 78 6e 20 28 62 75 73 79 29 20 20 (exn (busy)
47e0: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
47f0: 74 2d 65 72 72 20 22 45 52 52 4f 52 3a 20 64 61 t-err "ERROR: da
4800: 74 61 62 61 73 65 20 6e 6f 2d 73 79 6e 63 20 64 tabase no-sync d
4810: 62 20 69 73 20 6c 6f 63 6b 65 64 2e 20 54 72 79 b is locked. Try
4820: 20 63 6f 70 79 69 6e 67 20 74 6f 20 61 6e 6f 74 copying to anot
4830: 68 65 72 20 6c 6f 63 61 74 69 6f 6e 2c 20 72 65 her location, re
4840: 6d 6f 76 65 20 6f 72 69 67 69 6e 61 6c 20 61 6e move original an
4850: 64 20 63 6f 70 79 20 62 61 63 6b 2e 22 29 29 0a d copy back.")).
4860: 20 20 20 20 20 20 20 28 65 78 6e 20 28 70 65 72 (exn (per
4870: 6d 69 73 73 69 6f 6e 29 28 64 62 66 69 6c 65 3a mission)(dbfile:
4880: 70 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 print-err "ERROR
4890: 3a 20 64 61 74 61 62 61 73 65 20 6e 6f 2d 73 79 : database no-sy
48a0: 6e 63 20 64 62 20 68 61 73 20 73 6f 6d 65 20 70 nc db has some p
48b0: 65 72 6d 69 73 73 69 6f 6e 73 20 70 72 6f 62 6c ermissions probl
48c0: 65 6d 2e 22 29 29 0a 20 20 20 20 20 20 20 28 65 em.")). (e
48d0: 78 6e 20 28 29 20 3b 3b 20 28 73 74 61 74 75 73 xn () ;; (status
48e0: 20 64 6f 6e 65 29 20 3b 3b 20 49 20 64 6f 6e 27 done) ;; I don'
48f0: 74 20 6b 6e 6f 77 20 68 6f 77 20 74 6f 20 64 65 t know how to de
4900: 74 65 63 74 20 73 74 61 74 75 73 20 64 6f 6e 65 tect status done
4910: 20 62 75 74 20 6e 6f 20 64 61 74 61 21 0a 09 20 but no data!..
4920: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
4930: 2d 65 72 72 20 22 45 52 52 4f 52 3a 20 55 6e 6b -err "ERROR: Unk
4940: 6e 6f 77 6e 20 65 72 72 6f 72 20 77 69 74 68 20 nown error with
4950: 64 61 74 61 62 61 73 65 20 6e 6f 2d 73 79 6e 63 database no-sync
4960: 20 64 62 20 6d 65 73 73 61 67 65 3a 20 65 78 6e db message: exn
4970: 3d 22 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 ="(condition->li
4980: 73 74 20 65 78 6e 29 22 2c 20 5c 6e 22 0a 09 09 st exn)", \n"...
4990: 09 20 20 20 20 20 20 28 28 63 6f 6e 64 69 74 69 . ((conditi
49a0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
49b0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
49c0: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 60 ge) exn)).. `
49d0: 28 23 66 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d (#f . ,(current-
49e0: 73 65 63 6f 6e 64 73 29 29 29 29 29 29 29 0a 0a seconds)))))))..
49f0: 28 64 65 66 69 6e 65 20 28 64 62 3a 6e 6f 2d 73 (define (db:no-s
4a00: 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 2d 74 69 6d ync-get-lock-tim
4a10: 65 6f 75 74 20 64 62 20 6b 65 79 6e 61 6d 65 20 eout db keyname
4a20: 74 69 6d 65 6f 75 74 29 0a 20 20 28 6c 65 74 2a timeout). (let*
4a30: 20 28 28 6c 6f 63 6b 64 61 74 20 28 64 62 3a 6e ((lockdat (db:n
4a40: 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 o-sync-get-lock
4a50: 64 62 20 6b 65 79 6e 61 6d 65 29 29 29 0a 20 20 db keyname))).
4a60: 20 20 28 6d 61 74 63 68 20 6c 6f 63 6b 64 61 74 (match lockdat
4a70: 0a 20 20 20 20 20 20 28 28 23 66 20 2e 20 6c 6f . ((#f . lo
4a80: 63 6b 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 ck-time).
4a90: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
4aa0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 69 66 20 nt-seconds) (if
4ab0: 28 73 74 72 69 6e 67 3f 20 6c 6f 63 6b 2d 74 69 (string? lock-ti
4ac0: 6d 65 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 me)(string->numb
4ad0: 65 72 20 6c 6f 63 6b 2d 74 69 6d 65 29 6c 6f 63 er lock-time)loc
4ae0: 6b 2d 74 69 6d 65 29 29 20 74 69 6d 65 6f 75 74 k-time)) timeout
4af0: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6c 6f 63 ).. (let ((loc
4b00: 6b 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d k-time (current-
4b10: 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 seconds)))..
4b20: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
4b30: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
4b40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 62 3a 6e -log-port* "db:n
4b50: 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 o-sync-get-lock
4b60: 6b 65 79 6e 61 6d 65 3d 22 20 6b 65 79 6e 61 6d keyname=" keynam
4b70: 65 20 22 2c 20 6c 6f 63 6b 2d 74 69 6d 65 3d 22 e ", lock-time="
4b80: 20 6c 6f 63 6b 2d 74 69 6d 65 20 22 2c 20 65 78 lock-time ", ex
4b90: 6e 3d 22 20 65 78 6e 29 0a 09 20 20 20 20 20 28 n=" exn).. (
4ba0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
4bb0: 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 db "INSERT OR RE
4bc0: 50 4c 41 43 45 20 49 4e 54 4f 20 6e 6f 5f 73 79 PLACE INTO no_sy
4bd0: 6e 63 5f 6d 65 74 61 64 61 74 20 28 76 61 72 2c nc_metadat (var,
4be0: 76 61 6c 29 20 56 41 4c 55 45 53 28 3f 2c 3f 29 val) VALUES(?,?)
4bf0: 3b 22 20 6b 65 79 6e 61 6d 65 20 6c 6f 63 6b 2d ;" keyname lock-
4c00: 74 69 6d 65 29 0a 09 20 20 20 20 20 60 28 23 74 time).. `(#t
4c10: 20 2e 20 2c 6c 6f 63 6b 2d 74 69 6d 65 29 29 0a . ,lock-time)).
4c20: 09 20 20 20 6c 6f 63 6b 64 61 74 29 29 0a 20 20 . lockdat)).
4c30: 20 20 20 20 28 65 6c 73 65 20 6c 6f 63 6b 64 61 (else lockda
4c40: 74 29 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 t))))..;; NOTE:
4c50: 54 68 69 73 20 77 69 6c 6c 20 73 74 65 61 6c 20 This will steal
4c60: 74 68 65 20 6c 6f 63 6b 20 61 66 74 65 72 20 74 the lock after t
4c70: 69 6d 65 6f 75 74 20 6f 66 20 77 61 69 74 69 6e imeout of waitin
4c80: 67 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 g..;;.(define (d
4c90: 62 3a 77 69 74 68 2d 6e 6f 2d 73 79 6e 63 2d 6c b:with-no-sync-l
4ca0: 6f 63 6b 20 64 62 20 6b 65 79 6e 61 6d 65 20 74 ock db keyname t
4cb0: 69 6d 65 6f 75 74 20 70 72 6f 63 29 0a 20 20 28 imeout proc). (
4cc0: 6c 65 74 2a 20 28 28 6c 6f 63 6b 64 61 74 20 20 let* ((lockdat
4cd0: 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d (db:no-sync-get-
4ce0: 6c 6f 63 6b 2d 74 69 6d 65 6f 75 74 20 64 62 20 lock-timeout db
4cf0: 6b 65 79 6e 61 6d 65 29 29 0a 09 20 28 67 6f 74 keyname)).. (got
4d00: 6c 6f 63 6b 20 20 28 63 61 72 20 6c 6f 63 6b 64 lock (car lockd
4d10: 61 74 29 29 0a 09 20 28 6c 6f 63 6b 74 69 6d 65 at)).. (locktime
4d20: 20 28 63 64 72 20 6c 6f 63 6b 64 61 74 29 29 29 (cdr lockdat)))
4d30: 0a 20 20 20 20 28 69 66 20 67 6f 74 6c 6f 63 6b . (if gotlock
4d40: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 70 72 ..(let ((res (pr
4d50: 6f 63 29 29 29 0a 09 20 20 28 64 62 3a 6e 6f 2d oc))).. (db:no-
4d60: 73 79 6e 63 2d 64 65 6c 21 20 64 62 20 6b 65 79 sync-del! db key
4d70: 6e 61 6d 65 29 0a 09 20 20 72 65 73 29 29 29 29 name).. res))))
4d80: 0a 20 20 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
4dd0: 73 79 6e 63 20 62 61 63 6b 20 66 75 6e 63 74 69 sync back functi
4de0: 6f 6e 73 20 70 75 6c 6c 65 64 20 66 72 6f 6d 20 ons pulled from
4df0: 64 62 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d db.scm.;;=======
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 3d 3d 3d 3d 3d 3d 3d 3d ================
4e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
4e40: 0a 3b 3b 20 47 65 74 20 61 20 6c 6f 63 6b 20 66 .;; Get a lock f
4e50: 72 6f 6d 20 74 68 65 20 6e 6f 2d 73 79 6e 63 2d rom the no-sync-
4e60: 64 62 20 66 6f 72 20 74 68 65 20 66 72 6f 6d 2d db for the from-
4e70: 64 62 2c 20 74 68 65 6e 20 64 65 6c 74 61 20 73 db, then delta s
4e80: 79 6e 63 20 74 68 65 20 66 72 6f 6d 2d 64 62 20 ync the from-db
4e90: 74 6f 20 74 68 65 20 74 6f 2d 64 62 2c 20 6f 74 to the to-db, ot
4ea0: 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 herwise return #
4eb0: 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 f.;;.(define (db
4ec0: 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 2d :lock-and-delta-
4ed0: 73 79 6e 63 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 sync no-sync-db
4ee0: 64 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 62 dbstruct from-db
4ef0: 2d 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 73 -file runid keys
4f00: 20 64 62 69 6e 69 74 29 0a 20 20 28 61 73 73 65 dbinit). (asse
4f10: 72 74 20 28 6e 6f 74 20 2a 64 62 2d 73 79 6e 63 rt (not *db-sync
4f20: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 20 22 -in-progress*) "
4f30: 46 41 54 41 4c 3a 20 64 62 3a 6c 6f 63 6b 2d 61 FATAL: db:lock-a
4f40: 6e 64 2d 73 79 6e 63 20 63 61 6c 6c 65 64 20 77 nd-sync called w
4f50: 68 69 6c 65 20 61 20 73 79 6e 63 20 69 73 20 69 hile a sync is i
4f60: 6e 20 70 72 6f 67 72 65 73 73 2e 22 29 0a 20 20 n progress.").
4f70: 3b 3b 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 ;; (dbfile:print
4f80: 2d 65 72 72 20 2a 64 65 66 61 75 6c 74 2d 6c 6f -err *default-lo
4f90: 67 2d 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b g-port* "db:lock
4fa0: 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 22 -and-delta-sync"
4fb0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ). (let* ((lock
4fc0: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 72 6f 6d -file (conc from
4fd0: 2d 64 62 2d 66 69 6c 65 20 22 2e 6c 6f 63 6b 22 -db-file ".lock"
4fe0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d ))). (if (com
4ff0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
5000: 6c 6f 63 6b 20 6c 6f 63 6b 2d 66 69 6c 65 29 0a lock lock-file).
5010: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 62 66 69 .(begin.. (dbfi
5020: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 49 4e le:print-err "IN
5030: 46 4f 3a 20 64 62 3a 6c 6f 63 6b 2d 61 6e 64 2d FO: db:lock-and-
5040: 64 65 6c 74 61 2d 73 79 6e 63 20 63 6f 70 79 69 delta-sync copyi
5050: 6e 67 20 64 62 20 22 72 75 6e 69 64 22 20 61 74 ng db "runid" at
5060: 20 22 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e "(current-secon
5070: 64 73 29 29 0a 09 20 20 28 73 65 74 21 20 2a 64 ds)).. (set! *d
5080: 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 b-sync-in-progre
5090: 73 73 2a 20 23 74 29 0a 09 20 20 28 64 62 3a 73 ss* #t).. (db:s
50a0: 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 74 ync-touched dbst
50b0: 72 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 20 ruct runid keys
50c0: 64 62 69 6e 69 74 29 0a 09 20 20 28 73 65 74 21 dbinit).. (set!
50d0: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
50e0: 67 72 65 73 73 2a 20 23 66 29 0a 09 20 20 28 64 gress* #f).. (d
50f0: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 6c 6f 63 6b elete-file* lock
5100: 2d 66 69 6c 65 29 0a 09 20 20 23 74 29 0a 20 20 -file).. #t).
5110: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 (begin..
5120: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
5130: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 noise-print 120
5140: 28 63 6f 6e 63 20 22 6e 6f 20 6c 6f 63 6b 20 22 (conc "no lock "
5150: 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 29 29 0a 09 from-db-file))..
5160: 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 (dbfile:pr
5170: 69 6e 74 2d 65 72 72 20 22 49 4e 46 4f 3a 20 63 int-err "INFO: c
5180: 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 6c 6f 63 ould not get loc
5190: 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d 64 62 2d k for " from-db-
51a0: 66 69 6c 65 20 22 2c 20 73 79 6e 63 20 6c 69 6b file ", sync lik
51b0: 65 6c 79 20 69 6e 20 70 72 6f 67 72 65 73 73 2e ely in progress.
51c0: 22 29 29 0a 09 20 20 23 66 0a 09 20 20 29 29 29 ")).. #f.. )))
51d0: 29 0a 0a 3b 3b 20 3b 3b 20 47 65 74 20 61 20 6c )..;; ;; Get a l
51e0: 6f 63 6b 20 66 72 6f 6d 20 74 68 65 20 6e 6f 2d ock from the no-
51f0: 73 79 6e 63 2d 64 62 20 66 6f 72 20 74 68 65 20 sync-db for the
5200: 66 72 6f 6d 2d 64 62 2c 20 74 68 65 6e 20 64 65 from-db, then de
5210: 6c 74 61 20 73 79 6e 63 20 74 68 65 20 66 72 6f lta sync the fro
5220: 6d 2d 64 62 20 74 6f 20 74 68 65 20 74 6f 2d 64 m-db to the to-d
5230: 62 2c 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 b, otherwise ret
5240: 75 72 6e 20 23 66 0a 3b 3b 20 3b 3b 0a 3b 3b 20 urn #f.;; ;;.;;
5250: 28 64 65 66 69 6e 65 20 28 64 62 3a 6c 6f 63 6b (define (db:lock
5260: 2d 61 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 2d -and-delta-sync-
5270: 6f 72 69 67 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 orig no-sync-db
5280: 64 62 73 74 72 75 63 74 20 66 72 6f 6d 2d 64 62 dbstruct from-db
5290: 2d 66 69 6c 65 20 72 75 6e 69 64 20 6b 65 79 73 -file runid keys
52a0: 20 64 62 69 6e 69 74 29 0a 3b 3b 20 20 20 28 61 dbinit).;; (a
52b0: 73 73 65 72 74 20 28 6e 6f 74 20 2a 64 62 2d 73 ssert (not *db-s
52c0: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
52d0: 29 20 22 46 41 54 41 4c 3a 20 64 62 3a 6c 6f 63 ) "FATAL: db:loc
52e0: 6b 2d 61 6e 64 2d 73 79 6e 63 20 63 61 6c 6c 65 k-and-sync calle
52f0: 64 20 77 68 69 6c 65 20 61 20 73 79 6e 63 20 69 d while a sync i
5300: 73 20 69 6e 20 70 72 6f 67 72 65 73 73 2e 22 29 s in progress.")
5310: 0a 3b 3b 20 20 20 3b 3b 20 28 64 62 66 69 6c 65 .;; ;; (dbfile
5320: 3a 70 72 69 6e 74 2d 65 72 72 20 2a 64 65 66 61 :print-err *defa
5330: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 ult-log-port* "d
5340: 62 3a 6c 6f 63 6b 2d 61 6e 64 2d 64 65 6c 74 61 b:lock-and-delta
5350: 2d 73 79 6e 63 22 29 0a 3b 3b 20 20 20 28 6c 65 -sync").;; (le
5360: 74 2a 20 28 28 6c 6f 63 6b 64 61 74 20 20 28 64 t* ((lockdat (d
5370: 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f b:no-sync-get-lo
5380: 63 6b 2d 74 69 6d 65 6f 75 74 20 6e 6f 2d 73 79 ck-timeout no-sy
5390: 6e 63 2d 64 62 20 66 72 6f 6d 2d 64 62 2d 66 69 nc-db from-db-fi
53a0: 6c 65 20 36 30 29 29 0a 3b 3b 20 09 20 28 67 6f le 60)).;; . (go
53b0: 74 6c 6f 63 6b 20 20 28 63 61 72 20 6c 6f 63 6b tlock (car lock
53c0: 64 61 74 29 29 0a 3b 3b 20 09 20 28 6c 6f 63 6b dat)).;; . (lock
53d0: 74 69 6d 65 20 28 63 64 72 20 6c 6f 63 6b 64 61 time (cdr lockda
53e0: 74 29 29 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 28 t))).;; ;; (
53f0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5400: 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 3 *default-log-
5410: 70 6f 72 74 2a 20 22 64 62 3a 6c 6f 63 6b 2d 61 port* "db:lock-a
5420: 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 3a 20 67 nd-delta-sync: g
5430: 6f 74 20 6c 6f 63 6b 3f 22 29 0a 3b 3b 20 20 20 ot lock?").;;
5440: 20 20 0a 3b 3b 20 20 20 20 20 28 69 66 20 67 6f .;; (if go
5450: 74 6c 6f 63 6b 0a 3b 3b 20 09 28 62 65 67 69 6e tlock.;; .(begin
5460: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 64 .;; (d
5470: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
5480: 22 49 4e 46 4f 3a 20 64 62 3a 6c 6f 63 6b 2d 61 "INFO: db:lock-a
5490: 6e 64 2d 64 65 6c 74 61 2d 73 79 6e 63 20 63 6f nd-delta-sync co
54a0: 70 79 69 6e 67 20 64 62 20 22 72 75 6e 69 64 22 pying db "runid"
54b0: 20 61 74 20 22 28 63 75 72 72 65 6e 74 2d 73 65 at "(current-se
54c0: 63 6f 6e 64 73 29 29 0a 3b 3b 20 09 20 20 28 73 conds)).;; . (s
54d0: 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d et! *db-sync-in-
54e0: 70 72 6f 67 72 65 73 73 2a 20 23 74 29 0a 3b 3b progress* #t).;;
54f0: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 73 (db:s
5500: 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 73 74 ync-touched dbst
5510: 72 75 63 74 20 72 75 6e 69 64 20 6b 65 79 73 20 ruct runid keys
5520: 64 62 69 6e 69 74 29 0a 3b 3b 20 09 20 20 28 73 dbinit).;; . (s
5530: 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d et! *db-sync-in-
5540: 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a 3b 3b progress* #f).;;
5550: 20 09 20 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d . (db:no-sync-
5560: 64 65 6c 21 20 6e 6f 2d 73 79 6e 63 2d 64 62 20 del! no-sync-db
5570: 66 72 6f 6d 2d 64 62 2d 66 69 6c 65 29 0a 3b 3b from-db-file).;;
5580: 20 09 20 20 23 74 29 0a 3b 3b 20 20 20 20 20 20 . #t).;;
5590: 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 (begin.;;
55a0: 20 20 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 (dbfile:p
55b0: 72 69 6e 74 2d 65 72 72 20 22 45 52 52 4f 52 3a rint-err "ERROR:
55c0: 20 63 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 6c could not get l
55d0: 6f 63 6b 20 66 6f 72 20 22 20 66 72 6f 6d 2d 64 ock for " from-d
55e0: 62 2d 66 69 6c 65 20 22 20 66 72 6f 6d 20 6e 6f b-file " from no
55f0: 2d 73 79 6e 63 2d 64 62 22 29 0a 3b 3b 20 09 20 -sync-db").;; .
5600: 20 23 66 0a 3b 3b 20 20 20 20 20 20 20 20 20 29 #f.;; )
5610: 29 29 29 0a 0a 3b 3b 20 73 79 6e 63 20 72 75 6e )))..;; sync run
5620: 20 66 72 6f 6d 20 74 6d 70 20 64 69 73 6b 20 74 from tmp disk t
5630: 6f 20 6e 66 73 20 64 69 73 6b 20 69 66 20 74 6f o nfs disk if to
5640: 75 63 68 65 64 0a 3b 3b 0a 3b 3b 20 63 61 6c 6c uched.;;.;; call
5650: 20 77 69 74 68 20 64 62 69 6e 69 74 3d 64 62 3a with dbinit=db:
5660: 69 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 69 6e 2d initialize-main-
5670: 64 62 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 db.;;.(define (d
5680: 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 b:sync-touched d
5690: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 6b bstruct run-id k
56a0: 65 79 73 20 23 21 6b 65 79 20 64 62 69 6e 69 74 eys #!key dbinit
56b0: 20 28 66 6f 72 63 65 2d 73 79 6e 63 20 23 66 29 (force-sync #f)
56c0: 29 0a 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e ). (dbfile:prin
56d0: 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d 74 t-err "db:sync-t
56e0: 6f 75 63 68 65 64 20 53 79 6e 63 69 6e 67 3a 20 ouched Syncing:
56f0: 22 20 28 63 6f 6e 63 20 28 69 66 20 72 75 6e 2d " (conc (if run-
5700: 69 64 20 72 75 6e 2d 69 64 20 22 6d 61 69 6e 22 id run-id "main"
5710: 29 20 22 2e 64 62 22 29 29 0a 20 20 28 6c 65 74 ) ".db")). (let
5720: 2a 20 28 3b 3b 20 74 68 65 20 73 75 62 64 62 20 * (;; the subdb
5730: 69 73 20 6e 65 65 64 65 64 20 74 6f 20 61 63 63 is needed to acc
5740: 65 73 73 20 74 68 65 20 6d 74 64 62 64 61 74 0a ess the mtdbdat.
5750: 09 20 28 73 75 62 64 62 20 20 20 20 20 28 6f 72 . (subdb (or
5760: 20 28 64 62 66 69 6c 65 3a 67 65 74 2d 73 75 62 (dbfile:get-sub
5770: 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d db dbstruct run-
5780: 69 64 29 0a 09 09 09 28 64 62 66 69 6c 65 3a 69 id)....(dbfile:i
5790: 6e 69 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 nit-subdb dbstru
57a0: 63 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 ct run-id dbinit
57b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6d ))). (tm
57c0: 70 64 62 66 69 6c 65 20 28 64 62 72 3a 73 75 62 pdbfile (dbr:sub
57d0: 64 62 2d 74 6d 70 64 62 66 69 6c 65 20 73 75 62 db-tmpdbfile sub
57e0: 64 62 29 29 0a 09 20 28 6d 74 64 62 20 20 20 20 db)).. (mtdb
57f0: 20 20 28 64 62 72 3a 73 75 62 64 62 2d 6d 74 64 (dbr:subdb-mtd
5800: 62 64 61 74 20 73 75 62 64 62 29 29 0a 20 20 20 bdat subdb)).
5810: 20 20 20 20 20 20 28 74 6d 70 64 62 20 20 20 20 (tmpdb
5820: 20 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 73 (db:open-db dbs
5830: 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 69 truct run-id dbi
5840: 6e 69 74 29 29 20 3b 3b 20 73 71 6c 69 74 65 33 nit)) ;; sqlite3
5850: 2d 64 62 20 74 6d 70 64 62 66 69 6c 65 20 23 66 -db tmpdbfile #f
5860: 29 29 0a 09 20 28 73 74 61 72 74 2d 74 20 20 20 )).. (start-t
5870: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
5880: 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 6c ))). (mutex-l
5890: 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 ock! *db-multi-s
58a0: 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 ync-mutex*).
58b0: 28 6c 65 74 20 28 28 75 70 64 61 74 65 5f 69 6e (let ((update_in
58c0: 66 6f 20 28 63 6f 6e 73 20 22 6c 61 73 74 5f 75 fo (cons "last_u
58d0: 70 64 61 74 65 22 20 28 69 66 20 66 6f 72 63 65 pdate" (if force
58e0: 2d 73 79 6e 63 20 30 20 2a 64 62 2d 6c 61 73 74 -sync 0 *db-last
58f0: 2d 73 79 6e 63 2a 29 20 29 29 29 0a 20 20 20 20 -sync*) ))).
5900: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
5910: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
5920: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 mutex*). (d
5930: 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 28 64 b:sync-tables (d
5940: 62 3a 73 79 6e 63 2d 61 6c 6c 2d 74 61 62 6c 65 b:sync-all-table
5950: 73 2d 6c 69 73 74 20 6b 65 79 73 29 20 75 70 64 s-list keys) upd
5960: 61 74 65 5f 69 6e 66 6f 20 74 6d 70 64 62 20 6d ate_info tmpdb m
5970: 74 64 62 29 29 0a 20 20 20 20 28 6d 75 74 65 78 tdb)). (mutex
5980: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 -lock! *db-multi
5990: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 -sync-mutex*).
59a0: 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 (set! *db-last
59b0: 2d 73 79 6e 63 2a 20 73 74 61 72 74 2d 74 29 0a -sync* start-t).
59c0: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 (set! *db-la
59d0: 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 72 74 st-access* start
59e0: 2d 74 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 -t). (mutex-u
59f0: 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 nlock! *db-multi
5a00: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 -sync-mutex*).
5a10: 20 20 28 64 62 66 69 6c 65 3a 61 64 64 2d 64 62 (dbfile:add-db
5a20: 64 61 74 20 64 62 73 74 72 75 63 74 20 72 75 6e dat dbstruct run
5a30: 2d 69 64 20 74 6d 70 64 62 29 0a 20 20 23 74 29 -id tmpdb). #t)
5a40: 29 0a 0a 3b 3b 20 6a 75 73 74 20 74 65 73 74 73 )..;; just tests
5a50: 2c 20 74 65 73 74 5f 73 74 65 70 73 20 61 6e 64 , test_steps and
5a60: 20 74 65 73 74 5f 64 61 74 61 20 74 61 62 6c 65 test_data table
5a70: 73 0a 28 64 65 66 69 6e 65 20 64 62 3a 73 79 6e s.(define db:syn
5a80: 63 2d 74 65 73 74 73 2d 6f 6e 6c 79 0a 20 20 28 c-tests-only. (
5a90: 6c 69 73 74 0a 20 20 20 3b 3b 20 28 6c 69 73 74 list. ;; (list
5aa0: 20 22 73 74 72 73 22 0a 20 20 20 3b 3b 20 20 20 "strs". ;;
5ab0: 20 20 20 20 27 28 22 69 64 22 20 20 20 20 20 20 '("id"
5ac0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 3b 3b #f). ;;
5ad0: 20 20 20 20 20 20 20 27 28 22 73 74 72 22 20 20 '("str"
5ae0: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 #f)).
5af0: 20 20 28 6c 69 73 74 20 22 74 65 73 74 73 22 20 (list "tests"
5b00: 0a 09 20 27 28 22 69 64 22 20 20 20 20 20 20 20 .. '("id"
5b10: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 72 #f).. '("r
5b20: 75 6e 5f 69 64 22 20 20 20 20 20 20 20 20 20 23 un_id" #
5b30: 66 29 0a 09 20 27 28 22 74 65 73 74 6e 61 6d 65 f).. '("testname
5b40: 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 " #f).. '(
5b50: 22 68 6f 73 74 22 20 20 20 20 20 20 20 20 20 20 "host"
5b60: 20 23 66 29 0a 09 20 27 28 22 63 70 75 6c 6f 61 #f).. '("cpuloa
5b70: 64 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 d" #f)..
5b80: 27 28 22 64 69 73 6b 66 72 65 65 22 20 20 20 20 '("diskfree"
5b90: 20 20 20 23 66 29 0a 09 20 27 28 22 75 6e 61 6d #f).. '("unam
5ba0: 65 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a e" #f).
5bb0: 09 20 27 28 22 72 75 6e 64 69 72 22 20 20 20 20 . '("rundir"
5bc0: 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 68 #f).. '("sh
5bd0: 6f 72 74 64 69 72 22 20 20 20 20 20 20 20 23 66 ortdir" #f
5be0: 29 0a 09 20 27 28 22 69 74 65 6d 5f 70 61 74 68 ).. '("item_path
5bf0: 22 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 " #f).. '("
5c00: 73 74 61 74 65 22 20 20 20 20 20 20 20 20 20 20 state"
5c10: 23 66 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 #f).. '("status"
5c20: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
5c30: 28 22 61 74 74 65 6d 70 74 6e 75 6d 22 20 20 20 ("attemptnum"
5c40: 20 20 23 66 29 0a 09 20 27 28 22 66 69 6e 61 6c #f).. '("final
5c50: 5f 6c 6f 67 66 22 20 20 20 20 20 23 66 29 0a 09 _logf" #f)..
5c60: 20 27 28 22 6c 6f 67 64 61 74 22 20 20 20 20 20 '("logdat"
5c70: 20 20 20 20 23 66 29 0a 09 20 27 28 22 72 75 6e #f).. '("run
5c80: 5f 64 75 72 61 74 69 6f 6e 22 20 20 20 23 66 29 _duration" #f)
5c90: 0a 09 20 27 28 22 63 6f 6d 6d 65 6e 74 22 20 20 .. '("comment"
5ca0: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 65 #f).. '("e
5cb0: 76 65 6e 74 5f 74 69 6d 65 22 20 20 20 20 20 23 vent_time" #
5cc0: 66 29 0a 09 20 27 28 22 66 61 69 6c 5f 63 6f 75 f).. '("fail_cou
5cd0: 6e 74 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 nt" #f).. '(
5ce0: 22 70 61 73 73 5f 63 6f 75 6e 74 22 20 20 20 20 "pass_count"
5cf0: 20 23 66 29 0a 09 20 27 28 22 61 72 63 68 69 76 #f).. '("archiv
5d00: 65 64 22 20 20 20 20 20 20 20 23 66 29 0a 20 20 ed" #f).
5d10: 20 20 20 20 20 20 20 27 28 22 6c 61 73 74 5f 75 '("last_u
5d20: 70 64 61 74 65 22 20 20 20 20 23 66 29 29 0a 20 pdate" #f)).
5d30: 20 28 6c 69 73 74 20 22 74 65 73 74 5f 73 74 65 (list "test_ste
5d40: 70 73 22 0a 09 20 27 28 22 69 64 22 20 20 20 20 ps".. '("id"
5d50: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 #f).. '
5d60: 28 22 74 65 73 74 5f 69 64 22 20 20 20 20 20 20 ("test_id"
5d70: 20 20 23 66 29 0a 09 20 27 28 22 73 74 65 70 6e #f).. '("stepn
5d80: 61 6d 65 22 20 20 20 20 20 20 20 23 66 29 0a 09 ame" #f)..
5d90: 20 27 28 22 73 74 61 74 65 22 20 20 20 20 20 20 '("state"
5da0: 20 20 20 20 23 66 29 0a 09 20 27 28 22 73 74 61 #f).. '("sta
5db0: 74 75 73 22 20 20 20 20 20 20 20 20 20 23 66 29 tus" #f)
5dc0: 0a 09 20 27 28 22 65 76 65 6e 74 5f 74 69 6d 65 .. '("event_time
5dd0: 22 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 63 " #f).. '("c
5de0: 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 20 23 omment" #
5df0: 66 29 0a 09 20 27 28 22 6c 6f 67 66 69 6c 65 22 f).. '("logfile"
5e00: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 #f).
5e10: 20 20 20 20 20 27 28 22 6c 61 73 74 5f 75 70 64 '("last_upd
5e20: 61 74 65 22 20 20 20 20 23 66 29 29 0a 20 20 20 ate" #f)).
5e30: 28 6c 69 73 74 20 22 74 65 73 74 5f 64 61 74 61 (list "test_data
5e40: 22 0a 09 20 27 28 22 69 64 22 20 20 20 20 20 20 ".. '("id"
5e50: 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 #f).. '("
5e60: 74 65 73 74 5f 69 64 22 20 20 20 20 20 20 20 20 test_id"
5e70: 23 66 29 0a 09 20 27 28 22 63 61 74 65 67 6f 72 #f).. '("categor
5e80: 79 22 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 y" #f).. '
5e90: 28 22 76 61 72 69 61 62 6c 65 22 20 20 20 20 20 ("variable"
5ea0: 20 20 23 66 29 0a 09 20 27 28 22 76 61 6c 75 65 #f).. '("value
5eb0: 22 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 " #f)..
5ec0: 20 27 28 22 65 78 70 65 63 74 65 64 22 20 20 20 '("expected"
5ed0: 20 20 20 20 23 66 29 0a 09 20 27 28 22 74 6f 6c #f).. '("tol
5ee0: 22 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 " #f)
5ef0: 0a 09 20 27 28 22 75 6e 69 74 73 22 20 20 20 20 .. '("units"
5f00: 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 22 63 #f).. '("c
5f10: 6f 6d 6d 65 6e 74 22 20 20 20 20 20 20 20 20 23 omment" #
5f20: 66 29 0a 09 20 27 28 22 73 74 61 74 75 73 22 20 f).. '("status"
5f30: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 27 28 #f).. '(
5f40: 22 74 79 70 65 22 20 20 20 20 20 20 20 20 20 20 "type"
5f50: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 27 28 #f). '(
5f60: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 20 20 20 "last_update"
5f70: 20 23 66 29 29 29 29 0a 0a 3b 3b 20 6e 65 65 64 #f))))..;; need
5f80: 73 20 64 62 20 74 6f 20 67 65 74 20 6b 65 79 73 s db to get keys
5f90: 2c 20 74 68 69 73 20 69 73 20 66 6f 72 20 73 79 , this is for sy
5fa0: 6e 63 69 6e 67 20 61 6c 6c 20 74 61 62 6c 65 73 ncing all tables
5fb0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 3a .;;.(define (db:
5fc0: 73 79 6e 63 2d 6d 61 69 6e 2d 6c 69 73 74 20 6b sync-main-list k
5fd0: 65 79 73 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 eys). (let ((ke
5fe0: 79 73 20 20 6b 65 79 73 29 29 0a 20 20 20 20 28 ys keys)). (
5ff0: 6c 69 73 74 0a 20 20 20 20 20 28 6c 69 73 74 20 list. (list
6000: 22 6b 65 79 73 22 0a 09 20 20 20 27 28 22 69 64 "keys".. '("id
6010: 22 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 " #f)..
6020: 20 27 28 22 66 69 65 6c 64 6e 61 6d 65 22 20 23 '("fieldname" #
6030: 66 29 0a 09 20 20 20 27 28 22 66 69 65 6c 64 74 f).. '("fieldt
6040: 79 70 65 22 20 23 66 29 29 0a 20 20 20 20 20 28 ype" #f)). (
6050: 6c 69 73 74 20 22 6d 65 74 61 64 61 74 22 20 27 list "metadat" '
6060: 28 22 76 61 72 22 20 23 66 29 20 27 28 22 76 61 ("var" #f) '("va
6070: 6c 22 20 23 66 29 29 0a 20 20 20 20 20 28 61 70 l" #f)). (ap
6080: 70 65 6e 64 20 28 6c 69 73 74 20 22 72 75 6e 73 pend (list "runs
6090: 22 20 0a 09 09 20 20 20 27 28 22 69 64 22 20 20 " ... '("id"
60a0: 23 66 29 29 0a 09 20 20 20 20 20 28 6d 61 70 20 #f)).. (map
60b0: 28 6c 61 6d 62 64 61 20 28 6b 29 28 6c 69 73 74 (lambda (k)(list
60c0: 20 6b 20 23 66 29 29 0a 09 09 20 20 28 61 70 70 k #f))... (app
60d0: 65 6e 64 20 6b 65 79 73 0a 09 09 09 20 20 28 6c end keys.... (l
60e0: 69 73 74 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 ist "runname" "s
60f0: 74 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 tate" "status" "
6100: 6f 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 owner" "event_ti
6110: 6d 65 22 20 22 63 6f 6d 6d 65 6e 74 22 20 22 66 me" "comment" "f
6120: 61 69 6c 5f 63 6f 75 6e 74 22 20 22 70 61 73 73 ail_count" "pass
6130: 5f 63 6f 75 6e 74 22 20 22 63 6f 6e 74 6f 75 72 _count" "contour
6140: 22 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 29 " "last_update")
6150: 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 22 ))). (list "
6160: 61 72 63 68 69 76 65 5f 64 69 73 6b 73 22 0a 20 archive_disks".
6170: 20 20 20 20 20 20 20 20 20 20 27 28 22 69 64 22 '("id"
6180: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
6190: 27 28 22 61 72 63 68 69 76 65 5f 61 72 65 61 5f '("archive_area_
61a0: 6e 61 6d 65 22 20 23 66 29 20 0a 20 20 20 20 20 name" #f) .
61b0: 20 20 20 20 20 20 27 28 22 64 69 73 6b 5f 70 61 '("disk_pa
61c0: 74 68 22 20 23 66 29 0a 20 20 20 20 20 20 20 20 th" #f).
61d0: 20 20 20 27 28 22 6c 61 73 74 5f 64 66 22 20 23 '("last_df" #
61e0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
61f0: 22 6c 61 73 74 5f 64 66 5f 74 69 6d 65 22 20 23 "last_df_time" #
6200: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
6210: 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 22 20 "creation_time"
6220: 23 66 29 29 20 0a 0a 20 20 20 20 20 28 6c 69 73 #f)) .. (lis
6230: 74 20 22 61 72 63 68 69 76 65 5f 62 6c 6f 63 6b t "archive_block
6240: 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 s". '(
6250: 22 69 64 22 20 23 66 29 0a 20 20 20 20 20 20 20 "id" #f).
6260: 20 20 20 20 27 28 22 61 72 63 68 69 76 65 5f 64 '("archive_d
6270: 69 73 6b 5f 69 64 22 20 23 66 29 20 0a 20 20 20 isk_id" #f) .
6280: 20 20 20 20 20 20 20 20 27 28 22 64 69 73 6b 5f '("disk_
6290: 70 61 74 68 22 20 23 66 29 0a 20 20 20 20 20 20 path" #f).
62a0: 20 20 20 20 20 27 28 22 6c 61 73 74 5f 64 75 22 '("last_du"
62b0: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
62c0: 27 28 22 6c 61 73 74 5f 64 75 5f 74 69 6d 65 22 '("last_du_time"
62d0: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
62e0: 27 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 '("creation_time
62f0: 22 20 23 66 29 29 20 0a 0a 20 20 20 20 20 28 6c " #f)) .. (l
6300: 69 73 74 20 22 74 65 73 74 5f 6d 65 74 61 22 0a ist "test_meta".
6310: 09 20 20 20 27 28 22 69 64 22 20 20 20 20 20 20 . '("id"
6320: 20 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 27 #f).. '
6330: 28 22 74 65 73 74 6e 61 6d 65 22 20 20 20 20 20 ("testname"
6340: 20 20 23 66 29 0a 09 20 20 20 27 28 22 6f 77 6e #f).. '("own
6350: 65 72 22 20 20 20 20 20 20 20 20 20 20 23 66 29 er" #f)
6360: 0a 09 20 20 20 27 28 22 64 65 73 63 72 69 70 74 .. '("descript
6370: 69 6f 6e 22 20 20 20 20 23 66 29 0a 09 20 20 20 ion" #f)..
6380: 27 28 22 72 65 76 69 65 77 65 64 22 20 20 20 20 '("reviewed"
6390: 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 69 74 #f).. '("it
63a0: 65 72 61 74 65 64 22 20 20 20 20 20 20 20 23 66 erated" #f
63b0: 29 0a 09 20 20 20 27 28 22 61 76 67 5f 72 75 6e ).. '("avg_run
63c0: 74 69 6d 65 22 20 20 20 20 23 66 29 0a 09 20 20 time" #f)..
63d0: 20 27 28 22 61 76 67 5f 64 69 73 6b 22 20 20 20 '("avg_disk"
63e0: 20 20 20 20 23 66 29 0a 09 20 20 20 27 28 22 74 #f).. '("t
63f0: 61 67 73 22 20 20 20 20 20 20 20 20 20 20 20 23 ags" #
6400: 66 29 0a 09 20 20 20 27 28 22 6a 6f 62 67 72 6f f).. '("jobgro
6410: 75 70 22 20 20 20 20 20 20 20 23 66 29 29 0a 0a up" #f))..
6420: 0a 20 20 20 20 20 28 6c 69 73 74 20 22 74 61 73 . (list "tas
6430: 6b 73 5f 71 75 65 75 65 22 0a 20 20 20 20 20 20 ks_queue".
6440: 20 20 20 20 20 27 28 22 69 64 22 20 20 20 20 20 '("id"
6450: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f).
6460: 20 20 20 20 20 20 27 28 22 61 63 74 69 6f 6e 22 '("action"
6470: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 #f).
6480: 20 20 20 20 20 20 20 27 28 22 6f 77 6e 65 72 22 '("owner"
6490: 20 20 20 20 20 20 20 20 20 23 66 29 20 0a 20 20 #f) .
64a0: 20 20 20 20 20 20 20 20 20 27 28 22 73 74 61 74 '("stat
64b0: 65 22 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 e" #f).
64c0: 20 20 20 20 20 20 20 20 20 20 27 28 22 74 61 72 '("tar
64d0: 67 65 74 22 20 20 20 20 20 20 20 20 23 66 29 0a get" #f).
64e0: 20 20 20 20 20 20 20 20 20 20 20 27 28 22 6e 61 '("na
64f0: 6d 65 22 20 20 20 20 20 20 20 20 20 20 23 66 29 me" #f)
6500: 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 74 . '("t
6510: 65 73 74 70 61 74 74 22 20 20 20 20 20 20 23 66 estpatt" #f
6520: 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 22 ). '("
6530: 6b 65 79 6c 6f 63 6b 22 20 20 20 20 20 20 20 23 keylock" #
6540: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 28 f). '(
6550: 22 70 61 72 61 6d 73 22 20 20 20 20 20 20 20 20 "params"
6560: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 27 #f). '
6570: 28 22 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 22 ("creation_time"
6580: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
6590: 27 28 22 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d '("execution_tim
65a0: 65 22 20 23 66 29 29 0a 20 20 20 20 20 29 29 29 e" #f)). )))
65b0: 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 73 79 ..(define (db:sy
65c0: 6e 63 2d 61 6c 6c 2d 74 61 62 6c 65 73 2d 6c 69 nc-all-tables-li
65d0: 73 74 20 6b 65 79 73 29 0a 20 20 28 61 70 70 65 st keys). (appe
65e0: 6e 64 20 28 64 62 3a 73 79 6e 63 2d 6d 61 69 6e nd (db:sync-main
65f0: 2d 6c 69 73 74 20 6b 65 79 73 29 0a 09 20 20 64 -list keys).. d
6600: 62 3a 73 79 6e 63 2d 74 65 73 74 73 2d 6f 6e 6c b:sync-tests-onl
6610: 79 29 29 0a 0a 3b 3b 20 74 62 6c 73 20 69 73 20 y))..;; tbls is
6620: 28 20 28 22 74 61 62 6c 65 6e 61 6d 65 22 20 28 ( ("tablename" (
6630: 20 22 66 69 65 6c 64 31 22 20 5b 23 66 7c 70 72 "field1" [#f|pr
6640: 6f 63 31 5d 20 29 20 28 20 22 66 69 65 6c 64 32 oc1] ) ( "field2
6650: 22 20 5b 23 66 7c 70 72 6f 63 32 5d 20 29 20 2e " [#f|proc2] ) .
6660: 2e 2e 2e 20 29 20 29 0a 3b 3b 20 64 62 27 73 20 ... ) ).;; db's
6670: 61 72 65 20 64 62 64 61 74 27 73 0a 3b 3b 0a 3b are dbdat's.;;.;
6680: 3b 20 69 66 20 6c 61 73 74 2d 75 70 64 61 74 65 ; if last-update
6690: 20 73 70 65 63 69 66 69 65 64 20 28 22 66 69 65 specified ("fie
66a0: 6c 64 2d 6e 61 6d 65 22 20 2e 20 74 69 6d 65 2d ld-name" . time-
66b0: 69 6e 2d 73 65 63 6f 6e 64 73 29 0a 3b 3b 20 20 in-seconds).;;
66c0: 20 20 74 68 65 6e 20 73 79 6e 63 20 6f 6e 6c 79 then sync only
66d0: 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 66 records where f
66e0: 69 65 6c 64 2d 6e 61 6d 65 20 3e 3d 20 74 69 6d ield-name >= tim
66f0: 65 2d 69 6e 2d 73 65 63 6f 6e 64 73 0a 3b 3b 20 e-in-seconds.;;
6700: 20 20 20 49 46 46 20 66 69 65 6c 64 2d 6e 61 6d IFF field-nam
6710: 65 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 65 66 e exists.;;.(def
6720: 69 6e 65 20 28 64 62 3a 73 79 6e 63 2d 74 61 62 ine (db:sync-tab
6730: 6c 65 73 20 74 62 6c 73 20 6c 61 73 74 2d 75 70 les tbls last-up
6740: 64 61 74 65 20 66 72 6f 6d 64 62 20 74 6f 64 62 date fromdb todb
6750: 20 2e 20 73 6c 61 76 65 2d 64 62 73 29 0a 20 20 . slave-dbs).
6760: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
6770: 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 ns. exn. (be
6780: 67 69 6e 0a 20 20 20 20 20 28 64 62 66 69 6c 65 gin. (dbfile
6790: 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 45 58 43 :print-err "EXC
67a0: 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 65 EPTION: database
67b0: 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c 6f probably overlo
67c0: 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 61 62 aded or unreadab
67d0: 6c 65 20 69 6e 20 64 62 3a 73 79 6e 63 2d 74 61 le in db:sync-ta
67e0: 62 6c 65 73 2e 22 29 0a 20 20 20 20 20 28 70 72 bles."). (pr
67f0: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
6800: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
6810: 72 74 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c rt)). (dbfil
6820: 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 20 6d e:print-err " m
6830: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
6840: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
6850: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
6860: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 ssage) exn)).
6870: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
6880: 65 72 72 20 20 22 65 78 6e 3d 22 20 28 63 6f 6e err "exn=" (con
6890: 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e dition->list exn
68a0: 29 29 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a )). (dbfile:
68b0: 70 72 69 6e 74 2d 65 72 72 20 20 22 20 73 74 61 print-err " sta
68c0: 74 75 73 3a 20 20 22 20 28 28 63 6f 6e 64 69 74 tus: " ((condit
68d0: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
68e0: 65 73 73 6f 72 20 27 73 71 6c 69 74 65 33 20 27 essor 'sqlite3 '
68f0: 73 74 61 74 75 73 29 20 65 78 6e 29 29 0a 20 20 status) exn)).
6900: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
6910: 2d 65 72 72 20 20 22 20 73 72 63 20 64 62 3a 20 -err " src db:
6920: 20 22 20 28 64 62 72 3a 64 62 64 61 74 2d 64 62 " (dbr:dbdat-db
6930: 66 69 6c 65 20 66 72 6f 6d 64 62 29 29 0a 20 20 file fromdb)).
6940: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
6950: 6d 62 64 61 20 28 64 62 64 61 74 29 0a 09 09 20 mbda (dbdat)...
6960: 28 6c 65 74 20 28 28 64 62 70 61 74 68 20 28 64 (let ((dbpath (d
6970: 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 20 br:dbdat-dbfile
6980: 64 62 64 61 74 29 29 29 0a 09 09 20 20 20 28 64 dbdat)))... (d
6990: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
69a0: 20 22 20 64 62 70 61 74 68 3a 20 20 22 20 64 62 " dbpath: " db
69b0: 70 61 74 68 29 0a 09 09 20 20 20 28 69 66 20 23 path)... (if #
69c0: 74 20 3b 3b 20 28 6e 6f 74 20 28 64 62 3a 72 65 t ;; (not (db:re
69d0: 70 61 69 72 2d 64 62 20 64 62 64 61 74 29 29 0a pair-db dbdat)).
69e0: 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
69f0: 09 09 09 20 28 64 62 66 69 6c 65 3a 70 72 69 6e ... (dbfile:prin
6a00: 74 2d 65 72 72 20 22 46 61 69 6c 65 64 20 74 6f t-err "Failed to
6a10: 20 72 65 62 75 69 6c 64 20 28 72 65 70 61 69 72 rebuild (repair
6a20: 20 69 73 20 74 75 72 6e 65 64 20 6f 66 66 29 20 is turned off)
6a30: 22 20 64 62 70 61 74 68 20 22 2c 20 65 78 69 74 " dbpath ", exit
6a40: 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 09 09 20 28 ing now.").... (
6a50: 65 78 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 exit)))))..
6a60: 20 20 28 63 6f 6e 73 20 74 6f 64 62 20 73 6c 61 (cons todb sla
6a70: 76 65 2d 64 62 73 29 29 0a 20 20 20 20 20 0a 20 ve-dbs)). .
6a80: 20 20 20 20 30 29 0a 0a 20 20 20 3b 3b 20 74 68 0).. ;; th
6a90: 69 73 20 69 73 20 74 68 65 20 77 6f 72 6b 20 74 is is the work t
6aa0: 6f 20 62 65 20 64 6f 6e 65 22 29 0a 20 20 20 28 o be done"). (
6ab0: 63 6f 6e 64 0a 20 20 20 20 28 28 6e 6f 74 20 66 cond. ((not f
6ac0: 72 6f 6d 64 62 29 20 28 64 62 66 69 6c 65 3a 70 romdb) (dbfile:p
6ad0: 72 69 6e 74 2d 65 72 72 20 20 22 57 41 52 4e 49 rint-err "WARNI
6ae0: 4e 47 3a 20 64 62 3a 73 79 6e 63 2d 74 61 62 6c NG: db:sync-tabl
6af0: 65 73 20 63 61 6c 6c 65 64 20 77 69 74 68 20 66 es called with f
6b00: 72 6f 6d 64 62 20 6d 69 73 73 69 6e 67 22 29 0a romdb missing").
6b10: 20 20 20 20 20 2d 31 29 0a 20 20 20 20 28 28 6e -1). ((n
6b20: 6f 74 20 74 6f 64 62 29 20 20 20 28 64 62 66 69 ot todb) (dbfi
6b30: 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 20 22 57 le:print-err "W
6b40: 41 52 4e 49 4e 47 3a 20 64 62 3a 73 79 6e 63 2d ARNING: db:sync-
6b50: 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 tables called wi
6b60: 74 68 20 74 6f 64 62 20 6d 69 73 73 69 6e 67 22 th todb missing"
6b70: 29 0a 20 20 20 20 20 2d 32 29 0a 20 20 20 20 28 ). -2). (
6b80: 28 6e 6f 74 20 28 73 71 6c 69 74 65 33 3a 64 61 (not (sqlite3:da
6b90: 74 61 62 61 73 65 3f 20 28 64 62 72 3a 64 62 64 tabase? (dbr:dbd
6ba0: 61 74 2d 64 62 68 20 66 72 6f 6d 64 62 29 29 29 at-dbh fromdb)))
6bb0: 0a 20 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 . (dbfile:pr
6bc0: 69 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 int-err "db:sync
6bd0: 2d 74 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 -tables called w
6be0: 69 74 68 20 66 72 6f 6d 64 62 20 6e 6f 74 20 61 ith fromdb not a
6bf0: 20 64 61 74 61 62 61 73 65 20 22 20 66 72 6f 6d database " from
6c00: 64 62 29 0a 20 20 20 2d 33 29 0a 20 20 20 20 28 db). -3). (
6c10: 28 6e 6f 74 20 28 73 71 6c 69 74 65 33 3a 64 61 (not (sqlite3:da
6c20: 74 61 62 61 73 65 3f 20 28 64 62 72 3a 64 62 64 tabase? (dbr:dbd
6c30: 61 74 2d 64 62 68 20 74 6f 64 62 29 29 29 0a 20 at-dbh todb))).
6c40: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
6c50: 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d 74 t-err "db:sync-t
6c60: 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 74 ables called wit
6c70: 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 64 61 74 h todb not a dat
6c80: 61 62 61 73 65 20 22 20 74 6f 64 62 29 0a 20 20 abase " todb).
6c90: 20 2d 34 29 0a 0a 20 20 20 20 28 28 6e 6f 74 20 -4).. ((not
6ca0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
6cb0: 73 73 3f 20 28 64 62 72 3a 64 62 64 61 74 2d 64 ss? (dbr:dbdat-d
6cc0: 62 66 69 6c 65 20 74 6f 64 62 29 29 29 0a 20 20 bfile todb))).
6cd0: 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 (dbfile:print
6ce0: 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d 74 61 -err "db:sync-ta
6cf0: 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 74 68 bles called with
6d00: 20 74 6f 64 62 20 6e 6f 74 20 61 20 72 65 61 64 todb not a read
6d10: 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 20 22 -only database "
6d20: 20 74 6f 64 62 29 0a 20 20 20 20 20 2d 35 29 0a todb). -5).
6d30: 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ((not (null?
6d40: 20 28 6c 65 74 20 28 28 72 65 61 64 6f 6e 6c 79 (let ((readonly
6d50: 2d 73 6c 61 76 65 2d 64 62 73 0a 20 20 20 20 20 -slave-dbs.
6d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d70: 20 20 20 28 66 69 6c 74 65 72 0a 20 20 20 20 20 (filter.
6d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d90: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 64 (lambda (dbd
6da0: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
6db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6dc0: 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d not (file-write-
6dd0: 61 63 63 65 73 73 3f 20 28 64 62 72 3a 64 62 64 access? (dbr:dbd
6de0: 61 74 2d 64 62 66 69 6c 65 20 74 6f 64 62 29 29 at-dbfile todb))
6df0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6e00: 20 20 20 20 20 20 20 20 20 20 20 20 73 6c 61 76 slav
6e10: 65 2d 64 62 73 29 29 29 0a 20 20 20 20 20 20 20 e-dbs))).
6e20: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 (for
6e30: 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 20 20 -each.
6e40: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
6e50: 61 20 28 62 61 64 2d 64 62 64 61 74 29 0a 20 20 a (bad-dbdat).
6e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e70: 20 20 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e (dbfile:prin
6e80: 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d 74 t-err "db:sync-t
6e90: 61 62 6c 65 73 20 63 61 6c 6c 65 64 20 77 69 74 ables called wit
6ea0: 68 20 74 6f 64 62 20 6e 6f 74 20 61 20 72 65 61 h todb not a rea
6eb0: 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 20 d-only database
6ec0: 22 20 62 61 64 2d 64 62 64 61 74 29 29 0a 20 20 " bad-dbdat)).
6ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ee0: 20 20 72 65 61 64 6f 6e 6c 79 2d 73 6c 61 76 65 readonly-slave
6ef0: 2d 64 62 73 29 0a 20 20 20 20 20 20 20 20 20 20 -dbs).
6f00: 20 20 20 20 20 20 20 20 20 72 65 61 64 6f 6e 6c readonl
6f10: 79 2d 73 6c 61 76 65 2d 64 62 73 29 29 29 20 2d y-slave-dbs))) -
6f20: 36 29 0a 20 20 20 20 28 65 6c 73 65 0a 20 20 20 6). (else.
6f30: 20 20 3b 3b 20 28 64 62 66 69 6c 65 3a 70 72 69 ;; (dbfile:pri
6f40: 6e 74 2d 65 72 72 20 22 64 62 3a 73 79 6e 63 2d nt-err "db:sync-
6f50: 74 61 62 6c 65 73 3a 20 61 72 67 73 20 61 72 65 tables: args are
6f60: 20 67 6f 6f 64 22 29 0a 0a 20 20 20 20 20 28 6c good").. (l
6f70: 65 74 20 28 28 73 74 6d 74 73 20 20 20 20 20 20 et ((stmts
6f80: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
6f90: 65 29 29 20 3b 3b 20 74 61 62 6c 65 2d 66 69 65 e)) ;; table-fie
6fa0: 6c 64 20 3d 3e 20 73 74 6d 74 0a 09 20 20 20 28 ld => stmt.. (
6fb0: 61 6c 6c 2d 73 74 6d 74 73 20 20 20 27 28 29 29 all-stmts '())
6fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
6fd0: 20 28 20 28 20 73 74 6d 74 31 20 76 61 6c 75 65 ( ( stmt1 value
6fe0: 31 20 29 20 28 20 73 74 6d 6c 32 20 76 61 6c 75 1 ) ( stml2 valu
6ff0: 65 32 20 29 29 0a 09 20 20 20 28 6e 75 6d 72 65 e2 )).. (numre
7000: 63 73 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 cs (make-has
7010: 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 28 73 h-table)).. (s
7020: 74 61 72 74 2d 74 69 6d 65 20 20 28 63 75 72 72 tart-time (curr
7030: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
7040: 29 29 0a 09 20 20 20 28 74 6f 74 2d 63 6f 75 6e )).. (tot-coun
7050: 74 20 20 20 30 29 29 0a 20 20 20 20 20 20 20 28 t 0)). (
7060: 66 6f 72 2d 65 61 63 68 20 3b 3b 20 74 61 62 6c for-each ;; tabl
7070: 65 0a 09 28 6c 61 6d 62 64 61 20 28 74 61 62 6c e..(lambda (tabl
7080: 65 64 61 74 29 0a 09 20 20 28 6c 65 74 2a 20 28 edat).. (let* (
7090: 28 74 61 62 6c 65 6e 61 6d 65 20 20 20 20 20 20 (tablename
70a0: 20 20 28 63 61 72 20 74 61 62 6c 65 64 61 74 29 (car tabledat)
70b0: 29 0a 09 09 20 28 66 69 65 6c 64 73 20 20 20 20 )... (fields
70c0: 20 20 20 20 20 20 20 28 63 64 72 20 74 61 62 6c (cdr tabl
70d0: 65 64 61 74 29 29 0a 09 09 20 28 68 61 73 2d 6c edat))... (has-l
70e0: 61 73 74 2d 75 70 64 61 74 65 20 20 28 6d 65 6d ast-update (mem
70f0: 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 ber "last_update
7100: 22 20 66 69 65 6c 64 73 29 29 0a 09 09 20 28 75 " fields))... (u
7110: 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 20 se-last-update
7120: 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 28 28 (cond..... ((
7130: 61 6e 64 20 68 61 73 2d 6c 61 73 74 2d 75 70 64 and has-last-upd
7140: 61 74 65 0a 09 09 09 09 09 20 20 28 6d 65 6d 62 ate...... (memb
7150: 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 er "last_update"
7160: 20 66 69 65 6c 64 73 29 29 0a 09 09 09 09 20 20 fields)).....
7170: 20 20 20 23 74 29 20 3b 3b 20 69 66 20 67 69 76 #t) ;; if giv
7180: 65 6e 20 61 20 6e 75 6d 62 65 72 2c 20 6a 75 73 en a number, jus
7190: 74 20 75 73 65 20 69 74 20 66 6f 72 20 61 6c 6c t use it for all
71a0: 20 66 69 65 6c 64 73 0a 09 09 09 09 20 20 20 20 fields.....
71b0: 28 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d 75 ((number? last-u
71c0: 70 64 61 74 65 29 20 23 66 29 20 3b 3b 20 69 66 pdate) #f) ;; if
71d0: 20 6e 6f 74 20 6d 61 74 63 68 65 64 20 66 69 72 not matched fir
71e0: 73 74 20 65 6e 74 72 79 20 74 68 65 6e 20 69 67 st entry then ig
71f0: 6e 6f 72 65 20 6c 61 73 74 2d 75 70 64 61 74 65 nore last-update
7200: 20 66 6f 72 20 74 68 69 73 20 74 61 62 6c 65 0a for this table.
7210: 09 09 09 09 20 20 20 20 28 28 61 6e 64 20 28 70 .... ((and (p
7220: 61 69 72 3f 20 6c 61 73 74 2d 75 70 64 61 74 65 air? last-update
7230: 29 0a 09 09 09 09 09 20 20 28 6d 65 6d 62 65 72 )...... (member
7240: 20 28 63 61 72 20 6c 61 73 74 2d 75 70 64 61 74 (car last-updat
7250: 65 29 20 20 20 20 3b 3b 20 6c 61 73 74 2d 75 70 e) ;; last-up
7260: 64 61 74 65 20 66 69 65 6c 64 20 6e 61 6d 65 0a date field name.
7270: 09 09 09 09 09 09 20 20 28 6d 61 70 20 63 61 72 ...... (map car
7280: 20 66 69 65 6c 64 73 29 29 29 0a 20 20 20 20 20 fields))).
7290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72b0: 20 20 20 23 74 29 0a 09 09 09 09 20 20 20 20 28 #t)..... (
72c0: 28 61 6e 64 20 6c 61 73 74 2d 75 70 64 61 74 65 (and last-update
72d0: 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 6c 61 73 (not (pair? las
72e0: 74 2d 75 70 64 61 74 65 29 29 20 28 6e 6f 74 20 t-update)) (not
72f0: 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d 75 70 (number? last-up
7300: 64 61 74 65 29 29 29 0a 09 09 09 09 20 20 20 20 date))).....
7310: 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 (dbfile:print-e
7320: 72 72 20 20 22 45 52 52 4f 52 3a 20 70 61 72 61 rr "ERROR: para
7330: 6d 65 74 65 72 20 6c 61 73 74 2d 75 70 64 61 74 meter last-updat
7340: 65 20 66 6f 72 20 64 62 3a 73 79 6e 63 2d 74 61 e for db:sync-ta
7350: 62 6c 65 73 20 6d 75 73 74 20 62 65 20 61 20 70 bles must be a p
7360: 61 69 72 20 6f 72 20 61 20 6e 75 6d 62 65 72 2c air or a number,
7370: 20 72 65 63 65 69 76 65 64 3a 20 22 20 6c 61 73 received: " las
7380: 74 2d 75 70 64 61 74 65 29 3b 3b 20 66 6f 75 6e t-update);; foun
7390: 64 20 69 6e 20 66 69 65 6c 64 73 0a 09 09 09 09 d in fields.....
73a0: 20 20 20 20 20 23 66 29 0a 09 09 09 09 20 20 20 #f).....
73b0: 20 28 65 6c 73 65 0a 09 09 09 09 20 20 20 20 20 (else.....
73c0: 23 66 29 29 29 0a 09 09 20 28 6c 61 73 74 2d 75 #f)))... (last-u
73d0: 70 64 61 74 65 2d 76 61 6c 75 65 20 28 69 66 20 pdate-value (if
73e0: 75 73 65 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 use-last-update
73f0: 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 20 63 68 ;; no need to ch
7400: 65 63 6b 20 66 6f 72 20 68 61 73 2d 6c 61 73 74 eck for has-last
7410: 2d 75 70 64 61 74 65 20 2d 20 69 74 20 69 73 20 -update - it is
7420: 61 6c 72 65 61 64 79 20 61 63 63 6f 75 6e 74 65 already accounte
7430: 64 20 66 6f 72 0a 09 09 09 09 09 28 69 66 20 28 d for......(if (
7440: 6e 75 6d 62 65 72 3f 20 6c 61 73 74 2d 75 70 64 number? last-upd
7450: 61 74 65 29 0a 09 09 09 09 09 20 20 20 20 6c 61 ate)...... la
7460: 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 09 20 st-update......
7470: 20 20 20 28 63 64 72 20 6c 61 73 74 2d 75 70 64 (cdr last-upd
7480: 61 74 65 29 29 0a 09 09 09 09 09 23 66 29 29 0a ate))......#f)).
7490: 09 09 20 28 6c 61 73 74 2d 75 70 64 61 74 65 2d .. (last-update-
74a0: 66 69 65 6c 64 20 28 69 66 20 75 73 65 2d 6c 61 field (if use-la
74b0: 73 74 2d 75 70 64 61 74 65 0a 09 09 09 09 09 28 st-update......(
74c0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6c 61 73 74 if (number? last
74d0: 2d 75 70 64 61 74 65 29 0a 09 09 09 09 09 20 20 -update)......
74e0: 20 20 22 6c 61 73 74 5f 75 70 64 61 74 65 22 0a "last_update".
74f0: 09 09 09 09 09 20 20 20 20 28 63 61 72 20 6c 61 ..... (car la
7500: 73 74 2d 75 70 64 61 74 65 29 29 0a 09 09 09 09 st-update)).....
7510: 09 23 66 29 29 0a 09 09 20 28 6e 75 6d 2d 66 69 .#f))... (num-fi
7520: 65 6c 64 73 20 28 6c 65 6e 67 74 68 20 66 69 65 elds (length fie
7530: 6c 64 73 29 29 0a 09 09 20 28 66 69 65 6c 64 2d lds))... (field-
7540: 3e 6e 75 6d 20 28 6d 61 6b 65 2d 68 61 73 68 2d >num (make-hash-
7550: 74 61 62 6c 65 29 29 0a 09 09 20 28 6e 75 6d 2d table))... (num-
7560: 3e 66 69 65 6c 64 20 28 61 70 70 6c 79 20 76 65 >field (apply ve
7570: 63 74 6f 72 20 28 6d 61 70 20 63 61 72 20 66 69 ctor (map car fi
7580: 65 6c 64 73 29 29 29 20 3b 3b 20 42 42 48 45 52 elds))) ;; BBHER
7590: 45 0a 09 09 20 28 66 75 6c 6c 2d 73 65 6c 20 20 E... (full-sel
75a0: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 (conc "SELECT "
75b0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
75c0: 65 72 73 65 20 28 6d 61 70 20 63 61 72 20 66 69 erse (map car fi
75d0: 65 6c 64 73 29 20 22 2c 22 29 20 0a 09 09 09 09 elds) ",") .....
75e0: 20 20 20 22 20 46 52 4f 4d 20 22 20 74 61 62 6c " FROM " tabl
75f0: 65 6e 61 6d 65 20 28 69 66 20 75 73 65 2d 6c 61 ename (if use-la
7600: 73 74 2d 75 70 64 61 74 65 20 3b 3b 20 61 70 70 st-update ;; app
7610: 6c 79 20 6c 61 73 74 2d 75 70 64 61 74 65 20 63 ly last-update c
7620: 72 69 74 65 72 69 61 0a 09 09 09 09 09 09 09 20 riteria........
7630: 20 28 63 6f 6e 63 20 22 20 57 48 45 52 45 20 22 (conc " WHERE "
7640: 20 6c 61 73 74 2d 75 70 64 61 74 65 2d 66 69 65 last-update-fie
7650: 6c 64 20 22 20 3e 3d 20 22 20 6c 61 73 74 2d 75 ld " >= " last-u
7660: 70 64 61 74 65 2d 76 61 6c 75 65 29 0a 09 09 09 pdate-value)....
7670: 09 09 09 09 20 20 22 22 29 0a 09 09 09 09 20 20 .... "").....
7680: 20 22 3b 22 29 29 0a 09 09 20 28 66 75 6c 6c 2d ";"))... (full-
7690: 69 6e 73 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 ins (conc "INS
76a0: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
76b0: 4e 54 4f 20 22 20 74 61 62 6c 65 6e 61 6d 65 20 NTO " tablename
76c0: 22 20 28 20 22 20 28 73 74 72 69 6e 67 2d 69 6e " ( " (string-in
76d0: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 tersperse (map c
76e0: 61 72 20 66 69 65 6c 64 73 29 20 22 2c 22 29 20 ar fields) ",")
76f0: 22 20 29 20 22 0a 09 09 09 09 20 20 20 22 20 56 " ) "..... " V
7700: 41 4c 55 45 53 20 28 20 22 20 28 73 74 72 69 6e ALUES ( " (strin
7710: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
7720: 61 6b 65 2d 6c 69 73 74 20 6e 75 6d 2d 66 69 65 ake-list num-fie
7730: 6c 64 73 20 22 3f 22 29 20 22 2c 22 29 20 22 20 lds "?") ",") "
7740: 29 3b 22 29 29 0a 09 09 20 28 66 72 6f 6d 64 61 );"))... (fromda
7750: 74 20 20 20 20 27 28 29 29 0a 09 09 20 28 66 72 t '())... (fr
7760: 6f 6d 64 61 74 73 20 20 20 27 28 29 29 0a 09 09 omdats '())...
7770: 20 28 74 6f 74 72 65 63 6f 72 64 73 20 30 29 0a (totrecords 0).
7780: 09 09 20 28 62 61 74 63 68 2d 6c 65 6e 20 20 31 .. (batch-len 1
7790: 30 30 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 3e 00) ;; (string->
77a0: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
77b0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
77c0: 69 67 64 61 74 2a 20 22 73 79 6e 63 22 20 22 62 igdat* "sync" "b
77d0: 61 74 63 68 73 69 7a 65 22 29 20 22 31 30 30 22 atchsize") "100"
77e0: 29 29 29 0a 09 09 20 28 74 6f 64 61 74 20 20 20 )))... (todat
77f0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
7800: 62 6c 65 29 29 0a 09 09 20 28 63 6f 75 6e 74 20 ble))... (count
7810: 20 20 20 20 20 30 29 0a 20 20 20 20 20 20 20 20 0).
7820: 20 20 20 20 20 20 20 20 20 28 66 69 65 6c 64 2d (field-
7830: 6e 61 6d 65 73 20 28 6d 61 70 20 63 61 72 20 66 names (map car f
7840: 69 65 6c 64 73 29 29 0a 20 20 20 20 20 20 20 20 ields)).
7850: 20 20 20 20 20 20 20 20 20 28 64 65 6c 61 79 2d (delay-
7860: 68 61 6e 64 69 63 61 70 20 20 30 29 20 3b 3b 20 handicap 0) ;;
7870: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
7880: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
7890: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
78a0: 22 73 79 6e 63 22 20 22 64 65 6c 61 79 2d 68 61 "sync" "delay-ha
78b0: 6e 64 69 63 61 70 22 29 20 22 30 22 29 29 29 0a ndicap") "0"))).
78c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78d0: 20 29 0a 0a 09 20 20 20 20 3b 3b 20 73 65 74 20 )... ;; set
78e0: 75 70 20 74 68 65 20 66 69 65 6c 64 2d 3e 6e 75 up the field->nu
78f0: 6d 20 74 61 62 6c 65 0a 09 20 20 20 20 28 66 6f m table.. (fo
7900: 72 2d 65 61 63 68 0a 09 20 20 20 20 20 28 6c 61 r-each.. (la
7910: 6d 62 64 61 20 28 66 69 65 6c 64 29 0a 09 20 20 mbda (field)..
7920: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
7930: 2d 73 65 74 21 20 66 69 65 6c 64 2d 3e 6e 75 6d -set! field->num
7940: 20 66 69 65 6c 64 20 63 6f 75 6e 74 29 0a 09 20 field count)..
7950: 20 20 20 20 20 20 28 73 65 74 21 20 63 6f 75 6e (set! coun
7960: 74 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 0a t (+ count 1))).
7970: 09 20 20 20 20 20 66 69 65 6c 64 73 29 0a 0a 09 . fields)...
7980: 20 20 20 20 3b 3b 20 72 65 61 64 20 74 68 65 20 ;; read the
7990: 73 6f 75 72 63 65 20 74 61 62 6c 65 0a 20 20 20 source table.
79a0: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 74 6f 72 ;; stor
79b0: 65 20 61 20 6c 69 73 74 20 6f 66 20 61 6c 6c 20 e a list of all
79c0: 72 6f 77 73 20 69 6e 20 74 68 65 20 74 61 62 6c rows in the tabl
79d0: 65 20 69 6e 20 66 72 6f 6d 64 61 74 2c 20 75 70 e in fromdat, up
79e0: 20 74 6f 20 62 61 74 63 68 2d 6c 65 6e 2e 0a 20 to batch-len..
79f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 54 68 ;; Th
7a00: 65 6e 20 61 64 64 20 66 72 6f 6d 64 61 74 20 74 en add fromdat t
7a10: 6f 20 74 68 65 20 66 72 6f 6d 64 61 74 73 20 6c o the fromdats l
7a20: 69 73 74 2c 20 63 6c 65 61 72 20 66 72 6f 6d 64 ist, clear fromd
7a30: 61 74 20 61 6e 64 20 72 65 70 65 61 74 2e 0a 09 at and repeat...
7a40: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
7a50: 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 20 20 -each-row..
7a60: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a (lambda (a . b).
7a70: 09 20 20 20 20 20 20 20 28 73 65 74 21 20 66 72 . (set! fr
7a80: 6f 6d 64 61 74 20 28 63 6f 6e 73 20 28 61 70 70 omdat (cons (app
7a90: 6c 79 20 76 65 63 74 6f 72 20 61 20 62 29 20 66 ly vector a b) f
7aa0: 72 6f 6d 64 61 74 29 29 0a 09 20 20 20 20 20 20 romdat))..
7ab0: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
7ac0: 66 72 6f 6d 64 61 74 29 20 62 61 74 63 68 2d 6c fromdat) batch-l
7ad0: 65 6e 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a en)... (begin.
7ae0: 09 09 20 20 20 20 20 28 73 65 74 21 20 66 72 6f .. (set! fro
7af0: 6d 64 61 74 73 20 28 63 6f 6e 73 20 66 72 6f 6d mdats (cons from
7b00: 64 61 74 20 66 72 6f 6d 64 61 74 73 29 29 0a 09 dat fromdats))..
7b10: 09 20 20 20 20 20 28 73 65 74 21 20 66 72 6f 6d . (set! from
7b20: 64 61 74 20 20 27 28 29 29 0a 09 09 20 20 20 20 dat '())...
7b30: 20 28 73 65 74 21 20 74 6f 74 72 65 63 6f 72 64 (set! totrecord
7b40: 73 20 28 2b 20 74 6f 74 72 65 63 6f 72 64 73 20 s (+ totrecords
7b50: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1))).
7b60: 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 ).
7b70: 20 20 20 29 0a 09 20 20 20 20 20 28 64 62 72 3a ).. (dbr:
7b80: 64 62 64 61 74 2d 64 62 68 20 66 72 6f 6d 64 62 dbdat-dbh fromdb
7b90: 29 0a 09 20 20 20 20 20 66 75 6c 6c 2d 73 65 6c ).. full-sel
7ba0: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )..
7bb0: 3b 3b 20 43 6f 75 6e 74 20 6c 65 73 73 20 74 68 ;; Count less th
7bc0: 61 6e 20 62 61 74 63 68 2d 6c 65 6e 20 61 73 20 an batch-len as
7bd0: 61 20 72 65 63 6f 72 64 0a 20 20 20 20 20 20 20 a record.
7be0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 (if (> (le
7bf0: 6e 67 74 68 20 66 72 6f 6d 64 61 74 29 20 30 29 ngth fromdat) 0)
7c00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7c10: 20 20 28 73 65 74 21 20 74 6f 74 72 65 63 6f 72 (set! totrecor
7c20: 64 73 20 28 2b 20 74 6f 74 72 65 63 6f 72 64 73 ds (+ totrecords
7c30: 20 31 29 29 29 0a 0a 09 20 20 20 20 3b 3b 20 74 1)))... ;; t
7c40: 61 63 6b 20 6f 6e 20 72 65 6d 61 69 6e 69 6e 67 ack on remaining
7c50: 20 72 65 63 6f 72 64 73 20 69 6e 20 66 72 6f 6d records in from
7c60: 64 61 74 0a 09 20 20 20 20 28 69 66 20 28 6e 6f dat.. (if (no
7c70: 74 20 28 6e 75 6c 6c 3f 20 66 72 6f 6d 64 61 74 t (null? fromdat
7c80: 29 29 0a 09 09 28 73 65 74 21 20 66 72 6f 6d 64 ))...(set! fromd
7c90: 61 74 73 20 28 63 6f 6e 73 20 66 72 6f 6d 64 61 ats (cons fromda
7ca0: 74 20 66 72 6f 6d 64 61 74 73 29 29 29 0a 0a 09 t fromdats)))...
7cb0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
7cc0: 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 20 20 -each-row..
7cd0: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a (lambda (a . b).
7ce0: 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 . (hash-ta
7cf0: 62 6c 65 2d 73 65 74 21 20 74 6f 64 61 74 20 61 ble-set! todat a
7d00: 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 61 (apply vector a
7d10: 20 62 29 29 29 0a 09 20 20 20 20 20 28 64 62 72 b))).. (dbr
7d20: 3a 64 62 64 61 74 2d 64 62 68 20 74 6f 64 62 29 :dbdat-dbh todb)
7d30: 0a 09 20 20 20 20 20 66 75 6c 6c 2d 73 65 6c 29 .. full-sel)
7d40: 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 77 .. (w
7d50: 68 65 6e 20 28 61 6e 64 20 64 65 6c 61 79 2d 68 hen (and delay-h
7d60: 61 6e 64 69 63 61 70 20 28 3e 20 64 65 6c 61 79 andicap (> delay
7d70: 2d 68 61 6e 64 69 63 61 70 20 30 29 29 0a 20 20 -handicap 0)).
7d80: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 66 (dbf
7d90: 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 69 ile:print-err "i
7da0: 6d 70 6f 73 69 6e 67 20 73 79 6e 74 68 65 74 69 mposing syntheti
7db0: 63 20 73 79 6e 63 20 64 65 6c 61 79 20 6f 66 20 c sync delay of
7dc0: 22 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 22 "delay-handicap"
7dd0: 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 73 seconds since s
7de0: 79 6e 63 2f 64 65 6c 61 79 2d 68 61 6e 64 69 63 ync/delay-handic
7df0: 61 70 20 69 73 20 63 6f 6e 66 69 67 75 72 65 64 ap is configured
7e00: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
7e10: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
7e20: 64 65 6c 61 79 2d 68 61 6e 64 69 63 61 70 29 0a delay-handicap).
7e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
7e40: 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 bfile:print-err
7e50: 22 73 79 6e 74 68 65 74 69 63 20 73 79 6e 63 20 "synthetic sync
7e60: 64 65 6c 61 79 20 6f 66 20 22 64 65 6c 61 79 2d delay of "delay-
7e70: 68 61 6e 64 69 63 61 70 22 20 73 65 63 6f 6e 64 handicap" second
7e80: 73 20 63 6f 6d 70 6c 65 74 65 64 22 29 0a 20 20 s completed").
7e90: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 ).
7ea0: 20 20 20 20 20 20 20 20 20 20 0a 09 20 20 20 20 ..
7eb0: 3b 3b 20 66 69 72 73 74 20 70 61 73 73 20 69 6d ;; first pass im
7ec0: 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 2c 20 6a 75 plementation, ju
7ed0: 73 74 20 69 6e 73 65 72 74 20 61 6c 6c 20 63 68 st insert all ch
7ee0: 61 6e 67 65 64 20 72 6f 77 73 0a 0a 09 20 20 20 anged rows...
7ef0: 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 (for-each ..
7f00: 20 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 64 (lambda (targd
7f10: 62 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 2a b).. (let*
7f20: 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 ((db
7f30: 20 20 20 20 20 20 28 64 62 72 3a 64 62 64 61 74 (dbr:dbdat
7f40: 2d 64 62 68 20 74 61 72 67 64 62 29 29 0a 20 20 -dbh targdb)).
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 28 64 72 70 2d 74 72 69 67 67 65 72 (drp-trigger
7f70: 20 20 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d (if (mem
7f80: 62 65 72 20 22 6c 61 73 74 5f 75 70 64 61 74 65 ber "last_update
7f90: 22 20 66 69 65 6c 64 2d 6e 61 6d 65 73 29 0a 09 " field-names)..
7fa0: 09 09 09 09 20 20 20 20 20 20 28 64 62 3a 64 72 .... (db:dr
7fb0: 6f 70 2d 74 72 69 67 67 65 72 20 64 62 20 74 61 op-trigger db ta
7fc0: 62 6c 65 6e 61 6d 65 29 20 0a 09 09 09 09 09 20 blename) ......
7fd0: 20 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 20 #f))...
7fe0: 20 20 28 68 61 73 2d 6c 61 73 74 2d 75 70 64 61 (has-last-upda
7ff0: 74 65 20 20 20 20 28 6d 65 6d 62 65 72 20 22 6c te (member "l
8000: 61 73 74 5f 75 70 64 61 74 65 22 20 66 69 65 6c ast_update" fiel
8010: 64 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 d-names)).
8020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8030: 28 69 73 2d 74 72 69 67 67 65 72 2d 64 72 6f 70 (is-trigger-drop
8040: 70 65 64 20 28 69 66 20 68 61 73 2d 6c 61 73 74 ped (if has-last
8050: 2d 75 70 64 61 74 65 0a 20 20 20 20 20 20 20 20 -update.
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8080: 20 20 20 20 20 20 28 64 62 3a 69 73 2d 74 72 69 (db:is-tri
8090: 67 67 65 72 2d 64 72 6f 70 70 65 64 20 64 62 20 gger-dropped db
80a0: 74 61 62 6c 65 6e 61 6d 65 29 0a 09 09 09 09 09 tablename)......
80b0: 20 20 20 20 20 20 23 66 29 29 20 0a 09 09 20 20 #f)) ...
80c0: 20 20 20 20 28 73 74 6d 74 68 20 20 28 73 71 6c (stmth (sql
80d0: 69 74 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 ite3:prepare db
80e0: 66 75 6c 6c 2d 69 6e 73 29 29 0a 20 20 20 20 20 full-ins)).
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8100: 20 28 63 68 61 6e 67 65 64 2d 72 6f 77 73 20 30 (changed-rows 0
8110: 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 0a ))... (for-each.
8120: 09 09 20 20 28 6c 61 6d 62 64 61 20 28 66 72 6f .. (lambda (fro
8130: 6d 64 61 74 2d 6c 73 74 29 0a 09 09 20 20 20 20 mdat-lst)...
8140: 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 (sqlite3:with-tr
8150: 61 6e 73 61 63 74 69 6f 6e 0a 09 09 20 20 20 20 ansaction...
8160: 20 64 62 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 db... (lamb
8170: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
8180: 66 6f 72 2d 65 61 63 68 20 3b 3b 20 0a 09 09 09 for-each ;; ....
8190: 28 6c 61 6d 62 64 61 20 28 66 72 6f 6d 72 6f 77 (lambda (fromrow
81a0: 29 0a 09 09 09 20 20 28 6c 65 74 2a 20 28 28 61 ).... (let* ((a
81b0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
81c0: 66 72 6f 6d 72 6f 77 20 30 29 29 0a 09 09 09 09 fromrow 0)).....
81d0: 20 28 63 75 72 72 20 28 68 61 73 68 2d 74 61 62 (curr (hash-tab
81e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
81f0: 6f 64 61 74 20 61 20 23 66 29 29 0a 09 09 09 09 odat a #f)).....
8200: 20 28 73 61 6d 65 20 23 74 29 29 0a 09 09 09 20 (same #t))....
8210: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i
8220: 20 30 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 0)).... (i
8230: 66 20 28 6f 72 20 28 6e 6f 74 20 63 75 72 72 29 f (or (not curr)
8240: 0a 09 09 09 09 20 20 20 20 20 20 28 6e 6f 74 20 ..... (not
8250: 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
8260: 72 65 66 20 66 72 6f 6d 72 6f 77 20 69 29 28 76 ref fromrow i)(v
8270: 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 20 69 ector-ref curr i
8280: 29 29 29 29 0a 09 09 09 09 20 20 28 73 65 74 21 ))))..... (set!
8290: 20 73 61 6d 65 20 23 66 29 29 0a 09 09 09 20 20 same #f))....
82a0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 61 6d (if (and sam
82b0: 65 0a 09 09 09 09 20 20 20 20 20 20 20 28 3c 20 e..... (<
82c0: 69 20 28 2d 20 6e 75 6d 2d 66 69 65 6c 64 73 20 i (- num-fields
82d0: 31 29 29 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 1)))..... (loop
82e0: 20 28 2b 20 69 20 31 29 29 29 29 0a 09 09 09 20 (+ i 1))))....
82f0: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 61 6d 65 (if (not same
8300: 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ).....(begin....
8310: 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 . (apply sqlite
8320: 33 3a 65 78 65 63 75 74 65 20 73 74 6d 74 68 20 3:execute stmth
8330: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 66 72 (vector->list fr
8340: 6f 6d 72 6f 77 29 29 0a 09 09 09 09 20 20 28 68 omrow))..... (h
8350: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 6e ash-table-set! n
8360: 75 6d 72 65 63 73 20 74 61 62 6c 65 6e 61 6d 65 umrecs tablename
8370: 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c (+ 1 (hash-tabl
8380: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6e 75 e-ref/default nu
8390: 6d 72 65 63 73 20 74 61 62 6c 65 6e 61 6d 65 20 mrecs tablename
83a0: 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0))).
83b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83c0: 20 20 20 20 20 20 20 28 73 65 74 21 20 63 68 61 (set! cha
83d0: 6e 67 65 64 2d 72 6f 77 73 20 28 2b 20 63 68 61 nged-rows (+ cha
83e0: 6e 67 65 64 2d 72 6f 77 73 20 31 29 29 0a 20 20 nged-rows 1)).
83f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 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 20 20 20 20 20 29 29 0a 09 09 09 ))....
8450: 66 72 6f 6d 64 61 74 2d 6c 73 74 29 29 29 29 0a fromdat-lst)))).
8460: 09 09 20 20 66 72 6f 6d 64 61 74 73 29 0a 0a 09 .. fromdats)...
8470: 09 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c . (sqlite3:final
8480: 69 7a 65 21 20 73 74 6d 74 68 29 0a 20 20 20 20 ize! stmth).
8490: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
84a0: 20 28 6d 65 6d 62 65 72 20 22 6c 61 73 74 5f 75 (member "last_u
84b0: 70 64 61 74 65 22 20 66 69 65 6c 64 2d 6e 61 6d pdate" field-nam
84c0: 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 es).
84d0: 20 20 20 20 20 20 20 20 28 64 62 3a 63 72 65 61 (db:crea
84e0: 74 65 2d 74 72 69 67 67 65 72 20 64 62 20 74 61 te-trigger db ta
84f0: 62 6c 65 6e 61 6d 65 29 29 29 29 0a 09 20 20 20 blename))))..
8500: 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 (append (list
8510: 74 6f 64 62 29 20 73 6c 61 76 65 2d 64 62 73 29 todb) slave-dbs)
8520: 0a 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 . ).
8530: 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
8540: 20 20 29 0a 09 74 62 6c 73 29 0a 20 20 20 20 20 )..tbls).
8550: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 74 69 6d (let* ((runtim
8560: 65 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 e (- (curre
8570: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
8580: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 20 start-time))..
8590: 20 20 20 20 20 28 73 68 6f 75 6c 64 2d 70 72 69 (should-pri
85a0: 6e 74 20 28 6f 72 20 3b 3b 20 28 64 65 62 75 67 nt (or ;; (debug
85b0: 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 32 29 0a :debug-mode 12).
85c0: 09 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ... (common:
85d0: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
85e0: 31 32 30 20 22 64 62 20 73 79 6e 63 22 29 0a 09 120 "db sync")..
85f0: 09 09 20 20 20 20 20 28 3e 20 72 75 6e 74 69 6d .. (> runtim
8600: 65 20 35 30 30 29 29 29 29 20 3b 3b 20 6c 6f 77 e 500)))) ;; low
8610: 20 61 6e 64 20 68 69 67 68 20 73 79 6e 63 20 74 and high sync t
8620: 69 6d 65 73 20 74 72 65 61 74 65 64 20 61 73 20 imes treated as
8630: 73 65 70 61 72 61 74 65 2e 0a 09 20 28 66 6f 72 separate... (for
8640: 2d 65 61 63 68 20 0a 09 20 20 28 6c 61 6d 62 64 -each .. (lambd
8650: 61 20 28 64 61 74 29 0a 09 20 20 20 20 28 6c 65 a (dat).. (le
8660: 74 20 28 28 74 62 6c 6e 61 6d 65 20 28 63 61 72 t ((tblname (car
8670: 20 64 61 74 29 29 0a 09 09 20 20 28 63 6f 75 6e dat))... (coun
8680: 74 20 20 20 28 63 64 72 20 64 61 74 29 29 29 0a t (cdr dat))).
8690: 09 20 20 20 20 20 20 28 73 65 74 21 20 74 6f 74 . (set! tot
86a0: 2d 63 6f 75 6e 74 20 28 2b 20 74 6f 74 2d 63 6f -count (+ tot-co
86b0: 75 6e 74 20 63 6f 75 6e 74 29 29 0a 20 20 20 20 unt count)).
86c0: 20 20 20 20 20 20 20 20 20 20 29 29 20 0a 09 20 )) ..
86d0: 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
86e0: 6c 65 2d 3e 61 6c 69 73 74 20 6e 75 6d 72 65 63 le->alist numrec
86f0: 73 29 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 s)(lambda (a b)(
8700: 3e 20 28 63 64 72 20 61 29 28 63 64 72 20 62 29 > (cdr a)(cdr b)
8710: 29 29 29 29 29 0a 20 20 20 20 20 20 20 74 6f 74 ))))). tot
8720: 2d 63 6f 75 6e 74 29 29 29 29 29 0a 0a 3b 3b 3d -count)))))..;;=
8730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8740: 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 74 72 69 67 67 65 72 =====.;; trigger
8780: 20 73 65 74 75 70 2f 74 61 6b 65 64 6f 77 6e 0a setup/takedown.
8790: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
87a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 64 65 66 69 6e ========..(defin
87e0: 65 20 64 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 e db:trigger-lis
87f0: 74 20 0a 20 20 20 20 20 28 6c 69 73 74 20 28 6c t . (list (l
8800: 69 73 74 20 22 75 70 64 61 74 65 5f 72 75 6e 73 ist "update_runs
8810: 5f 74 72 69 67 67 65 72 22 20 20 22 43 52 45 41 _trigger" "CREA
8820: 54 45 20 54 52 49 47 47 45 52 20 49 46 20 4e 4f TE TRIGGER IF NO
8830: 54 20 45 58 49 53 54 53 20 75 70 64 61 74 65 5f T EXISTS update_
8840: 72 75 6e 73 5f 74 72 69 67 67 65 72 20 41 46 54 runs_trigger AFT
8850: 45 52 20 55 50 44 41 54 45 20 4f 4e 20 72 75 6e ER UPDATE ON run
8860: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 F
8880: 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 OR EACH ROW.
8890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88a0: 20 20 20 20 20 20 20 20 20 20 20 42 45 47 49 4e BEGIN
88b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
88c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88d0: 20 20 20 55 50 44 41 54 45 20 72 75 6e 73 20 53 UPDATE runs S
88e0: 45 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 ET last_update=(
88f0: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
8900: 6f 77 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 ow')).
8910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8920: 20 20 20 20 20 20 20 20 20 57 48 45 52 45 20 69 WHERE i
8930: 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 d=old.id;.
8940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8950: 20 20 20 20 20 20 20 20 20 45 4e 44 3b 22 20 29 END;" )
8960: 20 0a 09 20 20 20 28 6c 69 73 74 20 22 75 70 64 .. (list "upd
8970: 61 74 65 5f 72 75 6e 5f 73 74 61 74 73 5f 74 72 ate_run_stats_tr
8980: 69 67 67 65 72 22 20 20 22 43 52 45 41 54 45 20 igger" "CREATE
8990: 54 52 49 47 47 45 52 20 20 49 46 20 4e 4f 54 20 TRIGGER IF NOT
89a0: 45 58 49 53 54 53 20 75 70 64 61 74 65 5f 72 75 EXISTS update_ru
89b0: 6e 5f 73 74 61 74 73 5f 74 72 69 67 67 65 72 20 n_stats_trigger
89c0: 41 46 54 45 52 20 55 50 44 41 54 45 20 4f 4e 20 AFTER UPDATE ON
89d0: 72 75 6e 5f 73 74 61 74 73 0a 20 20 20 20 20 20 run_stats.
89e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89f0: 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 FOR EACH
8a00: 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 ROW.
8a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a20: 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 BEGIN .
8a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a40: 20 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 UPDAT
8a50: 45 20 72 75 6e 5f 73 74 61 74 73 20 53 45 54 20 E run_stats SET
8a60: 6c 61 73 74 5f 75 70 64 61 74 65 3d 28 73 74 72 last_update=(str
8a70: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
8a80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8aa0: 20 20 20 20 20 20 57 48 45 52 45 20 69 64 3d 6f WHERE id=o
8ab0: 6c 64 2e 69 64 3b 0a 20 20 20 20 20 20 20 20 20 ld.id;.
8ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ad0: 20 20 20 20 20 20 45 4e 44 3b 22 20 29 0a 09 20 END;" )..
8ae0: 20 20 28 6c 69 73 74 20 22 75 70 64 61 74 65 5f (list "update_
8af0: 74 65 73 74 73 5f 74 72 69 67 67 65 72 22 20 20 tests_trigger"
8b00: 22 43 52 45 41 54 45 20 54 52 49 47 47 45 52 20 "CREATE TRIGGER
8b10: 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 IF NOT EXISTS u
8b20: 70 64 61 74 65 5f 74 65 73 74 73 5f 74 72 69 67 pdate_tests_trig
8b30: 67 65 72 20 41 46 54 45 52 20 55 50 44 41 54 45 ger AFTER UPDATE
8b40: 20 4f 4e 20 74 65 73 74 73 0a 20 20 20 20 20 20 ON tests.
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b60: 20 20 20 20 20 20 20 46 4f 52 20 45 41 43 48 20 FOR EACH
8b70: 52 4f 57 0a 20 20 20 20 20 20 20 20 20 20 20 20 ROW.
8b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b90: 20 20 20 42 45 47 49 4e 20 0a 20 20 20 20 20 20 BEGIN .
8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bb0: 20 20 20 20 20 20 20 20 20 20 20 55 50 44 41 54 UPDAT
8bc0: 45 20 74 65 73 74 73 20 53 45 54 20 6c 61 73 74 E tests SET last
8bd0: 5f 75 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d _update=(strftim
8be0: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 e('%s','now')).
8bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c10: 20 20 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 WHERE id=old.i
8c20: 64 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d;.
8c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c40: 20 20 45 4e 44 3b 22 20 29 0a 09 20 20 20 28 6c END;" ).. (l
8c50: 69 73 74 20 22 75 70 64 61 74 65 5f 74 65 73 74 ist "update_test
8c60: 73 74 65 70 73 5f 74 72 69 67 67 65 72 22 20 20 steps_trigger"
8c70: 22 43 52 45 41 54 45 20 54 52 49 47 47 45 52 20 "CREATE TRIGGER
8c80: 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 IF NOT EXISTS u
8c90: 70 64 61 74 65 5f 74 65 73 74 73 74 65 70 73 5f pdate_teststeps_
8ca0: 74 72 69 67 67 65 72 20 41 46 54 45 52 20 55 50 trigger AFTER UP
8cb0: 44 41 54 45 20 4f 4e 20 74 65 73 74 5f 73 74 65 DATE ON test_ste
8cc0: 70 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ps.
8cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ce0: 46 4f 52 20 45 41 43 48 20 52 4f 57 0a 20 20 20 FOR EACH ROW.
8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d00: 20 20 20 20 20 20 20 20 20 20 20 20 42 45 47 49 BEGI
8d10: 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 N .
8d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d30: 20 20 20 20 55 50 44 41 54 45 20 74 65 73 74 5f UPDATE test_
8d40: 73 74 65 70 73 20 53 45 54 20 6c 61 73 74 5f 75 steps SET last_u
8d50: 70 64 61 74 65 3d 28 73 74 72 66 74 69 6d 65 28 pdate=(strftime(
8d60: 27 25 73 27 2c 27 6e 6f 77 27 29 29 0a 20 20 20 '%s','now')).
8d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d90: 57 48 45 52 45 20 69 64 3d 6f 6c 64 2e 69 64 3b WHERE id=old.id;
8da0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dc0: 45 4e 44 3b 22 20 29 0a 09 20 20 20 28 6c 69 73 END;" ).. (lis
8dd0: 74 20 22 75 70 64 61 74 65 5f 74 65 73 74 5f 64 t "update_test_d
8de0: 61 74 61 5f 74 72 69 67 67 65 72 22 20 20 22 43 ata_trigger" "C
8df0: 52 45 41 54 45 20 54 52 49 47 47 45 52 20 20 49 REATE TRIGGER I
8e00: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 75 70 64 F NOT EXISTS upd
8e10: 61 74 65 5f 74 65 73 74 5f 64 61 74 61 5f 74 72 ate_test_data_tr
8e20: 69 67 67 65 72 20 41 46 54 45 52 20 55 50 44 41 igger AFTER UPDA
8e30: 54 45 20 4f 4e 20 74 65 73 74 5f 64 61 74 61 0a TE ON test_data.
8e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 4f 52 FOR
8e60: 20 45 41 43 48 20 52 4f 57 0a 20 20 20 20 20 20 EACH ROW.
8e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e80: 20 20 20 20 20 20 20 20 20 42 45 47 49 4e 20 0a BEGIN .
8e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8eb0: 20 55 50 44 41 54 45 20 74 65 73 74 5f 64 61 74 UPDATE test_dat
8ec0: 61 20 53 45 54 20 6c 61 73 74 5f 75 70 64 61 74 a SET last_updat
8ed0: 65 3d 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 e=(strftime('%s'
8ee0: 2c 27 6e 6f 77 27 29 29 0a 20 20 20 20 20 20 20 ,'now')).
8ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f00: 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 WHER
8f10: 45 20 69 64 3d 6f 6c 64 2e 69 64 3b 0a 20 20 20 E id=old.id;.
8f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f30: 20 20 20 20 20 20 20 20 20 20 20 20 45 4e 44 3b END;
8f40: 22 20 29 29 29 0a 28 64 65 66 69 6e 65 20 28 64 " ))).(define (d
8f50: 62 3a 69 73 2d 74 72 69 67 67 65 72 2d 64 72 6f b:is-trigger-dro
8f60: 70 70 65 64 20 64 62 20 74 62 6c 2d 6e 61 6d 65 pped db tbl-name
8f70: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 72 69 67 ). (let* ((trig
8f80: 67 65 72 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 ger-name (if (eq
8f90: 75 61 6c 3f 20 74 62 6c 2d 6e 61 6d 65 20 22 74 ual? tbl-name "t
8fa0: 65 73 74 5f 73 74 65 70 73 22 29 0a 09 09 09 20 est_steps")....
8fb0: 20 20 22 75 70 64 61 74 65 5f 74 65 73 74 73 74 "update_testst
8fc0: 65 70 73 5f 74 72 69 67 67 65 72 22 20 0a 20 20 eps_trigger" .
8fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fe0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 (conc "
8ff0: 75 70 64 61 74 65 5f 22 20 74 62 6c 2d 6e 61 6d update_" tbl-nam
9000: 65 20 22 5f 74 72 69 67 67 65 72 22 29 29 29 0a e "_trigger"))).
9010: 09 20 28 72 65 73 20 20 20 20 20 20 20 20 20 20 . (res
9020: 23 66 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 #f)). (sqlite
9030: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 3:for-each-row.
9040: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6e 61 6d (lambda (nam
9050: 65 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 e). (if (e
9060: 71 75 61 6c 3f 20 6e 61 6d 65 20 74 72 69 67 67 qual? name trigg
9070: 65 72 2d 6e 61 6d 65 29 0a 09 20 20 20 28 73 65 er-name).. (se
9080: 74 21 20 72 65 73 20 23 74 29 29 29 0a 20 20 20 t! res #t))).
9090: 20 20 64 62 20 0a 20 20 20 20 20 22 53 45 4c 45 db . "SELE
90a0: 43 54 20 6e 61 6d 65 20 46 52 4f 4d 20 73 71 6c CT name FROM sql
90b0: 69 74 65 5f 6d 61 73 74 65 72 20 57 48 45 52 45 ite_master WHERE
90c0: 20 74 79 70 65 20 3d 20 27 74 72 69 67 67 65 72 type = 'trigger
90d0: 27 20 3b 22 29 0a 20 20 20 20 72 65 73 29 29 0a ' ;"). res)).
90e0: 0a 28 64 65 66 69 6e 65 20 28 64 62 3a 64 72 6f .(define (db:dro
90f0: 70 2d 74 72 69 67 67 65 72 73 20 64 62 29 0a 20 p-triggers db).
9100: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 28 6c (for-each. (l
9110: 61 6d 62 64 61 20 28 6b 65 79 29 20 0a 20 20 20 ambda (key) .
9120: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
9130: 74 65 20 64 62 20 28 63 6f 6e 63 20 22 64 72 6f te db (conc "dro
9140: 70 20 74 72 69 67 67 65 72 20 69 66 20 65 78 69 p trigger if exi
9150: 73 74 73 20 22 20 28 63 61 72 20 6b 65 79 29 29 sts " (car key))
9160: 29 29 0a 20 20 20 64 62 3a 74 72 69 67 67 65 72 )). db:trigger
9170: 2d 6c 69 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 -list))..(define
9180: 20 20 28 64 62 3a 64 72 6f 70 2d 74 72 69 67 67 (db:drop-trigg
9190: 65 72 20 64 62 20 74 62 6c 2d 6e 61 6d 65 29 0a er db tbl-name).
91a0: 20 20 28 6c 65 74 2a 20 28 28 74 72 69 67 67 65 (let* ((trigge
91b0: 72 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 r-name (if (equa
91c0: 6c 3f 20 74 62 6c 2d 6e 61 6d 65 20 22 74 65 73 l? tbl-name "tes
91d0: 74 5f 73 74 65 70 73 22 29 0a 09 09 09 20 20 20 t_steps")....
91e0: 22 75 70 64 61 74 65 5f 74 65 73 74 73 74 65 70 "update_teststep
91f0: 73 5f 74 72 69 67 67 65 72 22 20 0a 20 20 20 20 s_trigger" .
9200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9210: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 75 70 (conc "up
9220: 64 61 74 65 5f 22 20 74 62 6c 2d 6e 61 6d 65 20 date_" tbl-name
9230: 22 5f 74 72 69 67 67 65 72 22 29 29 29 29 0a 20 "_trigger")))).
9240: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
9250: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 20 (lambda (key)
9260: 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 . (if (equ
9270: 61 6c 3f 20 28 63 61 72 20 6b 65 79 29 20 74 72 al? (car key) tr
9280: 69 67 67 65 72 2d 6e 61 6d 65 29 0a 20 20 20 20 igger-name).
9290: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
92a0: 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 execute db (conc
92b0: 20 22 64 72 6f 70 20 74 72 69 67 67 65 72 20 69 "drop trigger i
92c0: 66 20 65 78 69 73 74 73 20 22 20 74 72 69 67 67 f exists " trigg
92d0: 65 72 2d 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 er-name)))).
92e0: 20 64 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 74 db:trigger-list
92f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 20 28 64 )))..(define (d
9300: 62 3a 63 72 65 61 74 65 2d 74 72 69 67 67 65 72 b:create-trigger
9310: 20 64 62 20 74 62 6c 2d 6e 61 6d 65 29 0a 20 20 db tbl-name).
9320: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 72 69 67 (let* ((trig
9330: 67 65 72 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 ger-name (if (eq
9340: 75 61 6c 3f 20 74 62 6c 2d 6e 61 6d 65 20 22 74 ual? tbl-name "t
9350: 65 73 74 5f 73 74 65 70 73 22 29 0a 20 20 20 20 est_steps").
9360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9370: 20 20 20 20 20 20 20 20 20 20 22 75 70 64 61 74 "updat
9380: 65 5f 74 65 73 74 73 74 65 70 73 5f 74 72 69 67 e_teststeps_trig
9390: 67 65 72 22 20 0a 20 20 20 20 20 20 20 20 20 20 ger" .
93a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93b0: 20 20 20 20 28 63 6f 6e 63 20 22 75 70 64 61 74 (conc "updat
93c0: 65 5f 22 20 74 62 6c 2d 6e 61 6d 65 20 22 5f 74 e_" tbl-name "_t
93d0: 72 69 67 67 65 72 22 29 29 29 29 0a 20 20 20 20 rigger")))).
93e0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
93f0: 6d 62 64 61 20 28 6b 65 79 29 20 0a 20 20 20 20 mbda (key) .
9400: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 71 (if (eq
9410: 75 61 6c 3f 20 28 63 61 72 20 6b 65 79 29 20 74 ual? (car key) t
9420: 72 69 67 67 65 72 2d 6e 61 6d 65 29 0a 20 20 20 rigger-name).
9430: 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 74 (sqlit
9440: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 e3:execute db (c
9450: 61 64 72 20 6b 65 79 29 29 29 29 0a 20 20 20 20 adr key)))).
9460: 20 20 64 62 3a 74 72 69 67 67 65 72 2d 6c 69 73 db:trigger-lis
9470: 74 29 29 29 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d t))) ..;;=======
9480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9490: 3d 3d 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 0a ===============.
94c0: 3b 3b 20 64 62 20 61 63 63 65 73 73 20 73 74 75 ;; db access stu
94d0: 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ff.;;===========
94e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 ===========..;;
9520: 63 61 6c 6c 20 77 69 74 68 20 64 62 69 6e 69 74 call with dbinit
9530: 3d 64 62 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 6d =db:initialize-m
9540: 61 69 6e 2d 64 62 0a 3b 3b 0a 28 64 65 66 69 6e ain-db.;;.(defin
9550: 65 20 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 e (db:open-db db
9560: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 struct run-id db
9570: 69 6e 69 74 29 0a 20 20 3b 3b 20 28 6d 75 74 65 init). ;; (mute
9580: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6f 70 65 6e x-lock! *db-open
9590: 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 2a -mutex*). (let*
95a0: 20 28 28 64 62 64 61 74 20 28 64 62 66 69 6c 65 ((dbdat (dbfile
95b0: 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 72 75 63 :open-db dbstruc
95c0: 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 29 t run-id dbinit)
95d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
95e0: 20 23 3b 28 63 61 73 65 20 28 72 6d 74 3a 74 72 #;(case (rmt:tr
95f0: 61 6e 73 70 6f 72 74 2d 6d 6f 64 65 29 0a 09 09 ansport-mode)...
9600: 20 20 28 28 68 74 74 70 29 20 28 64 62 66 69 6c ((http) (dbfil
9610: 65 3a 6f 70 65 6e 2d 64 62 20 64 62 73 74 72 75 e:open-db dbstru
9620: 63 74 20 72 75 6e 2d 69 64 20 64 62 69 6e 69 74 ct run-id dbinit
9630: 29 29 0a 09 09 20 20 28 28 74 63 70 29 20 20 28 ))... ((tcp) (
9640: 64 62 6d 6f 64 3a 6f 70 65 6e 2d 64 62 20 20 64 dbmod:open-db d
9650: 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 bstruct run-id d
9660: 62 69 6e 69 74 29 29 0a 09 09 20 20 28 65 6c 73 binit))... (els
9670: 65 20 28 61 73 73 65 72 74 20 23 66 20 22 46 41 e (assert #f "FA
9680: 54 41 4c 3a 20 72 6d 74 3a 74 72 61 6e 73 70 6f TAL: rmt:transpo
9690: 72 74 2d 6e 6f 64 65 20 6e 6f 74 20 63 6f 72 72 rt-node not corr
96a0: 65 63 74 20 76 61 6c 75 65 22 28 72 6d 74 3a 74 ect value"(rmt:t
96b0: 72 61 6e 73 70 6f 72 74 2d 6d 6f 64 65 29 29 29 ransport-mode)))
96c0: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d ). (set! *db-
96d0: 77 72 69 74 65 2d 61 63 63 65 73 73 2a 20 28 6e write-access* (n
96e0: 6f 74 20 28 64 62 72 3a 64 62 64 61 74 2d 72 65 ot (dbr:dbdat-re
96f0: 61 64 2d 6f 6e 6c 79 20 64 62 64 61 74 29 29 29 ad-only dbdat)))
9700: 0a 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 . ;; (mutex-u
9710: 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6f 70 65 6e 2d nlock! *db-open-
9720: 6d 75 74 65 78 2a 29 0a 20 20 20 20 64 62 64 61 mutex*). dbda
9730: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 64 62 66 t))..(define dbf
9740: 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 72 6f 63 ile:db-init-proc
9750: 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 (make-parameter
9760: 20 23 66 29 29 0a 0a 3b 3b 20 69 6e 20 78 6d 61 #f))..;; in xma
9770: 78 69 6d 61 20 74 68 69 73 20 67 69 76 65 73 20 xima this gives
9780: 61 20 63 75 72 76 65 20 63 6c 6f 73 65 20 74 6f a curve close to
9790: 20 77 68 61 74 20 49 20 77 61 6e 74 3a 0a 3b 3b what I want:.;;
97a0: 20 20 20 20 70 6c 6f 74 32 64 20 28 28 65 78 70 plot2d ((exp
97b0: 28 78 2f 31 2e 32 29 2d 31 29 2f 33 30 30 2c 20 (x/1.2)-1)/300,
97c0: 5b 78 2c 20 30 2c 20 31 30 5d 29 24 0a 3b 3b 20 [x, 0, 10])$.;;
97d0: 20 20 20 70 6c 6f 74 32 64 20 28 28 65 78 70 28 plot2d ((exp(
97e0: 78 2f 31 2e 35 29 2d 31 29 2f 34 30 2c 20 5b 78 x/1.5)-1)/40, [x
97f0: 2c 20 30 2c 20 31 30 5d 29 24 0a 3b 3b 20 20 20 , 0, 10])$.;;
9800: 20 70 6c 6f 74 32 64 20 28 28 65 78 70 28 78 2f plot2d ((exp(x/
9810: 35 29 2d 31 29 2f 34 30 2c 20 5b 78 2c 20 30 2c 5)-1)/40, [x, 0,
9820: 20 32 30 5d 29 24 0a 28 64 65 66 69 6e 65 20 28 20])$.(define (
9830: 64 62 66 69 6c 65 3a 64 72 6f 6f 70 20 78 29 0a dbfile:droop x).
9840: 20 20 28 2f 20 28 2d 20 28 65 78 70 20 28 2f 20 (/ (- (exp (/
9850: 78 20 35 29 29 20 31 29 20 34 30 29 29 0a 20 20 x 5)) 1) 40)).
9860: 3b 3b 20 28 2a 20 6e 75 6d 71 72 79 73 20 28 2f ;; (* numqrys (/
9870: 20 31 20 28 71 69 66 2d 73 6c 6f 70 65 29 29 29 1 (qif-slope)))
9880: 29 0a 0a 3b 3b 20 63 72 65 61 74 65 20 61 20 64 )..;; create a d
9890: 72 6f 70 70 69 6e 67 20 6e 65 61 72 20 74 68 65 ropping near the
98a0: 20 64 62 20 66 69 6c 65 20 69 6e 20 61 20 71 69 db file in a qi
98b0: 66 20 64 69 72 0a 3b 3b 20 75 73 65 20 63 6f 75 f dir.;; use cou
98c0: 6e 74 20 6f 66 20 73 75 63 68 20 66 69 6c 65 73 nt of such files
98d0: 20 74 6f 20 67 61 74 65 20 71 75 65 72 69 65 73 to gate queries
98e0: 20 28 71 75 65 72 69 65 73 20 69 6e 20 66 6c 69 (queries in fli
98f0: 67 68 74 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ght).;;.(define
9900: 28 64 62 66 69 6c 65 3a 77 61 69 74 2d 66 6f 72 (dbfile:wait-for
9910: 2d 71 69 66 20 66 6e 61 6d 65 20 72 75 6e 2d 69 -qif fname run-i
9920: 64 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 d params). (let
9930: 2a 20 28 28 74 68 65 64 69 72 20 20 28 70 61 74 * ((thedir (pat
9940: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
9950: 66 6e 61 6d 65 29 29 0a 09 20 28 64 62 6e 75 6d fname)).. (dbnum
9960: 20 20 20 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 (dbfile:run-i
9970: 64 2d 3e 64 62 6e 75 6d 20 72 75 6e 2d 69 64 29 d->dbnum run-id)
9980: 29 0a 09 20 28 64 65 73 74 64 69 72 20 28 63 6f ).. (destdir (co
9990: 6e 63 20 74 68 65 64 69 72 22 2f 71 69 66 2d 22 nc thedir"/qif-"
99a0: 64 62 6e 75 6d 29 29 0a 09 20 28 75 6e 69 71 6e dbnum)).. (uniqn
99b0: 20 20 20 28 67 65 74 2d 61 72 65 61 2d 70 61 74 (get-area-pat
99c0: 68 2d 73 69 67 6e 61 74 75 72 65 20 28 63 6f 6e h-signature (con
99d0: 63 20 64 62 6e 75 6d 20 70 61 72 61 6d 73 29 29 c dbnum params))
99e0: 29 0a 09 20 28 63 72 75 6d 62 6e 20 20 28 63 6f ).. (crumbn (co
99f0: 6e 63 20 64 65 73 74 64 69 72 22 2f 22 28 63 75 nc destdir"/"(cu
9a00: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 22 2d rrent-seconds)"-
9a10: 22 75 6e 69 71 6e 22 2e 22 28 63 75 72 72 65 6e "uniqn"."(curren
9a20: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 t-process-id))))
9a30: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 . (if (not (f
9a40: 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 65 73 74 ile-exists? dest
9a50: 64 69 72 29 29 28 63 72 65 61 74 65 2d 64 69 72 dir))(create-dir
9a60: 65 63 74 6f 72 79 20 28 63 6f 6e 63 20 64 65 73 ectory (conc des
9a70: 74 64 69 72 22 2f 61 74 74 69 63 22 29 20 23 74 tdir"/attic") #t
9a80: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
9a90: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 ((count 0)).
9aa0: 20 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 6c (let* ((currl
9ab0: 6b 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 64 ks (glob (conc d
9ac0: 65 73 74 64 69 72 22 2f 2a 22 29 29 29 0a 09 20 estdir"/*")))..
9ad0: 20 20 20 20 28 6e 75 6d 71 72 79 73 20 28 6c 65 (numqrys (le
9ae0: 6e 67 74 68 20 63 75 72 72 6c 6b 73 29 29 0a 09 ngth currlks))..
9af0: 20 20 20 20 20 28 64 65 6c 61 79 76 61 6c 20 28 (delayval (
9b00: 63 6f 6e 64 20 3b 3b 20 64 6f 20 61 20 64 72 6f cond ;; do a dro
9b10: 6f 70 69 73 68 20 63 75 72 76 65 0a 09 09 09 28 opish curve....(
9b20: 28 3e 20 6e 75 6d 71 72 79 73 20 32 35 29 0a 09 (> numqrys 25)..
9b30: 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 09 .. (for-each....
9b40: 20 20 28 6c 61 6d 62 64 61 20 28 66 29 0a 09 09 (lambda (f)...
9b50: 09 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 28 . (if (> (- (
9b60: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
9b70: 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 6e 64 ..... (hand
9b80: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
9b90: 09 09 09 20 20 65 78 6e 0a 09 09 09 09 09 28 63 ... exn......(c
9ba0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
9bb0: 3b 3b 20 66 69 6c 65 20 69 73 20 6c 69 6b 65 6c ;; file is likel
9bc0: 79 20 67 6f 6e 65 2c 20 6a 75 73 74 20 66 61 6b y gone, just fak
9bd0: 65 20 6f 75 74 0a 09 09 09 09 09 28 66 69 6c 65 e out......(file
9be0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
9bf0: 6d 65 20 66 29 29 29 0a 09 09 09 09 20 20 20 28 me f)))..... (
9c00: 6b 65 65 70 2d 61 67 65 2d 70 61 72 61 6d 29 29 keep-age-param))
9c10: 0a 09 09 09 09 28 6c 65 74 2a 20 28 28 62 61 73 .....(let* ((bas
9c20: 65 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 edir (pathname-d
9c30: 69 72 65 63 74 6f 72 79 20 66 29 29 0a 09 09 09 irectory f))....
9c40: 09 20 20 20 20 20 20 20 28 66 69 6c 65 6e 20 20 . (filen
9c50: 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 (pathname-file
9c60: 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 f))..... (
9c70: 64 65 73 74 66 20 20 20 28 63 6f 6e 63 20 62 61 destf (conc ba
9c80: 73 65 64 69 72 22 2f 61 74 74 69 63 2f 22 66 69 sedir"/attic/"fi
9c90: 6c 65 6e 29 29 29 0a 09 09 09 09 20 20 28 64 62 len)))..... (db
9ca0: 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 72 20 22 file:print-err "
9cb0: 4d 6f 76 69 6e 67 20 71 69 66 20 66 69 6c 65 20 Moving qif file
9cc0: 22 66 22 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 "f" older than 1
9cd0: 30 20 73 65 63 6f 6e 64 73 20 74 6f 20 22 64 65 0 seconds to "de
9ce0: 73 74 66 29 0a 09 09 09 09 20 20 3b 3b 20 28 64 stf)..... ;; (d
9cf0: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 29 0a 09 elete-file* f)..
9d00: 09 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ... (handle-exc
9d10: 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 eptions.....
9d20: 20 20 65 78 6e 0a 09 09 09 09 20 20 20 20 23 74 exn..... #t
9d30: 0a 09 09 09 09 20 20 20 20 28 66 69 6c 65 2d 6d ..... (file-m
9d40: 6f 76 65 20 66 20 64 65 73 74 66 20 23 74 29 29 ove f destf #t))
9d50: 29 29 29 0a 09 09 09 20 20 63 75 72 72 6c 6b 73 ))).... currlks
9d60: 29 0a 09 09 09 20 34 29 0a 09 09 09 28 28 3e 20 ).... 4)....((>
9d70: 6e 75 6d 71 72 79 73 20 30 29 20 20 28 64 62 66 numqrys 0) (dbf
9d80: 69 6c 65 3a 64 72 6f 6f 70 20 6e 75 6d 71 72 79 ile:droop numqry
9d90: 73 29 29 20 3b 3b 20 73 6c 6f 70 65 20 6f 66 20 s)) ;; slope of
9da0: 31 2f 31 30 30 0a 09 09 09 28 65 6c 73 65 20 23 1/100....(else #
9db0: 66 29 29 29 29 0a 09 28 69 66 20 28 61 6e 64 20 f))))..(if (and
9dc0: 64 65 6c 61 79 76 61 6c 0a 09 09 20 28 3c 20 63 delayval... (< c
9dd0: 6f 75 6e 74 20 35 29 29 0a 09 20 20 20 20 28 62 ount 5)).. (b
9de0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 72 egin.. (thr
9df0: 65 61 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 ead-sleep! delay
9e00: 76 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f val).. (loo
9e10: 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 p (+ count 1))))
9e20: 29 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 )). (with-out
9e30: 70 75 74 2d 74 6f 2d 66 69 6c 65 20 63 72 75 6d put-to-file crum
9e40: 62 6e 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 bn. (lambda
9e50: 20 28 29 0a 09 28 70 72 69 6e 74 20 66 6e 61 6d ()..(print fnam
9e60: 65 22 20 72 75 6e 2d 69 64 3d 22 72 75 6e 2d 69 e" run-id="run-i
9e70: 64 22 20 70 61 72 61 6d 73 3d 22 70 61 72 61 6d d" params="param
9e80: 73 29 0a 09 29 29 0a 20 20 20 20 63 72 75 6d 62 s)..)). crumb
9e90: 6e 29 29 0a 0a 28 64 65 66 69 6e 65 20 6e 6f 2d n))..(define no-
9ea0: 63 6f 6e 64 69 74 69 6f 6e 2d 64 62 2d 77 69 74 condition-db-wit
9eb0: 68 2d 64 62 20 28 6d 61 6b 65 2d 70 61 72 61 6d h-db (make-param
9ec0: 65 74 65 72 20 23 74 29 29 0a 0a 3b 3b 20 28 64 eter #t))..;; (d
9ed0: 62 3a 77 69 74 68 2d 64 62 20 64 62 73 74 72 75 b:with-db dbstru
9ee0: 63 74 20 72 75 6e 2d 69 64 20 73 71 6c 69 74 65 ct run-id sqlite
9ef0: 33 3a 65 78 65 63 20 22 73 65 6c 65 63 74 20 62 3:exec "select b
9f00: 6c 61 68 20 66 67 72 6f 6d 20 62 6c 61 7a 3b 22 lah fgrom blaz;"
9f10: 29 0a 3b 3b 20 72 2f 77 20 69 73 20 61 20 66 6c ).;; r/w is a fl
9f20: 61 67 20 74 6f 20 69 6e 64 69 63 61 74 65 20 69 ag to indicate i
9f30: 66 20 74 68 65 20 64 62 20 69 73 20 6d 6f 64 69 f the db is modi
9f40: 66 69 65 64 20 62 79 20 74 68 69 73 20 71 75 65 fied by this que
9f50: 72 79 20 23 74 20 3d 20 79 65 73 2c 20 23 66 20 ry #t = yes, #f
9f60: 3d 20 6e 6f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 = no.;;.(define
9f70: 28 64 62 66 69 6c 65 3a 77 69 74 68 2d 64 62 20 (dbfile:with-db
9f80: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
9f90: 72 2f 77 20 70 72 6f 63 20 70 61 72 61 6d 73 29 r/w proc params)
9fa0: 0a 20 20 28 61 73 73 65 72 74 20 64 62 73 74 72 . (assert dbstr
9fb0: 75 63 74 20 22 46 41 54 41 4c 3a 20 64 62 3a 77 uct "FATAL: db:w
9fc0: 69 74 68 2d 64 62 20 63 61 6c 6c 65 64 20 77 69 ith-db called wi
9fd0: 74 68 20 64 62 73 74 72 75 63 74 20 22 23 66 29 th dbstruct "#f)
9fe0: 0a 20 20 28 61 73 73 65 72 74 20 28 64 62 72 3a . (assert (dbr:
9ff0: 64 62 73 74 72 75 63 74 3f 20 64 62 73 74 72 75 dbstruct? dbstru
a000: 63 74 29 20 22 46 41 54 41 4c 3a 20 64 62 73 74 ct) "FATAL: dbst
a010: 72 75 63 74 20 69 73 20 22 64 62 73 74 72 75 63 ruct is "dbstruc
a020: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 65 t). (let* ((use
a030: 2d 6d 75 74 65 78 20 28 3e 20 2a 61 70 69 2d 70 -mutex (> *api-p
a040: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
a050: 6f 75 6e 74 2a 20 32 35 29 29 20 3b 3b 20 72 69 ount* 25)) ;; ri
a060: 73 6b 20 6f 66 20 64 62 20 63 6f 72 72 75 70 74 sk of db corrupt
a070: 69 6f 6e 0a 09 20 28 68 61 76 65 2d 73 74 72 75 ion.. (have-stru
a080: 63 74 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 ct (dbr:dbstruct
a090: 3f 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 ? dbstruct)).
a0a0: 20 20 20 20 20 20 28 64 62 64 61 74 20 20 20 20 (dbdat
a0b0: 20 28 69 66 20 68 61 76 65 2d 73 74 72 75 63 74 (if have-struct
a0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0d0: 3b 3b 20 74 68 69 73 20 73 74 75 66 66 20 6a 75 ;; this stuff ju
a0e0: 73 74 20 61 6c 6c 6f 77 73 20 75 73 20 74 6f 20 st allows us to
a0f0: 63 61 6c 6c 20 77 69 74 68 20 61 20 64 62 20 68 call with a db h
a100: 61 6e 64 6c 65 20 64 69 72 65 63 74 6c 79 0a 09 andle directly..
a110: 09 09 28 64 62 3a 6f 70 65 6e 2d 64 62 20 64 62 ..(db:open-db db
a120: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 28 64 struct run-id (d
a130: 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 72 bfile:db-init-pr
a140: 6f 63 29 29 20 3b 3b 20 28 64 62 66 69 6c 65 3a oc)) ;; (dbfile:
a150: 67 65 74 2d 73 75 62 64 62 20 64 62 73 74 72 75 get-subdb dbstru
a160: 63 74 20 72 75 6e 2d 69 64 29 0a 09 09 09 23 66 ct run-id)....#f
a170: 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 )).. (db
a180: 28 69 66 20 68 61 76 65 2d 73 74 72 75 63 74 20 (if have-struct
a190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
a1a0: 3b 20 74 68 69 73 20 73 74 75 66 66 20 6a 75 73 ; this stuff jus
a1b0: 74 20 61 6c 6c 6f 77 73 20 75 73 20 74 6f 20 63 t allows us to c
a1c0: 61 6c 6c 20 77 69 74 68 20 61 20 64 62 20 68 61 all with a db ha
a1d0: 6e 64 6c 65 20 64 69 72 65 63 74 6c 79 0a 09 09 ndle directly...
a1e0: 09 28 64 62 72 3a 64 62 64 61 74 2d 64 62 68 20 .(dbr:dbdat-dbh
a1f0: 64 62 64 61 74 29 0a 09 09 09 64 62 73 74 72 75 dbdat)....dbstru
a200: 63 74 29 29 0a 09 20 28 66 6e 61 6d 65 20 20 20 ct)).. (fname
a210: 20 20 28 69 66 20 64 62 64 61 74 0a 09 09 09 28 (if dbdat....(
a220: 64 62 72 3a 64 62 64 61 74 2d 64 62 66 69 6c 65 dbr:dbdat-dbfile
a230: 20 64 62 64 61 74 29 0a 09 09 09 22 6e 6f 66 69 dbdat)...."nofi
a240: 6c 65 6e 61 6d 65 61 76 61 69 6c 61 62 6c 65 22 lenameavailable"
a250: 29 29 0a 09 20 28 6a 66 69 6c 65 20 20 20 20 20 )).. (jfile
a260: 28 63 6f 6e 63 20 66 6e 61 6d 65 22 2d 6a 6f 75 (conc fname"-jou
a270: 72 6e 61 6c 22 29 29 0a 09 20 28 71 72 79 70 72 rnal")).. (qrypr
a280: 6f 63 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a oc (lambda ().
a290: 09 09 20 20 20 20 20 20 28 69 66 20 75 73 65 2d .. (if use-
a2a0: 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 6c 6f 63 mutex (mutex-loc
a2b0: 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d 6d k! *db-with-db-m
a2c0: 75 74 65 78 2a 29 29 0a 09 09 20 20 20 20 20 20 utex*))...
a2d0: 28 6c 65 74 20 28 28 72 65 73 20 28 61 70 70 6c (let ((res (appl
a2e0: 79 20 70 72 6f 63 20 64 62 64 61 74 20 64 62 20 y proc dbdat db
a2f0: 70 61 72 61 6d 73 29 29 29 20 3b 3b 20 74 68 65 params))) ;; the
a300: 20 61 63 74 75 61 6c 20 63 61 6c 6c 20 69 73 20 actual call is
a310: 68 65 72 65 2e 0a 09 09 09 28 69 66 20 75 73 65 here.....(if use
a320: 2d 6d 75 74 65 78 20 28 6d 75 74 65 78 2d 75 6e -mutex (mutex-un
a330: 6c 6f 63 6b 21 20 2a 64 62 2d 77 69 74 68 2d 64 lock! *db-with-d
a340: 62 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 3b 3b b-mutex*))....;;
a350: 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 64 62 (if (vector? db
a360: 73 74 72 75 63 74 29 28 64 62 3a 64 6f 6e 65 2d struct)(db:done-
a370: 77 69 74 68 20 64 62 73 74 72 75 63 74 20 72 75 with dbstruct ru
a380: 6e 2d 69 64 20 72 2f 77 29 29 0a 09 09 09 28 69 n-id r/w))....(i
a390: 66 20 64 62 64 61 74 0a 09 09 09 20 20 20 20 28 f dbdat.... (
a3a0: 64 62 66 69 6c 65 3a 61 64 64 2d 64 62 64 61 74 dbfile:add-dbdat
a3b0: 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 dbstruct run-id
a3c0: 20 64 62 64 61 74 29 29 0a 09 09 09 3b 3b 20 28 dbdat))....;; (
a3d0: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 63 72 75 delete-file* cru
a3e0: 6d 62 66 69 6c 65 29 0a 09 09 09 72 65 73 29 29 mbfile)....res))
a3f0: 29 29 0a 0a 20 20 20 20 28 61 73 73 65 72 74 20 )).. (assert
a400: 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 (sqlite3:databas
a410: 65 3f 20 64 62 29 20 22 46 41 54 41 4c 3a 20 64 e? db) "FATAL: d
a420: 62 3a 77 69 74 68 2d 64 62 2c 20 64 62 20 69 73 b:with-db, db is
a430: 20 6e 6f 74 20 61 20 64 61 74 61 62 61 73 65 2c not a database,
a440: 20 64 62 3d 22 64 62 22 2c 20 66 6e 61 6d 65 3d db="db", fname=
a450: 22 66 6e 61 6d 65 29 0a 20 20 20 20 28 69 66 20 "fname). (if
a460: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6a 66 (file-exists? jf
a470: 69 6c 65 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ile)..(begin..
a480: 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 72 (dbfile:print-er
a490: 72 20 22 49 4e 46 4f 3a 20 22 6a 66 69 6c 65 22 r "INFO: "jfile"
a4a0: 20 65 78 69 73 74 73 2c 20 64 65 6c 61 79 69 6e exists, delayin
a4b0: 67 20 74 6f 20 72 65 64 75 63 65 20 64 61 74 61 g to reduce data
a4c0: 62 61 73 65 20 6c 6f 61 64 22 29 0a 09 20 20 28 base load").. (
a4d0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
a4e0: 32 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 2))). (if (an
a4f0: 64 20 75 73 65 2d 6d 75 74 65 78 0a 09 20 20 20 d use-mutex..
a500: 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f (common:low-no
a510: 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 6f ise-print 120 "o
a520: 76 65 72 2d 35 30 2d 70 61 72 61 6c 6c 65 6c 2d ver-50-parallel-
a530: 61 70 69 2d 72 65 71 75 65 73 74 73 22 29 29 0a api-requests")).
a540: 09 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d 65 .(dbfile:print-e
a550: 72 72 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d rr *api-process-
a560: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 22 request-count* "
a570: 20 70 61 72 61 6c 6c 65 6c 20 61 70 69 20 72 65 parallel api re
a580: 71 75 65 73 74 73 20 62 65 69 6e 67 20 70 72 6f quests being pro
a590: 63 65 73 73 65 64 20 69 6e 20 70 72 6f 63 65 73 cessed in proces
a5a0: 73 20 22 0a 09 09 09 20 20 28 63 75 72 72 65 6e s ".... (curren
a5b0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 20 t-process-id)))
a5c0: 3b 3b 20 20 22 2c 20 74 68 72 6f 74 74 6c 69 6e ;; ", throttlin
a5d0: 67 20 61 63 63 65 73 73 22 29 29 0a 20 20 20 20 g access")).
a5e0: 28 69 66 20 28 6e 6f 2d 63 6f 6e 64 69 74 69 6f (if (no-conditio
a5f0: 6e 2d 64 62 2d 77 69 74 68 2d 64 62 29 0a 09 28 n-db-with-db)..(
a600: 71 72 79 70 72 6f 63 29 0a 09 28 63 6f 6e 64 69 qryproc)..(condi
a610: 74 69 6f 6e 2d 63 61 73 65 0a 09 20 28 71 72 79 tion-case.. (qry
a620: 70 72 6f 63 29 0a 09 20 28 65 78 6e 20 28 69 6f proc).. (exn (io
a630: 2d 65 72 72 6f 72 29 0a 09 20 20 20 20 20 20 28 -error).. (
a640: 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 db:generic-error
a650: 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 -printout exn "E
a660: 52 52 4f 52 3a 20 69 2f 6f 20 65 72 72 6f 72 20 RROR: i/o error
a670: 77 69 74 68 20 22 20 66 6e 61 6d 65 20 22 2e 20 with " fname ".
a680: 43 68 65 63 6b 20 70 65 72 6d 69 73 73 69 6f 6e Check permission
a690: 73 2c 20 64 69 73 6b 20 73 70 61 63 65 20 65 74 s, disk space et
a6a0: 63 2e 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e c. and try again
a6b0: 2e 22 29 29 0a 09 20 28 65 78 6e 20 28 63 6f 72 .")).. (exn (cor
a6c0: 72 75 70 74 29 0a 09 20 20 20 20 20 20 28 64 62 rupt).. (db
a6d0: 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d 70 :generic-error-p
a6e0: 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 52 rintout exn "ERR
a6f0: 4f 52 3a 20 64 61 74 61 62 61 73 65 20 22 20 66 OR: database " f
a700: 6e 61 6d 65 20 22 20 69 73 20 63 6f 72 72 75 70 name " is corrup
a710: 74 2e 20 52 65 70 61 69 72 20 69 74 20 74 6f 20 t. Repair it to
a720: 70 72 6f 63 65 65 64 2e 22 29 29 0a 09 20 28 65 proceed.")).. (e
a730: 78 6e 20 28 62 75 73 79 29 0a 09 20 20 20 20 20 xn (busy)..
a740: 20 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 (db:generic-err
a750: 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 or-printout exn
a760: 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 65 "ERROR: database
a770: 20 22 20 66 6e 61 6d 65 0a 09 09 09 09 09 20 22 " fname...... "
a780: 20 69 73 20 6c 6f 63 6b 65 64 2e 20 54 72 79 20 is locked. Try
a790: 63 6f 70 79 69 6e 67 20 74 6f 20 61 6e 6f 74 68 copying to anoth
a7a0: 65 72 20 6c 6f 63 61 74 69 6f 6e 2c 20 72 65 6d er location, rem
a7b0: 6f 76 65 20 6f 72 69 67 69 6e 61 6c 20 61 6e 64 ove original and
a7c0: 20 63 6f 70 79 20 62 61 63 6b 2e 22 29 29 0a 09 copy back."))..
a7d0: 20 28 65 78 6e 20 28 70 65 72 6d 69 73 73 69 6f (exn (permissio
a7e0: 6e 29 28 64 62 3a 67 65 6e 65 72 69 63 2d 65 72 n)(db:generic-er
a7f0: 72 6f 72 2d 70 72 69 6e 74 6f 75 74 20 65 78 6e ror-printout exn
a800: 20 22 45 52 52 4f 52 3a 20 64 61 74 61 62 61 73 "ERROR: databas
a810: 65 20 22 20 66 6e 61 6d 65 20 22 20 68 61 73 20 e " fname " has
a820: 73 6f 6d 65 20 70 65 72 6d 69 73 73 69 6f 6e 73 some permissions
a830: 20 70 72 6f 62 6c 65 6d 2e 22 29 29 0a 09 20 28 problem.")).. (
a840: 65 78 6e 20 28 29 0a 09 20 20 20 20 20 20 28 64 exn ().. (d
a850: 62 3a 67 65 6e 65 72 69 63 2d 65 72 72 6f 72 2d b:generic-error-
a860: 70 72 69 6e 74 6f 75 74 20 65 78 6e 20 22 45 52 printout exn "ER
a870: 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 65 72 72 ROR: Unknown err
a880: 6f 72 20 77 69 74 68 20 64 61 74 61 62 61 73 65 or with database
a890: 20 22 20 66 6e 61 6d 65 20 22 20 6d 65 73 73 61 " fname " messa
a8a0: 67 65 3a 20 22 0a 09 09 09 09 09 20 28 28 63 6f ge: "...... ((co
a8b0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
a8c0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
a8d0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 29 message) exn))))
a8e0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
a8f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b =============.;;
a930: 20 61 6e 6f 74 68 65 72 20 61 74 74 65 6d 70 74 another attempt
a940: 20 61 74 20 61 20 74 72 61 6e 73 61 63 74 69 6f at a transactio
a950: 6e 69 7a 65 64 20 71 75 65 75 65 0a 3b 3b 3d 3d nized queue.;;==
a960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 ====..;; ;; ;; (
a9b0: 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 61 63 74 define *transact
a9c0: 69 6f 6e 2d 71 75 65 75 65 73 2a 20 28 6d 61 6b ion-queues* (mak
a9d0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 3b e-hash-table)).;
a9e0: 3b 20 3b 3b 20 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b ; ;; ;; .;; ;; ;
a9f0: 3b 20 28 64 65 66 69 6e 65 20 28 64 62 3a 67 65 ; (define (db:ge
aa00: 74 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 29 0a t-queue run-id).
aa10: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 28 6c 65 74 2a ;; ;; ;; (let*
aa20: 20 28 28 72 65 73 20 28 68 61 73 68 2d 74 61 62 ((res (hash-tab
aa30: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
aa40: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 transaction-queu
aa50: 65 73 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 es* run-id #f)))
aa60: 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 28 69 .;; ;; ;; (i
aa70: 66 20 72 65 73 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 f res.;; ;; ;; .
aa80: 72 65 73 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 28 6c res.;; ;; ;; .(l
aa90: 65 74 2a 20 28 28 6e 65 77 71 20 28 6d 61 6b 65 et* ((newq (make
aaa0: 2d 71 75 65 75 65 29 29 29 0a 3b 3b 20 3b 3b 20 -queue))).;; ;;
aab0: 3b 3b 20 09 20 20 28 68 61 73 68 2d 74 61 62 6c ;; . (hash-tabl
aac0: 65 2d 73 65 74 21 20 2a 74 72 61 6e 73 61 63 74 e-set! *transact
aad0: 69 6f 6e 2d 71 75 65 75 65 73 2a 20 72 75 6e 2d ion-queues* run-
aae0: 69 64 20 6e 65 77 71 29 0a 3b 3b 20 3b 3b 20 3b id newq).;; ;; ;
aaf0: 3b 20 09 20 20 6e 65 77 71 29 29 29 29 0a 3b 3b ; . newq)))).;;
ab00: 20 3b 3b 20 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b ;; ;; .;; ;; ;;
ab10: 20 28 64 65 66 69 6e 65 20 28 64 62 3a 61 64 64 (define (db:add
ab20: 2d 74 6f 2d 74 72 61 6e 73 61 63 74 69 6f 6e 2d -to-transaction-
ab30: 71 75 65 75 65 20 64 62 73 74 72 75 63 74 20 70 queue dbstruct p
ab40: 72 6f 63 20 70 61 72 61 6d 73 29 0a 3b 3b 20 3b roc params).;; ;
ab50: 3b 20 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 6d ; ;; (let* ((m
ab60: 62 6f 78 20 28 6d 61 6b 65 2d 6d 61 69 6c 62 6f box (make-mailbo
ab70: 78 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 09 20 28 x)).;; ;; ;; . (
ab80: 71 20 20 20 20 28 64 62 3a 67 65 74 2d 71 75 65 q (db:get-que
ab90: 75 65 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 ue run-id))).;;
aba0: 3b 3b 20 3b 3b 20 20 20 20 20 28 71 75 65 75 65 ;; ;; (queue
abb0: 2d 61 64 64 21 20 2a 74 72 61 6e 73 61 63 74 69 -add! *transacti
abc0: 6f 6e 2d 71 75 65 75 65 2a 20 28 6c 69 73 74 20 on-queue* (list
abd0: 64 62 73 74 72 75 63 74 20 70 72 6f 63 20 6d 62 dbstruct proc mb
abe0: 6f 78 29 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 ox)).;; ;; ;;
abf0: 20 20 28 6d 61 69 6c 62 6f 78 2d 72 65 63 65 69 (mailbox-recei
ac00: 76 65 20 6d 62 6f 78 29 29 29 0a 3b 3b 20 3b 3b ve mbox))).;; ;;
ac10: 20 3b 3b 20 0a 3b 3b 20 3b 3b 20 3b 3b 20 28 64 ;; .;; ;; ;; (d
ac20: 65 66 69 6e 65 20 28 64 62 3a 70 72 6f 63 65 73 efine (db:proces
ac30: 73 2d 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 s-transaction-qu
ac40: 65 75 65 20 2a 64 62 73 74 72 75 63 74 2d 64 62 eue *dbstruct-db
ac50: 73 2a 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 28 s*).;; ;; ;; (
ac60: 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 3b 3b 20 3b for-each.;; ;; ;
ac70: 3b 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 ; (lambda (ru
ac80: 6e 2d 69 64 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 n-id).;; ;; ;;
ac90: 20 20 20 20 28 6c 65 74 2a 20 28 28 71 20 28 68 (let* ((q (h
aca0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 74 ash-table-ref *t
acb0: 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 65 ransaction-queue
acc0: 2a 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b * run-id))).;; ;
acd0: 3b 20 3b 3b 20 20 20 20 20 20 20 20 3b 3b 20 77 ; ;; ;; w
ace0: 69 74 68 2d 74 72 61 6e 73 61 63 74 69 6f 6e 0a ith-transaction.
acf0: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 ;; ;; ;;
ad00: 3b 3b 20 20 20 20 20 64 62 73 74 72 75 63 74 0a ;; dbstruct.
ad10: 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 ;; ;; ;;
ad20: 3b 3b 20 70 6f 70 20 69 74 65 6d 73 20 66 72 6f ;; pop items fro
ad30: 6d 20 71 75 65 75 65 20 61 6e 64 20 65 78 65 63 m queue and exec
ad40: 75 74 65 20 74 68 65 6d 2c 20 72 65 74 75 72 6e ute them, return
ad50: 20 72 65 73 75 6c 74 73 20 76 69 61 20 6d 61 69 results via mai
ad60: 6c 62 6f 78 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 lbox.;; ;; ;;
ad70: 20 20 20 20 20 71 0a 3b 3b 20 3b 3b 20 3b 3b 20 q.;; ;; ;;
ad80: 20 20 20 20 20 20 20 3b 3b 20 70 6f 70 20 0a 3b ;; pop .;
ad90: 3b 20 3b 3b 20 3b 3b 20 20 20 20 20 20 20 20 29 ; ;; ;; )
ada0: 29 0a 3b 3b 20 3b 3b 20 3b 3b 20 20 20 20 28 68 ).;; ;; ;; (h
adb0: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a ash-table-keys *
adc0: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 71 75 65 75 transaction-queu
add0: 65 73 2a 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d es*)))..;;======
ade0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
adf0: 3d 3d 3d 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: 0a 3b 3b 20 66 69 6c 65 20 75 74 69 6c 73 0a 3b .;; file utils.;
ae30: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
ae40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
ae80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae90: 3d 3d 3d 3d 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 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 =.;; lazy-safe g
aed0: 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 et file mod time
aee0: 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 . on any error (
aef0: 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e file not existin
af00: 67 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 g etc.) return 0
af10: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 64 62 66 .;;.(define (dbf
af20: 69 6c 65 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 ile:lazy-modific
af30: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
af40: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
af50: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e ptions. exn
af60: 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 . (begin.
af70: 20 20 28 64 62 66 69 6c 65 3a 70 72 69 6e 74 2d (dbfile:print-
af80: 65 72 72 20 22 46 61 69 6c 65 64 20 74 6f 20 67 err "Failed to g
af90: 65 74 20 6d 6f 64 69 66 69 63 61 74 69 6f 6e 20 et modification
afa0: 74 69 6d 65 20 66 6f 72 20 22 20 66 70 61 74 68 time for " fpath
afb0: 20 22 2c 20 74 72 65 61 74 69 6e 67 20 69 74 20 ", treating it
afc0: 61 73 20 7a 65 72 6f 2e 20 65 78 6e 3d 22 20 65 as zero. exn=" e
afd0: 78 6e 29 0a 20 20 20 20 20 20 30 29 0a 20 20 20 xn). 0).
afe0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
aff0: 73 3f 20 66 70 61 74 68 29 0a 09 28 66 69 6c 65 s? fpath)..(file
b000: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
b010: 6d 65 20 66 70 61 74 68 29 0a 09 30 29 29 29 0a me fpath)..0))).
b020: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
b030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b040: 3d 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 0a 3b 3b 20 66 69 6e =========.;; fin
b070: 64 20 74 69 6d 65 73 74 61 6d 70 20 6f 66 20 6e d timestamp of n
b080: 65 77 65 73 74 20 66 69 6c 65 20 61 73 73 6f 63 ewest file assoc
b090: 69 61 74 65 64 20 77 69 74 68 20 61 20 73 71 6c iated with a sql
b0a0: 69 74 65 20 64 62 20 66 69 6c 65 0a 28 64 65 66 ite db file.(def
b0b0: 69 6e 65 20 28 64 62 66 69 6c 65 3a 6c 61 7a 79 ine (dbfile:lazy
b0c0: 2d 73 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 69 66 -sqlite-db-modif
b0d0: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 ication-time fpa
b0e0: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 67 6c th). (let* ((gl
b0f0: 6f 62 2d 6c 69 73 74 20 28 68 61 6e 64 6c 65 2d ob-list (handle-
b100: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 65 78 exceptions....ex
b110: 6e 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e n... (begin
b120: 0a 09 09 09 28 64 62 66 69 6c 65 3a 70 72 69 6e ....(dbfile:prin
b130: 74 2d 65 72 72 20 22 46 61 69 6c 65 64 20 74 6f t-err "Failed to
b140: 20 67 6c 6f 62 20 22 20 66 70 61 74 68 20 22 2a glob " fpath "*
b150: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
b160: 60 28 2c 28 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 `(,(conc "/no/su
b170: 63 68 2f 66 69 6c 65 2c 20 6d 65 73 73 61 67 65 ch/file, message
b180: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
b190: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
b1a0: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
b1b0: 20 65 78 6e 29 29 29 29 0a 09 09 20 20 20 20 20 exn))))...
b1c0: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 66 70 61 (glob (conc fpa
b1d0: 74 68 20 22 2a 22 29 29 29 29 0a 20 20 20 20 20 th "*")))).
b1e0: 20 20 20 20 28 66 69 6c 65 2d 6c 69 73 74 20 28 (file-list (
b1f0: 69 66 20 28 65 71 3f 20 30 20 28 6c 65 6e 67 74 if (eq? 0 (lengt
b200: 68 20 67 6c 6f 62 2d 6c 69 73 74 29 29 0a 09 09 h glob-list))...
b210: 09 27 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c .'("/no/such/fil
b220: 65 22 29 0a 09 09 09 67 6c 6f 62 2d 6c 69 73 74 e")....glob-list
b230: 29 29 29 0a 20 20 28 61 70 70 6c 79 20 6d 61 78 ))). (apply max
b240: 0a 09 20 28 6d 61 70 0a 09 20 20 64 62 66 69 6c .. (map.. dbfil
b250: 65 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 e:lazy-modificat
b260: 69 6f 6e 2d 74 69 6d 65 20 0a 09 20 20 66 69 6c ion-time .. fil
b270: 65 2d 6c 69 73 74 29 29 29 29 0a 0a 3b 3b 20 64 e-list))))..;; d
b280: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 ot-locking egg s
b290: 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b eems not to work
b2a0: 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 , using this for
b2b0: 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 now.;; if lock
b2c0: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 is older than ex
b2d0: 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 pire-time then r
b2e0: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 emove it and try
b2f0: 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 again.;; to get
b300: 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 the lock.;;.(de
b310: 66 69 6e 65 20 28 64 62 66 69 6c 65 3a 73 69 6d fine (dbfile:sim
b320: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e ple-file-lock fn
b330: 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 ame #!key (expir
b340: 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 e-time 300)). (
b350: 6c 65 74 20 28 28 66 6d 6f 64 2d 74 69 6d 65 20 let ((fmod-time
b360: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
b370: 6e 73 0a 09 09 20 20 20 20 20 20 20 65 78 74 0a ns... ext.
b380: 09 09 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d .. (current-
b390: 73 65 63 6f 6e 64 73 29 0a 09 09 20 20 20 20 20 seconds)...
b3a0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
b3b0: 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 29 on-time fname)))
b3c0: 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d ). (if (file-
b3d0: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
b3e0: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
b3f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 66 6d 6f 64 nt-seconds) fmod
b400: 2d 74 69 6d 65 29 20 65 78 70 69 72 65 2d 74 69 -time) expire-ti
b410: 6d 65 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a me).. (begin.
b420: 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 . (handle-e
b430: 78 63 65 70 74 69 6f 6e 73 20 65 78 6e 20 23 66 xceptions exn #f
b440: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 (delete-file* f
b450: 6e 61 6d 65 29 29 09 0a 09 20 20 20 20 20 20 28 name))... (
b460: 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 dbfile:simple-fi
b470: 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 le-lock fname ex
b480: 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 pire-time: expir
b490: 65 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 23 66 e-time)).. #f
b4a0: 29 0a 09 28 6c 65 74 20 28 28 6b 65 79 2d 73 74 )..(let ((key-st
b4b0: 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 74 2d ring (conc (get-
b4c0: 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 28 host-name) "-" (
b4d0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
b4e0: 69 64 29 29 29 0a 09 20 20 20 20 20 20 28 6f 75 id))).. (ou
b4f0: 70 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f p (open-o
b500: 75 74 70 75 74 2d 66 69 6c 65 20 66 6e 61 6d 65 utput-file fname
b510: 29 29 29 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 ))).. (with-out
b520: 70 75 74 2d 74 6f 2d 70 6f 72 74 0a 09 20 20 20 put-to-port..
b530: 20 20 20 6f 75 70 0a 09 20 20 20 20 28 6c 61 6d oup.. (lam
b540: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 70 bda ().. (p
b550: 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 rint key-string)
b560: 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 74 )).. (close-out
b570: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 20 put-port oup)..
b580: 20 23 3b 28 77 69 74 68 2d 6f 75 74 70 75 74 2d #;(with-output-
b590: 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 20 3b 3b to-file fname ;;
b5a0: 20 62 69 7a 61 72 72 65 2e 20 77 69 74 68 2d 6f bizarre. with-o
b5b0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 64 6f utput-to-file do
b5c0: 65 73 20 6e 6f 74 20 73 65 65 6d 20 74 6f 20 62 es not seem to b
b5d0: 65 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 61 66 e cleaning up af
b5e0: 74 65 72 20 69 74 73 65 6c 66 2e 0a 09 20 20 20 ter itself...
b5f0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 (lambda ().. (
b600: 70 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 print key-string
b610: 29 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 ))).. (thread-s
b620: 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 leep! 0.25).. (
b630: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
b640: 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 fname).. (
b650: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
b660: 73 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 s exn.
b670: 20 20 20 20 20 20 23 66 20 0a 20 20 20 20 20 20 #f .
b680: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d (with-
b690: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
b6a0: 66 6e 61 6d 65 0a 09 20 20 09 20 20 28 6c 61 6d fname.. . (lam
b6b0: 62 64 61 20 28 29 0a 09 09 20 20 20 20 28 65 71 bda ()... (eq
b6c0: 75 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 20 ual? key-string
b6d0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
b6e0: 09 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 . #f).
b6f0: 20 20 29 0a 20 20 20 20 29 0a 20 20 29 0a 29 0a ). ). ).).
b700: 0a 28 64 65 66 69 6e 65 20 28 64 62 66 69 6c 65 .(define (dbfile
b710: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
b720: 6b 2d 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 k-and-wait fname
b730: 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 #!key (expire-t
b740: 69 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 ime 300)). (let
b750: 20 28 28 65 6e 64 2d 74 69 6d 65 20 28 2b 20 65 ((end-time (+ e
b760: 78 70 69 72 65 2d 74 69 6d 65 20 28 63 75 72 72 xpire-time (curr
b770: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
b780: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
b790: 67 6f 74 2d 6c 6f 63 6b 20 28 64 62 66 69 6c 65 got-lock (dbfile
b7a0: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
b7b0: 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 k fname expire-t
b7c0: 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 ime: expire-time
b7d0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 67 6f ))). (if go
b7e0: 74 2d 6c 6f 63 6b 0a 09 20 20 23 74 0a 09 20 20 t-lock.. #t..
b7f0: 28 69 66 20 28 3e 20 65 6e 64 2d 74 69 6d 65 20 (if (> end-time
b800: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
b810: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
b820: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
b830: 21 20 33 29 0a 09 09 28 6c 6f 6f 70 20 28 64 62 ! 3)...(loop (db
b840: 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 file:simple-file
b850: 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 -lock fname expi
b860: 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d re-time: expire-
b870: 74 69 6d 65 29 29 29 0a 09 20 20 20 20 20 20 23 time))).. #
b880: 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 f)))))..(define
b890: 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 (dbfile:simple-f
b8a0: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
b8b0: 20 66 6e 61 6d 65 29 0a 20 20 28 68 61 6e 64 6c fname). (handl
b8c0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
b8d0: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 20 exn. #f
b8e0: 3b 3b 20 49 20 64 6f 6e 27 74 20 72 65 61 6c 6c ;; I don't reall
b8f0: 79 20 63 61 72 65 20 77 68 79 20 74 68 69 73 20 y care why this
b900: 66 61 69 6c 65 64 20 28 61 74 20 6c 65 61 73 74 failed (at least
b910: 20 66 6f 72 20 6e 6f 77 29 0a 20 20 20 20 28 64 for now). (d
b920: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d elete-file* fnam
b930: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 e)))..(define (d
b940: 62 66 69 6c 65 3a 77 69 74 68 2d 73 69 6d 70 6c bfile:with-simpl
b950: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d e-file-lock fnam
b960: 65 20 70 72 6f 63 20 23 21 6b 65 79 20 28 65 78 e proc #!key (ex
b970: 70 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a pire-time 300)).
b980: 20 20 28 6c 65 74 20 28 28 67 6f 74 6c 6f 63 6b (let ((gotlock
b990: 20 28 64 62 66 69 6c 65 3a 73 69 6d 70 6c 65 2d (dbfile:simple-
b9a0: 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 2d 77 61 file-lock-and-wa
b9b0: 69 74 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d it fname expire-
b9c0: 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d time: expire-tim
b9d0: 65 29 29 29 0a 20 20 20 20 28 69 66 20 67 6f 74 e))). (if got
b9e0: 6c 6f 63 6b 0a 09 28 6c 65 74 20 28 28 72 65 73 lock..(let ((res
b9f0: 20 28 70 72 6f 63 29 29 29 0a 09 20 20 28 64 62 (proc))).. (db
ba00: 66 69 6c 65 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 file:simple-file
ba10: 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e -release-lock fn
ba20: 61 6d 65 29 0a 09 20 20 72 65 73 29 0a 09 28 61 ame).. res)..(a
ba30: 73 73 65 72 74 20 23 74 20 22 46 41 54 41 4c 3a ssert #t "FATAL:
ba40: 20 73 69 6d 70 6c 65 20 66 69 6c 65 20 6c 6f 63 simple file loc
ba50: 6b 20 6e 65 76 65 72 20 67 6f 74 20 61 20 6c 6f k never got a lo
ba60: 63 6b 2e 22 29 29 29 29 0a 20 20 0a 28 64 65 66 ck.")))). .(def
ba70: 69 6e 65 20 28 64 62 3a 67 65 74 2d 63 61 63 68 ine (db:get-cach
ba80: 65 2d 73 74 6d 74 68 20 64 62 64 61 74 20 64 62 e-stmth dbdat db
ba90: 20 73 74 6d 74 29 0a 20 20 28 6c 65 74 2a 20 28 stmt). (let* (
baa0: 3b 3b 20 28 64 62 64 61 74 20 20 20 20 20 20 20 ;; (dbdat
bab0: 28 64 62 66 69 6c 65 3a 67 65 74 2d 64 62 64 61 (dbfile:get-dbda
bac0: 74 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 t dbstruct run-i
bad0: 64 29 29 0a 09 20 28 73 74 6d 74 2d 63 61 63 68 d)).. (stmt-cach
bae0: 65 20 20 28 64 62 72 3a 64 62 64 61 74 2d 73 74 e (dbr:dbdat-st
baf0: 6d 74 2d 63 61 63 68 65 20 64 62 64 61 74 29 29 mt-cache dbdat))
bb00: 0a 09 20 3b 3b 20 28 73 74 6d 74 68 20 20 20 20 .. ;; (stmth
bb10: 20 20 20 28 64 62 3a 68 6f 68 2d 67 65 74 20 73 (db:hoh-get s
bb20: 74 6d 74 2d 63 61 63 68 65 20 64 62 20 73 74 6d tmt-cache db stm
bb30: 74 29 29 0a 09 20 28 73 74 6d 74 68 20 20 20 20 t)).. (stmth
bb40: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
bb50: 65 66 2f 64 65 66 61 75 6c 74 20 73 74 6d 74 2d ef/default stmt-
bb60: 63 61 63 68 65 20 73 74 6d 74 20 23 66 29 29 29 cache stmt #f)))
bb70: 0a 20 20 20 20 28 6f 72 20 73 74 6d 74 68 0a 09 . (or stmth..
bb80: 28 6c 65 74 2a 20 28 28 6e 65 77 73 74 6d 74 68 (let* ((newstmth
bb90: 20 28 73 71 6c 69 74 65 33 3a 70 72 65 70 61 72 (sqlite3:prepar
bba0: 65 20 64 62 20 73 74 6d 74 29 29 29 0a 09 20 20 e db stmt)))..
bbb0: 3b 3b 20 28 64 62 3a 68 6f 68 2d 73 65 74 21 20 ;; (db:hoh-set!
bbc0: 73 74 6d 74 2d 63 61 63 68 65 20 64 62 20 73 74 stmt-cache db st
bbd0: 6d 74 20 6e 65 77 73 74 6d 74 68 29 0a 09 20 20 mt newstmth)..
bbe0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
bbf0: 20 73 74 6d 74 2d 63 61 63 68 65 20 73 74 6d 74 stmt-cache stmt
bc00: 20 6e 65 77 73 74 6d 74 68 29 0a 09 20 20 6e 65 newstmth).. ne
bc10: 77 73 74 6d 74 68 29 29 29 29 0a 0a 0a 0a 29 0a wstmth))))....).