Artifact
b5405355dd10e04190d022e7b2c79fc36852730f:
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 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 53 69 6d 70 6c 65 20 70 ====.;; Simple p
0230: 65 72 73 69 73 74 61 6e 74 20 73 74 72 69 6e 67 ersistant string
0240: 73 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 2e 20 s lookup table.
0250: 4b 65 65 70 20 6f 75 74 20 6f 66 20 74 68 65 20 Keep out of the
0260: 6d 61 69 6e 20 64 62 0a 3b 3b 20 73 6f 20 77 72 main db.;; so wr
0270: 69 74 65 73 2f 72 65 61 64 73 20 64 6f 6e 27 74 ites/reads don't
0280: 20 73 6c 6f 77 20 64 6f 77 6e 20 63 65 6e 74 72 slow down centr
0290: 61 6c 20 61 63 63 65 73 73 2e 0a 3b 3b 3d 3d 3d al access..;;===
02a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02e0: 3d 3d 3d 0a 0a 28 72 65 71 75 69 72 65 2d 65 78 ===..(require-ex
02f0: 74 65 6e 73 69 6f 6e 20 28 73 72 66 69 20 31 38 tension (srfi 18
0300: 29 20 65 78 74 72 61 73 29 0a 28 75 73 65 20 73 ) extras).(use s
0310: 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f qlite3 srfi-1 po
0320: 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d six regex regex-
0330: 63 61 73 65 20 73 72 66 69 2d 36 39 20 63 73 76 case srfi-69 csv
0340: 2d 78 6d 6c 20 73 31 31 6e 20 6d 64 35 20 6d 65 -xml s11n md5 me
0350: 73 73 61 67 65 2d 64 69 67 65 73 74 20 62 61 73 ssage-digest bas
0360: 65 36 34 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 e64).(import (pr
0370: 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c efix sqlite3 sql
0380: 69 74 65 33 3a 29 29 0a 28 69 6d 70 6f 72 74 20 ite3:)).(import
0390: 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 62 (prefix base64 b
03a0: 61 73 65 36 34 3a 29 29 0a 0a 28 64 65 63 6c 61 ase64:))..(decla
03b0: 72 65 20 28 75 6e 69 74 20 73 64 62 29 29 0a 0a re (unit sdb))..
03c0: 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 64 62 ;; .(define (sdb
03d0: 3a 6f 70 65 6e 20 66 6e 61 6d 65 29 0a 20 20 28 :open fname). (
03e0: 6c 65 74 2a 20 28 28 64 62 70 61 74 68 20 20 20 let* ((dbpath
03f0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
0400: 74 6f 72 79 20 66 6e 61 6d 65 29 29 0a 09 20 28 tory fname)).. (
0410: 64 62 65 78 69 73 74 73 20 20 28 6c 65 74 20 28 dbexists (let (
0420: 28 66 65 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (fe (file-exists
0430: 3f 20 66 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 ? fname)))...
0440: 20 20 20 28 69 66 20 66 65 20 0a 09 09 09 20 20 (if fe ....
0450: 66 65 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 fe.... (begin..
0460: 09 09 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 .. (create-di
0470: 72 65 63 74 6f 72 79 20 64 62 70 61 74 68 20 23 rectory dbpath #
0480: 74 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 29 t).... #f))))
0490: 0a 09 20 28 73 64 62 20 20 20 20 20 20 20 20 28 .. (sdb (
04a0: 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 sqlite3:open-dat
04b0: 61 62 61 73 65 20 66 6e 61 6d 65 29 29 0a 09 20 abase fname))..
04c0: 28 68 61 6e 64 6c 65 72 20 20 20 28 6d 61 6b 65 (handler (make
04d0: 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 33 -busy-timeout 13
04e0: 36 30 30 30 29 29 29 0a 20 20 20 20 28 73 71 6c 6000))). (sql
04f0: 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 61 ite3:set-busy-ha
0500: 6e 64 6c 65 72 21 20 73 64 62 20 68 61 6e 64 6c ndler! sdb handl
0510: 65 72 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 er). (if (not
0520: 20 64 62 65 78 69 73 74 73 29 0a 09 28 73 64 62 dbexists)..(sdb
0530: 3a 69 6e 69 74 69 61 6c 69 7a 65 20 73 64 62 29 :initialize sdb)
0540: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 ). (sqlite3:e
0550: 78 65 63 75 74 65 20 73 64 62 20 22 50 52 41 47 xecute sdb "PRAG
0560: 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 3d MA synchronous =
0570: 20 31 3b 22 29 0a 20 20 20 20 73 64 62 29 29 0a 1;"). sdb)).
0580: 0a 28 64 65 66 69 6e 65 20 28 73 64 62 3a 69 6e .(define (sdb:in
0590: 69 74 69 61 6c 69 7a 65 20 73 64 62 29 0a 20 20 itialize sdb).
05a0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
05b0: 20 73 64 62 20 22 43 52 45 41 54 45 20 54 41 42 sdb "CREATE TAB
05c0: 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
05d0: 20 73 74 72 73 0a 20 20 20 20 20 20 20 20 20 20 strs.
05e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05f0: 20 28 69 64 20 20 49 4e 54 45 47 45 52 20 50 52 (id INTEGER PR
0600: 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
0610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0620: 20 20 20 20 20 20 20 73 74 72 20 54 45 58 54 2c str TEXT,
0630: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0640: 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 CONSTRA
0650: 49 4e 54 20 73 74 72 20 55 4e 49 51 55 45 20 28 INT str UNIQUE (
0660: 73 74 72 29 29 3b 22 29 0a 20 20 28 73 71 6c 69 str));"). (sqli
0670: 74 65 33 3a 65 78 65 63 75 74 65 20 73 64 62 20 te3:execute sdb
0680: 22 43 52 45 41 54 45 20 49 4e 44 45 58 20 49 46 "CREATE INDEX IF
0690: 20 4e 4f 54 20 45 58 49 53 54 53 20 73 74 72 69 NOT EXISTS stri
06a0: 6e 64 78 20 4f 4e 20 73 74 72 73 20 28 73 74 72 ndx ON strs (str
06b0: 29 3b 22 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e );"))..;; (defin
06c0: 65 20 73 75 6d 75 70 20 28 6c 65 74 20 28 28 61 e sumup (let ((a
06d0: 20 30 29 29 28 6c 61 6d 62 64 61 20 28 78 29 28 0))(lambda (x)(
06e0: 73 65 74 21 20 61 20 28 2b 20 78 20 61 29 29 20 set! a (+ x a))
06f0: 61 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 a)))..(define (s
0700: 64 62 3a 72 65 67 69 73 74 65 72 2d 73 74 72 69 db:register-stri
0710: 6e 67 20 73 64 62 20 73 74 72 29 0a 20 20 28 73 ng sdb str). (s
0720: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 73 qlite3:execute s
0730: 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 49 47 db "INSERT OR IG
0740: 4e 4f 52 45 20 49 4e 54 4f 20 73 74 72 73 20 28 NORE INTO strs (
0750: 73 74 72 29 20 56 41 4c 55 45 53 20 28 3f 29 3b str) VALUES (?);
0760: 22 20 73 74 72 29 29 0a 0a 28 64 65 66 69 6e 65 " str))..(define
0770: 20 28 73 64 62 3a 73 74 72 69 6e 67 2d 3e 69 64 (sdb:string->id
0780: 20 73 64 62 20 73 74 72 2d 63 61 63 68 65 20 73 sdb str-cache s
0790: 74 72 29 0a 20 20 28 6c 65 74 20 28 28 69 64 20 tr). (let ((id
07a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
07b0: 64 65 66 61 75 6c 74 20 73 74 72 2d 63 61 63 68 default str-cach
07c0: 65 20 73 74 72 20 23 66 29 29 29 0a 20 20 20 20 e str #f))).
07d0: 28 69 66 20 28 6e 6f 74 20 69 64 29 0a 09 28 73 (if (not id)..(s
07e0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
07f0: 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 73 row.. (lambda (s
0800: 69 64 29 0a 09 20 20 20 28 73 65 74 21 20 69 64 id).. (set! id
0810: 20 73 69 64 29 0a 09 20 20 20 28 68 61 73 68 2d sid).. (hash-
0820: 74 61 62 6c 65 2d 73 65 74 21 20 73 74 72 2d 63 table-set! str-c
0830: 61 63 68 65 20 73 74 72 20 69 64 29 29 0a 09 20 ache str id))..
0840: 73 64 62 0a 09 20 22 53 45 4c 45 43 54 20 69 64 sdb.. "SELECT id
0850: 20 46 52 4f 4d 20 73 74 72 73 20 57 48 45 52 45 FROM strs WHERE
0860: 20 73 74 72 3d 3f 3b 22 20 73 74 72 29 29 0a 20 str=?;" str)).
0870: 20 20 20 69 64 29 29 0a 0a 28 64 65 66 69 6e 65 id))..(define
0880: 20 28 73 64 62 3a 69 64 2d 3e 73 74 72 69 6e 67 (sdb:id->string
0890: 20 73 64 62 20 69 64 2d 63 61 63 68 65 20 69 64 sdb id-cache id
08a0: 29 0a 20 20 28 6c 65 74 20 28 28 73 74 72 20 28 ). (let ((str (
08b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
08c0: 65 66 61 75 6c 74 20 69 64 2d 63 61 63 68 65 20 efault id-cache
08d0: 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 id #f))). (if
08e0: 20 28 6e 6f 74 20 73 74 72 29 0a 09 28 73 71 6c (not str)..(sql
08f0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
0900: 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 69 73 74 w.. (lambda (ist
0910: 72 29 0a 09 20 20 20 28 73 65 74 21 20 73 74 72 r).. (set! str
0920: 20 69 73 74 72 29 0a 09 20 20 20 28 68 61 73 68 istr).. (hash
0930: 2d 74 61 62 6c 65 2d 73 65 74 21 20 69 64 2d 63 -table-set! id-c
0940: 61 63 68 65 20 69 64 20 73 74 72 29 29 0a 09 20 ache id str))..
0950: 73 64 62 0a 09 20 22 53 45 4c 45 43 54 20 73 74 sdb.. "SELECT st
0960: 72 20 46 52 4f 4d 20 73 74 72 73 20 57 48 45 52 r FROM strs WHER
0970: 45 20 69 64 3d 3f 3b 22 20 69 64 29 29 0a 20 20 E id=?;" id)).
0980: 20 20 73 74 72 29 29 0a 0a 3b 3b 20 4e 75 6d 62 str))..;; Numb
0990: 65 72 73 20 67 65 74 20 70 61 73 73 65 64 20 74 ers get passed t
09a0: 68 6f 75 67 68 20 69 6e 20 62 6f 74 68 20 64 69 hough in both di
09b0: 72 65 63 74 69 6f 6e 73 0a 3b 3b 0a 28 64 65 66 rections.;;.(def
09c0: 69 6e 65 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 ine (make-sdb:qr
09d0: 79 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 y fname). (let
09e0: 28 28 73 64 62 20 20 20 20 23 66 29 0a 09 28 73 ((sdb #f)..(s
09f0: 63 61 63 68 65 20 28 6d 61 6b 65 2d 68 61 73 68 cache (make-hash
0a00: 2d 74 61 62 6c 65 29 29 0a 09 28 69 63 61 63 68 -table))..(icach
0a10: 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 e (make-hash-tab
0a20: 6c 65 29 29 29 0a 20 20 20 20 28 6c 61 6d 62 64 le))). (lambd
0a30: 61 20 28 63 6d 64 20 76 61 72 29 0a 20 20 20 20 a (cmd var).
0a40: 20 20 28 63 61 73 65 20 63 6d 64 0a 09 28 28 73 (case cmd..((s
0a50: 65 74 75 70 29 20 20 20 28 73 65 74 21 20 73 64 etup) (set! sd
0a60: 62 20 28 69 66 20 28 6e 6f 74 20 73 64 62 29 0a b (if (not sdb).
0a70: 09 09 09 09 20 28 73 64 62 3a 6f 70 65 6e 20 28 .... (sdb:open (
0a80: 69 66 20 76 61 72 20 76 61 72 20 66 6e 61 6d 65 if var var fname
0a90: 29 29 29 29 29 0a 09 28 28 73 65 74 64 62 29 20 )))))..((setdb)
0aa0: 20 20 20 28 73 65 74 21 20 73 64 62 20 76 61 72 (set! sdb var
0ab0: 29 29 0a 09 28 28 67 65 74 64 62 29 20 20 20 20 ))..((getdb)
0ac0: 73 64 62 29 0a 09 28 28 66 69 6e 61 6c 69 7a 65 sdb)..((finalize
0ad0: 29 20 28 69 66 20 73 64 62 0a 09 09 09 28 62 65 ) (if sdb....(be
0ae0: 67 69 6e 0a 09 09 09 20 20 28 73 71 6c 69 74 65 gin.... (sqlite
0af0: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 73 64 62 29 3:finalize! sdb)
0b00: 0a 09 09 09 20 20 28 73 65 74 21 20 73 64 62 20 .... (set! sdb
0b10: 23 66 29 29 29 29 0a 09 28 28 67 65 74 69 64 29 #f))))..((getid)
0b20: 20 20 20 20 20 28 6c 65 74 20 28 28 69 64 20 28 (let ((id (
0b30: 69 66 20 28 6f 72 20 28 6e 75 6d 62 65 72 3f 20 if (or (number?
0b40: 76 61 72 29 0a 09 09 09 09 20 20 20 20 20 20 20 var).....
0b50: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
0b60: 76 61 72 29 29 0a 09 09 09 09 20 20 20 76 61 72 var))..... var
0b70: 0a 09 09 09 09 20 20 20 28 73 64 62 3a 73 74 72 ..... (sdb:str
0b80: 69 6e 67 2d 3e 69 64 20 73 64 62 20 73 63 61 63 ing->id sdb scac
0b90: 68 65 20 76 61 72 29 29 29 29 0a 09 09 20 20 20 he var))))...
0ba0: 20 20 20 20 28 69 66 20 69 64 0a 09 09 09 20 20 (if id....
0bb0: 20 69 64 0a 09 09 09 20 20 20 28 62 65 67 69 6e id.... (begin
0bc0: 0a 09 09 09 20 20 20 20 20 28 73 64 62 3a 72 65 .... (sdb:re
0bd0: 67 69 73 74 65 72 2d 73 74 72 69 6e 67 20 73 64 gister-string sd
0be0: 62 20 76 61 72 29 0a 09 09 09 20 20 20 20 20 28 b var).... (
0bf0: 73 64 62 3a 73 74 72 69 6e 67 2d 3e 69 64 20 73 sdb:string->id s
0c00: 64 62 20 73 63 61 63 68 65 20 76 61 72 29 29 29 db scache var)))
0c10: 29 29 0a 09 28 28 67 65 74 73 74 72 29 20 20 20 ))..((getstr)
0c20: 20 28 69 66 20 28 6f 72 20 28 6e 75 6d 62 65 72 (if (or (number
0c30: 3f 20 76 61 72 29 0a 09 09 09 20 20 20 20 20 28 ? var).... (
0c40: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 string->number v
0c50: 61 72 29 29 0a 09 09 09 20 28 73 64 62 3a 69 64 ar)).... (sdb:id
0c60: 2d 3e 73 74 72 69 6e 67 20 73 64 62 20 69 63 61 ->string sdb ica
0c70: 63 68 65 20 76 61 72 29 0a 09 09 09 20 76 61 72 che var).... var
0c80: 29 29 0a 09 28 28 70 61 73 73 69 64 29 20 20 20 ))..((passid)
0c90: 20 76 61 72 29 0a 09 28 28 70 61 73 73 73 74 72 var)..((passstr
0ca0: 29 20 20 20 76 61 72 29 0a 09 28 65 6c 73 65 20 ) var)..(else
0cb0: 23 66 29 29 29 29 29 0a 0a #f)))))..