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

#

#

#......................................................................#

require 5.006_001;

use strict;

use warnings;

use Data::Dumper;

use IO::Handle;

package JatsError;

#-------------------------------------------------------------------------------

# Function        : BEGIN

#

# Description     : Standard Package Interface

#

# Inputs          :

#

# Returns         :

#

BEGIN {

    use Exporter   ();

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

    # set the version for version checking

    $VERSION     = 1.00;

    @ISA         = qw(Exporter);

    @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;

        } 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 eq 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

#

# Returns         : May not return

#

sub Error

{

    _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();

        }

        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;

    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 (*alias);             # a local typeglob

    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' );

        *alias = $globValue;

        if (defined ($alias)) {

            print Data::Dumper->Dump ( [$alias], ["*$varName" ]);

#            print "\t \$$varName $alias \n";

        } 

        if (defined (@alias)) {

            print Data::Dumper->Dump ( [\@alias], ["*$varName" ]);

#            print "\t \@$varName @alias \n";

        } 

        if (defined (%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;