Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

4 files changed, 399 insertions, 0 deletions

diff --git a/tcllib/examples/logger/logtofile.tcl b/tcllib/examples/logger/logtofile.tcl
new file mode 100755
index 0000000..5aa25ed
--- /dev/null
+++ b/tcllib/examples/logger/logtofile.tcl
@@ -0,0 +1,35 @@
+#!/usr/bin/env tclsh
+#
+# Logging to a simple file
+#
+# This creates the file mylog.log and adds a single line.
+#
+# (c) 2005 Michael Schlenker <mic42@users.sourceforge.net>
+#
+# $Id: logtofile.tcl,v 1.2 2005/09/28 03:46:37 andreas_kupries Exp $
+#
+#
+
+ package require logger
+
+# Define a simple custom logproc
+ proc log_to_file {lvl txt} {
+   set logfile "mylog.log"
+   set msg "\[[clock format [clock seconds]]\] $txt"
+   set f [open $logfile {WRONLY CREAT APPEND}] ;# instead of "a"
+   fconfigure $f -encoding utf-8
+   puts $f $msg
+   close $f
+ }
+
+# Initialize the logger
+ set log [logger::init global]
+
+# Install the logproc for all levels 
+ foreach lvl [logger::levels] {
+   interp alias {} log_to_file_$lvl {} log_to_file $lvl
+   ${log}::logproc $lvl log_to_file_$lvl
+ }
+
+# Send a simple message to the logfile
+ ${log}::info "Logging to a file"
\ No newline at end of file
diff --git a/tcllib/examples/logger/logtotext.tcl b/tcllib/examples/logger/logtotext.tcl
new file mode 100755
index 0000000..8c9ecb4
--- /dev/null
+++ b/tcllib/examples/logger/logtotext.tcl
@@ -0,0 +1,158 @@
+#!/usr/bin/env tclsh
+# 
+# Logger example - How to log to a text widget
+#
+# (c) 2005 Michael Schlenker <mic42@users.sourceforge.net>
+#
+# $Id: logtotext.tcl,v 1.2 2005/06/01 03:09:49 andreas_kupries Exp $
+
+package require Tcl 8.4
+package require Tk
+package require logger
+
+set config(elide,time) 0
+set config(elide,level) 0
+foreach level [logger::levels] {
+    set config(elide,$level) 0
+}
+
+set logmessage "A little log message"
+#
+# Create a simple logger with the servicename 'global'
+#
+#
+proc createLogger {} {
+    global mylogger
+    set mylogger [logger::init global]
+
+    # loggers logproc takes just one arg, so curry 
+    # our proc with the loglevel and use an alias
+    foreach level [logger::levels] {
+        interp alias {} insertLogLine_$level {} insertLogLine $level
+        ${mylogger}::logproc $level insertLogLine_$level        
+    }
+}
+
+# Put the logmessage to the logger system
+proc sendMessageToLog {level} {
+    ${::mylogger}::$level $::logmessage
+}
+
+proc createGUI {} {
+    global mylogger
+    global logwidget
+    
+    wm title . "Logger example - log to text widget"
+    
+    # a little compose window for entering messages
+    labelframe .compose -text "Compose log message"
+    entry .compose.logmessage -textvariable logmessage
+    frame .compose.levels 
+    foreach level [logger::levels] {
+        set p .compose.levels.$level 
+        button $p -command [list sendMessageToLog $level] -text "Log as $level"
+        lappend buttons $p                
+    }
+    eval grid $buttons -sticky ew -padx 2 -pady 5
+    grid .compose.logmessage -sticky ew
+    grid .compose.levels -sticky ew
+    grid .compose -sticky ew
+    
+    # The output window
+    labelframe .log -text "Log output" 
+    text .log.text -yscrollcommand [list .log.yscroll set] -wrap none
+    set logwidget .log.text 
+    scrollbar .log.yscroll -orient vertical -command [list $logwidget yview]
+    frame .log.buttons 
+    frame .log.buttons.elide
+    checkbutton .log.buttons.elide.toggletime -text "Display Timestamp" -command [list toggleElide time] \
+        -onvalue 0 -offvalue 1 -variable config(elide,time)
+    checkbutton .log.buttons.elide.togglelevel -text "Display Level" -command [list toggleElide level] \
+        -onvalue 0 -offvalue 1 -variable config(elide,level)
+    frame .log.buttons.elidelevels
+    foreach level [logger::levels] {
+        set b .log.buttons.elidelevels.$level 
+        checkbutton $b -text "Display $level" -command [list toggleElide $level] -variable config(elide,$level) \
+                       -onvalue 0 -offvalue 1
+        lappend elides $b
+    }
+    eval grid $elides 
+    grid .log.text .log.yscroll -sticky nsew
+    grid configure .log.yscroll -sticky nws
+    grid .log.buttons.elide.toggletime .log.buttons.elide.togglelevel
+    grid .log.buttons.elide -sticky ew
+    grid .log.buttons.elidelevels -sticky ew
+    grid .log.buttons -columnspan 2 -sticky ew
+    grid .log -sticky news
+    grid columnconfigure . 0 -weight 1
+    grid rowconfigure . 0 -weight 0
+    grid rowconfigure . 1 -weight 1
+    grid columnconfigure .log 0 -weight 1
+    grid columnconfigure .log 1 -weight 0
+    grid rowconfigure .log 0 -weight 1
+    
+    #
+    # Now we create some fonts
+    # a fixed font for the first two columns, so they stay nicely lined up
+    # a proportional font for the message as it is probably better to read
+    #
+    font create logger::timefont -family {Courier} -size 12
+    font create logger::levelfont -family {Courier} -size 12 
+    font create logger::msgfont -family {Times} -size 12    
+    $logwidget tag configure logger::time -font logger::timefont
+    $logwidget tag configure logger::level -font logger::levelfont
+    $logwidget tag configure logger::message -font logger::msgfont
+
+    # Now we create some colors for the levels, so our messages appear in different colors    
+    foreach level [logger::levels] color {darkgrey lightgrey brown blue orange red} {
+        $logwidget tag configure logger::$level -background $color        
+    }
+    
+    # Disable the widget, so it is read only
+    $logwidget configure -state disabled
+    
+}
+
+# Allow toggling of display
+# 
+# only time and level are used in this example, but you could
+# elide specific messages levels too
+#
+proc toggleElide {type} {
+    global config
+    $::logwidget tag configure logger::$type -elide $config(elide,$type)
+    return
+}
+
+# A rather basic insert
+#
+# I a long running application we would probably add some code to only keep
+# a specific number of log messages in the text widget, and throw away some older
+# ones. (basic stuff, just count lines and for example add a 
+# $logwidget delete 1.0 2.0
+# if the log grows too long, needs refinement if you have multi line log messages )
+# 
+proc insertLogLine {level txt} {
+    global logwidget    
+    
+    $logwidget configure -state normal
+    $logwidget insert end "<[clock format [clock seconds] -format "%H:%M:%S"]> " [list logger::time logger::$level] \
+                          [format "%10.10s : " <$level>]   [list logger::level logger::$level] \
+                          $txt\n [list logger::message logger::$level] 
+    $logwidget configure -state disabled
+}
+
+proc every {time body} {
+    after $time [info level 0]
+    uplevel #0 $body
+}
+
+proc main {} {
+    createLogger
+    createGUI  
+}
+
+main
+
+# Add some repeating message 
+every 10000 {${mylogger}::info "The current time is [clock format [clock seconds] -format "%H:%M:%S"]"} 
\ No newline at end of file
diff --git a/tcllib/examples/logger/snit-logger.tcl b/tcllib/examples/logger/snit-logger.tcl
new file mode 100755
index 0000000..4767aeb
--- /dev/null
+++ b/tcllib/examples/logger/snit-logger.tcl
@@ -0,0 +1,66 @@
+################################################################################
+#     Logger Utilities - SNIT wrapper for logger
+#     
+#     A SNIT type to wrap logger
+#     
+#     (c) 2005 Michael Schlenker <mic42@users.sourceforge.net>
+#     
+#     $Id: snit-logger.tcl,v 1.2 2005/04/27 02:40:40 andreas_kupries Exp $
+#
+#################################################################################
+
+package require snit
+package require logger
+
+namespace eval ::logger::snit {
+    
+    snit::type Logger {
+        variable loggertoken ""
+        option -servicename -configuremethod servicenameconf 
+        option -loglevel -default debug -configuremethod loglevelconf
+
+        delegate method * using "%s _indirect %m"         
+        constructor {args} {
+            $self configurelist $args            
+            ${loggertoken}::setlevel $options(-loglevel)
+
+        }
+    
+        destructor {
+            ${loggertoken}::delete
+        }
+
+        method log {level args} {
+            eval [linsert $args 0 ${loggertoken}::${level}]   
+        }     
+        
+        method _indirect {cmd args} {
+            eval [linsert $args 0 ${loggertoken}::${cmd}]
+        }
+        
+        method servicenameconf {opt val} {
+            if {$loggertoken != ""} {
+                ${loggertoken}::delete
+            }
+            
+            if {$val != ""} {
+            if {[lsearch -exact [logger::services] $val] == -1} {
+                set loggertoken [logger::init $val]
+                set options(-servicename) $val
+            } else {
+                set loggertoken [logger::servicecmd $val]
+                set options(-servicename) $val
+            }
+            }
+        }
+        
+        method loglevelconf {opt val} {
+            set options($opt) $val
+            if {$loggertoken != ""} {
+                ${loggertoken}::setlevel $val
+            }
+        }
+    }
+}
+
+package provide ::logger::snit 0.1
diff --git a/tcllib/examples/logger/xotcl-logger.tcl b/tcllib/examples/logger/xotcl-logger.tcl
new file mode 100755
index 0000000..eaf3aff
--- /dev/null
+++ b/tcllib/examples/logger/xotcl-logger.tcl
@@ -0,0 +1,140 @@
+################################################################################
+#     Logger Utilities - XOTcl wrapper for logger
+#     
+#     A XOTcl class to wrap logger
+#     
+#     (c) 2005 Michael Schlenker <mic42@users.sourceforge.net>
+#
+#         with enhancements by Gustaf Neumann, to be more idiomatic xotcl
+#
+#     $Id: xotcl-logger.tcl,v 1.3 2008/05/29 19:16:03 mic42 Exp $
+#
+#################################################################################
+
+package require XOTcl 1.6
+package require logger
+
+namespace eval ::logger::xotcl {
+ namespace import ::xotcl::*
+
+ ::xotcl::Class create Logger -slots {
+   #
+   # Define Attributes of the Logger
+   #
+   # Attribute servicename
+   #
+   Attribute loggertoken -default ""
+
+   #
+   # Attribute servicename
+   #
+   # When the attribute is set, perform some optional cleanup
+   # and the either create a new logger service or attach to
+   # an existing one
+   #
+   Attribute servicename \
+       -default {[namespace tail [self]]} \
+       -proc assign {domain var value} {
+         $domain instvar loggertoken servicename loglevel
+
+         if {$loggertoken ne ""} {
+           ${loggertoken}::delete
+           set loggertoken ""
+         } 
+
+         if {$value ne ""} {
+           #
+           # If a logging service with this name exists already,
+           # attach the logger to it. Otherwise create a service
+           # with the specified name
+           #
+           if {[lsearch -exact [logger::services] $value] == -1} {
+             set loggertoken [logger::init $value]
+             set servicename $value
+           } else {
+             set loggertoken [logger::servicecmd $value]
+             set servicename $value
+           }
+
+           if {[info exists loglevel]} {
+             ${loggertoken}::setlevel $loglevel
+           }
+
+         }
+         return $value
+       }
+
+   #
+   # Attribute loglevel
+   #
+   # When the attribute is set, forward the change to the logger command
+   # setlevel. For the getter, use the logger command currentloglevel.
+   #
+   Attribute loglevel \
+       -proc assign {domain var value} {
+         $domain instvar loggertoken
+         if {$loggertoken ne ""} {
+           ${loggertoken}::setlevel $value
+         }
+       } \
+       -proc get {domain var} {
+         $domain instvar loggertoken
+         if {$loggertoken ne ""} {
+           return [${loggertoken}::currentloglevel]
+         }
+       }
+ }
+
+ Logger instproc destroy {args} {
+   if {[my loggertoken] ne ""} {
+     [my loggertoken]::delete
+   }
+   next
+ }
+
+ #
+ # provide a few methods to delegate methods to the logger
+ # identified by the loggertoken
+ #
+ Logger instproc loggercmd {subcmd} {
+   return [my loggertoken]::$subcmd
+ }
+ Logger instforward services {%my loggercmd services}
+ Logger instforward delproc  {%my loggercmd delproc}
+ Logger instforward logproc  {%my loggercmd logproc}
+
+ #
+ # since for the log method, the argument has to be foldeded
+ # into the command name, we use the plain tcl approach to
+ # construct and evaluate the command
+ #
+ Logger instproc log {level args} {
+   eval [linsert $args 0 [my loggertoken]::${level}]   
+ }
+
+}
+
+# Usage cases:
+#
+# 1) Create a logger named 'mylog', which creates 
+#    a logging service with the same name
+#
+#       logger::xotcl::Logger mylog
+#       mylog log info "hi there"
+#
+# 2) Create a logger named 'l1', which creates 
+#    a logging service 'global'
+# 
+#       logger::xotcl::Logger l1 -servicename global
+#       l1 log info hello1
+#
+# 3) Create first a tcl logger 'myservice' and use later 
+#    the tcl logger form the wrapper class 'l2'
+#
+#       set log [logger::init myservice]
+
+#       logger::xotcl::Logger l2 -servicename myservice
+#       l2 log info hello2
+#
+package provide ::logger::xotcl 0.2
+