Subversion Repositories DevTools

Rev

Rev 6177 | Rev 6276 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 6177 Rev 6198
Line 7... Line 7...
7 
# Environment(s): jats
 7 
# Environment(s): jats
8 
#
 8 
#
9 
# Description   : A Perl Package to perform error handling within JATS
 9 
# Description   : A Perl Package to perform error handling within JATS
10 
#
 10 
#
11 
#                 Uses global variables
 11 
#                 Uses global variables
12 
#                       $::ScmWho;
 - 
 
13 
#                       $::ScmVerbose;
 12 
#                       $::ScmVerbose;
14 
#                       $::ScmQuiet;
 13 
#                       $::ScmQuiet;
15 
#                       $::ScmDebug;
 14 
#                       $::ScmDebug;
16 
#                 For use with existing scripts
 15 
#                 For use with existing scripts
17 
#
 16 
#
18 
#
 - 
 
19 
#......................................................................#
 17 
#......................................................................#
20 
 
 18 
 
21 
package JatsError;
 19 
package JatsError;
22 
use base qw(Exporter);
 20 
use base qw(Exporter);
23 
 
 21 
 
Line 25... Line 23...
25 
use strict;
 23 
use strict;
26 
use warnings;
 24 
use warnings;
27 
use Data::Dumper;
 25 
use Data::Dumper;
28 
use IO::Handle;
 26 
use IO::Handle;
29 
 
 27 
 
- 
 
 28 
# exported package globals go here
- 
 
 29 
#our $ScmVerbose;
- 
 
 30 
#our $ScmDebug;
- 
 
 31 
#our $ScmQuiet;
- 
 
 32 
our $ScmOnExit;
- 
 
 33 
our $ScmDelayExit;
- 
 
 34 
our $ScmErrorCount;
- 
 
 35 
our $ScmExitCode;
- 
 
 36 
 
- 
 
 37 
my $EPrefix = '';
- 
 
 38 
my $EName = '';
- 
 
 39 
my $EFn = '';
- 
 
 40 
my $ElPrefix = '';
- 
 
 41 
my $EIndent = '';
- 
 
 42 
my $EOffset = '';
- 
 
 43 
 
30 
#-------------------------------------------------------------------------------
 44 
#-------------------------------------------------------------------------------
31 
# Function        : BEGIN
 45 
# Function        : BEGIN
32 
#
 46 
#
33 
# Description     : Standard Package Interface
 47 
# Description     : Standard Package Interface
34 
#
 48 
#
Line 64... Line 78...
64 
    @EXPORT_OK   = qw();
 78 
    @EXPORT_OK   = qw();
65 
 
 79 
 
66 
    #
 80 
    #
67 
    #   Ensure globals have a defined value
 81 
    #   Ensure globals have a defined value
68 
    #
 82 
    #
69 
    $::ScmWho = ''                          unless defined( $::ScmWho );
 - 
 
70 
    $::ScmVerbose = $ENV{GBE_VERBOSE} || 0  unless defined( $::ScmVerbose );
 83 
    $::ScmVerbose = $ENV{GBE_VERBOSE} || 0  unless defined( $::ScmVerbose );
71 
    $::ScmDebug = $ENV{GBE_DEBUG} || 0      unless defined( $::ScmDebug );
 84 
    $::ScmDebug = $ENV{GBE_DEBUG} || 0      unless defined( $::ScmDebug );
72 
    $::ScmQuiet = 0                         unless defined( $::ScmQuiet );
 85 
    $::ScmQuiet = 0                         unless defined( $::ScmQuiet );
73 
 
 86 
 
- 
 
 87 
    $ScmErrorCount = 0;
- 
 
 88 
    $ScmExitCode = 1;
- 
 
 89 
 
74 
    #
 90 
    #
75 
    #   Force autoflush in an attempt to limit the intermingling of
 91 
    #   Force autoflush in an attempt to limit the intermingling of
76 
    #   Error and non-error output.
 92 
    #   Error and non-error output.
77 
    #
 93 
    #
78 
    STDOUT->autoflush(1);
 94 
    STDOUT->autoflush(1);
79 
    STDERR->autoflush(1);
 95 
    STDERR->autoflush(1);
80 
}
 96 
}
81 
 
 97 
 
82 
 
 - 
 
83 
 
 - 
 
84 
# exported package globals go here
 - 
 
85 
#our $ScmWho;
 - 
 
