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