Subversion Repositories DevTools

Rev

Rev 231 | Rev 261 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed 

#! perl
########################################################################
# Copyright ( C ) 2004 ERG Limited, All rights reserved
#
# Module name   : jats
# Module type   : Perl Package
# Compiler(s)   : n/a
# 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
#
# Usage:
#
# Version   Who      Date        Description
#
#......................................................................#

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 ErrorDoExit
                      ReportError Error Warning
                      Message Message1
                      Information Information1
                      Question
                      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 = 0   unless defined( $::ScmVerbose );
    $::ScmDebug = 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 $ScmOnExit;
our $ScmDelayExit;
our $ScmErrorCount;

# non-exported package globals go here
$ScmErrorCount = 0;

#  initialize package globals, first exported ones


#-------------------------------------------------------------------------------
# Function        : import
#
# Description     : Package import function
#                   This function will examine argumenst 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
#                       :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
#
# Inputs          : A hash of option,value pairs
#                   Valid options
#                       name        - Name to report in error
#                       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] ";
            $name = $value;

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

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

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

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

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

        } else {
            Error("ErrorConfig, Unknown option: $key");
        }
    }

    #
    #   Extract program specfic debug flags from the environment
    #   These will be based on the reporting 'name'
    #       GBE_name_DEBUG
    #       GBE_name_VERBOSE
    #
    if ( $name )
    {
        my ($value, $tag);

        $tag = "GBE_${name}_DEBUG" ;
        $value = $ENV{ $tag };
        if (defined $value)
        {
            $::ScmDebug = $value;
            Warning("Envar: $tag setting debug: $value");
        }

        $tag = "GBE_${name}_VERBOSE" ;
        $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        : 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        : Error
#
# Description     : Display a multiline 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 1;
    }
}

#-------------------------------------------------------------------------------
# Function        : 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
#
sub Verbose
{
    _Message '(V)', "@_" if ($::ScmVerbose);
}

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

sub Verbose3
{
    _Message '(V)', "@_" 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
#
sub Debug0
{
    _Message '------', "@_";
}

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


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


sub Debug3
{
    _Message '(D)', "@_" 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
#
# Inputs          : $name       - Nwe program name
#                   $level      - New program debug level
#
# Returns         : Current debug level
#

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

    push @DebugStack, $::ScmDebug;
    push @DebugStack, $::ScmWho;

    $::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
{
    $::ScmWho   = pop @DebugStack;
    $::ScmDebug = 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;