86 
#our $ScmVerbose;
 - 
 
87 
#our $ScmDebug;
 - 
 
88 
#our $ScmQuiet;
 - 
 
89 
our $ScmOnExit;
 - 
 
90 
our $ScmDelayExit;
 - 
 
91 
our $ScmErrorCount;
 - 
 
92 
our $ScmExitCode;
 - 
 
93 
 
 - 
 
94 
# non-exported package globals go here
 98 
# non-exported package globals go here
95 
$ScmErrorCount = 0;
 - 
 
96 
$ScmExitCode = 1;
 - 
 
97 
 
 - 
 
98 
 
 - 
 
99 
my $EName = '';
 - 
 
100 
my $EFn = '';
 - 
 
101 
my @captured;
 99 
my @captured;
102 
my $capturing;
 100 
my $capturing;
103 
 
 101 
 
104 
#  initialize package globals, first exported ones
 - 
 
105 
 
 - 
 
106 
 
 - 
 
107 
#-------------------------------------------------------------------------------
 102 
#-------------------------------------------------------------------------------
108 
# Function        : import
 103 
# Function        : import
109 
#
 104 
#
110 
# Description     : Package import function
 105 
# Description     : Package import function
111 
#                   This function will examine arguments provided in the
 106 
#                   This function will examine arguments provided in the
Line 115... Line 110...
115 
# Inputs          : $pack           - Name of this package
 110 
# Inputs          : $pack           - Name of this package
116 
#                   @vars           - User Config Options
 111 
#                   @vars           - User Config Options
117 
#                   Config Options:
 112 
#                   Config Options:
118 
#                       :name=xxxx
 113 
#                       :name=xxxx
119 
#                       :function=xxxx
 114 
#                       :function=xxxx
- 
 
 115 
#                       :prefix=xxxx
- 
 
 116 
#                       :indent=nn/xxx
- 
 
 117 
#                       :offset=nn/xxx
120 
#                       :quiet=xxx
 118 
#                       :quiet=xxx
121 
#                       :debug=xxx
 119 
#                       :debug=xxx
122 
#                       :verbose=xxx
 120 
#                       :verbose=xxx
123 
#                       :delay_exit=xxx
 121 
#                       :delay_exit=xxx
124 
#
 122 
#
Line 159... Line 157...
159 
#
 157 
#
160 
# Inputs          : A hash of option,value pairs
 158 
# Inputs          : A hash of option,value pairs
161 
#                   Valid options
 159 
#                   Valid options
162 
#                       name        - Name to report in error
 160 
#                       name        - Name to report in error
163 
#                       function    - Name of enclosing function
 161 
#                       function    - Name of enclosing function
- 
 
 162 
#                       prefix      - 1st line prefix
164 
#                       verbose     - vebosity level
 163 
#                       verbose     - vebosity level
165 
#                       debug       - debug level
 164 
#                       debug       - debug level
166 
#                       on_exit     - Register on-exit function
 165 
#                       on_exit     - Register on-exit function
167 
#                       delay_exit  - Delay exit on error
 166 
#                       delay_exit  - Delay exit on error
- 
 
 167 
#                       prefix      - Optional prefix. First line only
- 
 
 168 
#                       indent      - Optional. All lines (number or text)
- 
 
 169 
#                       offset      - Optional. Extra lines (number or text)
168 
#
 170 
#
169 
# Returns         :
 171 
# Returns         :
170 
#
 172 
#
171 
sub ErrorConfig
 173 
