lib/Stem/Trace.pm

   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 ;