1# logger.tcl -- 2# 3# Tcl implementation of a general logging facility. 4# 5# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> 6# Copyright (c) 2004-2008 by Michael Schlenker <mic42@users.sourceforge.net> 7# Copyright (c) 2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 8# 9# See the file license.terms. 10 11# The logger package provides an 'object oriented' log facility that 12# lets you have trees of services, that inherit from one another. 13# This is accomplished through the use of Tcl namespaces. 14 15 16package require Tcl 8.2 17package provide logger 0.9 18 19namespace eval ::logger { 20 namespace eval tree {} 21 namespace export init enable disable services servicecmd import 22 23 # The active services. 24 variable services {} 25 26 # The log 'levels'. 27 variable levels [list debug info notice warn error critical alert emergency] 28 29 # The default global log level used for new logging services 30 variable enabled "debug" 31 32 # Tcl return codes (in numeric order) 33 variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] 34} 35 36# Try to load msgcat and fall back to format if it fails 37if {[catch {package require msgcat}]} { 38 interp alias {} ::logger::mc {} ::format 39} else { 40 namespace eval ::logger { 41 namespace import ::msgcat::mc 42 } 43} 44 45# ::logger::_nsExists -- 46# 47# Workaround for missing namespace exists in Tcl 8.2 and 8.3. 48# 49 50if {[package vcompare [package provide Tcl] 8.4] < 0} { 51 proc ::logger::_nsExists {ns} { 52 expr {![catch {namespace parent $ns}]} 53 } 54} else { 55 proc ::logger::_nsExists {ns} { 56 namespace exists $ns 57 } 58} 59 60# ::logger::_cmdPrefixExists -- 61# 62# Utility function to check if a given callback prefix exists, 63# this should catch all oddities in prefix names, including spaces, 64# glob patterns, non normalized namespaces etc. 65# 66# Arguments: 67# prefix - The command prefix to check 68# 69# Results: 70# 1 or 0 for yes or no 71# 72proc ::logger::_cmdPrefixExists {prefix} { 73 set cmd [lindex $prefix 0] 74 set full [namespace eval :: namespace which [list $cmd]] 75 if {[string equal $full ""]} {return 0} else {return 1} 76 # normalize namespaces 77 set ns [namespace qualifiers $cmd] 78 set cmd ${ns}::[namespace tail $cmd] 79 set matches [::info commands ${ns}::*] 80 if {[lsearch -exact $matches $cmd] != -1} {return 1} 81 return 0 82} 83 84# ::logger::walk -- 85# 86# Walk namespaces, starting in 'start', and evaluate 'code' in 87# them. 88# 89# Arguments: 90# start - namespace to start in. 91# code - code to execute in namespaces walked. 92# 93# Side Effects: 94# Side effects of code executed. 95# 96# Results: 97# None. 98 99proc ::logger::walk { start code } { 100 set children [namespace children $start] 101 foreach c $children { 102 logger::walk $c $code 103 namespace eval $c $code 104 } 105} 106 107proc ::logger::init {service} { 108 variable levels 109 variable services 110 variable enabled 111 112 # We create a 'tree' namespace to house all the services, so 113 # they are in a 'safe' namespace sandbox, and won't overwrite 114 # any commands. 115 namespace eval tree::${service} { 116 variable service 117 variable levels 118 variable oldname 119 variable enabled 120 } 121 122 lappend services $service 123 124 set [namespace current]::tree::${service}::service $service 125 set [namespace current]::tree::${service}::levels $levels 126 set [namespace current]::tree::${service}::oldname $service 127 set [namespace current]::tree::${service}::enabled $enabled 128 129 namespace eval tree::${service} { 130 # Callback to use when the service in question is shut down. 131 variable delcallback [namespace current]::no-op 132 133 # Callback when the loglevel is changed 134 variable levelchangecallback [namespace current]::no-op 135 136 # State variable to decide when to call levelcallback 137 variable inSetLevel 0 138 139 # The currently configured levelcommands 140 variable lvlcmds 141 array set lvlcmds {} 142 143 # List of procedures registered via the trace command 144 variable traceList "" 145 146 # Flag indicating whether or not tracing is currently enabled 147 variable tracingEnabled 0 148 149 # We use this to disable a service completely. In Tcl 8.4 150 # or greater, by using this, disabled log calls are a 151 # no-op! 152 153 proc no-op args {} 154 155 156 proc stdoutcmd {level text} { 157 variable service 158 puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" 159 } 160 161 proc stderrcmd {level text} { 162 variable service 163 puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" 164 } 165 166 167 # setlevel -- 168 # 169 # This command differs from enable and disable in that 170 # it disables all the levels below that selected, and 171 # then enables all levels above it, which enable/disable 172 # do not do. 173 # 174 # Arguments: 175 # lv - the level, as defined in $levels. 176 # 177 # Side Effects: 178 # Runs disable for the level, and then enable, in order 179 # to ensure that all levels are set correctly. 180 # 181 # Results: 182 # None. 183 184 185 proc setlevel {lv} { 186 variable inSetLevel 1 187 set oldlvl [currentloglevel] 188 189 # do not allow enable and disable to do recursion 190 if {[catch { 191 disable $lv 0 192 set newlvl [enable $lv 0] 193 } msg] == 1} { 194 return -code error -errorcode $::errorCode $msg 195 } 196 # do the recursion here 197 logger::walk [namespace current] [list setlevel $lv] 198 199 set inSetLevel 0 200 lvlchangewrapper $oldlvl $newlvl 201 return 202 } 203 204 # enable -- 205 # 206 # Enable a particular 'level', and above, for the 207 # service, and its 'children'. 208 # 209 # Arguments: 210 # lv - the level, as defined in $levels. 211 # 212 # Side Effects: 213 # Enables logging for the particular level, and all 214 # above it (those more important). It also walks 215 # through all services that are 'children' and enables 216 # them at the same level or above. 217 # 218 # Results: 219 # None. 220 221 proc enable {lv {recursion 1}} { 222 variable levels 223 set lvnum [lsearch -exact $levels $lv] 224 if { $lvnum == -1 } { 225 return -code error \ 226 -errorcode [list LOGGER INVALID_LEVEL] \ 227 [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] 228 } 229 230 variable enabled 231 set newlevel $enabled 232 set elnum [lsearch -exact $levels $enabled] 233 if {($elnum == -1) || ($elnum > $lvnum)} { 234 set newlevel $lv 235 } 236 237 variable service 238 while { $lvnum < [llength $levels] } { 239 interp alias {} [namespace current]::[lindex $levels $lvnum] \ 240 {} [namespace current]::[lindex $levels $lvnum]cmd 241 incr lvnum 242 } 243 244 if {$recursion} { 245 logger::walk [namespace current] [list enable $lv] 246 } 247 lvlchangewrapper $enabled $newlevel 248 set enabled $newlevel 249 } 250 251 # disable -- 252 # 253 # Disable a particular 'level', and below, for the 254 # service, and its 'children'. 255 # 256 # Arguments: 257 # lv - the level, as defined in $levels. 258 # 259 # Side Effects: 260 # Disables logging for the particular level, and all 261 # below it (those less important). It also walks 262 # through all services that are 'children' and disables 263 # them at the same level or below. 264 # 265 # Results: 266 # None. 267 268 proc disable {lv {recursion 1}} { 269 variable levels 270 set lvnum [lsearch -exact $levels $lv] 271 if { $lvnum == -1 } { 272 return -code error \ 273 -errorcode [list LOGGER INVALID_LEVEL] \ 274 [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] 275 } 276 277 variable enabled 278 set newlevel $enabled 279 set elnum [lsearch -exact $levels $enabled] 280 if {($elnum > -1) && ($elnum <= $lvnum)} { 281 if {$lvnum+1 >= [llength $levels]} { 282 set newlevel "none" 283 } else { 284 set newlevel [lindex $levels [expr {$lvnum+1}]] 285 } 286 } 287 288 while { $lvnum >= 0 } { 289 290 interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ 291 [namespace current]::no-op 292 incr lvnum -1 293 } 294 if {$recursion} { 295 logger::walk [namespace current] [list disable $lv] 296 } 297 lvlchangewrapper $enabled $newlevel 298 set enabled $newlevel 299 } 300 301 # currentloglevel -- 302 # 303 # Get the currently enabled log level for this service. 304 # 305 # Arguments: 306 # none 307 # 308 # Side Effects: 309 # none 310 # 311 # Results: 312 # current log level 313 # 314 315 proc currentloglevel {} { 316 variable enabled 317 return $enabled 318 } 319 320 # lvlchangeproc -- 321 # 322 # Set or introspect a callback for when the logger instance 323 # changes its loglevel. 324 # 325 # Arguments: 326 # cmd - the Tcl command to call, it is called with two parameters, old and new log level. 327 # or none for introspection 328 # 329 # Side Effects: 330 # None. 331 # 332 # Results: 333 # If no arguments are given return the current callback cmd. 334 335 proc lvlchangeproc {args} { 336 variable levelchangecallback 337 338 switch -exact -- [llength [::info level 0]] { 339 1 {return $levelchangecallback} 340 2 { 341 if {[::logger::_cmdPrefixExists [lindex $args 0]]} { 342 set levelchangecallback [lindex $args 0] 343 } else { 344 return -code error \ 345 -errorcode [list LOGGER INVALID_CMD] \ 346 [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] 347 } 348 } 349 default { 350 return -code error \ 351 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 352 [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] 353 } 354 } 355 } 356 357 proc lvlchangewrapper {old new} { 358 variable inSetLevel 359 360 # we are called after disable and enable are finished 361 if {$inSetLevel} {return} 362 363 # no action if level does not change 364 if {[string equal $old $new]} {return} 365 366 variable levelchangecallback 367 # no action if levelchangecallback isn't a valid command 368 if {[::logger::_cmdPrefixExists $levelchangecallback]} { 369 catch { 370 uplevel \#0 [linsert $levelchangecallback end $old $new] 371 } 372 } 373 } 374 375 # logproc -- 376 # 377 # Command used to create a procedure that is executed to 378 # perform the logging. This could write to disk, out to 379 # the network, or something else. 380 # If two arguments are given, use an existing command. 381 # If three arguments are given, create a proc. 382 # 383 # Arguments: 384 # lv - the level to log, which must be one of $levels. 385 # args - either zero, one or two arguments. 386 # if zero this returns the current command registered 387 # if one, this is a cmd name that is called for this level 388 # if two, these are an argument and proc body 389 # 390 # Side Effects: 391 # Creates a logging command to take care of the details 392 # of logging an event. 393 # 394 # Results: 395 # If called with zero length args, returns the name of the currently 396 # configured logging procedure. 397 # 398 # 399 400 proc logproc {lv args} { 401 variable levels 402 variable lvlcmds 403 404 set lvnum [lsearch -exact $levels $lv] 405 if { ($lvnum == -1) && ($lv != "trace") } { 406 return -code error \ 407 -errorcode [list LOGGER INVALID_LEVEL] \ 408 [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] 409 } 410 switch -exact -- [llength $args] { 411 0 { 412 return $lvlcmds($lv) 413 } 414 1 { 415 set cmd [lindex $args 0] 416 if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} 417 if {[llength [::info commands $cmd]]} { 418 proc ${lv}cmd args [format {\ 419 uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] 420 } $cmd] 421 } else { 422 return -code error \ 423 -errorcode [list LOGGER INVALID_CMD] \ 424 [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] 425 } 426 set lvlcmds($lv) $cmd 427 } 428 2 { 429 foreach {arg body} $args {break} 430 proc ${lv}cmd args [format {\ 431 _setservicename args 432 set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] 433 _restoreservice 434 set val} ${lv}customcmd] 435 proc ${lv}customcmd $arg $body 436 set lvlcmds($lv) [namespace current]::${lv}customcmd 437 } 438 default { 439 return -code error \ 440 -errorcode [list LOGGER WRONG_USAGE] \ 441 [::logger::mc \ 442 "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] 443 } 444 } 445 } 446 447 448 # delproc -- 449 # 450 # Set or introspect a callback for when the logger instance 451 # is deleted. 452 # 453 # Arguments: 454 # cmd - the Tcl command to call. 455 # or none for introspection 456 # 457 # Side Effects: 458 # None. 459 # 460 # Results: 461 # If no arguments are given return the current callback cmd. 462 463 proc delproc {args} { 464 variable delcallback 465 466 switch -exact -- [llength [::info level 0]] { 467 1 {return $delcallback} 468 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { 469 set delcallback [lindex $args 0] 470 } else { 471 return -code error \ 472 -errorcode [list LOGGER INVALID_CMD] \ 473 [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] 474 } 475 } 476 default { 477 return -code error \ 478 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 479 [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] 480 } 481 } 482 } 483 484 485 # delete -- 486 # 487 # Delete the namespace and its children. 488 489 proc delete {} { 490 variable delcallback 491 variable service 492 493 logger::walk [namespace current] delete 494 if {[::logger::_cmdPrefixExists $delcallback]} { 495 uplevel \#0 [lrange $delcallback 0 end] 496 } 497 # clean up the global services list 498 set idx [lsearch -exact [logger::services] $service] 499 if {$idx !=-1} { 500 set ::logger::services [lreplace [logger::services] $idx $idx] 501 } 502 503 namespace delete [namespace current] 504 505 } 506 507 # services -- 508 # 509 # Return all child services 510 511 proc services {} { 512 variable service 513 514 set children [list] 515 foreach srv [logger::services] { 516 if {[string match "${service}::*" $srv]} { 517 lappend children $srv 518 } 519 } 520 return $children 521 } 522 523 # servicename -- 524 # 525 # Return the name of the service 526 527 proc servicename {} { 528 variable service 529 return $service 530 } 531 532 proc _setservicename {argname} { 533 variable service 534 variable oldname 535 upvar 1 $argname arg 536 if {[llength $arg] <= 1} { 537 return 538 } 539 540 set count -1 541 set newname "" 542 while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { 543 incr count 2 544 set newname [lindex $arg $count] 545 } 546 if {[string equal $newname ""]} { 547 return 548 } 549 set oldname $service 550 set service $newname 551 # Pop off "-_logger::service <service>" from argument list 552 set arg [lreplace $arg 0 $count] 553 } 554 555 proc _restoreservice {} { 556 variable service 557 variable oldname 558 set service $oldname 559 return 560 } 561 562 proc trace { action args } { 563 variable service 564 565 # Allow other boolean values (true, false, yes, no, 0, 1) to be used 566 # as synonymns for "on" and "off". 567 568 if {[string is boolean $action]} { 569 set xaction [expr {($action && 1) ? "on" : "off"}] 570 } else { 571 set xaction $action 572 } 573 574 # Check for required arguments for actions/subcommands and dispatch 575 # to the appropriate procedure. 576 577 switch -- $xaction { 578 "status" { 579 return [uplevel 1 [list logger::_trace_status $service $args]] 580 } 581 "on" { 582 if {[llength $args]} { 583 return -code error \ 584 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 585 [::logger::mc "wrong # args: should be \"trace on\""] 586 } 587 return [logger::_trace_on $service] 588 } 589 "off" { 590 if {[llength $args]} { 591 return -code error \ 592 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 593 [::logger::mc "wrong # args: should be \"trace off\""] 594 } 595 return [logger::_trace_off $service] 596 } 597 "add" { 598 if {![llength $args]} { 599 return -code error \ 600 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 601 [::logger::mc "wrong # args: should be \"trace add ?-ns? <proc> ...\""] 602 } 603 return [uplevel 1 [list ::logger::_trace_add $service $args]] 604 } 605 "remove" { 606 if {![llength $args]} { 607 return -code error \ 608 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 609 [::logger::mc "wrong # args: should be \"trace remove ?-ns? <proc> ...\""] 610 } 611 return [uplevel 1 [list ::logger::_trace_remove $service $args]] 612 } 613 614 default { 615 return -code error \ 616 -errorcode [list LOGGER INVALID_ARG] \ 617 [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ 618 on, or off" $action] 619 } 620 } 621 } 622 623 # Walk the parent service namespaces to see first, if they 624 # exist, and if any are enabled, and then, as a 625 # consequence, enable this one 626 # too. 627 628 enable $enabled 629 variable parent [namespace parent] 630 while {[string compare $parent "::logger::tree"]} { 631 # If the 'enabled' variable doesn't exist, create the 632 # whole thing. 633 if { ! [::info exists ${parent}::enabled] } { 634 635 logger::init [string range $parent 16 end] 636 } 637 set enabled [set ${parent}::enabled] 638 enable $enabled 639 set parent [namespace parent $parent] 640 } 641 } 642 643 # Now create the commands for different levels. 644 645 namespace eval tree::${service} { 646 set parent [namespace parent] 647 648 # We 'inherit' the commands from the parents. This 649 # means that, if you want to share the same methods with 650 # children, they should be instantiated after the parent's 651 # methods have been defined. 652 if {[string compare $parent "::logger::tree"]} { 653 foreach lvl [::logger::levels] { 654 # OPTIMIZE: do not allow multiple aliases in the hierarchy 655 # they can always be replaced by more efficient 656 # direct aliases to the target procs. 657 interp alias {} [namespace current]::${lvl}cmd \ 658 {} ${parent}::${lvl}cmd -_logger::service $service 659 } 660 # inherit the starting loglevel of the parent service 661 setlevel [${parent}::currentloglevel] 662 663 } else { 664 foreach lvl [concat [::logger::levels] "trace"] { 665 proc ${lvl}cmd args [format {\ 666 _setservicename args 667 set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] 668 _restoreservice 669 set val } $lvl] 670 671 set lvlcmds($lvl) [namespace current]::${lvl}cmd 672 } 673 } 674 } 675 676 677 return ::logger::tree::${service} 678} 679 680# ::logger::services -- 681# 682# Returns a list of all active services. 683# 684# Arguments: 685# None. 686# 687# Side Effects: 688# None. 689# 690# Results: 691# List of active services. 692 693proc ::logger::services {} { 694 variable services 695 return $services 696} 697 698# ::logger::enable -- 699# 700# Global enable for a certain level. NOTE - this implementation 701# isn't terribly effective at the moment, because it might hit 702# children before their parents, who will then walk down the 703# tree attempting to disable the children again. 704# 705# Arguments: 706# lv - level above which to enable logging. 707# 708# Side Effects: 709# Enables logging in a given level, and all higher levels. 710# 711# Results: 712# None. 713 714proc ::logger::enable {lv} { 715 variable services 716 if {[catch { 717 foreach sv $services { 718 ::logger::tree::${sv}::enable $lv 719 } 720 } msg] == 1} { 721 return -code error -errorcode $::errorCode $msg 722 } 723} 724 725proc ::logger::disable {lv} { 726 variable services 727 if {[catch { 728 foreach sv $services { 729 ::logger::tree::${sv}::disable $lv 730 } 731 } msg] == 1} { 732 return -code error -errorcode $::errorCode $msg 733 } 734} 735 736proc ::logger::setlevel {lv} { 737 variable services 738 variable enabled 739 variable levels 740 if {[lsearch -exact $levels $lv] == -1} { 741 return -code error \ 742 -errorcode [list LOGGER INVALID_LEVEL] \ 743 [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] 744 } 745 set enabled $lv 746 if {[catch { 747 foreach sv $services { 748 ::logger::tree::${sv}::setlevel $lv 749 } 750 } msg] == 1} { 751 return -code error -errorcode $::errorCode $msg 752 } 753} 754 755# ::logger::levels -- 756# 757# Introspect the available log levels. Provided so a caller does 758# not need to know implementation details or code the list 759# himself. 760# 761# Arguments: 762# None. 763# 764# Side Effects: 765# None. 766# 767# Results: 768# levels - The list of valid log levels accepted by enable and disable 769 770proc ::logger::levels {} { 771 variable levels 772 return $levels 773} 774 775# ::logger::servicecmd -- 776# 777# Get the command token for a given service name. 778# 779# Arguments: 780# service - name of the service. 781# 782# Side Effects: 783# none 784# 785# Results: 786# log - namespace token for this service 787 788proc ::logger::servicecmd {service} { 789 variable services 790 if {[lsearch -exact $services $service] == -1} { 791 return -code error \ 792 -errorcode [list LOGGER NO_SUCH_SERVICE] \ 793 [::logger::mc "Service \"%s\" does not exist." $service] 794 } 795 return "::logger::tree::${service}" 796} 797 798# ::logger::import -- 799# 800# Import the logging commands. 801# 802# Arguments: 803# service - name of the service. 804# 805# Side Effects: 806# creates aliases in the target namespace 807# 808# Results: 809# none 810 811proc ::logger::import {args} { 812 variable services 813 814 if {[llength $args] == 0 || [llength $args] > 7} { 815 return -code error \ 816 -errorcode [list LOGGER WRONG_NUM_ARGS] \ 817 [::logger::mc \ 818 "Wrong # of arguments: \"logger::import ?-all?\ 819 ?-force?\ 820 ?-prefix prefix? ?-namespace namespace? service\""] 821 } 822 823 # process options 824 # 825 set import_all 0 826 set force 0 827 set prefix "" 828 set ns [uplevel 1 namespace current] 829 while {[llength $args] > 1} { 830 set opt [lindex $args 0] 831 set args [lrange $args 1 end] 832 switch -exact -- $opt { 833 -all { set import_all 1} 834 -prefix { set prefix [lindex $args 0] 835 set args [lrange $args 1 end] 836 } 837 -namespace { 838 set ns [lindex $args 0] 839 set args [lrange $args 1 end] 840 } 841 -force { 842 set force 1 843 } 844 default { 845 return -code error \ 846 -errorcode [list LOGGER UNKNOWN_ARG] \ 847 [::logger::mc \ 848 "Unknown argument: \"%s\" :\nUsage:\ 849 \"logger::import ?-all? ?-force?\ 850 ?-prefix prefix? ?-namespace namespace? service\"" $opt] 851 } 852 } 853 } 854 855 # 856 # build the list of commands to import 857 # 858 859 set cmds [logger::levels] 860 lappend cmds "trace" 861 if {$import_all} { 862 lappend cmds setlevel enable disable logproc delproc services 863 lappend cmds servicename currentloglevel delete 864 } 865 866 # 867 # check the service argument 868 # 869 870 set service [lindex $args 0] 871 if {[lsearch -exact $services $service] == -1} { 872 return -code error \ 873 -errorcode [list LOGGER NO_SUCH_SERVICE] \ 874 [::logger::mc "Service \"%s\" does not exist." $service] 875 } 876 877 # 878 # setup the namespace for the import 879 # 880 881 set sourcens [logger::servicecmd $service] 882 set localns [uplevel 1 namespace current] 883 884 if {[string match ::* $ns]} { 885 set importns $ns 886 } else { 887 set importns ${localns}::$ns 888 } 889 890 # fake namespace exists for Tcl 8.2 - 8.3 891 if {![_nsExists $importns]} { 892 namespace eval $importns {} 893 } 894 895 896 # 897 # prepare the import 898 # 899 900 set imports "" 901 foreach cmd $cmds { 902 set cmdname ${importns}::${prefix}$cmd 903 set collision [llength [info commands $cmdname]] 904 if {$collision && !$force} { 905 return -code error \ 906 -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ 907 [::logger::mc "can't import command \"%s\": already exists" $cmdname] 908 } 909 lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} 910 } 911 912 # 913 # and execute the aliasing after checking all is well 914 # 915 916 foreach {target source} $imports { 917 proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]" 918 } 919} 920 921# ::logger::initNamespace -- 922# 923# Creates a logger for the specified namespace and makes the log 924# commands available to said namespace as well. Allows the initial 925# setting of a default log level. 926# 927# Arguments: 928# ns - Namespace to initialize, is also the service name, modulo a ::-prefix 929# level - Initial log level, optional, defaults to 'warn'. 930# 931# Side Effects: 932# creates aliases in the target namespace 933# 934# Results: 935# none 936 937proc ::logger::initNamespace {ns {level warn}} { 938 set service [string trimleft $ns :] 939 namespace eval $ns [list ::logger::init $service] 940 namespace eval $ns [list ::logger::import -force -all -namespace log $service] 941 namespace eval $ns [list log::setlevel $level] 942 return 943} 944 945# This procedure handles the "logger::trace status" command. Given no 946# arguments, returns a list of all procedures that have been registered 947# via "logger::trace add". Given one or more procedure names, it will 948# return 1 if all were registered, or 0 if any were not. 949 950proc ::logger::_trace_status { service procList } { 951 upvar #0 ::logger::tree::${service}::traceList traceList 952 953 # If no procedure names were given, just return the registered list 954 955 if {![llength $procList]} { 956 return $traceList 957 } 958 959 # Get caller's namespace for qualifying unqualified procedure names 960 961 set caller_ns [uplevel 1 namespace current] 962 set caller_ns [string trimright $caller_ns ":"] 963 964 # Search for any specified proc names that are *not* registered 965 966 foreach procName $procList { 967 # Make sure the procedure namespace is qualified 968 969 if {![string match "::*" $procName]} { 970 set procName ${caller_ns}::$procName 971 } 972 973 # Check if the procedure has been registered for tracing 974 975 if {[lsearch -exact $traceList $procName] == -1} { 976 return 0 977 } 978 } 979 980 return 1 981} 982 983# This procedure handles the "logger::trace on" command. If tracing 984# is turned off, it will enable Tcl trace handlers for all of the procedures 985# registered via "logger::trace add". Does nothing if tracing is already 986# turned on. 987 988proc ::logger::_trace_on { service } { 989 set tcl_version [package provide Tcl] 990 991 if {[package vcompare $tcl_version "8.4"] < 0} { 992 return -code error \ 993 -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ 994 [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] 995 } 996 997 namespace eval ::logger::tree::${service} { 998 if {!$tracingEnabled} { 999 set tracingEnabled 1 1000 ::logger::_enable_traces $service $traceList 1001 } 1002 } 1003 1004 return 1 1005} 1006 1007# This procedure handles the "logger::trace off" command. If tracing 1008# is turned on, it will disable Tcl trace handlers for all of the procedures 1009# registered via "logger::trace add", leaving them in the list so they 1010# tracing on all of them can be enabled again with "logger::trace on". 1011# Does nothing if tracing is already turned off. 1012 1013proc ::logger::_trace_off { service } { 1014 namespace eval ::logger::tree::${service} { 1015 if {$tracingEnabled} { 1016 ::logger::_disable_traces $service $traceList 1017 set tracingEnabled 0 1018 } 1019 } 1020 1021 return 1 1022} 1023 1024# This procedure is used by the logger::trace add and remove commands to 1025# process the arguments in a common fashion. If the -ns switch is given 1026# first, this procedure will return a list of all existing procedures in 1027# all of the namespaces given in remaining arguments. Otherwise, each 1028# argument is taken to be either a pattern for a glob-style search of 1029# procedure names or, failing that, a namespace, in which case this 1030# procedure returns a list of all the procedures matching the given 1031# pattern (or all in the named namespace, if no procedures match). 1032 1033proc ::logger::_trace_get_proclist { inputList } { 1034 set procList "" 1035 1036 if {[string equal [lindex $inputList 0] "-ns"]} { 1037 # Verify that at least one target namespace was supplied 1038 1039 set inputList [lrange $inputList 1 end] 1040 if {![llength $inputList]} { 1041 return -code error \ 1042 -errorcode [list LOGGER TARGET_MISSING] \ 1043 [::logger::mc "Must specify at least one namespace target"] 1044 } 1045 1046 # Rebuild the argument list to contain namespace procedures 1047 1048 foreach namespace $inputList { 1049 # Don't allow tracing of the logger (or child) namespaces 1050 1051 if {![string match "::logger::*" $namespace]} { 1052 set nsProcList [::info procs ${namespace}::*] 1053 set procList [concat $procList $nsProcList] 1054 } 1055 } 1056 } else { 1057 # Search for procs or namespaces matching each of the specified 1058 # patterns. 1059 1060 foreach pattern $inputList { 1061 set matches [uplevel 1 ::info proc $pattern] 1062 1063 if {![llength $matches]} { 1064 if {[uplevel 1 namespace exists $pattern]} { 1065 set matches [::info procs ${pattern}::*] 1066 } 1067 1068 # Matched procs will be qualified due to above pattern 1069 1070 set procList [concat $procList $matches] 1071 } elseif {[string match "::*" $pattern]} { 1072 # Patterns were pre-qualified - add them directly 1073 1074 set procList [concat $procList $matches] 1075 } else { 1076 # Qualify each proc with the namespace it was in 1077 1078 set ns [uplevel 1 namespace current] 1079 if {$ns == "::"} { 1080 set ns "" 1081 } 1082 foreach proc $matches { 1083 lappend procList ${ns}::$proc 1084 } 1085 } 1086 } 1087 } 1088 1089 return $procList 1090} 1091 1092# This procedure handles the "logger::trace add" command. If the tracing 1093# feature is enabled, it will enable the Tcl entry and leave trace handlers 1094# for each procedure specified that isn't already being traced. Each 1095# procedure is added to the list of procedures that the logger trace feature 1096# should log when tracing is enabled. 1097 1098proc ::logger::_trace_add { service procList } { 1099 upvar #0 ::logger::tree::${service}::traceList traceList 1100 1101 # Handle -ns switch and glob search patterns for procedure names 1102 1103 set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] 1104 1105 # Enable tracing for each procedure that has not previously been 1106 # specified via logger::trace add. If tracing is off, this will just 1107 # store the name of the procedure for later when tracing is turned on. 1108 1109 foreach procName $procList { 1110 if {[lsearch -exact $traceList $procName] == -1} { 1111 lappend traceList $procName 1112 ::logger::_enable_traces $service [list $procName] 1113 } 1114 } 1115} 1116 1117# This procedure handles the "logger::trace remove" command. If the tracing 1118# feature is enabled, it will remove the Tcl entry and leave trace handlers 1119# for each procedure specified. Each procedure is removed from the list 1120# of procedures that the logger trace feature should log when tracing is 1121# enabled. 1122 1123proc ::logger::_trace_remove { service procList } { 1124 upvar #0 ::logger::tree::${service}::traceList traceList 1125 1126 # Handle -ns switch and glob search patterns for procedure names 1127 1128 set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] 1129 1130 # Disable tracing for each proc that previously had been specified 1131 # via logger::trace add. If tracing is off, this will just 1132 # remove the name of the procedure from the trace list so that it 1133 # will be excluded when tracing is turned on. 1134 1135 foreach procName $procList { 1136 set index [lsearch -exact $traceList $procName] 1137 if {$index != -1} { 1138 set traceList [lreplace $traceList $index $index] 1139 ::logger::_disable_traces $service [list $procName] 1140 } 1141 } 1142} 1143 1144# This procedure enables Tcl trace handlers for all procedures specified. 1145# It is used both to enable Tcl's tracing for a single procedure when 1146# removed via "logger::trace add", as well as to enable all traces 1147# via "logger::trace on". 1148 1149proc ::logger::_enable_traces { service procList } { 1150 upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled 1151 1152 if {$tracingEnabled} { 1153 foreach procName $procList { 1154 ::trace add execution $procName enter \ 1155 [list ::logger::_trace_enter $service] 1156 ::trace add execution $procName leave \ 1157 [list ::logger::_trace_leave $service] 1158 } 1159 } 1160} 1161 1162# This procedure disables Tcl trace handlers for all procedures specified. 1163# It is used both to disable Tcl's tracing for a single procedure when 1164# removed via "logger::trace remove", as well as to disable all traces 1165# via "logger::trace off". 1166 1167proc ::logger::_disable_traces { service procList } { 1168 upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled 1169 1170 if {$tracingEnabled} { 1171 foreach procName $procList { 1172 ::trace remove execution $procName enter \ 1173 [list ::logger::_trace_enter $service] 1174 ::trace remove execution $procName leave \ 1175 [list ::logger::_trace_leave $service] 1176 } 1177 } 1178} 1179 1180######################################################################## 1181# Trace Handlers 1182######################################################################## 1183 1184# This procedure is invoked upon entry into a procedure being traced 1185# via "logger::trace add" when tracing is enabled via "logger::trace on" 1186# to log information about how the procedure was called. 1187 1188proc ::logger::_trace_enter { service cmd op } { 1189 # Parse the command 1190 set procName [uplevel 1 namespace origin [lindex $cmd 0]] 1191 set args [lrange $cmd 1 end] 1192 1193 # Display the message prefix 1194 set callerLvl [expr {[::info level] - 1}] 1195 set calledLvl [::info level] 1196 1197 lappend message "proc" $procName 1198 lappend message "level" $calledLvl 1199 lappend message "script" [uplevel ::info script] 1200 1201 # Display the caller information 1202 set caller "" 1203 if {$callerLvl >= 1} { 1204 # Display the name of the caller proc w/prepended namespace 1205 catch { 1206 set callerProcName [lindex [::info level $callerLvl] 0] 1207 set caller [uplevel 2 namespace origin $callerProcName] 1208 } 1209 } 1210 1211 lappend message "caller" $caller 1212 1213 # Display the argument names and values 1214 set argSpec [uplevel 1 ::info args $procName] 1215 set argList "" 1216 if {[llength $argSpec]} { 1217 foreach argName $argSpec { 1218 lappend argList $argName 1219 1220 if {$argName == "args"} { 1221 lappend argList $args 1222 break 1223 } else { 1224 lappend argList [lindex $args 0] 1225 set args [lrange $args 1 end] 1226 } 1227 } 1228 } 1229 1230 lappend message "procargs" $argList 1231 set message [list $op $message] 1232 1233 ::logger::tree::${service}::tracecmd $message 1234} 1235 1236# This procedure is invoked upon leaving into a procedure being traced 1237# via "logger::trace add" when tracing is enabled via "logger::trace on" 1238# to log information about the result of the procedure call. 1239 1240proc ::logger::_trace_leave { service cmd status rc op } { 1241 variable RETURN_CODES 1242 1243 # Parse the command 1244 set procName [uplevel 1 namespace origin [lindex $cmd 0]] 1245 1246 # Gather the caller information 1247 set callerLvl [expr {[::info level] - 1}] 1248 set calledLvl [::info level] 1249 1250 lappend message "proc" $procName "level" $calledLvl 1251 lappend message "script" [uplevel ::info script] 1252 1253 # Get the name of the proc being returned to w/prepended namespace 1254 set caller "" 1255 catch { 1256 set callerProcName [lindex [::info level $callerLvl] 0] 1257 set caller [uplevel 2 namespace origin $callerProcName] 1258 } 1259 1260 lappend message "caller" $caller 1261 1262 # Convert the return code from numeric to verbal 1263 1264 if {$status < [llength $RETURN_CODES]} { 1265 set status [lindex $RETURN_CODES $status] 1266 } 1267 1268 lappend message "status" $status 1269 lappend message "result" $rc 1270 1271 # Display the leave message 1272 1273 set message [list $op $message] 1274 ::logger::tree::${service}::tracecmd $message 1275 1276 return 1 1277} 1278 1279