Subversion Repositories DevTools

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