Artifact
36890e0c145c95c8a5e38ccb7e28cc0ca00b8870:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 34 2c 20 4d 61 74 74 68 65 77 06-2014, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 28 72 65 71 nses/>..;;..(req
0300: 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 uire-extension (
0310: 73 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 srfi 18) extras
0320: 74 63 70 20 73 31 31 6e 29 0a 0a 28 64 65 63 6c tcp s11n)..(decl
0330: 61 72 65 20 28 75 6e 69 74 20 70 6f 72 74 6c 6f are (unit portlo
0340: 67 67 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 gger)).(declare
0350: 28 75 73 65 73 20 64 65 62 75 67 70 72 69 6e 74 (uses debugprint
0360: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0370: 73 20 64 62 6d 6f 64 29 29 0a 0a 28 6d 6f 64 75 s dbmod))..(modu
0380: 6c 65 20 70 6f 72 74 6c 6f 67 67 65 72 0a 2a 0a le portlogger.*.
0390: 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 29 .(import scheme)
03a0: 0a 0a 28 63 6f 6e 64 2d 65 78 70 61 6e 64 0a 20 ..(cond-expand.
03b0: 28 63 68 69 63 6b 65 6e 2d 34 0a 20 20 28 69 6d (chicken-4. (im
03c0: 70 6f 72 74 20 63 68 69 63 6b 65 6e 20 64 61 74 port chicken dat
03d0: 61 2d 73 74 72 75 63 74 75 72 65 73 29 0a 20 20 a-structures).
03e0: 28 69 6d 70 6f 72 74 20 70 6f 73 69 78 0a 09 20 (import posix..
03f0: 20 3b 3b 20 68 6f 73 74 69 6e 66 6f 0a 09 20 20 ;; hostinfo..
0400: 3b 3b 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 0a 09 ;; dot-locking..
0410: 20 20 65 78 74 72 61 73 0a 09 20 20 29 0a 20 20 extras.. ).
0420: 0a 20 20 28 69 6d 70 6f 72 74 20 28 70 72 65 66 . (import (pref
0430: 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 ix sqlite3 sqlit
0440: 65 33 3a 29 29 0a 20 20 28 69 6d 70 6f 72 74 20 e3:)). (import
0450: 64 65 62 75 67 70 72 69 6e 74 20 64 62 6d 6f 64 debugprint dbmod
0460: 29 0a 20 20 29 0a 20 28 63 68 69 63 6b 65 6e 2d ). ). (chicken-
0470: 35 0a 20 20 28 69 6d 70 6f 72 74 20 63 68 69 63 5. (import chic
0480: 6b 65 6e 2e 62 61 73 65 0a 09 20 20 63 68 69 63 ken.base.. chic
0490: 6b 65 6e 2e 63 6f 6e 64 69 74 69 6f 6e 0a 09 20 ken.condition..
04a0: 20 63 68 69 63 6b 65 6e 2e 66 69 6c 65 0a 09 20 chicken.file..
04b0: 20 63 68 69 63 6b 65 6e 2e 70 61 74 68 6e 61 6d chicken.pathnam
04c0: 65 0a 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 6f e.. chicken.pro
04d0: 63 65 73 73 2d 63 6f 6e 74 65 78 74 2e 70 6f 73 cess-context.pos
04e0: 69 78 0a 09 20 20 63 68 69 63 6b 65 6e 2e 70 72 ix.. chicken.pr
04f0: 6f 63 65 73 73 0a 09 20 20 63 68 69 63 6b 65 6e ocess.. chicken
0500: 2e 73 6f 72 74 0a 09 20 20 63 68 69 63 6b 65 6e .sort.. chicken
0510: 2e 73 74 72 69 6e 67 0a 09 20 20 63 68 69 63 6b .string.. chick
0520: 65 6e 2e 74 69 6d 65 0a 09 20 20 63 68 69 63 6b en.time.. chick
0530: 65 6e 2e 72 61 6e 64 6f 6d 0a 09 20 20 0a 09 20 en.random.. ..
0540: 20 73 79 73 74 65 6d 2d 69 6e 66 6f 72 6d 61 74 system-informat
0550: 69 6f 6e 0a 09 20 20 29 0a 20 20 28 64 65 66 69 ion.. ). (defi
0560: 6e 65 20 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 ne file-write-ac
0570: 63 65 73 73 3f 20 66 69 6c 65 2d 77 72 69 74 61 cess? file-writa
0580: 62 6c 65 3f 29 0a 20 20 28 64 65 66 69 6e 65 20 ble?). (define
0590: 72 61 6e 64 6f 6d 20 70 73 65 75 64 6f 2d 72 61 random pseudo-ra
05a0: 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 29 0a 20 20 ndom-integer).
05b0: 29 29 0a 0a 28 69 6d 70 6f 72 74 20 73 72 66 69 ))..(import srfi
05c0: 2d 31 20 73 72 66 69 2d 36 39 20 7a 33 0a 09 28 -1 srfi-69 z3..(
05d0: 73 72 66 69 20 31 38 29 20 73 31 31 6e 29 0a 28 srfi 18) s11n).(
05e0: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 import (prefix s
05f0: 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 qlite3 sqlite3:)
0600: 29 0a 28 69 6d 70 6f 72 74 20 64 65 62 75 67 70 ).(import debugp
0610: 72 69 6e 74 20 64 62 6d 6f 64 29 0a 0a 3b 3b 20 rint dbmod)..;;
0620: 6c 73 6f 66 20 2d 69 0a 0a 28 64 65 66 69 6e 65 lsof -i..(define
0630: 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 (portlogger:ope
0640: 6e 2d 64 62 20 66 6e 61 6d 65 29 0a 20 20 28 6c n-db fname). (l
0650: 65 74 2a 20 28 3b 3b 20 28 61 76 61 69 6c 20 20 et* (;; (avail
0660: 20 20 28 74 61 73 6b 73 3a 77 61 69 74 2d 6f 6e (tasks:wait-on
0670: 2d 6a 6f 75 72 6e 61 6c 20 66 6e 61 6d 65 20 35 -journal fname 5
0680: 20 72 65 6d 6f 76 65 3a 20 23 74 29 29 20 3b 3b remove: #t)) ;;
0690: 20 77 61 69 74 20 75 70 20 74 6f 20 61 62 6f 75 wait up to abou
06a0: 74 20 31 30 20 73 65 63 6f 6e 64 73 20 66 6f 72 t 10 seconds for
06b0: 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 74 6f 20 the journal to
06c0: 67 6f 20 61 77 61 79 0a 20 20 20 20 20 20 20 20 go away.
06d0: 20 28 61 76 61 69 6c 20 23 74 29 0a 09 20 28 65 (avail #t).. (e
06e0: 78 69 73 74 73 20 20 20 28 66 69 6c 65 2d 65 78 xists (file-ex
06f0: 69 73 74 73 3f 20 66 6e 61 6d 65 29 29 0a 09 20 ists? fname))..
0700: 28 64 62 20 20 20 20 20 20 20 28 69 66 20 61 76 (db (if av
0710: 61 69 6c 20 0a 09 09 20 20 20 20 20 20 20 28 73 ail ... (s
0720: 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 qlite3:open-data
0730: 62 61 73 65 20 66 6e 61 6d 65 29 0a 09 09 20 20 base fname)...
0740: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
0750: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
0760: 6d 20 2d 66 20 22 20 66 6e 61 6d 65 29 29 0a 09 m -f " fname))..
0770: 09 09 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e .. (sqlite3:open
0780: 2d 64 61 74 61 62 61 73 65 20 66 6e 61 6d 65 29 -database fname)
0790: 29 29 29 0a 09 20 28 68 61 6e 64 6c 65 72 20 20 ))).. (handler
07a0: 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 (sqlite3:make-bu
07b0: 73 79 2d 74 69 6d 65 6f 75 74 20 31 33 36 30 30 sy-timeout 13600
07c0: 30 29 29 0a 09 20 28 63 61 6e 77 72 69 74 65 20 0)).. (canwrite
07d0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
07e0: 73 73 3f 20 66 6e 61 6d 65 29 29 29 0a 09 20 3b ss? fname))).. ;
07f0: 3b 20 28 64 62 2d 69 6e 69 74 20 20 28 6c 61 6d ; (db-init (lam
0800: 62 64 61 20 28 29 0a 09 20 3b 3b 20 20 20 20 20 bda ().. ;;
0810: 20 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 (sqlite3
0820: 3a 65 78 65 63 75 74 65 20 0a 09 20 3b 3b 20 20 :execute .. ;;
0830: 20 20 20 20 20 20 20 20 20 20 20 20 64 62 0a 09 db..
0840: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
0850: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
0860: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 70 6f 72 F NOT EXISTS por
0870: 74 73 20 28 0a 20 20 20 20 20 20 20 20 20 3b 3b ts (. ;;
0880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0890: 20 70 6f 72 74 20 49 4e 54 45 47 45 52 20 50 52 port INTEGER PR
08a0: 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
08b0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
08c0: 20 20 20 20 20 20 20 73 74 61 74 65 20 54 45 58 state TEX
08d0: 54 20 44 45 46 41 55 4c 54 20 27 6e 6f 74 2d 75 T DEFAULT 'not-u
08e0: 73 65 64 27 2c 0a 20 20 20 20 20 20 20 20 20 3b sed',. ;
08f0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
0900: 20 20 66 61 69 6c 5f 63 6f 75 6e 74 20 49 4e 54 fail_count INT
0910: 45 47 45 52 20 44 45 46 41 55 4c 54 20 30 2c 0a EGER DEFAULT 0,.
0920: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
0930: 20 20 20 20 20 20 20 20 20 20 20 20 75 70 64 61 upda
0940: 74 65 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d te_time TIMESTAM
0950: 50 20 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 P DEFAULT (strft
0960: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 ime('%s','now'))
0970: 20 29 3b 22 29 29 29 29 0a 20 20 20 20 28 73 71 );")))). (sq
0980: 6c 69 74 65 33 3a 73 65 74 2d 62 75 73 79 2d 68 lite3:set-busy-h
0990: 61 6e 64 6c 65 72 21 20 64 62 20 68 61 6e 64 6c andler! db handl
09a0: 65 72 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 er). (sqlite3
09b0: 3a 65 78 65 63 75 74 65 20 64 62 20 22 50 52 41 :execute db "PRA
09c0: 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 73 20 GMA synchronous
09d0: 3d 20 30 3b 22 29 0a 20 20 20 20 28 73 71 6c 69 = 0;"). (sqli
09e0: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 20 20 20 te3:execute .
09f0: 20 20 64 62 0a 20 20 20 20 20 22 43 52 45 41 54 db. "CREAT
0a00: 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 E TABLE IF NOT E
0a10: 58 49 53 54 53 20 70 6f 72 74 73 20 28 0a 20 20 XISTS ports (.
0a20: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 20 49 port I
0a30: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
0a40: 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 EY,.
0a50: 73 74 61 74 65 20 54 45 58 54 20 44 45 46 41 55 state TEXT DEFAU
0a60: 4c 54 20 27 6e 6f 74 2d 75 73 65 64 27 2c 0a 20 LT 'not-used',.
0a70: 20 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 5f fail_
0a80: 63 6f 75 6e 74 20 49 4e 54 45 47 45 52 20 44 45 count INTEGER DE
0a90: 46 41 55 4c 54 20 30 2c 0a 20 20 20 20 20 20 20 FAULT 0,.
0aa0: 20 20 20 20 20 75 70 64 61 74 65 5f 74 69 6d 65 update_time
0ab0: 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 TIMESTAMP DEFAU
0ac0: 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 LT (strftime('%s
0ad0: 27 2c 27 6e 6f 77 27 29 29 20 29 3b 22 29 0a 20 ','now')) );").
0ae0: 20 20 20 64 62 29 29 0a 0a 28 64 65 66 69 6e 65 db))..(define
0af0: 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 (portlogger:ope
0b00: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 72 6f 63 n-run-close proc
0b10: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 . params). (le
0b20: 74 2a 20 28 28 66 6e 61 6d 65 20 20 28 63 6f 6e t* ((fname (con
0b30: 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 c "/tmp/." (curr
0b40: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 ent-user-name) "
0b50: 2d 70 6f 72 74 6c 6f 67 67 65 72 2e 64 62 22 29 -portlogger.db")
0b60: 29 29 0a 09 20 3b 3b 20 28 61 76 61 69 6c 20 20 )).. ;; (avail
0b70: 28 74 61 73 6b 73 3a 77 61 69 74 2d 6f 6e 2d 6a (tasks:wait-on-j
0b80: 6f 75 72 6e 61 6c 20 66 6e 61 6d 65 20 31 30 29 ournal fname 10)
0b90: 29 29 20 3b 3b 20 77 61 69 74 20 75 70 20 74 6f )) ;; wait up to
0ba0: 20 61 62 6f 75 74 20 31 30 20 73 65 63 6f 6e 64 about 10 second
0bb0: 73 20 66 6f 72 20 74 68 65 20 6a 6f 75 72 6e 61 s for the journa
0bc0: 6c 20 74 6f 20 67 6f 20 61 77 61 79 0a 20 20 20 l to go away.
0bd0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0be0: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
0bf0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
0c00: 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d ;; (release-dot-
0c10: 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 20 20 20 20 lock fname).
0c20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0c30: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
0c40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6f 72 74 -log-port* "port
0c50: 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d logger:open-run-
0c60: 63 6c 6f 73 65 20 66 61 69 6c 65 64 2e 20 22 20 close failed. "
0c70: 70 72 6f 63 20 22 20 22 20 70 61 72 61 6d 73 29 proc " " params)
0c80: 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
0c90: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
0ca0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
0cb0: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
0cc0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
0cd0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
0ce0: 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 ge) exn)).
0cf0: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
0d00: 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 5 *default-log-
0d10: 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f port* "exn=" (co
0d20: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
0d30: 6e 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 n)). (if (
0d40: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
0d50: 6d 65 29 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 me)(delete-file
0d60: 66 6e 61 6d 65 29 29 20 3b 3b 20 62 72 75 74 61 fname)) ;; bruta
0d70: 6c 6c 79 20 67 65 74 20 72 69 64 20 6f 66 20 69 lly get rid of i
0d80: 74 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 2d t. (print-
0d90: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
0da0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0db0: 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 3b 3b ). (let* (;;
0dc0: 20 28 6c 6f 63 6b 20 20 20 28 6f 62 74 61 69 6e (lock (obtain
0dd0: 2d 64 6f 74 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 -dot-lock fname
0de0: 32 20 39 20 31 30 29 29 0a 09 20 20 20 20 28 64 2 9 10)).. (d
0df0: 62 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 b (portlogge
0e00: 72 3a 6f 70 65 6e 2d 64 62 20 66 6e 61 6d 65 29 r:open-db fname)
0e10: 29 0a 09 20 20 20 20 28 72 65 73 20 20 20 20 28 ).. (res (
0e20: 61 70 70 6c 79 20 70 72 6f 63 20 64 62 20 70 61 apply proc db pa
0e30: 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 28 rams))). (
0e40: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
0e50: 21 20 64 62 29 0a 20 20 20 20 20 20 20 3b 3b 20 ! db). ;;
0e60: 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 (release-dot-loc
0e70: 6b 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 k fname).
0e80: 72 65 73 29 29 29 29 0a 0a 3b 3b 20 28 66 6f 6c res))))..;; (fol
0e90: 64 2d 72 6f 77 20 50 52 4f 43 20 49 4e 49 54 20 d-row PROC INIT
0ea0: 44 41 54 41 42 41 53 45 20 53 51 4c 20 2e 20 50 DATABASE SQL . P
0eb0: 41 52 41 4d 45 54 45 52 53 29 20 0a 28 64 65 66 ARAMETERS) .(def
0ec0: 69 6e 65 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a ine (portlogger:
0ed0: 74 61 6b 65 2d 70 6f 72 74 20 64 62 20 70 6f 72 take-port db por
0ee0: 74 6e 75 6d 29 0a 20 20 28 6c 65 74 2a 20 28 28 tnum). (let* ((
0ef0: 71 72 79 31 20 28 73 71 6c 69 74 65 33 3a 70 72 qry1 (sqlite3:pr
0f00: 65 70 61 72 65 20 64 62 20 22 49 4e 53 45 52 54 epare db "INSERT
0f10: 20 49 4e 54 4f 20 70 6f 72 74 73 20 28 70 6f 72 INTO ports (por
0f20: 74 2c 73 74 61 74 65 29 20 56 41 4c 55 45 53 20 t,state) VALUES
0f30: 28 3f 2c 3f 29 3b 22 29 29 0a 09 20 28 71 72 79 (?,?);")).. (qry
0f40: 32 20 28 73 71 6c 69 74 65 33 3a 70 72 65 70 61 2 (sqlite3:prepa
0f50: 72 65 20 64 62 20 22 55 50 44 41 54 45 20 70 6f re db "UPDATE po
0f60: 72 74 73 20 53 45 54 20 73 74 61 74 65 3d 3f 2c rts SET state=?,
0f70: 75 70 64 61 74 65 5f 74 69 6d 65 3d 73 74 72 66 update_time=strf
0f80: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
0f90: 20 57 48 45 52 45 20 70 6f 72 74 3d 3f 3b 22 29 WHERE port=?;")
0fa0: 29 0a 09 20 28 71 72 79 33 20 28 73 71 6c 69 74 ).. (qry3 (sqlit
0fb0: 65 33 3a 70 72 65 70 61 72 65 20 64 62 20 22 53 e3:prepare db "S
0fc0: 45 4c 45 43 54 20 73 74 61 74 65 20 46 52 4f 4d ELECT state FROM
0fd0: 20 70 6f 72 74 73 20 57 48 45 52 45 20 70 6f 72 ports WHERE por
0fe0: 74 3d 3f 3b 22 29 29 0a 09 20 28 72 65 73 20 20 t=?;")).. (res
0ff0: 28 73 71 6c 69 74 65 33 3a 77 69 74 68 2d 74 72 (sqlite3:with-tr
1000: 61 6e 73 61 63 74 69 6f 6e 0a 09 09 64 62 0a 09 ansaction...db..
1010: 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 .(lambda ()...
1020: 3b 3b 20 28 66 6f 6c 64 2d 72 6f 77 20 28 6c 61 ;; (fold-row (la
1030: 6d 62 64 61 20 28 76 61 72 20 63 75 72 72 29 20 mbda (var curr)
1040: 28 6f 72 20 76 61 72 20 63 75 72 72 29 29 20 23 (or var curr)) #
1050: 66 20 64 62 20 22 53 45 4c 45 43 54 20 76 61 72 f db "SELECT var
1060: 20 46 52 4f 4d 20 66 6f 6f 20 57 48 45 52 45 20 FROM foo WHERE
1070: 69 64 3d 31 30 30 3b 22 29 0a 09 09 20 20 28 6c id=100;")... (l
1080: 65 74 2a 20 28 28 63 75 72 72 20 23 66 29 0a 09 et* ((curr #f)..
1090: 09 09 20 28 72 65 73 20 20 23 66 29 29 0a 09 09 .. (res #f))...
10a0: 20 20 20 20 28 73 65 74 21 20 63 75 72 72 20 28 (set! curr (
10b0: 73 71 6c 69 74 65 33 3a 66 6f 6c 64 2d 72 6f 77 sqlite3:fold-row
10c0: 0a 09 09 09 09 28 6c 61 6d 62 64 61 20 28 76 61 .....(lambda (va
10d0: 72 20 63 75 72 72 29 0a 09 09 09 09 20 20 28 6f r curr)..... (o
10e0: 72 20 63 75 72 72 20 76 61 72 20 63 75 72 72 29 r curr var curr)
10f0: 29 0a 09 09 09 09 22 6e 6f 74 2d 74 72 69 65 64 )....."not-tried
1100: 22 0a 09 09 09 09 71 72 79 33 0a 09 09 09 09 70 ".....qry3.....p
1110: 6f 72 74 6e 75 6d 29 29 0a 09 09 20 20 20 20 3b ortnum))... ;
1120: 3b 20 28 70 72 69 6e 74 20 22 63 75 72 72 3d 22 ; (print "curr="
1130: 20 63 75 72 72 29 0a 09 09 20 20 20 20 28 73 65 curr)... (se
1140: 74 21 20 72 65 73 20 28 63 61 73 65 20 28 73 74 t! res (case (st
1150: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 63 75 72 ring->symbol cur
1160: 72 29 0a 09 09 09 09 28 28 72 65 6c 65 61 73 65 r).....((release
1170: 64 29 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 d) (sqlite3:exe
1180: 63 75 74 65 20 71 72 79 32 20 22 74 61 6b 65 6e cute qry2 "taken
1190: 22 20 70 6f 72 74 6e 75 6d 29 20 27 74 61 6b 65 " portnum) 'take
11a0: 6e 29 0a 09 09 09 09 28 28 6e 6f 74 2d 74 72 69 n).....((not-tri
11b0: 65 64 29 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ed) (sqlite3:exe
11c0: 63 75 74 65 20 71 72 79 31 20 70 6f 72 74 6e 75 cute qry1 portnu
11d0: 6d 20 22 74 61 6b 65 6e 22 29 20 27 74 61 6b 65 m "taken") 'take
11e0: 6e 29 0a 09 09 09 09 28 28 74 61 6b 65 6e 29 20 n).....((taken)
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1210: 20 20 20 20 20 20 20 20 20 20 20 27 61 6c 72 65 'alre
1220: 61 64 79 2d 74 61 6b 65 6e 29 0a 09 09 09 09 28 ady-taken).....(
1230: 28 66 61 69 6c 65 64 29 20 20 20 20 20 20 20 20 (failed)
1240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1260: 20 20 20 27 66 61 69 6c 65 64 29 0a 09 09 09 09 'failed).....
1270: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
1280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12a0: 20 20 20 20 27 65 72 72 6f 72 29 29 29 0a 09 09 'error)))...
12b0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 ;; (print "r
12c0: 65 73 3d 22 20 72 65 73 29 0a 09 09 20 20 20 20 es=" res)...
12d0: 72 65 73 29 29 29 29 29 0a 20 20 20 20 28 73 71 res))))). (sq
12e0: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
12f0: 71 72 79 31 29 0a 20 20 20 20 28 73 71 6c 69 74 qry1). (sqlit
1300: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 71 72 79 e3:finalize! qry
1310: 32 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 2). (sqlite3:
1320: 66 69 6e 61 6c 69 7a 65 21 20 71 72 79 33 29 0a finalize! qry3).
1330: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
1340: 6e 65 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 67 ne (portlogger:g
1350: 65 74 2d 70 72 65 76 2d 75 73 65 64 2d 70 6f 72 et-prev-used-por
1360: 74 20 64 62 29 0a 20 20 28 68 61 6e 64 6c 65 2d t db). (handle-
1370: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
1380: 20 65 78 6e 0a 20 20 20 20 20 20 28 62 65 67 69 exn. (begi
1390: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 n..(debug:print
13a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
13b0: 6f 72 74 2a 20 22 45 58 43 45 50 54 49 4f 4e 3a ort* "EXCEPTION:
13c0: 20 70 6f 72 74 6c 6f 67 67 65 72 20 64 61 74 61 portlogger data
13d0: 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 base probably ov
13e0: 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 erloaded or unre
13f0: 61 64 61 62 6c 65 2e 20 49 66 20 79 6f 75 20 73 adable. If you s
1400: 65 65 20 74 68 69 73 20 6d 65 73 73 61 67 65 20 ee this message
1410: 61 67 61 69 6e 20 72 65 6d 6f 76 65 20 2f 74 6d again remove /tm
1420: 70 2f 2e 24 55 53 45 52 2d 70 6f 72 74 6c 6f 67 p/.$USER-portlog
1430: 67 65 72 2e 64 62 22 29 0a 09 28 64 65 62 75 67 ger.db")..(debug
1440: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1450: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 t-log-port* " me
1460: 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 ssage: " ((condi
1470: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
1480: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
1490: 73 61 67 65 29 20 65 78 6e 29 29 0a 09 28 64 65 sage) exn))..(de
14a0: 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 bug:print 5 *def
14b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
14c0: 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e exn=" (condition
14d0: 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 28 70 ->list exn))..(p
14e0: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
14f0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
1500: 6f 72 74 29 29 0a 09 28 64 65 62 75 67 3a 70 72 ort))..(debug:pr
1510: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1520: 6f 67 2d 70 6f 72 74 2a 20 22 43 6f 6e 74 69 6e og-port* "Contin
1530: 75 69 6e 67 20 61 6e 79 77 61 79 2e 22 29 0a 09 uing anyway.")..
1540: 23 66 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 #f). (sqlite3
1550: 3a 66 6f 6c 64 2d 72 6f 77 0a 20 20 20 20 20 28 :fold-row. (
1560: 6c 61 6d 62 64 61 20 28 76 61 72 20 63 75 72 72 lambda (var curr
1570: 29 0a 20 20 20 20 20 20 20 28 6f 72 20 63 75 72 ). (or cur
1580: 72 20 76 61 72 20 63 75 72 72 29 29 0a 20 20 20 r var curr)).
1590: 20 20 23 66 0a 20 20 20 20 20 64 62 0a 20 20 20 #f. db.
15a0: 20 20 22 53 45 4c 45 43 54 20 28 70 6f 72 74 29 "SELECT (port)
15b0: 20 46 52 4f 4d 20 70 6f 72 74 73 20 57 48 45 52 FROM ports WHER
15c0: 45 20 73 74 61 74 65 3d 27 72 65 6c 65 61 73 65 E state='release
15d0: 64 27 20 4c 49 4d 49 54 20 31 3b 22 29 29 29 0a d' LIMIT 1;"))).
15e0: 0a 28 64 65 66 69 6e 65 20 28 70 6f 72 74 6c 6f .(define (portlo
15f0: 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 20 64 gger:find-port d
1600: 62 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 6c 6f b #!optional (lo
1610: 77 70 6f 72 74 20 33 32 37 36 38 29 29 0a 20 20 wport 32768)).
1620: 28 6c 65 74 2a 20 28 28 70 6f 72 74 6e 75 6d 20 (let* ((portnum
1630: 28 6f 72 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a (or (portlogger:
1640: 67 65 74 2d 70 72 65 76 2d 75 73 65 64 2d 70 6f get-prev-used-po
1650: 72 74 20 64 62 29 0a 09 09 20 20 20 20 20 20 28 rt db)... (
1660: 2b 20 6c 6f 77 70 6f 72 74 20 3b 3b 20 74 6f 70 + lowport ;; top
1670: 20 6f 66 20 72 65 67 69 73 74 65 72 65 64 20 70 of registered p
1680: 6f 72 74 73 20 69 73 20 34 39 31 35 32 20 62 75 orts is 49152 bu
1690: 74 20 6c 65 74 73 20 75 73 65 20 70 6f 72 74 73 t lets use ports
16a0: 20 69 6e 20 74 68 65 20 72 65 67 69 73 74 65 72 in the register
16b0: 65 64 20 72 61 6e 67 65 0a 09 09 09 20 28 72 61 ed range.... (ra
16c0: 6e 64 6f 6d 20 28 2d 20 36 34 30 30 30 20 6c 6f ndom (- 64000 lo
16d0: 77 70 6f 72 74 29 29 29 29 29 29 0a 20 20 20 20 wport)))))).
16e0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
16f0: 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 ns. exn.
1700: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 (begin. (
1710: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1720: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1730: 20 22 45 58 43 45 50 54 49 4f 4e 3a 20 70 6f 72 "EXCEPTION: por
1740: 74 6c 6f 67 67 65 72 20 64 61 74 61 62 61 73 65 tlogger database
1750: 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c 6f probably overlo
1760: 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 61 62 aded or unreadab
1770: 6c 65 2e 20 49 66 20 79 6f 75 20 73 65 65 20 74 le. If you see t
1780: 68 69 73 20 6d 65 73 73 61 67 65 20 61 67 61 69 his message agai
1790: 6e 20 72 65 6d 6f 76 65 20 2f 74 6d 70 2f 2e 24 n remove /tmp/.$
17a0: 55 53 45 52 2d 70 6f 72 74 6c 6f 67 67 65 72 2e USER-portlogger.
17b0: 64 62 22 29 0a 20 20 20 20 20 20 20 28 64 65 62 db"). (deb
17c0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
17d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
17e0: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
17f0: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
1800: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
1810: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 20 essage) exn)).
1820: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1830: 74 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 5 *default-log
1840: 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 -port* "exn=" (c
1850: 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 ondition->list e
1860: 78 6e 29 29 0a 20 20 20 20 20 20 20 28 70 72 69 xn)). (pri
1870: 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
1880: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
1890: 74 29 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 t)). (debu
18a0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
18b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f lt-log-port* "Co
18c0: 6e 74 69 6e 75 69 6e 67 20 61 6e 79 77 61 79 2e ntinuing anyway.
18d0: 22 29 29 0a 20 20 20 20 20 28 70 6f 72 74 6c 6f ")). (portlo
18e0: 67 67 65 72 3a 74 61 6b 65 2d 70 6f 72 74 20 64 gger:take-port d
18f0: 62 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 b portnum)).
1900: 70 6f 72 74 6e 75 6d 29 29 0a 0a 3b 3b 20 73 65 portnum))..;; se
1910: 74 20 70 6f 72 74 20 74 6f 20 22 72 65 6c 65 61 t port to "relea
1920: 73 65 64 22 2c 20 22 66 61 69 6c 65 64 22 20 65 sed", "failed" e
1930: 74 63 2e 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 tc..;; .(define
1940: 28 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d (portlogger:set-
1950: 70 6f 72 74 20 64 62 20 70 6f 72 74 6e 75 6d 20 port db portnum
1960: 76 61 6c 75 65 29 0a 20 20 28 73 71 6c 69 74 65 value). (sqlite
1970: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
1980: 44 41 54 45 20 70 6f 72 74 73 20 53 45 54 20 73 DATE ports SET s
1990: 74 61 74 65 3d 3f 2c 75 70 64 61 74 65 5f 74 69 tate=?,update_ti
19a0: 6d 65 3d 73 74 72 66 74 69 6d 65 28 27 25 73 27 me=strftime('%s'
19b0: 2c 27 6e 6f 77 27 29 20 57 48 45 52 45 20 70 6f ,'now') WHERE po
19c0: 72 74 3d 3f 3b 22 20 76 61 6c 75 65 20 70 6f 72 rt=?;" value por
19d0: 74 6e 75 6d 29 29 0a 0a 3b 3b 20 73 65 74 20 70 tnum))..;; set p
19e0: 6f 72 74 20 74 6f 20 66 61 69 6c 65 64 20 28 61 ort to failed (a
19f0: 74 74 65 6d 70 74 65 64 20 74 6f 20 74 61 6b 65 ttempted to take
1a00: 20 62 75 74 20 67 6f 74 20 65 72 72 6f 72 29 0a but got error).
1a10: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 70 6f 72 74 ;;.(define (port
1a20: 6c 6f 67 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 logger:set-faile
1a30: 64 20 64 62 20 70 6f 72 74 6e 75 6d 29 0a 20 20 d db portnum).
1a40: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
1a50: 20 64 62 20 22 55 50 44 41 54 45 20 70 6f 72 74 db "UPDATE port
1a60: 73 20 53 45 54 20 73 74 61 74 65 3d 27 66 61 69 s SET state='fai
1a70: 6c 65 64 27 2c 66 61 69 6c 5f 63 6f 75 6e 74 3d led',fail_count=
1a80: 66 61 69 6c 5f 63 6f 75 6e 74 2b 31 2c 75 70 64 fail_count+1,upd
1a90: 61 74 65 5f 74 69 6d 65 3d 73 74 72 66 74 69 6d ate_time=strftim
1aa0: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 20 57 48 e('%s','now') WH
1ab0: 45 52 45 20 70 6f 72 74 3d 3f 3b 22 20 70 6f 72 ERE port=?;" por
1ac0: 74 6e 75 6d 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d tnum))..;;======
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b10: 0a 3b 3b 20 4d 41 49 4e 0a 3b 3b 3d 3d 3d 3d 3d .;; MAIN.;;=====
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b60: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 70 6f 72 74 =..(define (port
1b70: 6c 6f 67 67 65 72 3a 6d 61 69 6e 20 2e 20 61 72 logger:main . ar
1b80: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 gs). (let* ((db
1b90: 66 6e 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d fname (conc "/tm
1ba0: 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 p/." (current-us
1bb0: 65 72 2d 6e 61 6d 65 29 20 22 2d 70 6f 72 74 6c er-name) "-portl
1bc0: 6f 67 67 65 72 2e 64 62 22 29 29 0a 09 20 28 64 ogger.db")).. (d
1bd0: 62 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 b (portlogg
1be0: 65 72 3a 6f 70 65 6e 2d 64 62 20 64 62 66 6e 61 er:open-db dbfna
1bf0: 6d 65 29 29 0a 09 20 28 6e 75 6d 61 72 67 73 20 me)).. (numargs
1c00: 28 6c 65 6e 67 74 68 20 61 72 67 73 29 29 0a 09 (length args))..
1c10: 20 28 72 65 73 75 6c 74 20 20 0a 09 20 20 28 68 (result .. (h
1c20: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
1c30: 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 .. exn.. (be
1c40: 67 69 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 gin.. (debug
1c50: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1c60: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 58 43 t-log-port* "EXC
1c70: 45 50 54 49 4f 4e 3a 20 70 6f 72 74 6c 6f 67 67 EPTION: portlogg
1c80: 65 72 20 64 61 74 61 62 61 73 65 20 61 74 20 22 er database at "
1c90: 20 64 62 66 6e 61 6d 65 20 22 20 70 72 6f 62 61 dbfname " proba
1ca0: 62 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 6f bly overloaded o
1cb0: 72 20 75 6e 72 65 61 64 61 62 6c 65 2e 20 54 72 r unreadable. Tr
1cc0: 79 20 72 65 6d 6f 76 69 6e 67 20 69 74 2e 22 29 y removing it.")
1cd0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
1ce0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
1cf0: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
1d00: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
1d10: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
1d20: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
1d30: 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 e) exn)).. (
1d40: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 debug:print 5 *d
1d50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1d60: 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 "exn=" (conditi
1d70: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
1d80: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1d90: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1da0: 2d 70 6f 72 74 2a 20 22 20 73 74 61 74 75 73 3a -port* " status:
1db0: 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
1dc0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
1dd0: 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 r 'sqlite3 'stat
1de0: 75 73 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 us) exn))..
1df0: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
1e00: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
1e10: 2d 70 6f 72 74 29 29 0a 09 20 20 20 20 20 23 66 -port)).. #f
1e20: 29 0a 09 20 20 20 28 63 61 73 65 20 28 73 74 72 ).. (case (str
1e30: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 61 72 ing->symbol (car
1e40: 20 61 72 67 73 29 29 20 3b 3b 20 63 6f 6d 6d 61 args)) ;; comma
1e50: 6e 64 73 20 77 69 74 68 20 74 77 6f 20 6f 72 20 nds with two or
1e60: 6d 6f 72 65 20 70 61 72 61 6d 73 0a 09 20 20 20 more params..
1e70: 20 20 28 28 74 61 6b 65 29 28 70 6f 72 74 6c 6f ((take)(portlo
1e80: 67 67 65 72 3a 74 61 6b 65 2d 70 6f 72 74 20 64 gger:take-port d
1e90: 62 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 b (string->numbe
1ea0: 72 20 28 63 61 64 72 20 61 72 67 73 29 29 29 29 r (cadr args))))
1eb0: 0a 09 20 20 20 20 20 28 28 66 69 6e 64 29 28 70 .. ((find)(p
1ec0: 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 ortlogger:find-p
1ed0: 6f 72 74 20 64 62 29 29 0a 09 20 20 20 20 20 28 ort db)).. (
1ee0: 28 73 65 74 29 20 28 6c 65 74 20 28 28 70 6f 72 (set) (let ((por
1ef0: 74 20 20 28 63 61 64 72 20 20 61 72 67 73 29 29 t (cadr args))
1f00: 0a 09 09 09 20 20 28 73 74 61 74 65 20 28 63 61 .... (state (ca
1f10: 64 64 72 20 61 72 67 73 29 29 29 0a 09 09 20 20 ddr args)))...
1f20: 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a (portlogger:
1f30: 73 65 74 2d 70 6f 72 74 20 64 62 20 0a 09 09 09 set-port db ....
1f40: 09 09 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 .. (if (number
1f50: 3f 20 70 6f 72 74 29 20 70 6f 72 74 20 28 73 74 ? port) port (st
1f60: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 6f 72 ring->number por
1f70: 74 29 29 0a 09 09 09 09 09 20 20 20 73 74 61 74 t))...... stat
1f80: 65 29 0a 09 09 20 20 20 20 20 20 73 74 61 74 65 e)... state
1f90: 29 29 0a 09 20 20 20 20 20 28 28 66 61 69 6c 65 )).. ((faile
1fa0: 64 29 28 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 d)(portlogger:se
1fb0: 74 2d 66 61 69 6c 65 64 20 64 62 20 28 73 74 72 t-failed db (str
1fc0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
1fd0: 72 20 61 72 67 73 29 29 29 20 27 66 61 69 6c 65 r args))) 'faile
1fe0: 64 29 29 29 29 29 0a 20 20 20 20 28 73 71 6c 69 d))))). (sqli
1ff0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
2000: 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 20 ). result)).
2010: 20 20 20 20 0a 3b 3b 20 28 70 72 69 6e 74 20 28 .;; (print (
2020: 61 70 70 6c 79 20 70 6f 72 74 6c 6f 67 67 65 72 apply portlogger
2030: 3a 6d 61 69 6e 20 28 63 64 72 20 28 61 72 67 76 :main (cdr (argv
2040: 29 29 29 29 0a 29 0a )))).).