Subversion Repositories DevTools

# Environment(s): jats

# Environment(s): jats

#

#

# Description   : A Perl Package to perform error handling within JATS

# Description   : A Perl Package to perform error handling within JATS

#

#

#                 Uses global variables

#                 Uses global variables

#                       $::ScmVerbose;

#                       $::ScmVerbose;

#                       $::ScmQuiet;

#                       $::ScmQuiet;

#                       $::ScmDebug;

#                       $::ScmDebug;

#                 For use with existing scripts

#                 For use with existing scripts

#

#

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

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

package JatsError;

package JatsError;

use base qw(Exporter);

use base qw(Exporter);

use strict;

use strict;

use warnings;

use warnings;

use Data::Dumper;

use Data::Dumper;

use IO::Handle;

use IO::Handle;

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

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

# Function        : BEGIN

# Function        : BEGIN

#

#

# Description     : Standard Package Interface

# Description     : Standard Package Interface

#

#

    @EXPORT_OK   = qw();

    @EXPORT_OK   = qw();

    #

    #

    #   Ensure globals have a defined value

    #   Ensure globals have a defined value

    #

    #

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

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

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

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

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

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

    #

    #

    #   Force autoflush in an attempt to limit the intermingling of

    #   Force autoflush in an attempt to limit the intermingling of

    #   Error and non-error output.

    #   Error and non-error output.

    #

    #

    STDOUT->autoflush(1);

    STDOUT->autoflush(1);

    STDERR->autoflush(1);

    STDERR->autoflush(1);

}

}

# non-exported package globals go here

# non-exported package globals go here

my @captured;

my @captured;

my $capturing;

my $capturing;

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

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

# Function        : import

# Function        : import

#

#

# Description     : Package import function

# Description     : Package import function

#                   This function will examine arguments provided in the

#                   This function will examine arguments provided in the

# Inputs          : $pack           - Name of this package

# Inputs          : $pack           - Name of this package

#                   @vars           - User Config Options

#                   @vars           - User Config Options

#                   Config Options:

#                   Config Options:

#                       :name=xxxx

#                       :name=xxxx

#                       :function=xxxx

#                       :function=xxxx

#                       :quiet=xxx

#                       :quiet=xxx

#                       :debug=xxx

#                       :debug=xxx

#                       :verbose=xxx

#                       :verbose=xxx

#                       :delay_exit=xxx

#                       :delay_exit=xxx

#

#

#                       function    - Name of enclosing function

#                       function    - Name of enclosing function

#                       verbose     - vebosity level

#                       verbose     - vebosity level

#                       debug       - debug level

#                       debug       - debug level

#                       on_exit     - Register on-exit function

#                       on_exit     - Register on-exit function

#                       delay_exit  - Delay exit on error

#                       delay_exit  - Delay exit on error

#

#

# Returns         :

# Returns         :

#

#

sub ErrorConfig

sub ErrorConfig

{

{

    my %args = @_;

    my %args = @_;

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

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

    {

    {

            $EName = $value;

            $EName = $value;

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

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

            $EFn = ':' . $value;

            $EFn = ':' . $value;

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

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

            $::ScmDebug = $value

            $::ScmDebug = $value

                if ( defined $value && $value > $::ScmDebug  );

                if ( defined $value && $value > $::ScmDebug  );

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

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

    #

    #

    #   Calculate the prefix to all messages

    #   Calculate the prefix to all messages

    #   Based on Name and Function( if provided

    #   Based on Name and Function( if provided

    #

    #

    #

    #

    #   Extract program specfic debug flags from the environment

    #   Extract program specfic debug flags from the environment

    #   These will be based on the reporting 'name'

    #   These will be based on the reporting 'name'

    #       GBE_name_DEBUG

    #       GBE_name_DEBUG

    #   The error information will be restored when the handle returned to

    #   The error information will be restored when the handle returned to

    #   the user goes out of scope.

    #   the user goes out of scope.

    #

    #

    my $self;

    my $self;

    $self->{ScmVerbose}     =  $::ScmVerbose;

    $self->{ScmVerbose}     =  $::ScmVerbose;

    $self->{ScmDebug}       =  $::ScmDebug;

    $self->{ScmDebug}       =  $::ScmDebug;

    $self->{ScmQuiet}       =  $::ScmQuiet;

    $self->{ScmQuiet}       =  $::ScmQuiet;

    $self->{ScmOnExit}      =  $ScmOnExit;

    $self->{ScmOnExit}      =  $ScmOnExit;

    $self->{ScmDelayExit}   =  $ScmDelayExit;

    $self->{ScmDelayExit}   =  $ScmDelayExit;

}

}

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

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

# Function        : DESTROY

# Function        : DESTROY

#

#

#                   scope.

#                   scope.

#

#

#                   Restores the state of the Error Reporting information

#                   Restores the state of the Error Reporting information

#

#

# Inputs          : $self               - Created by ErrorReConfig

# Inputs          : $self               - Created by ErrorReConfig

#

#

sub DESTROY

sub DESTROY

{

{

    my ($self) = @_;

    my ($self) = @_;

    $::ScmVerbose     = $self->{ScmVerbose};

    $::ScmVerbose     = $self->{ScmVerbose};

    $::ScmDebug       = $self->{ScmDebug};

    $::ScmDebug       = $self->{ScmDebug};

    $::ScmQuiet       = $self->{ScmQuiet};

    $::ScmQuiet       = $self->{ScmQuiet};

    $ScmOnExit        = $self->{ScmOnExit};

    $ScmOnExit        = $self->{ScmOnExit};

    $ScmDelayExit     = $self->{ScmDelayExit};

    $ScmDelayExit     = $self->{ScmDelayExit};

    #

    #

    #   Generate the message prefix

    #   Generate the message prefix

    #   This will only be used on the first line

    #   This will only be used on the first line

    #   All other lines will have a space filled prefix

    #   All other lines will have a space filled prefix

    #

    #

    #

    #

    #   Kill the eol if the Question is being asked

    #   Kill the eol if the Question is being asked

    #

    #

    my $eol = ( $tag =~ m/Q/ ) ? "" : "\n";

    my $eol = ( $tag =~ m/Q/ ) ? "" : "\n";

        next unless ( defined $nextline );              # Ignore undefined arguments

        next unless ( defined $nextline );              # Ignore undefined arguments

        chomp( my $line = $nextline );

        chomp( my $line = $nextline );

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

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

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

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

        }

        }

        $count++;

        $count++;

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

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

            print "$prefix $line$eol";

            print "$prefix $line$eol";

        }

        }

    }

    }

}

}

    #

    #

    my $estate = ErrorReConfig ();

    my $estate = ErrorReConfig ();

    push @DebugStack, $estate;

    push @DebugStack, $estate;

    $::ScmDebug = $new_level if ( defined $new_level && $new_level );

    $::ScmDebug = $new_level if ( defined $new_level && $new_level );

    return $::ScmDebug;

    return $::ScmDebug;

}

}

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

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