Subversion Repositories DevTools

########################################################################
# Copyright ( C ) 2004-2009 ERG Limited, All rights reserved
#
# Module name   : JatsError
# Module type   : Perl Package
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : A Perl Package to perform error handling within JATS
#
#                 Uses global variables
#                       $::ScmWho;
#                       $::ScmVerbose;
#                       $::ScmQuiet;
#                       $::ScmDebug;
#                 For use with existing scripts
#
#
#......................................................................#

package JatsError;
use base qw(Exporter);

require 5.006_001;
use strict;
use warnings;
use Data::Dumper;
use IO::Handle;

#-------------------------------------------------------------------------------
# Function        : BEGIN
#
# Description     : Standard Package Interface
#
# Inputs          :
#
# Returns         :
#

BEGIN {
    our ($VERSION, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    # set the version for version checking
    $VERSION     = 1.00;

    @EXPORT      = qw(ErrorConfig ErrorReConfig ErrorDoExit
                      ReportError Fatal Error Warning
                      Message Message1
                      Information Information1
                      Question
                      Verbose0 Verbose Verbose2 Verbose3
                      Debug0 Debug Debug2 Debug3
                      IsVerbose IsDebug IsQuiet
                      DebugDumpData DebugDumpPackage DebugTraceBack
                      DebugPush DebugPop
                      );

    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],

    # your exported package globals go here,
    # as well as any optionally exported functions
    @EXPORT_OK   = qw();

    #
    #   Ensure globals have a defined value
    #
    $::ScmWho = ''                          unless defined( $::ScmWho );
    $::ScmVerbose = $ENV{GBE_VERBOSE} || 0  unless defined( $::ScmVerbose );
    $::ScmDebug = $ENV{GBE_DEBUG} || 0      unless defined( $::ScmDebug );
    $::ScmQuiet = 0                         unless defined( $::ScmQuiet );

    #
    #   Force autoflush in an attempt to limit the intermingling of
    #   Error and non-error output.
    #
    STDOUT->autoflush(1);
    STDERR->autoflush(1);
}



# 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 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
#
# Returns         : 
#
sub import {
    my $pack = shift;
    my @vars;
    my @config;

    #
    #   Extract options of the form: :name=value and pass them to the
    #   ErrorConfig function. All other arguments will be passed to the
    #
    foreach ( @_ )
    {
        if ( m/^:(.+)=(.+)/ ) {
            push @config, $1, $2;
        } else {
            push @vars, $_;
        }
    }

    ErrorConfig( @config )
        if ( @config );

    #
    #   Invoke Exporter function to handle the arguments that I don't understand
    #
    $pack->export_to_level(1, $pack , @vars);
}

