Commit | Line | Data |
4536f655 |
1 | # File: Stem/Trace.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
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. |
10 | |
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. |
15 | |
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 |
19 | |
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: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | package Stem::Trace ; |
30 | |
31 | use strict; |
32 | |
33 | use Stem::Vars ; |
34 | use Stem::Log::Entry ; |
35 | |
36 | sub import { |
37 | |
38 | my( $class, %trace_args ) = @_ ; |
39 | |
40 | $class = caller ; |
41 | |
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 - ' ; |
50 | |
51 | no strict 'refs'; |
52 | |
53 | if ( $type eq 'args' ) { |
54 | |
55 | *{ "${class}::$sub" } = sub { |
56 | |
57 | return if |
58 | ( $Stem::Vars::Env{ $def_env } || 0 ) < |
59 | $def_env_level ; |
60 | |
61 | my $prefix = $def_prefix ; |
62 | my( $line_num ) = (caller)[2] ; |
63 | |
64 | $prefix =~ s/%P/$class/ ; |
65 | $prefix =~ s/%L/$line_num/ ; |
66 | |
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 |
70 | |
71 | my $text = pop ; |
72 | my $level = pop || $def_level ; |
73 | my $label = pop || $def_label ; |
74 | my $log = pop || $def_log ; |
75 | |
76 | Stem::Log::Entry->new ( |
77 | 'logs' => $log, |
78 | 'level' => $level, |
79 | 'label' => $label, |
80 | 'text' => "$prefix$text\n" |
81 | ) ; |
82 | } ; |
83 | |
84 | return ; |
85 | } |
86 | |
87 | if ( $type eq 'keyed' ) { |
88 | |
89 | *{ "${class}::$sub" } = sub { |
90 | |
91 | my ( %args ) = @_; |
92 | |
93 | my $env = $args{ 'env' } || $def_env ; |
94 | my $env_level = $args{ 'env_level' } || $def_env_level ; |
95 | |
96 | return if |
97 | ( $Stem::Vars::Env{ $env } || 0 ) < $env_level ; |
98 | |
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 ; |
104 | |
105 | my( $line_num ) = (caller)[2] ; |
106 | $prefix =~ s/%P/$class/ ; |
107 | $prefix =~ s/%L/$line_num/ ; |
108 | |
109 | Stem::Log::Entry->new ( |
110 | 'logs' => $log, |
111 | 'level' => $level, |
112 | 'label' => $label, |
113 | 'text' => "$prefix$text\n", |
114 | ) ; |
115 | } ; |
116 | |
117 | return ; |
118 | } |
119 | |
120 | if ( $type eq 'textlist' ) { |
121 | |
122 | *{ "${class}::$sub" } = sub { |
123 | |
124 | return if |
125 | ( $Stem::Vars::Env{ $def_env } || 0 ) < |
126 | $def_env_level ; |
127 | |
128 | my $text = join '', @_ ; |
129 | |
130 | my( $line_num ) = (caller)[2] ; |
131 | |
132 | my $prefix = $def_prefix ; |
133 | |
134 | $prefix =~ s/%P/$class/ ; |
135 | $prefix =~ s/%L/$line_num/ ; |
136 | |
137 | |
138 | Stem::Log::Entry->new ( |
139 | 'logs' => $def_log, |
140 | 'level' => $def_level, |
141 | 'label' => $def_label, |
142 | 'text' => "$prefix$text\n", |
143 | ) ; |
144 | } ; |
145 | |
146 | return ; |
147 | } |
148 | } |
149 | |
150 | 1 ; |