1# log.tcl -- 2# 3# Tcl implementation of a general logging facility 4# (Reaped from Pool_Base and modified to fit into tcllib) 5# 6# Copyright (c) 2001 by ActiveState Tool Corp. 7# See the file license.terms. 8 9package require Tcl 8 10package provide log 1.3 11 12# ### ### ### ######### ######### ######### 13 14namespace eval ::log { 15 namespace export levels lv2longform lv2color lv2priority 16 namespace export lv2cmd lv2channel lvCompare 17 namespace export lvSuppress lvSuppressLE lvIsSuppressed 18 namespace export lvCmd lvCmdForall 19 namespace export lvChannel lvChannelForall lvColor lvColorForall 20 namespace export log logMsg logError 21 22 # The known log-levels. 23 24 variable levels [list \ 25 emergency \ 26 alert \ 27 critical \ 28 error \ 29 warning \ 30 notice \ 31 info \ 32 debug] 33 34 # Array mapping from all unique prefixes for log levels to their 35 # corresponding long form. 36 37 # *future* Use a procedure from 'textutil' to calculate the 38 # prefixes and to fill the map. 39 40 variable levelMap 41 array set levelMap { 42 a alert 43 al alert 44 ale alert 45 aler alert 46 alert alert 47 c critical 48 cr critical 49 cri critical 50 crit critical 51 criti critical 52 critic critical 53 critica critical 54 critical critical 55 d debug 56 de debug 57 deb debug 58 debu debug 59 debug debug 60 em emergency 61 eme emergency 62 emer emergency 63 emerg emergency 64 emerge emergency 65 emergen emergency 66 emergenc emergency 67 emergency emergency 68 er error 69 err error 70 erro error 71 error error 72 i info 73 in info 74 inf info 75 info info 76 n notice 77 no notice 78 not notice 79 noti notice 80 notic notice 81 notice notice 82 w warning 83 wa warning 84 war warning 85 warn warning 86 warni warning 87 warnin warning 88 warning warning 89 } 90 91 # Map from log-levels to the commands to execute when a message 92 # with that level arrives in the system. The standard command for 93 # all levels is '::log::Puts' which writes the message to either 94 # stdout or stderr, depending on the level. The decision about the 95 # channel is stored in another map and modifiable by the user of 96 # the package. 97 98 variable cmdMap 99 array set cmdMap {} 100 101 variable lv 102 foreach lv $levels {set cmdMap($lv) ::log::Puts} 103 unset lv 104 105 # Map from log-levels to the channels ::log::Puts shall write 106 # messages with that level to. The map can be queried and changed 107 # by the user. 108 109 variable channelMap 110 array set channelMap { 111 emergency stderr 112 alert stderr 113 critical stderr 114 error stderr 115 warning stdout 116 notice stdout 117 info stdout 118 debug stdout 119 } 120 121 # Graphical user interfaces may want to colorize messages based 122 # upon their level. The following array stores a map from levels 123 # to colors. The map can be queried and changed by the user. 124 125 variable colorMap 126 array set colorMap { 127 emergency red 128 alert red 129 critical red 130 error red 131 warning yellow 132 notice seagreen 133 info {} 134 debug lightsteelblue 135 } 136 137 # To allow an easy comparison of the relative importance of a 138 # level the following array maps from levels to a numerical 139 # priority. The higher the number the more important the 140 # level. The user cannot change this map (for now). This package 141 # uses the priorities to allow the user to supress messages based 142 # upon their levels. 143 144 variable priorityMap 145 array set priorityMap { 146 emergency 7 147 alert 6 148 critical 5 149 error 4 150 warning 3 151 notice 2 152 info 1 153 debug 0 154 } 155 156 # The following array is internal and holds the information about 157 # which levels are suppressed, i.e. may not be written. 158 # 159 # 0 - messages with with level are written out. 160 # 1 - messages with this level are suppressed. 161 162 # Note: This initialization is partially overridden via 163 # 'log::lvSuppressLE' at the bottom of this file. 164 165 variable suppressed 166 array set suppressed { 167 emergency 0 168 alert 0 169 critical 0 170 error 0 171 warning 0 172 notice 0 173 info 0 174 debug 0 175 } 176 177 # Internal static information. Map from levels to a string of 178 # spaces. The number of spaces in each string is just enough to 179 # make all level names together with their string of the same 180 # length. 181 182 variable fill 183 array set fill { 184 emergency "" alert " " critical " " error " " 185 warning " " notice " " info " " debug " " 186 } 187} 188 189 190# log::levels -- 191# 192# Retrieves the names of all known levels. 193# 194# Arguments: 195# None. 196# 197# Side Effects: 198# None. 199# 200# Results: 201# A list containing the names of all known levels, 202# alphabetically sorted. 203 204proc ::log::levels {} { 205 variable levels 206 return [lsort $levels] 207} 208 209# log::lv2longform -- 210# 211# Converts any unique abbreviation of a level name to the full 212# level name. 213# 214# Arguments: 215# level The prefix of a level name to convert. 216# 217# Side Effects: 218# None. 219# 220# Results: 221# Returns the full name to the specified abbreviation or an 222# error. 223 224proc ::log::lv2longform {level} { 225 variable levelMap 226 227 if {[info exists levelMap($level)]} { 228 return $levelMap($level) 229 } 230 231 return -code error "bad level \"$level\": must be [join [lreplace [levels] end end "or [lindex [levels] end]"] ", "]." 232} 233 234# log::lv2color -- 235# 236# Converts any level name including unique abbreviations to the 237# corresponding color. 238# 239# Arguments: 240# level The level to convert into a color. 241# 242# Side Effects: 243# None. 244# 245# Results: 246# The name of a color or an error. 247 248proc ::log::lv2color {level} { 249 variable colorMap 250 set level [lv2longform $level] 251 return $colorMap($level) 252} 253 254# log::lv2priority -- 255# 256# Converts any level name including unique abbreviations to the 257# corresponding priority. 258# 259# Arguments: 260# level The level to convert into a priority. 261# 262# Side Effects: 263# None. 264# 265# Results: 266# The numerical priority of the level or an error. 267 268proc ::log::lv2priority {level} { 269 variable priorityMap 270 set level [lv2longform $level] 271 return $priorityMap($level) 272} 273 274# log::lv2cmd -- 275# 276# Converts any level name including unique abbreviations to the 277# command prefix used to write messages with that level. 278# 279# Arguments: 280# level The level to convert into a command prefix. 281# 282# Side Effects: 283# None. 284# 285# Results: 286# A string containing a command prefix or an error. 287 288proc ::log::lv2cmd {level} { 289 variable cmdMap 290 set level [lv2longform $level] 291 return $cmdMap($level) 292} 293 294# log::lv2channel -- 295# 296# Converts any level name including unique abbreviations to the 297# channel used by ::log::Puts to write messages with that level. 298# 299# Arguments: 300# level The level to convert into a channel. 301# 302# Side Effects: 303# None. 304# 305# Results: 306# A string containing a channel handle or an error. 307 308proc ::log::lv2channel {level} { 309 variable channelMap 310 set level [lv2longform $level] 311 return $channelMap($level) 312} 313 314# log::lvCompare -- 315# 316# Compares two levels (including unique abbreviations) with 317# respect to their priority. This command can be used by the 318# -command option of lsort. 319# 320# Arguments: 321# level1 The first of the levels to compare. 322# level2 The second of the levels to compare. 323# 324# Side Effects: 325# None. 326# 327# Results: 328# One of -1, 0 or 1 or an error. A result of -1 signals that 329# level1 is of less priority than level2. 0 signals that both 330# levels have the same priority. 1 signals that level1 has 331# higher priority than level2. 332 333proc ::log::lvCompare {level1 level2} { 334 variable priorityMap 335 336 set level1 $priorityMap([lv2longform $level1]) 337 set level2 $priorityMap([lv2longform $level2]) 338 339 if {$level1 < $level2} { 340 return -1 341 } elseif {$level1 > $level2} { 342 return 1 343 } else { 344 return 0 345 } 346} 347 348# log::lvSuppress -- 349# 350# (Un)suppresses the output of messages having the specified 351# level. Unique abbreviations for the level are allowed here 352# too. 353# 354# Arguments: 355# level The name of the level to suppress or 356# unsuppress. Unique abbreviations are allowed 357# too. 358# suppress Boolean flag. Optional. Defaults to the value 359# 1, which means to suppress the level. The 360# value 0 on the other hand unsuppresses the 361# level. 362# 363# Side Effects: 364# See above. 365# 366# Results: 367# None. 368 369proc ::log::lvSuppress {level {suppress 1}} { 370 variable suppressed 371 set level [lv2longform $level] 372 373 switch -exact -- $suppress { 374 0 - 1 {} default { 375 return -code error "\"$suppress\" is not a member of \{0, 1\}" 376 } 377 } 378 379 set suppressed($level) $suppress 380 return 381} 382 383# log::lvSuppressLE -- 384# 385# (Un)suppresses the output of messages having the specified 386# level or one of lesser priority. Unique abbreviations for the 387# level are allowed here too. 388# 389# Arguments: 390# level The name of the level to suppress or 391# unsuppress. Unique abbreviations are allowed 392# too. 393# suppress Boolean flag. Optional. Defaults to the value 394# 1, which means to suppress the specified 395# levels. The value 0 on the other hand 396# unsuppresses the levels. 397# 398# Side Effects: 399# See above. 400# 401# Results: 402# None. 403 404proc ::log::lvSuppressLE {level {suppress 1}} { 405 variable suppressed 406 variable levels 407 variable priorityMap 408 409 set level [lv2longform $level] 410 411 switch -exact -- $suppress { 412 0 - 1 {} default { 413 return -code error "\"$suppress\" is not a member of \{0, 1\}" 414 } 415 } 416 417 set prio [lv2priority $level] 418 419 foreach l $levels { 420 if {$priorityMap($l) <= $prio} { 421 set suppressed($l) $suppress 422 } 423 } 424 return 425} 426 427# log::lvIsSuppressed -- 428# 429# Asks the package wether the specified level is currently 430# suppressed. Unique abbreviations of level names are allowed. 431# 432# Arguments: 433# level The level to query. 434# 435# Side Effects: 436# None. 437# 438# Results: 439# None. 440 441proc ::log::lvIsSuppressed {level} { 442 variable suppressed 443 set level [lv2longform $level] 444 return $suppressed($level) 445} 446 447# log::lvCmd -- 448# 449# Defines for the specified level with which command to write 450# the messages having this level. Unique abbreviations of level 451# names are allowed. The command is actually a command prefix 452# and this facility will append 2 arguments before calling it, 453# the level of the message and the message itself, in this 454# order. 455# 456# Arguments: 457# level The level the command prefix is for. 458# cmd The command prefix to use for the specified level. 459# 460# Side Effects: 461# See above. 462# 463# Results: 464# None. 465 466proc ::log::lvCmd {level cmd} { 467 variable cmdMap 468 set level [lv2longform $level] 469 set cmdMap($level) $cmd 470 return 471} 472 473# log::lvCmdForall -- 474# 475# Defines for all known levels with which command to write the 476# messages having this level. The command is actually a command 477# prefix and this facility will append 2 arguments before 478# calling it, the level of the message and the message itself, 479# in this order. 480# 481# Arguments: 482# cmd The command prefix to use for all levels. 483# 484# Side Effects: 485# See above. 486# 487# Results: 488# None. 489 490proc ::log::lvCmdForall {cmd} { 491 variable cmdMap 492 variable levels 493 494 foreach l $levels { 495 set cmdMap($l) $cmd 496 } 497 return 498} 499 500# log::lvChannel -- 501# 502# Defines for the specified level into which channel ::log::Puts 503# (the standard command) shall write the messages having this 504# level. Unique abbreviations of level names are allowed. The 505# command is actually a command prefix and this facility will 506# append 2 arguments before calling it, the level of the message 507# and the message itself, in this order. 508# 509# Arguments: 510# level The level the channel is for. 511# chan The channel to use for the specified level. 512# 513# Side Effects: 514# See above. 515# 516# Results: 517# None. 518 519proc ::log::lvChannel {level chan} { 520 variable channelMap 521 set level [lv2longform $level] 522 set channelMap($level) $chan 523 return 524} 525 526# log::lvChannelForall -- 527# 528# Defines for all known levels with which which channel 529# ::log::Puts (the standard command) shall write the messages 530# having this level. The command is actually a command prefix 531# and this facility will append 2 arguments before calling it, 532# the level of the message and the message itself, in this 533# order. 534# 535# Arguments: 536# chan The channel to use for all levels. 537# 538# Side Effects: 539# See above. 540# 541# Results: 542# None. 543 544proc ::log::lvChannelForall {chan} { 545 variable channelMap 546 variable levels 547 548 foreach l $levels { 549 set channelMap($l) $chan 550 } 551 return 552} 553 554# log::lvColor -- 555# 556# Defines for the specified level the color to return for it in 557# a call to ::log::lv2color. Unique abbreviations of level names 558# are allowed. 559# 560# Arguments: 561# level The level the color is for. 562# color The color to use for the specified level. 563# 564# Side Effects: 565# See above. 566# 567# Results: 568# None. 569 570proc ::log::lvColor {level color} { 571 variable colorMap 572 set level [lv2longform $level] 573 set colorMap($level) $color 574 return 575} 576 577# log::lvColorForall -- 578# 579# Defines for all known levels the color to return for it in a 580# call to ::log::lv2color. Unique abbreviations of level names 581# are allowed. 582# 583# Arguments: 584# color The color to use for all levels. 585# 586# Side Effects: 587# See above. 588# 589# Results: 590# None. 591 592proc ::log::lvColorForall {color} { 593 variable colorMap 594 variable levels 595 596 foreach l $levels { 597 set colorMap($l) $color 598 } 599 return 600} 601 602# log::logarray -- 603# 604# Similar to parray, except that the contents of the array 605# printed out through the log system instead of directly 606# to stdout. 607# 608# See also 'log::log' for a general explanation 609# 610# Arguments: 611# level The level of the message. 612# arrayvar The name of the array varaibe to dump 613# pattern Optional pattern to restrict the dump 614# to certain elements in the array. 615# 616# Side Effects: 617# See above. 618# 619# Results: 620# None. 621 622proc ::log::logarray {level arrayvar {pattern *}} { 623 variable cmdMap 624 625 if {[lvIsSuppressed $level]} { 626 # Ignore messages for suppressed levels. 627 return 628 } 629 630 set level [lv2longform $level] 631 632 set cmd $cmdMap($level) 633 if {$cmd == {}} { 634 # Ignore messages for levels without a command 635 return 636 } 637 638 upvar 1 $arrayvar array 639 if {![array exists array]} { 640 error "\"$arrayvar\" isn't an array" 641 } 642 set maxl 0 643 foreach name [lsort [array names array $pattern]] { 644 if {[string length $name] > $maxl} { 645 set maxl [string length $name] 646 } 647 } 648 set maxl [expr {$maxl + [string length $arrayvar] + 2}] 649 foreach name [lsort [array names array $pattern]] { 650 set nameString [format %s(%s) $arrayvar $name] 651 652 eval [linsert $cmd end $level \ 653 [format "%-*s = %s" $maxl $nameString $array($name)]] 654 } 655 return 656} 657 658# log::loghex -- 659# 660# Like 'log::log', except that the logged data is assumed to 661# be binary and is logged as a block of hex numbers. 662# 663# See also 'log::log' for a general explanation 664# 665# Arguments: 666# level The level of the message. 667# text Message printed before the hex block 668# data Binary data to show as hex. 669# 670# Side Effects: 671# See above. 672# 673# Results: 674# None. 675 676proc ::log::loghex {level text data} { 677 variable cmdMap 678 679 if {[lvIsSuppressed $level]} { 680 # Ignore messages for suppressed levels. 681 return 682 } 683 684 set level [lv2longform $level] 685 686 set cmd $cmdMap($level) 687 if {$cmd == {}} { 688 # Ignore messages for levels without a command 689 return 690 } 691 692 # Format the messages and print them. 693 694 set len [string length $data] 695 696 eval [linsert $cmd end $level "$text ($len bytes):"] 697 698 set address "" 699 set hexnums "" 700 set ascii "" 701 702 for {set i 0} {$i < $len} {incr i} { 703 set v [string index $data $i] 704 binary scan $v H2 hex 705 binary scan $v c num 706 set num [expr {($num + 0x100) % 0x100}] 707 708 set text . 709 if {$num > 31} {set text $v} 710 711 if {($i % 16) == 0} { 712 if {$address != ""} { 713 eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]] 714 set address "" 715 set hexnums "" 716 set ascii "" 717 } 718 append address [format "%04d" $i] 719 } 720 append hexnums "$hex " 721 append ascii $text 722 } 723 if {$address != ""} { 724 eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]] 725 } 726 eval [linsert $cmd end $level ""] 727 return 728} 729 730# log::log -- 731# 732# Log a message according to the specifications for commands, 733# channels and suppression. In other words: The command will do 734# nothing if the specified level is suppressed. If it is not 735# suppressed the actual logging is delegated to the specified 736# command. If there is no command specified for the level the 737# message won't be logged. The standard command ::log::Puts will 738# write the message to the channel specified for the given 739# level. If no channel is specified for the level the message 740# won't be logged. Unique abbreviations of level names are 741# allowed. Errors in the actual logging command are *not* 742# catched, but propagated to the caller, as they may indicate 743# misconfigurations of the log facility or errors in the callers 744# code itself. 745# 746# Arguments: 747# level The level of the message. 748# text The message to log. 749# 750# Side Effects: 751# See above. 752# 753# Results: 754# None. 755 756proc ::log::log {level text} { 757 variable cmdMap 758 759 if {[lvIsSuppressed $level]} { 760 # Ignore messages for suppressed levels. 761 return 762 } 763 764 set level [lv2longform $level] 765 766 set cmd $cmdMap($level) 767 if {$cmd == {}} { 768 # Ignore messages for levels without a command 769 return 770 } 771 772 # Delegate actual logging to the command. 773 # Handle multi-line messages correctly. 774 775 foreach line [split $text \n] { 776 eval [linsert $cmd end $level $line] 777 } 778 return 779} 780 781# log::logMsg -- 782# 783# Convenience wrapper around ::log::log. Equivalent to 784# '::log::log info text'. 785# 786# Arguments: 787# text The message to log. 788# 789# Side Effects: 790# See ::log::log. 791# 792# Results: 793# None. 794 795proc ::log::logMsg {text} { 796 log info $text 797} 798 799# log::logError -- 800# 801# Convenience wrapper around ::log::log. Equivalent to 802# '::log::log error text'. 803# 804# Arguments: 805# text The message to log. 806# 807# Side Effects: 808# See ::log::log. 809# 810# Results: 811# None. 812 813proc ::log::logError {text} { 814 log error $text 815} 816 817 818# log::Puts -- 819# 820# Standard log command, writing messages and levels to 821# user-specified channels. Assumes that the supression checks 822# were done by the caller. Expects full level names, 823# abbreviations are *not allowed*. 824# 825# Arguments: 826# level The level of the message. 827# text The message to log. 828# 829# Side Effects: 830# Writes into channels. 831# 832# Results: 833# None. 834 835proc ::log::Puts {level text} { 836 variable channelMap 837 variable fill 838 839 set chan $channelMap($level) 840 if {$chan == {}} { 841 # Ignore levels without channel. 842 return 843 } 844 845 puts $chan "$level$fill($level) $text" 846 flush $chan 847 return 848} 849 850# ### ### ### ######### ######### ######### 851## Initialization code. Disable logging for the lower levels by 852## default. 853 854## log::lvSuppressLE emergency 855log::lvSuppressLE warning 856