#-------------------------------------------------------------------------------
# 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 = @_;

    while (my($key, $value) = each %args)
    {
        if (       $key =~ /^name/ ) {
            $EName = $value;

        } elsif ( $key =~ /^function/ ) {
            $EFn = ':' . $value;

        } elsif ( $key =~ /^debug/ ) {
            $::ScmDebug = $value
                if ( defined $value && $value > $::ScmDebug  );

        } elsif ( $key =~ /^verbose/ ) {
            $::ScmVerbose = $value
                if ( defined $value && $value > $::ScmVerbose  );

        } elsif ( $key =~ /^quiet/ ) {
            $::ScmQuiet = $value || 0;

        } elsif ( $key =~ /^on_exit/ ) {
            $ScmOnExit = $value;

        } elsif ( $key =~ /^delay_exit/ ) {
            $ScmDelayExit = $value;

        } elsif ( $key =~ /^exitCode/i ) {
            $ScmExitCode = $value || 1;

        } else {
            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 ( $EName )
    {
        my ($value, $tag);

        $tag = "GBE_${EName}_DEBUG" ;
        $tag =~ s~\s+~~g;
        $value = $ENV{ $tag };
        if (defined $value)
        {
            $::ScmDebug = $value;
            Warning("Envar: $tag setting debug: $value");
        }

        $tag = "GBE_${EName}_VERBOSE" ;
        $tag =~ s~\s+~~g;
        $value = $ENV{ $tag };
        if (defined $value)
        {
            $::ScmVerbose = $value;
            Warning("Envar: $tag setting verbose: $value");
        }
    }

    #
    #   Sanitise quiet and verbose
    #   Any verboseness disables quiet
    #
    $::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
#                   Warning
#                   Error
#                   Verbose
#                   Debug
#                   _Message ( Internal use only )
#
# Description     : Error, Warning and Message routines
#                   These routines will display a message to the user
#                   with the module name.
#
#                   Multiple arguments are displayed on their own line
#                   with suitable spacing.
#
# Inputs          : Lines of text to display
#
# Returns         : Nothing
#
sub _Message
{
    my $tag = shift;                # First argument is a tag
    my $count = 0;

    #
    #   Generate the message prefix
    #   This will only be used on the first line
    #   All other lines will have a space filled prefix
    #
    my $prefix = $::ScmWho . $tag;
    #
    #   Kill the eol if the Question is being asked
    #
    my $eol = ( $tag =~ m/Q/ ) ? "" : "\n";
    foreach my $nextline ( @_ )
    {
        next unless ( defined $nextline );              # Ignore undefined arguments
        chomp( my $line = $nextline );
        if ( $count == 1 )
        {
            my $bol = $eol ? "" : "\n";
            $prefix = $bol . ' ' x length($prefix);
        }

        print "$prefix $line$eol";
        $count++;
    }
}

#-------------------------------------------------------------------------------
# Function        : Information
#                   Information1
#
# Description     : Will display informational messages
#                   These are normal operational messages. These may be
#                   supressed through the use of QUIET options
#
# Inputs          : An array of strings to display
#
sub Information
{
    _Message '(I)', @_ unless ( $::ScmQuiet);
}

sub Information1
{
    _Message '(I)', @_ unless ( $::ScmQuiet > 1);
}


#-------------------------------------------------------------------------------
# Function        : Message
#                   Message1
#
# Description     : Same as Information, except a different prefix
#
# Inputs          : An array of strings to display
#
sub Message
{
    _Message '(M)', @_ unless ( $::ScmQuiet > 1);
}

sub Message1
{
    _Message '(M)', @_ unless ( $::ScmQuiet);
}

#-------------------------------------------------------------------------------
# Function        : IsQuiet
#
# Description     : Determine if an Infrmation or Message will be displayed
#                   May be used to reduce excessive processing that may be
#                   discarded
#
# Inputs          : $level      - Level to test
#
# Returns         : TRUE:       A Message at $level would be displayed
#
sub IsQuiet
{
    my( $level) = @_;
    return $::ScmQuiet >= $level;
}

#-------------------------------------------------------------------------------
# Function        : Warning
#
# Description     : Display a warning message
#                   These may be disabled with a high quiet level
#
# Inputs          : An array of strings to display
#
sub Warning
{
    _Message '(W)', @_ unless ( $::ScmQuiet > 2);
}

#-------------------------------------------------------------------------------
# Function        : Question
#
# Description     : Display a Question message
#                   These cannot be disabled
#
# Inputs          : An array of strings to display
#
sub Question
{
    _Message '(Q)', @_;
    STDERR->flush;              # Force output to be displayed
    STDOUT->flush;              # Force output to be displayed
}

#-------------------------------------------------------------------------------
# Function        : Fatal
#
# Description     : Display a multi line fatal message
#                   This will cause the program to exit.
#
#                   Similar to Error(), except
#                       Display a (F) prefix
#                       Alters the exit code to "2"
#                       Will terminate program execution.
#                       Will not honor delayed exit configuration.
#
#                   Fatal is to be used to indicate to consumer processes that
#                   the error is a function of the infrastructure and cannot be
#                   corrected by a user. ie:
#                       clearcase is not available
#                           Not just a bad user parameter
#                       dpkg_archive is not available
#                       release manager database is not available
#
#                   Intended to be used by build deamons to determine if building
#                   should continue, or if the entire build process should be
#                   terminated.
#
# Inputs          : An array of strings to display
#
# Returns         : May not return
#
sub Fatal
{
    _Message '(F)', @_;
    $ScmErrorCount++;
    $ScmExitCode = 2;
    ErrorDoExit() unless ( $ScmDelayExit );
}

#-------------------------------------------------------------------------------
# Function        : Error
#
# Description     : Display a multi line error message
#                   This may cause the program to exit, or the user may have
#                   configured the package to accumulate error messages
#
#                   This could be used to generate multiple error messages
#                   while parsing a file, and then terminate program execution at
#                   the end of the phase.
#
# Inputs          : An array of strings to display
#                   First entry May be an exist code of the form
#                       ExitCode=nnn
#
# Returns         : May not return
#

sub Error
{
    if ( $_[0] =~ m~^ExitCode=(\d+)$~i )
    {
        $ScmExitCode = $1 || 1;
        shift @_;
    }
    _Message '(E)', @_;
    $ScmErrorCount++;
    ErrorDoExit() unless ( $ScmDelayExit );
}

#-------------------------------------------------------------------------------
# Function        : ReportError
#
# Description     : Like Error, but the error exit is delayed
#
# Inputs          : An array of strings to display
#
sub ReportError
{
    _Message '(E)', @_;
    $ScmErrorCount++;
}

#-------------------------------------------------------------------------------
# Function        : ErrorDoExit
#
# Description     : Will terminate the program if delayed error messages
#                   have been seen.
#
# Inputs          : None
#
# Returns         : Will return if no errors have been reported
#

sub ErrorDoExit
{
    if ( $ScmErrorCount )
    {
        #
        #   Prevent recusion.
        #   Kill error processing while doing error exit processing
        #
        if ( my $func = $ScmOnExit )
        {
            $ScmOnExit = undef;
            &$func( $ScmExitCode );
        }
        exit $ScmExitCode;
    }
}

#-------------------------------------------------------------------------------
# Function        : ArgsToString
#
# Description     : Convert an array of arguments to a string
#                   Main purpose is to allow Debug and Verbose
#                   calls to pass undef values without causing warnings
#
# Inputs          : REF to a list of scalar values
#                   Passing a REF is faster
#
# Returns         : A string
#
sub ArgsToString
{
    my $result = '';

    $result .= (defined ($_) ? $_ : '\'undef\'') . ' ' foreach  ( @{$_[0]} );
    return $result;
}

#-------------------------------------------------------------------------------
# Function        : Verbose0
#                   Verbose
#                   Verbose2
#                   Verbose3
#
# Description     : Various levels of progress reporting
#                   By default none are displayed
#
# Inputs          : A single line string
#                   Multi-line output is not supported
#                   Arguments will be processed such that undef is handled well
#
sub Verbose0
{
    _Message '------', ArgsToString (\@_);
}
sub Verbose
{
    _Message '(V)', ArgsToString (\@_) if ($::ScmVerbose);
}

sub Verbose2
{
    _Message '(V)', ArgsToString (\@_) if ($::ScmVerbose >= 2);
}

sub Verbose3
{
    _Message '(V)', ArgsToString (\@_) if ($::ScmVerbose >= 3);
}

sub IsVerbose
{
    my( $level) = @_;
    return $::ScmVerbose >= $level;
}

#-------------------------------------------------------------------------------
# Function        : Debug
#                   Debug0
#                   Debug1
#                   Debug2
#                   Debug3
#
# Description     : Various levels of debug reporting
#                   By default none are displayed
#
# Inputs          : A single line string
#                   Multi-line output is not supported
#                   Arguments will be processed such that undef is handled well
#
sub Debug0
{
    _Message '------', ArgsToString (\@_);
}

sub Debug
{
    _Message '(D)', ArgsToString (\@_) if ($::ScmDebug >= 1 ) ;
}


sub Debug2
{
    _Message '(D)', ArgsToString (\@_) if ($::ScmDebug >= 2) ;
}


sub Debug3
{
    _Message '(D)', ArgsToString (\@_) if ($::ScmDebug >= 3) ;
}

sub IsDebug
{
    my( $level) = @_;
    return $::ScmDebug >= $level;
}

#-------------------------------------------------------------------------------
# Function        : DebugDumpData
#
# Description     : Dump a data structure
#
# Inputs          : $name           - A name to give the structure
#                   @refp           - An array of references
#
# Returns         :
#
sub DebugDumpData
{
    my ($name, @refp) = @_;

    my $ii = 0;
    $Data::Dumper::Sortkeys = 1;
    foreach  ( @refp )
    {
        print Data::Dumper->Dump ( [$_], ["*[Arg:$ii] $name" ]);
        $ii++
    }
}

#-------------------------------------------------------------------------------
# Function        : DebugTraceBack
#
# Description     : Display the call stack
#
# Inputs          : $tag
#
# Returns         : Nothing
#
sub DebugTraceBack
{
    my ($tag) = @_;
    $tag = 'TraceBack' unless ( $tag );

    #
    #   Limit the stack stace.
    #   It can't go on forever
    #
    foreach my $ii ( 0 .. 20 )
    {
         my ($package, $filename, $line) = caller($ii);
         last unless ( $package );
         print "$tag: $ii: $package, $filename, $line\n";
    }
}

#-------------------------------------------------------------------------------
# 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       - New program name
#                   $level      - New program debug level
#
# Returns         : Current debug level
#

my @DebugStack = ();
sub DebugPush
{
    my ($name, $new_level) = @_;
    my %args;

    #
    #   Save current state on a stack
    #
    my $estate = ErrorReConfig ();
    push @DebugStack, $estate;
    
    $::ScmDebug = $new_level if ( defined $new_level && $new_level );
    $::ScmWho =   $name      if ( defined $name && $name );

    return $::ScmDebug;
}

#-------------------------------------------------------------------------------
# Function        : DebugPop
#
# Description     : Restores the operation of the DebugPush
#
# Inputs          : None
#
sub DebugPop
{
    pop @DebugStack;
}

#-------------------------------------------------------------------------------
# Function        : DebugDumpPackage
#
# Description     : Dump data within the scope of a given package
#
# Inputs          : $packageName            - To dump
#
# Returns         : 
#

sub DebugDumpPackage
{
    no strict "vars";
    no strict "refs";
    my ($packageName) = @_;
    print "==DebugDumpPackage: $packageName =============================\n";

    local $Data::Dumper::Pad = "\t ";
    local $Data::Dumper::Maxdepth = 2;
    local $Data::Dumper::Indent  = 1;

    # We want to get access to the stash corresponding to the package name

    *stash = *{"${packageName}::"};  # Now %stash is the symbol table
#    $, = " ";                        # Output separator for print
    # Iterate through the symbol table, which contains glob values
    # indexed by symbol names.
    while (my ($varName, $globValue) = each %stash)
    {
        print "$varName =============================\n";
        next if ( $varName eq 'stash' );
        local *alias = $globValue;
        if (defined ($alias)) {
            print Data::Dumper->Dump ( [$alias], ["*$varName" ]);
#            print "\t \$$varName $alias \n";
        } 
        if (@alias) {
            print Data::Dumper->Dump ( [\@alias], ["*$varName" ]);
#            print "\t \@$varName @alias \n";
        } 
        if (%alias) {
            print Data::Dumper->Dump ( [\%alias], ["*$varName" ]);
#            print "\t \%$varName ",%alias," \n";
        }
        if (defined (&alias)) {
#            print Data::Dumper->Dump ( [\&alias], ["*$varName" ]);
            print "\t \&$varName ","Code Fragment"," \n";
        }
     }
}

#
#
1;