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             0.1
  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} { #<<<
  25         package require sqlite3
  26
  27         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 {} { #<<<
  48         flush
  49         if {[info exists db]} {
  50                 tlc::try {
  51                         flush
  52                         $db close
  53                         unset db
  54                 } onerr {
  55                         default {STDMSG}
  56                 }
  57         }
  58
  59         tlc::Baselog::output_function {}
  60 }
  61
  62 #>>>
  63 body tlc::Sqlitelogger::init_db {} { #<<<
  64         set exists      [$db onecolumn {
  65                 select
  66                         count(1) > 0
  67                 from
  68                         sqlite_master
  69                 where
  70                         type = 'table'
  71                         and name = 'runs'
  72         }]
  73
  74         if {!($exists)} {
  75                 $db eval {
  76                         create table runs (
  77                                 id                      integer primary key autoincrement,
  78                                 started         integer,
  79                                 name            text
  80                         );
  81
  82                         create table logs (
  83                                 id                              integer primary key autoincrement,
  84                                 usec                    integer,
  85                                 instancename    text,
  86                                 ns                              text,
  87                                 class                   text,
  88                                 method                  text,
  89                                 argdesc                 text,
  90                                 lvl                             integer,
  91                                 msg                             text
  92                         );
  93                 }
  94         }
  95
  96         set now         [tlc::Baselog::timestamp]
  97         $db eval {
  98                 insert into runs (
  99                         started,
 100                         name
 101                 ) values (
 102                         $now,
 103                         $name
 104                 )
 105         }
 106 }
 107
 108 #>>>
 109 body tlc::Sqlitelogger::safelog {usec instancename ns class method argdesc lvl msg} { #<<<
 110         $db eval {
 111                 insert into logs (
 112                         usec,
 113                         instancename,
 114                         ns,
 115                         class,
 116                         method,
 117                         argdesc,
 118                         lvl,
 119                         msg
 120                 ) values (
 121                         $usec,
 122                         $instancename,
 123                         $ns,
 124                         $class,
 125                         $method,
 126                         $argdesc,
 127                         $lvl,
 128                         $msg
 129                 )
 130         }
 131
 132         if {$flush_id == ""} {
 133                 set flush_id    [after [expr {round($flush_secs * 1000)}] \
 134                                 [code $this flush]]
 135         }
 136 }
 137
 138 #>>>
 139 body tlc::Sqlitelogger::flush {} { #<<<
 140         after cancel $flush_id; set flush_id    ""
 141
 142         if {[info exists db]} {
 143                 $db eval {commit; begin}
 144         }
 145 }
 146
 147 #>>>