WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/LIB/JatsError.pm

-#! perl
 ########################################################################
-# Copyright ( C ) 2004 ERG Limited, All rights reserved
+# Copyright ( C ) 2004-2009 ERG Limited, All rights reserved
+#
-# Module name   : jats
+# Module name   : JatsError
 # Module type   : Perl Package
-# Compiler(s)   : n/a
+# Compiler(s)   : Perl
 # Environment(s): jats
+#
 # Description   : A Perl Package to perform error handling within JATS
+#
 #                 Uses global variables
 #                       $::ScmVerbose;
 #                       $::ScmQuiet;
 #                       $::ScmDebug;
 #                 For use with existing scripts
+#
-# Usage:
-#
-# Version   Who      Date        Description
+#
 #......................................................................#
 require 5.006_001;
 use strict;
     # set the version for version checking
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);
-    @EXPORT      = qw(ErrorConfig ErrorDoExit
+    @EXPORT      = qw(ErrorConfig ErrorReConfig ErrorDoExit
                       ReportError Fatal Error Warning
                       Message Message1
                       Information Information1
                       Question
                       Verbose0 Verbose Verbose2 Verbose3
 # exported package globals go here
 #our $ScmWho;
 #our $ScmVerbose;
 #our $ScmDebug;
+#our $ScmQuiet;
 our $ScmOnExit;
 our $ScmDelayExit;
 our $ScmErrorCount;
 our $ScmExitCode;
 # non-exported package globals go here
 $ScmErrorCount = 0;
 $ScmExitCode = 1;
+my $EName = '';
+my $EFn = '';
 #  initialize package globals, first exported ones
 #-------------------------------------------------------------------------------
 # Function        : import
+#
 # Description     : Package import function
-#                   This function will examine argumenst provided in the
+#                   This function will examine arguments provided in the
 #                   invoking 'uses' list and will configure the package
 #                   accordingly.
+#
 # Inputs          : $pack           - Name of this package
 #                   @vars           - User Config Options
 #                   Config Options:
 #                       :name=xxxx
+#                       :function=xxxx
 #                       :quiet=xxx
 #                       :debug=xxx
 #                       :verbose=xxx
 #                       :delay_exit=xxx
+#
 #-------------------------------------------------------------------------------
 # Function        : ErrorConfig
+#
 # Description     : Configure aspects of the JATS error handle
+#                   See ErrorReConfig
+#
 # Inputs          : A hash of option,value pairs
 #                   Valid options
 #                       name        - Name to report in error
+#                       function    - Name of enclosing function
 #                       verbose     - vebosity level
 #                       debug       - debug level
 #                       on_exit     - Register on-exit function
 #                       delay_exit  - Delay exit on error
+#
 # Returns         :
+#
 sub ErrorConfig
+{
     my %args = @_;
-    my $name;
     while (my($key, $value) = each %args)
+    {
         if (       $key =~ /^name/ ) {
-            $::ScmWho = "[$value] ";
+            $EName = $value;
+        } elsif ( $key =~ /^function/ ) {
-            $name = $value;
+            $EFn = ':' . $value;
         } elsif ( $key =~ /^debug/ ) {
-            $::ScmDebug = $value || 0;
+            $::ScmDebug = $value
+                if ( defined $value && $value > $::ScmDebug  );
         } elsif ( $key =~ /^verbose/ ) {
-            $::ScmVerbose = $value || 0;
+            $::ScmVerbose = $value
+                if ( defined $value && $value > $::ScmVerbose  );
         } elsif ( $key =~ /^quiet/ ) {
             $::ScmQuiet = $value || 0;
         } elsif ( $key =~ /^on_exit/ ) {
             Error("ErrorConfig, Unknown option: $key");
+        }
+    }
+    #
+    #   Calculate the prefix to all messages
+    #   Based on Name and Function( if provided
+    #
+    $::ScmWho = "[$EName$EFn] ";
+    #
     #   Extract program specfic debug flags from the environment
     #   These will be based on the reporting 'name'
     #       GBE_name_DEBUG
     #       GBE_name_VERBOSE
+    #
-    if ( $name )
+    if ( $EName )
+    {
         my ($value, $tag);
-        $tag = "GBE_${name}_DEBUG" ;
+        $tag = "GBE_${EName}_DEBUG" ;
         $tag =~ s~\s+~~g;
         $value = $ENV{ $tag };
         if (defined $value)
+        {
             $::ScmDebug = $value;
             Warning("Envar: $tag setting debug: $value");
+        }
-        $tag = "GBE_${name}_VERBOSE" ;
+        $tag = "GBE_${EName}_VERBOSE" ;
         $tag =~ s~\s+~~g;
         $value = $ENV{ $tag };
         if (defined $value)
+        {
             $::ScmVerbose = $value;
+    #
     $::ScmQuiet = 0 if ( $::ScmVerbose );
     $::ScmQuiet = 0 if ( $::ScmDebug );
+}
+#-------------------------------------------------------------------------------
+# Function        : ErrorReConfig
+#
+# Description     : Similar to ErrorConfig , except it is used to push and
+#                   automatically pop the current state
+#
+#                   Intended to be used to control error reporting
+#                   within a function. Let the class go out of scope
+#                   at the end of the function.
+#
+#                   Not intended that the user hold and pass around the
+#                   class ref as this may confuse all.
+#
+# Inputs          : As for ErrorConfig
+#
+# Returns         : Ref to a class
+#                   When this goes out of scope the Error State will be
+#                   restored.
+#
+sub ErrorReConfig
+{
+    #
+    #   Create a small class to hold existing Error Information
+    #   The error information will be restored when the handle returned to
+    #   the user goes out of scope.
+    #
+    my $self;
+    $self->{ScmWho}         =  $::ScmWho;
+    $self->{ScmVerbose}     =  $::ScmVerbose;
+    $self->{ScmDebug}       =  $::ScmDebug;
+    $self->{ScmQuiet}       =  $::ScmQuiet;
+    $self->{ScmOnExit}      =  $ScmOnExit;
+    $self->{ScmDelayExit}   =  $ScmDelayExit;
+    $self->{ScmErrorCount}  =  $ScmErrorCount;
+    $self->{ScmExitCode}    =  $ScmExitCode;
+    $self->{EName}          =  $EName;
+    $self->{EFn}            =  $EFn;
+    bless ($self, __PACKAGE__);
+    #
+    #   Invoke ErrorConfig to do the hard work
+    #
+    ErrorConfig (@_);
+    #
+    #   Return ref to stored data
+    #
+    return $self;
+}
+#-------------------------------------------------------------------------------
+# Function        : DESTROY
+#
+# Description     : Called when the handle retruned by ErrorConfig goes out of
+#                   scope.
+#
+#                   Restores the state of the Error Reporting information
+#
+# Inputs          : $self               - Created by ErrorReConfig
+#
+# Returns         : Nothing
+#
+sub DESTROY
+{
+    my ($self) = @_;
+    $::ScmWho         = $self->{ScmWho};
+    $::ScmVerbose     = $self->{ScmVerbose};
+    $::ScmDebug       = $self->{ScmDebug};
+    $::ScmQuiet       = $self->{ScmQuiet};
+    $ScmOnExit        = $self->{ScmOnExit};
+    $ScmDelayExit     = $self->{ScmDelayExit};
+    $ScmErrorCount    = $self->{ScmErrorCount};
+    $ScmExitCode      = $self->{ScmExitCode};
+    $EFn              = $self->{EFn};
+    $EName            = $self->{EName};
+}
 #-------------------------------------------------------------------------------
 # Function        : Information
 #                   Message
 #                   Question
 # Function        : DebugPush
+#
 # Description     : Save the current debug level and then use a new name and
 #                   debug level for future reporting
+#
+#                   Provided for backward compatability
+#                   Preferred solution is ErrorReConfig
+#
-# Inputs          : $name       - Nwe program name
+# Inputs          : $name       - New program name
 #                   $level      - New program debug level
+#
 # Returns         : Current debug level
+#
 my @DebugStack = ();
 sub DebugPush
+{
     my ($name, $new_level) = @_;
+    my %args;
+    #
-    push @DebugStack, $::ScmDebug;
+    #   Save current state on a stack
+    #
+    my $estate = ErrorReConfig ();
-    push @DebugStack, $::ScmWho;
+    push @DebugStack, $estate;
     $::ScmDebug = $new_level if ( defined $new_level && $new_level );
     $::ScmWho =   $name      if ( defined $name && $name );
     return $::ScmDebug;
+}
+#
 # Inputs          : None
+#
 sub DebugPop
+{
-    $::ScmWho   = pop @DebugStack;
-    $::ScmDebug = pop @DebugStack;
+    pop @DebugStack;
+}
 #-------------------------------------------------------------------------------
 # Function        : DebugDumpPackage
+#

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/JatsError.pm – Rev 263 → 279