Subversion Repositories DevTools

########################################################################

# COPYRIGHT - VIX IP PTY LTD ("VIX"). 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

#                       $::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;

# exported package globals go here

#our $ScmVerbose;

#our $ScmDebug;

#our $ScmQuiet;

our $ScmOnExit;

our $ScmDelayExit;

our $ScmErrorCount;

our $ScmExitCode;

my $EPrefix = '';

my $EName = '';

my $EFn = '';

my $ElPrefix = '';

my $EIndent = '';

my $EOffset = '';

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

# 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

                      WarnError

                      Message Message1

                      Information Information1

                      Question

                      Verbose0 Verbose Verbose2 Verbose3

                      Debug0 Debug Debug2 Debug3

                      IsVerbose IsDebug IsQuiet

                      DebugDumpData DebugDumpPackage DebugTraceBack

                      DebugPush DebugPop

                      StartCapture

                      DumpCapture

                      );

    %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

    #

    $::ScmVerbose = $ENV{GBE_VERBOSE} || 0  unless defined( $::ScmVerbose );

    $::ScmDebug = $ENV{GBE_DEBUG} || 0      unless defined( $::ScmDebug );

    $::ScmQuiet = 0                         unless defined( $::ScmQuiet );

    $ScmErrorCount = 0;

    $ScmExitCode = 1;

    #

    #   Force autoflush in an attempt to limit the intermingling of

    #   Error and non-error output.

    #

    STDOUT->autoflush(1);

    STDERR->autoflush(1);

}

# non-exported package globals go here

my @captured;

my $capturing;

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

# 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

#                       :prefix=xxxx

#                       :indent=nn/xxx

#                       :offset=nn/xxx

#                       :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

#                       prefix      - Optional prefix. First line only

#                       indent      - Optional. All lines (number or text)

#                       offset      - Optional. Extra lines (number or text)

#

# Returns         :

#

sub ErrorConfig

{

    my %args = @_;

    while (my($key, $value) = each %args)

    {

        if ( $key =~ /^name/ ) {

            $EName = $value;

        } elsif ( $key =~ /^function/ ) {

            $EFn = ':' . $value;

        } elsif ( $key =~ /^prefix/ ) {

            $ElPrefix = $value;

        } elsif ( $key =~ /^indent/ ) {

            my $pad = $value;

            if ($pad =~ m~^\d+$~) {

                $pad = ' ' x $value;

            }

            $EIndent = $EIndent . $pad;

        } elsif ( $key =~ /^offset/ ) {

            $EOffset = $value;

            if ($EOffset =~ m~^\d+$~) {

                $EOffset = ' ' x $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

    #

    $EPrefix = "[$EName$EFn] " if $EName;

    #

    #   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->{EPrefix}        =  $EPrefix;

    $self->{ElPrefix}       =  $ElPrefix;

    $self->{EIndent}        =  $EIndent;

    $self->{EOffset}        =  $EOffset;

    $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 returned 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) = @_;

    $EPrefix          = $self->{EPrefix};

    $ElPrefix         = $self->{ElPrefix};

    $EIndent          = $self->{EIndent};

    $EOffset          = $self->{EOffset};

    $::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

#                   WarnError

#                   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 = $EPrefix . $tag. $EIndent;

    #

    #   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 == 0 ) {

            $line = ($ElPrefix || '') . $line;

        } elsif ( $count == 1 ) {

            my $bol = $eol ? "" : "\n";

            $prefix = $bol . ' ' x length($prefix) . $EOffset;

        }

        $count++;

        if ($capturing && $tag =~ m/[MWEF]/) {

            push @captured, "$prefix $line$eol" 

        } else {

            print "$prefix $line$eol";

        }

    }

}

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

# 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        : WarnError 

#

# Description     : Display a warning or an error based on the first argument

#

# Inputs          : Mode    - True. Error, False warn

#                   ...     - Fed to warn or error

#

# Returns         : May not return 

#

sub WarnError

{

    my $mode = shift;

    if ($mode) {

        Error (@_);

    }

    Warning(@_);

}

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

# 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++;

#    DebugTraceBack();

    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 )

    {

        # If capturing, then force the captured messages to be displayed

        DumpCapture();

        #

        #   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

#                   

#                   Put all args on one line, unless '++' is encountered

#                   This will force one arg per line mode

#

# Inputs          : REF to a list of scalar values

#                   Passing a REF is faster

#

# Returns         : A string. May be empty, but will be defined

#

sub ArgsToString

{

    my @result;

    my $mode;

    foreach ( @{$_[0]} ) {

        my $item = defined($_) ? $_ : '\'undef\'';

        if ( $item eq '++' ) {

            @result = join (' ', @result);

            $mode = 1;

        } else {

            push @result, $item;

        }

    }

    unless ($mode) {

        @result = join (' ', @result);

    }

    push @result, '' unless @result;

    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 supported after arg that is '++'

#                   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 supported after arg that is '++'

#                   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        : StartCapture 

#

# Description     : Start capturing non-debug non-verbose messages 

#

# Inputs          : mode    - True: Start 

#

# Returns         : 

#

sub StartCapture

{

    my ($mode) = @_;

    $capturing = $mode;

}

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

# Function        : DumpCapture 

#

# Description     : Dump the captured output

#

# Inputs          : None

#

# Returns         : Nothing

#

sub DumpCapture

{

    foreach my $line ( @captured) {

        print $line;

    }

    @captured = ();

    $capturing = 0;

}

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

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

    $EPrefix =   $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

    # Iterate through the symbol table, which contains glob values

    # indexed by symbol names.

    foreach my $varName ( sort keys %stash)

    {

        my $globValue = $stash{$varName};

        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;