lib/debug_subs.pm

   1 # The Debug class is a little bit special in that it should never be
   2 # instanciated. An instance is kept globaly which can be accessed by
   3 # the members of the debug class if they are called staticaly. Calling
   4 # a member staticaly means that you adress them using the perl module
   5 # name, for example:
   6 #
   7 # debug -> level( );
   8 #
   9 # Notice that there is no $ in front of 'debug'. Here level is called
  10 # "staticaly". In other words, it means "call a member without an
  11 # instance".
  12 #
  13 # The reason for this is that debug keeps a "level" variable globaly,
  14 # which indicates how verbose PsN should be, the higher the level, the
  15 # more messages you will see.. The level variable is numerical, but
  16 # each level has a name in order to make its use a bit more
  17 # intuitive. The levels are, starting with the lowest:
  18 #
  19 # "fatal" - only when an error so grave that PsN has to exit, a fatal
  20 #           message may be printed. This is the least amount of messages
  21 #           you can see.
  22 #
  23 #
  24 # "warning" - When something critical happens, somethings that
  25 #             probably should be examined closer, though not
  26 #             serious enough to exit PsN a warning message may be
  27 #             printed.
  28 #
  29 # "information" - When something out of the ordinary happens and
  30 #                 we think the user should be informed, an
  31 #                 informational message may be printed.
  32 #
  33 # "call_trace" - This level is mostly used by developers when
  34 #                debugging PsN. If this level is set a message
  35 #                will be printed for each method which is called
  36 #                inside PsN. Needless to say, this will print a
  37 #                lot of text. The only time a user should turn this
  38 #                is when filing a bug report, and only then if a
  39 #                developer thinks it is necessary.
  40 #
  41 # Setting a higher level than "fatal" also means that message of all
  42 # lower levels will be printed.
  43 #
  44 # No PsN class may change the level.
  45
  46 # {{{ include
  47 start include statements
  48 use Carp;
  49 use Carp qw(cluck);
  50 use Text::Wrap;
  51 use File::Find 'find';
  52 use File::Spec::Functions;
  53
  54 # These variables are used for mapping level names to numbers.
  55
  56 my $fatal = 0;
  57 my $warning = 1;
  58 my $information = 2;
  59 my $call_trace = 3;
  60
  61 my $the_instance = debug::new();
  62
  63 end include statements
  64 # }}}
  65
  66 # {{{ new
  67 start new
  68 end new
  69 # }}}
  70
  71 # {{{ level
  72
  73 start level
  74     {
  75       # Usage:
  76       #
  77       # debug -> level( debug::warning )
  78       #
  79       # If you give a value to level as a single argument, you will
  80       # set the global level of debug messages.
  81       #
  82       # my $current_level = debug -> level
  83       #
  84       # If you don't give any argument the current level is returned.
  85
  86       if( defined($parm) ){
  87         $the_instance -> {'level'} = $parm;
  88       } else {
  89         return $the_instance -> {'level'};
  90       }
  91       #$self -> psn_in_inc;
  92       return;
  93     }
  94 end level
  95
  96 # }}}
  97
  98 # {{{ package
  99
 100 start package
 101     {
 102       # Usage:
 103       #
 104       # debug -> package( 'output' )
 105       #
 106       # If you give a value to package as a single argument, you will
 107       # set the global package of debug messages.
 108       #
 109       # my $current_package = debug -> package
 110       #
 111       # If you don't give any argument the current package is returned.
 112
 113       if( defined($parm) ){
 114         $the_instance -> {'package'} = $parm;
 115       } else {
 116         return $the_instance -> {'package'};
 117       }
 118       return;
 119     }
 120 end package
 121
 122 # }}}
 123
 124 # {{{ subroutine
 125
 126 start subroutine
 127     {
 128       # Usage:
 129       #
 130       # debug -> subroutine( 'output' )
 131       #
 132       # If you give a value to subroutine as a single argument, you will
 133       # set the global subroutine of debug messages.
 134       #
 135       # my $current_subroutine = debug -> subroutine
 136       #
 137       # If you don't give any argument the current subroutine is returned.
 138
 139       if( defined($parm) ){
 140         $the_instance -> {'subroutine'} = $parm;
 141       } else {
 142         return $the_instance -> {'subroutine'};
 143       }
 144       return;
 145     }
 146 end subroutine
 147
 148 # }}}
 149
 150 # {{{ level_name
 151 start level_name
 152     {
 153       # Usage:
 154       #
 155       # my $level_name = debug -> level_name( level => 1 )
 156
 157       # level_name will map an integer in the interval 0 to 3 to a
 158       # string. The string is the name of the level with that number
 159       # in the order of levels. ( "fatal" is lowest and "call_trace"
 160       # highest ).
 161
 162       # By default it returns the name of the current set level.
 163
 164       # my $current_level_name = debug -> level_name;
 165
 166       $return_val = $the_instance -> {'level_names'} -> [$level];
 167     }
 168 end level_name
 169 # }}}
 170
 171 # {{{ warn_with_trace
 172 start warn_with_trace
 173     {
 174       # Usage:
 175       #
 176       # debug -> warn_with_trace( debug::warning )
 177       #
 178       # By default, a trace of function calls is printed when PsN
 179       # dies. If you like you can set a level for which you like
 180       # traces to be printed. Notice that all lower level messages
 181       # will also have a trace printed after them.
 182
 183       if( defined($parm) ){
 184         $the_instance -> {'warn_with_trace'} = $parm;
 185       } else {
 186         return $the_instance -> {'warn_with_trace'};
 187       }
 188       return;
 189     }
 190 end warn_with_trace
 191 # }}}
 192
 193 # {{{ warn
 194 start warn
 195     {
 196
 197       # Usage:
 198       #
 199       # debug -> warn( level => debug::warning, message => "This is a warning" );
 200       #
 201       # debug::warn will print out warning, informational or
 202       # call_trace messages corresponding to the level specified as
 203       # argument. debug::warn will look at the level given and the
 204       # global level to see whether anything should be printed.
 205       #
 206       #
 207       # NOTICE the lack of "\n" at the end of the message, debug::warn
 208       # will append one "\n". In case there ever is a GUI for PsN
 209       # debug::warn could be used to create a message in the GUI. And
 210       # in that case, an extra "\n" might be annoying.
 211
 212       if( $the_instance -> {'level'} >= $level ){
 213
 214         my ( $package_junk, $filename, $line, $subroutine, $junk ) = caller(1);
 215         my @names = split('::', $subroutine );
 216         $subroutine = $names[$#names];
 217         my $package = join( '::', @names[0..$#names-1] );
 218
 219         if ( ( not defined $the_instance -> {'package'} or
 220                $the_instance -> {'package'} eq $package ) and
 221              ( not defined $the_instance -> {'subroutine'} or
 222                $the_instance -> {'subroutine'} eq $subroutine ) ) {
 223
 224           my $level_name = $self -> level_name(level => $level);
 225           my $prefix;
 226           my $text;
 227
 228           if( $the_instance -> {'level'} >= 3 ){
 229             my @longmess = split( /\n/, Carp::longmess );
 230             my $arr = scalar(@longmess);
 231             $prefix = '  ' x ($arr-2);
 232           }
 233
 234           if( $level >= 3 ){
 235             $text = $prefix . $level_name . ': ' . $package . '->' .
 236               $subroutine. " : " . $message . "\n";
 237           } else {
 238             my $level_name_length = length( $level_name );
 239             my $indent = ' ' x (4);
 240             $text = "\n". $level_name . ': ' . $package . '->' . $subroutine. " :";
 241             $text .= wrap($prefix, $prefix . $indent, "\n" . $message );
 242             $text .= "\n";
 243           }
 244
 245           if( $the_instance -> {'warn_with_trace'} ){
 246             cluck( $text );
 247           } else {
 248             print STDERR ( $text );
 249           }
 250         }
 251       }
 252     }
 253 end warn
 254 # }}}
 255
 256 # {{{ die
 257 start die
 258     {
 259       # Usage
 260       #
 261       # debug -> die( message => "This message will print, and then PsN will die" );
 262       #
 263       #
 264       # debug::die is what PsN calls instead of "die" in order to get
 265       # a call trace. The given message is allways printed.
 266       #
 267       # NOTICE the lack of "\n" at the end of the message, debug::warn
 268       # will append one "\n". In case there ever is a GUI for PsN
 269       # debug::doe could be used to create a message in the GUI. And
 270       # in that case, an extra "\n" might be annoying.
 271
 272       if( $the_instance -> {'level'} >= 0 ){
 273         my $prefix;
 274         if( $the_instance -> {'level'} >= 3 ){
 275           my @longmess = split( /\n/, Carp::longmess );
 276           my $arr = scalar(@longmess);
 277           $prefix = '  ' x ($arr-2);
 278         }
 279         if( $the_instance -> {'level'} > 1 ){
 280           $! = 1;
 281           confess( $prefix . $message );
 282         } else {
 283           $! = 1;
 284           croak(  $prefix . $self -> level_name(level => 0) . ': ' . $message . "\n" );
 285         }
 286       }
 287     }
 288 end die
 289 # }}}
 290
 291 # {{{ psn_in_inc
 292 start psn_in_inc
 293 foreach my $plib ( @INC ) {
 294   if ( $the_instance -> {'level'} > 1 ) {
 295     find( { wanted => sub { print canonpath($_),"\n" if /PsN.*\.pm\z/ }, no_chdir => 1 }, $plib ) if ( $plib ne '.' );
 296   } elsif ( $the_instance -> {'level'} == 1 ) {
 297     find( { wanted => sub { print canonpath($_),"\n" if /PsN\.pm\z/ }, no_chdir => 1 }, $plib ) if ( $plib ne '.' );
 298   }
 299 }
 300 end psn_in_inc
 301 # }}} psn_in_inc