1: # I wrote this to find an annoying warning in a large package
   2: # of functions. Its rather simple, but I found it fairly useful.
   3: package TraceWarning;
   4: 
   5: require Exporter;
   6: 
   7: @ISA = qw(Exporter);
   8: @EXPORT = qw(TRACE_W);
   9: 
  10: #######################################################################
  11: # This code will provide more verbose warning messages.
  12: #   In addition to displaying the warning messages, it will display
  13: #   the last non-fatal OS error and the sub-routine call stack.
  14: ##################################################################ADAM#
  15: 
  16: sub TRACE_W
  17: {
  18:     print STDERR "Warning: $_[0]";           # Print the warning.
  19:     $! and print STDERR "Error:   $!\n";     # If error, print it
  20:     $! = 0;                                  # and reset.
  21:     my ($index, @callStack) = (0, ("", "", "", "TRACE STACK ERROR"));
  22: 
  23:     while (@callStack = caller(++$index))    # Trace the call stack.
  24:     { 
  25:         my ($routineName, $fileNameAndLine) = (" $callStack[3]", "");
  26:         # If the file name is available, append it to the trace mesg.
  27:             if ($callStack[1] ne "Home")  
  28:             {
  29:                 $fileNameAndLine = " ($callStack[1]:$callStack[2])";
  30:             }
  31:         print STDERR "$index$routineName$fileNameAndLine\n";
  32:     } 
  33: }
  34: 
  35: BEGIN
  36: {
  37:     # Insist on warning messages being on.
  38:     $^W = 1;
  39: 
  40:     # Catch warnings and display additional information.
  41:     $SIG{__WARN__} = \&TRACE_W;
  42: }
  43: 
  44: __END__