sub ErrorConfig
172 
{
 174 
{
173 
    my %args = @_;
 175 
    my %args = @_;
174 
 
 176 
 
175 
    while (my($key, $value) = each %args)
 177 
    while (my($key, $value) = each %args)
176 
    {
 178 
    {
177 
        if (       $key =~ /^name/ ) {
 179 
        if ( $key =~ /^name/ ) {
178 
            $EName = $value;
 180 
            $EName = $value;
179 
 
 181 
 
180 
        } elsif ( $key =~ /^function/ ) {
 182 
        } elsif ( $key =~ /^function/ ) {
181 
            $EFn = ':' . $value;
 183 
            $EFn = ':' . $value;
182 
 
 184 
 
- 
 
 185 
        } elsif ( $key =~ /^prefix/ ) {
- 
 
 186 
            $ElPrefix = $value;
- 
 
 187 
 
- 
 
 188 
        } elsif ( $key =~ /^indent/ ) {
- 
 
 189 
            my $pad = $value;
- 
 
 190 
            if ($pad =~ m~^\d+$~) {
- 
 
 191 
                $pad = ' ' x $value;
- 
 
 192 
            }
- 
 
 193 
            $EIndent = $EIndent . $pad;
- 
 
 194 
 
- 
 
 195 
        } elsif ( $key =~ /^offset/ ) {
- 
 
 196 
            $EOffset = $value;
- 
 
 197 
            if ($EOffset =~ m~^\d+$~) {
- 
 
 198 
                $EOffset = ' ' x $value;
- 
 
 199 
            }
- 
 
 200 
 
183 
        } elsif ( $key =~ /^debug/ ) {
 201 
        } elsif ( $key =~ /^debug/ ) {
184 
            $::ScmDebug = $value
 202 
            $::ScmDebug = $value
185 
                if ( defined $value && $value > $::ScmDebug  );
 203 
                if ( defined $value && $value > $::ScmDebug  );
186 
 
 204 
 
187 
        } elsif ( $key =~ /^verbose/ ) {
 205 
        } elsif ( $key =~ /^verbose/ ) {
Line 207... Line 225...
207 
 
 225 
 
208 
    #
 226 
    #
209 
    #   Calculate the prefix to all messages
 227 
    #   Calculate the prefix to all messages
210 
    #   Based on Name and Function( if provided
 228 
    #   Based on Name and Function( if provided
211 
    #
 229 
    #
212 
    $::ScmWho = "[$EName$EFn] ";
 230 
    $EPrefix = "[$EName$EFn] " if $EName;
213 
 
 231 
 
214 
    #
 232 
    #
215 
    #   Extract program specfic debug flags from the environment
 233 
    #   Extract program specfic debug flags from the environment
216 
    #   These will be based on the reporting 'name'
 234 
    #   These will be based on the reporting 'name'
217 
    #       GBE_name_DEBUG
 235 
    #       GBE_name_DEBUG
Line 274... Line 292...
274 
    #   The error information will be restored when the handle returned to
 292 
    #   The error information will be restored when the handle returned to
275 
    #   the user goes out of scope.
 293 
    #   the user goes out of scope.
276 
    #
 294 
    #
277 
    my $self;
 295 
    my $self;
278 
 
 296 
 
- 
 
 297 
    $self->{EPrefix}        =  $EPrefix;
- 
 
 298 
    $self->{ElPrefix}       =  $ElPrefix;
- 
 
 299 
    $self->{EIndent}        =  $EIndent;
279 
    $self->{ScmWho}         =  $::ScmWho;
 300 
    $self->{EOffset}        =  $EOffset;
280 
    $self->{ScmVerbose}     =  $::ScmVerbose;
 301 
    $self->{ScmVerbose}     =  $::ScmVerbose;
281 
    $self->{ScmDebug}       =  $::ScmDebug;
 302 
    $self->{ScmDebug}       =  $::ScmDebug;
282 
    $self->{ScmQuiet}       =  $::ScmQuiet;
 303 
    $self->{ScmQuiet}       =  $::ScmQuiet;
283 
    $self->{ScmOnExit}      =  $ScmOnExit;
 304 
    $self->{ScmOnExit}      =  $ScmOnExit;
284 
    $self->{ScmDelayExit}   =  $ScmDelayExit;
 305 
    $self->{ScmDelayExit}   =  $ScmDelayExit;
Line 302... Line 323...
302 
}
 323 
}
303 
 
 324 
 
304 
#-------------------------------------------------------------------------------
 325 
#-------------------------------------------------------------------------------
305 
# Function        : DESTROY
 326 
# Function        : DESTROY
306 
#
 327 
#
307 
# Description     : Called when the handle retruned by ErrorConfig goes out of
 328 
# Description     : Called when the handle returned by ErrorConfig goes out of
308 
#                   scope.
 329 
#                   scope.
309 
#
 330 
#
310 
#                   Restores the state of the Error Reporting information
 331 
#                   Restores the state of the Error Reporting information
311 
#
 332 
#
312 
# Inputs          : $self               - Created by ErrorReConfig
 333 
# Inputs          : $self               - Created by ErrorReConfig
Line 315... Line 336...
315 
#
 336 
#
316 
 
 337 
 
317 
sub DESTROY
 338 
sub DESTROY
318 
{
 339 
{
319 
    my ($self) = @_;
 340 
    my ($self) = @_;
- 
 
 341 
    $EPrefix          = $self->{EPrefix};
- 
 
 342 
    $ElPrefix         = $self->{ElPrefix};
- 
 
 343 
    $EIndent          = $self->{EIndent};
320 
    $::ScmWho         = $self->{ScmWho};
 344 
    $EOffset          = $self->{EOffset};
321 
    $::ScmVerbose     = $self->{ScmVerbose};
 345 
    $::ScmVerbose     = $self->{ScmVerbose};
322 
    $::ScmDebug       = $self->{ScmDebug};
 346 
    $::ScmDebug       = $self->{ScmDebug};
323 
    $::ScmQuiet       = $self->{ScmQuiet};
 347 
    $::ScmQuiet       = $self->{ScmQuiet};
324 
    $ScmOnExit        = $self->{ScmOnExit};
 348 
    $ScmOnExit        = $self->{ScmOnExit};
325 
    $ScmDelayExit     = $self->{ScmDelayExit};
 349 
    $ScmDelayExit     = $self->{ScmDelayExit};
Line 359... Line 383...
359 
    #
 383 
    #
360 
    #   Generate the message prefix
 384 
    #   Generate the message prefix
361 
    #   This will only be used on the first line
 385 
    #   This will only be used on the first line
362 
    #   All other lines will have a space filled prefix
 386 
    #   All other lines will have a space filled prefix
363 
    #
 387 
    #
364 
    my $prefix = $::ScmWho . $tag;
 388 
    my $prefix = $EPrefix . $tag. $EIndent;
365 
    #
 389 
    #
366 
    #   Kill the eol if the Question is being asked
 390 
    #   Kill the eol if the Question is being asked
367 
    #
 391 
    #
368 
    my $eol = ( $tag =~ m/Q/ ) ? "" : "\n";
 392 
    my $eol = ( $tag =~ m/Q/ ) ? "" : "\n";
369 
    foreach my $nextline ( @_ )
 393 
    foreach my $nextline ( @_ ) {
370 
    {
 - 
 
371 
        next unless ( defined $nextline );              # Ignore undefined arguments
 394 
        next unless ( defined $nextline );              # Ignore undefined arguments
372 
        chomp( my $line = $nextline );
 395 
        chomp( my $line = $nextline );
373 
        if ( $count == 1 )
 396 
        if ( $count == 0 ) {
- 
 
 397 
            $line = ($ElPrefix || '') . $line;
- 
 
 398 
 
374 
        {
 399 
        } elsif ( $count == 1 ) {
375 
            my $bol = $eol ? "" : "\n";
 400 
            my $bol = $eol ? "" : "\n";
376 
            $prefix = $bol . ' ' x length($prefix);
 401 
            $prefix = $bol . ' ' x length($prefix) . $EOffset;
377 
        }
 402 
        }
378 
        $count++;
 403 
        $count++;
379 
 
 404 
 
380 
        if ($capturing && $tag =~ m/[MWEF]/)
 405 
        if ($capturing && $tag =~ m/[MWEF]/) {
381 
        {
 - 
 
382 
            push @captured, "$prefix $line$eol"
406 
            push @captured, "$prefix $line$eol"
383 
        }
 407 
 
384 
        else
 408 
        } else {
385 
        {
 - 
 
386 
            print "$prefix $line$eol";
 409 
            print "$prefix $line$eol";
387 
        }
 410 
        }
388 
    }
 411 
    }
389 
}
 412 
}
390 
 
 413 
 
Line 790... Line 813...
790 
    #
 813 
    #
791 
    my $estate = ErrorReConfig ();
 814 
    my $estate = ErrorReConfig ();
792 
    push @DebugStack, $estate;
 815 
    push @DebugStack, $estate;
793
816
794 
    $::ScmDebug = $new_level if ( defined $new_level && $new_level );
 817 
    $::ScmDebug = $new_level if ( defined $new_level && $new_level );
795 
    $::ScmWho =   $name      if ( defined $name && $name );
 818 
    $EPrefix =   $name        if ( defined $name && $name );
796 
 
 819 
 
797 
    return $::ScmDebug;
 820 
    return $::ScmDebug;
798 
}
 821 
}
799 
 
 822 
 
800 
#-------------------------------------------------------------------------------
 823 
#-------------------------------------------------------------------------------