3 # This file is part of Stem.
4 # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
6 # Stem is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
11 # Stem is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with Stem; if not, write to the Free Software
18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 # For a license to use the Stem under conditions other than those
21 # described here, to purchase support for this software, or to purchase a
22 # commercial warranty contract, please contact Stem Systems at:
24 # Stem Systems, Inc. 781-643-7504
25 # 79 Everett St. info@stemsystems.com
34 use Stem::Log::Entry ;
38 my( $class, %trace_args ) = @_ ;
42 my $sub = $trace_args{ 'sub' } || 'Trace' ;
43 my $type = $trace_args{ 'type' } || 'textlist' ;
44 my $def_level = $trace_args{ 'level' } || 5 ;
45 my $def_label = $trace_args{ 'label' } || 'trace' ;
46 my $def_log = $trace_args{ 'log' } || 'trace' ;
47 my $def_env = $trace_args{ 'env' } || "$class\::$sub" ;
48 my $def_env_level = $trace_args{ 'env_level' } || 0 ;
49 my $def_prefix = $trace_args{ 'prefix' } || '%P-%L - ' ;
53 if ( $type eq 'args' ) {
55 *{ "${class}::$sub" } = sub {
58 ( $Stem::Vars::Env{ $def_env } || 0 ) <
61 my $prefix = $def_prefix ;
62 my( $line_num ) = (caller)[2] ;
64 $prefix =~ s/%P/$class/ ;
65 $prefix =~ s/%L/$line_num/ ;
67 # if only 1 arg, it is text.
68 # if 2 args, it is level, text
69 # if 3 args, it is label, level, text
72 my $level = pop || $def_level ;
73 my $label = pop || $def_label ;
74 my $log = pop || $def_log ;
76 Stem::Log::Entry->new (
80 'text' => "$prefix$text\n"
87 if ( $type eq 'keyed' ) {
89 *{ "${class}::$sub" } = sub {
93 my $env = $args{ 'env' } || $def_env ;
94 my $env_level = $args{ 'env_level' } || $def_env_level ;
97 ( $Stem::Vars::Env{ $env } || 0 ) < $env_level ;
99 my $text = $args{ 'text' } || '' ;
100 my $log = $args{ 'log' } || $def_log ;
101 my $level = $args{ 'level' } || $def_level ;
102 my $label = $args{ 'label' } || $def_label ;
103 my $prefix = $args{ 'prefix' } || $def_prefix ;
105 my( $line_num ) = (caller)[2] ;
106 $prefix =~ s/%P/$class/ ;
107 $prefix =~ s/%L/$line_num/ ;
109 Stem::Log::Entry->new (
113 'text' => "$prefix$text\n",
120 if ( $type eq 'textlist' ) {
122 *{ "${class}::$sub" } = sub {
125 ( $Stem::Vars::Env{ $def_env } || 0 ) <
128 my $text = join '', @_ ;
130 my( $line_num ) = (caller)[2] ;
132 my $prefix = $def_prefix ;
134 $prefix =~ s/%P/$class/ ;
135 $prefix =~ s/%L/$line_num/ ;
138 Stem::Log::Entry->new (
140 'level' => $def_level,
141 'label' => $def_label,
142 'text' => "$prefix$text\n",