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