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