scripts/sqlite_logger.itcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 class tlc::Sqlitelogger {
   4         constructor {args} {}
   5         destructor {}
   6
   7         public {
   8                 variable dbfile
   9                 variable name
  10                 variable flush_secs             2.0
  11         }
  12
  13         private {
  14                 variable db
  15                 variable flush_id               ""
  16
  17                 method init_db {}
  18                 method safelog {usec instancename ns class method argdesc lvl msg}
  19                 method flush {}
  20         }
  21 }
  22
  23
  24 body tlc::Sqlitelogger::constructor {args} { #<<<1
  25         package require sqlite3
  26
  27         eval configure $args
  28
  29         foreach reqf {dbfile name} {
  30                 if {![info exists $reqf]} {
  31                         error "Required argument missing: -$reqf"
  32                 }
  33         }
  34
  35         set db  "dblog,$this"
  36
  37         sqlite3 [namespace current]::$db $dbfile
  38
  39         init_db
  40
  41         $db eval {begin}
  42
  43         tlc::Baselog::output_function [code $this safelog]
  44 }
  45
  46
  47 body tlc::Sqlitelogger::destructor {} { #<<<1
  48         flush
  49         if {[info exists db]} {
  50                 tlc::try {
  51                         $db close
  52                         unset db
  53                 } onerr {
  54                         default {STDMSG}
  55                 }
  56         }
  57 }
  58
  59
  60 body tlc::Sqlitelogger::init_db {} { #<<<1
  61         set exists      [$db onecolumn {
  62                 select
  63                         count(1) > 0
  64                 from
  65                         sqlite_master
  66                 where
  67                         type = 'table'
  68                         and name = 'runs'
  69         }]
  70
  71         if {!($exists)} {
  72                 $db eval {
  73                         create table runs (
  74                                 id                      integer primary key autoincrement,
  75                                 started         integer,
  76                                 name            text
  77                         );
  78
  79                         create table logs (
  80                                 id                              integer primary key autoincrement,
  81                                 usec                    integer,
  82                                 instancename    text,
  83                                 ns                              text,
  84                                 class                   text,
  85                                 method                  text,
  86                                 argdesc                 text,
  87                                 lvl                             integer,
  88                                 msg                             text
  89                         );
  90                 }
  91         }
  92
  93         set now         [tlc::Baselog::timestamp]
  94         $db eval {
  95                 insert into runs (
  96                         started,
  97                         name
  98                 ) values (
  99                         $now,
 100                         $name
 101                 )
 102         }
 103 }
 104
 105
 106 body tlc::Sqlitelogger::safelog {usec instancename ns class method argdesc lvl msg} { #<<<1
 107         $db eval {
 108                 insert into logs (
 109                         usec,
 110                         instancename,
 111                         ns,
 112                         class,
 113                         method,
 114                         argdesc,
 115                         lvl,
 116                         msg
 117                 ) values (
 118                         $usec,
 119                         $instancename,
 120                         $ns,
 121                         $class,
 122                         $method,
 123                         $argdesc,
 124                         $lvl,
 125                         $msg
 126                 )
 127         }
 128
 129         if {$flush_id == ""} {
 130                 set flush_id    [after [expr {round($flush_secs * 1000)}] \
 131                                 [code $this flush]]
 132         }
 133 }
 134
 135
 136 body tlc::Sqlitelogger::flush {} { #<<<1
 137         after cancel $flush_id; set flush_id    ""
 138
 139         if {[info exists db]} {
 140                 $db eval {commit; begin}
 141         }
 142 }
 143
 144