Subversion Repositories DevTools

Rev

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

Rev 263 Rev 279
Line 1... Line -...
1
#! perl
-
 
2
########################################################################
1
########################################################################
3
# Copyright ( C ) 2004 ERG Limited, All rights reserved
2
# Copyright ( C ) 2004-2009 ERG Limited, All rights reserved
4
#
3
#
5
# Module name   : jats
4
# Module name   : JatsError
6
# Module type   : Perl Package
5
# Module type   : Perl Package
7
# Compiler(s)   : n/a
6
# Compiler(s)   : Perl
8
# Environment(s): jats
7
# Environment(s): jats
9
#
8
#
10
# Description   : A Perl Package to perform error handling within JATS
9
# Description   : A Perl Package to perform error handling within JATS
11
#
10
#
12
#                 Uses global variables
11
#                 Uses global variables
Line 14... Line 13...
14
#                       $::ScmVerbose;
13
#                       $::ScmVerbose;
15
#                       $::ScmQuiet;
14
#                       $::ScmQuiet;
16
#                       $::ScmDebug;
15
#                       $::ScmDebug;
17
#                 For use with existing scripts
16
#                 For use with existing scripts
18
#
17
#
19
# Usage:
-
 
20
#
-
 
21
# Version   Who      Date        Description
-
 
22
#
18
#
23
#......................................................................#
19
#......................................................................#
24
 
20
 
25
require 5.006_001;
21
require 5.006_001;
26
use strict;
22
use strict;
Line 46... Line 42...
46
 
42
 
47
    # set the version for version checking
43
    # set the version for version checking
48
    $VERSION     = 1.00;
44
    $VERSION     = 1.00;
49
 
45
 
50
    @ISA         = qw(Exporter);
46
    @ISA         = qw(Exporter);
51
    @EXPORT      = qw(ErrorConfig ErrorDoExit
47
    @EXPORT      = qw(ErrorConfig ErrorReConfig ErrorDoExit
52
                      ReportError Fatal Error Warning
48
                      ReportError Fatal Error Warning
53
                      Message Message1
49
                      Message Message1
54
                      Information Information1
50
                      Information Information1
55
                      Question
51
                      Question
56
                      Verbose0 Verbose Verbose2 Verbose3
52
                      Verbose0 Verbose Verbose2 Verbose3
Line 86... Line 82...
86
 
82
 
87
# exported package globals go here
83
# exported package globals go here
88
#our $ScmWho;
84
#our $ScmWho;
89
#our $ScmVerbose;
85
#our $ScmVerbose;
90
#our $ScmDebug;
86
#our $ScmDebug;
-
 
87
#our $ScmQuiet;
91
our $ScmOnExit;
88
our $ScmOnExit;
92
our $ScmDelayExit;
89
our $ScmDelayExit;
93
our $ScmErrorCount;
90
our $ScmErrorCount;
94
our $ScmExitCode;
91
our $ScmExitCode;
95
 
92
 
96
# non-exported package globals go here
93
# non-exported package globals go here
97
$ScmErrorCount = 0;
94
$ScmErrorCount = 0;
98
$ScmExitCode = 1;
95
$ScmExitCode = 1;
99
 
96
 
-
 
97
my $EName = '';
-
 
98
my $EFn = '';
-
 
99
 
100
#  initialize package globals, first exported ones
100
#  initialize package globals, first exported ones
101
 
101
 
102
 
102
 
103
#-------------------------------------------------------------------------------
103
#-------------------------------------------------------------------------------
104
# Function        : import
104
# Function        : import
105
#
105
#
106
# Description     : Package import function
106
# Description     : Package import function
107
#                   This function will examine argumenst provided in the
107
#                   This function will examine arguments provided in the
108
#                   invoking 'uses' list and will configure the package
108
#                   invoking 'uses' list and will configure the package
109
#                   accordingly.
109
#                   accordingly.
110
#
110
#
111
# Inputs          : $pack           - Name of this package
111
# Inputs          : $pack           - Name of this package
112
#                   @vars           - User Config Options
112
#                   @vars           - User Config Options
113
#                   Config Options:
113
#                   Config Options:
114
#                       :name=xxxx
114
#                       :name=xxxx
-
 
115
#                       :function=xxxx
115
#                       :quiet=xxx
116
#                       :quiet=xxx
116
#                       :debug=xxx
117
#                       :debug=xxx
117
#                       :verbose=xxx
118
#                       :verbose=xxx
118
#                       :delay_exit=xxx
119
#                       :delay_exit=xxx
119
#
120
#
Line 148... Line 149...
148
 
149
 
149
#-------------------------------------------------------------------------------
150
#-------------------------------------------------------------------------------
150
# Function        : ErrorConfig
151
# Function        : ErrorConfig
151
#
152
#
152
# Description     : Configure aspects of the JATS error handle
153
# Description     : Configure aspects of the JATS error handle
-
 
154
#                   See ErrorReConfig
153
#
155
#
154
# Inputs          : A hash of option,value pairs
156
# Inputs          : A hash of option,value pairs
155
#                   Valid options
157
#                   Valid options
156
#                       name        - Name to report in error
158
#                       name        - Name to report in error
-
 
159
#                       function    - Name of enclosing function
157
#                       verbose     - vebosity level
160
#                       verbose     - vebosity level
158
#                       debug       - debug level
161
#                       debug       - debug level
159
#                       on_exit     - Register on-exit function
162
#                       on_exit     - Register on-exit function
160
#                       delay_exit  - Delay exit on error
163
#                       delay_exit  - Delay exit on error
161
#
164
#
162
# Returns         :
165
# Returns         :
163
#
166
#
164
sub ErrorConfig
167
sub ErrorConfig
165
{
168
{
166
    my %args = @_;
169
    my %args = @_;
167
    my $name;
-
 
168
 
170
 
169
    while (my($key, $value) = each %args)
171
    while (my($key, $value) = each %args)
170
    {
172
    {
171
        if (       $key =~ /^name/ ) {
173
        if (       $key =~ /^name/ ) {
172
            $::ScmWho = "[$value] ";
174
            $EName = $value;
-
 
175
 
-
 
176
        } elsif ( $key =~ /^function/ ) {
173
            $name = $value;
177
            $EFn = ':' . $value;
174
 
178
 
175
        } elsif ( $key =~ /^debug/ ) {
179
        } elsif ( $key =~ /^debug/ ) {
176
            $::ScmDebug = $value || 0;
180
            $::ScmDebug = $value
-
 
181
                if ( defined $value && $value > $::ScmDebug  );
177
 
182
 
178
        } elsif ( $key =~ /^verbose/ ) {
183
        } elsif ( $key =~ /^verbose/ ) {
179
            $::ScmVerbose = $value || 0;
184
            $::ScmVerbose = $value
-
 
185
                if ( defined $value && $value > $::ScmVerbose  );
180
 
186
 
181
        } elsif ( $key =~ /^quiet/ ) {
187
        } elsif ( $key =~ /^quiet/ ) {
182
            $::ScmQuiet = $value || 0;
188
            $::ScmQuiet = $value || 0;
183
 
189
 
184
        } elsif ( $key =~ /^on_exit/ ) {
190
        } elsif ( $key =~ /^on_exit/ ) {
Line 191... Line 197...
191
            Error("ErrorConfig, Unknown option: $key");
197
            Error("ErrorConfig, Unknown option: $key");
192
        }
198
        }
193
    }
199
    }
194
 
200
 
195
    #
201
    #
-
 
202
    #   Calculate the prefix to all messages
-
 
203
    #   Based on Name and Function( if provided
-
 
204
    #
-
 
205
    $::ScmWho = "[$EName$EFn] ";
-
 
206
 
-
 
207
    #
196
    #   Extract program specfic debug flags from the environment
208
    #   Extract program specfic debug flags from the environment
197
    #   These will be based on the reporting 'name'
209
    #   These will be based on the reporting 'name'
198
    #       GBE_name_DEBUG
210
    #       GBE_name_DEBUG
199
    #       GBE_name_VERBOSE
211
    #       GBE_name_VERBOSE
200
    #
212
    #
201
    if ( $name )
213
    if ( $EName )
202
    {
214
    {
203
        my ($value, $tag);
215
        my ($value, $tag);
204
 
216
 
205
        $tag = "GBE_${name}_DEBUG" ;
217
        $tag = "GBE_${EName}_DEBUG" ;
206
        $tag =~ s~\s+~~g;
218
        $tag =~ s~\s+~~g;
207
        $value = $ENV{ $tag };
219
        $value = $ENV{ $tag };
208
        if (defined $value)
220
        if (defined $value)
209
        {
221
        {
210
            $::ScmDebug = $value;
222
            $::ScmDebug = $value;
211
            Warning("Envar: $tag setting debug: $value");
223
            Warning("Envar: $tag setting debug: $value");
212
        }
224
        }
213
 
225
 
214
        $tag = "GBE_${name}_VERBOSE" ;
226
        $tag = "GBE_${EName}_VERBOSE" ;
215
        $tag =~ s~\s+~~g;
227
        $tag =~ s~\s+~~g;
216
        $value = $ENV{ $tag };
228
        $value = $ENV{ $tag };
217
        if (defined $value)
229
        if (defined $value)
218
        {
230
        {
219
            $::ScmVerbose = $value;
231
            $::ScmVerbose = $value;
Line 227... Line 239...
227
    #
239
    #
228
    $::ScmQuiet = 0 if ( $::ScmVerbose );
240
    $::ScmQuiet = 0 if ( $::ScmVerbose );
229
    $::ScmQuiet = 0 if ( $::ScmDebug );
241
    $::ScmQuiet = 0 if ( $::ScmDebug );
230
}
242
}
231
 
243
 
-
 
244
#-------------------------------------------------------------------------------
-
 
245
# Function        : ErrorReConfig
-
 
246
#
-
 
247
# Description     : Similar to ErrorConfig , except it is used to push and
-
 
248
#                   automatically pop the current state
-
 
249
#
-
 
250
#                   Intended to be used to control error reporting
-
 
251
#                   within a function. Let the class go out of scope
-
 
252
#                   at the end of the function.
-
 
253
#
-
 
254
#                   Not intended that the user hold and pass around the
-
 
255
#                   class ref as this may confuse all.
-
 
256
#
-
 
257
# Inputs          : As for ErrorConfig
-
 
258
#
-
 
259
# Returns         : Ref to a class
-
 
260
#                   When this goes out of scope the Error State will be
-
 
261
#                   restored.
-
 
262
#
-
 
263
sub ErrorReConfig
-
 
264
{
-
 
265
    #
-
 
266
    #   Create a small class to hold existing Error Information
-
 
267
    #   The error information will be restored when the handle returned to
-
 
268
    #   the user goes out of scope.
-
 
269
    #
-
 
270
    my $self;
-
 
271
 
-
 
272
    $self->{ScmWho}         =  $::ScmWho;
-
 
273
    $self->{ScmVerbose}     =  $::ScmVerbose;
-
 
274
    $self->{ScmDebug}       =  $::ScmDebug;
-
 
275
    $self->{ScmQuiet}       =  $::ScmQuiet;
-
 
276
    $self->{ScmOnExit}      =  $ScmOnExit;
-
 
277
    $self->{ScmDelayExit}   =  $ScmDelayExit;
-
 
278
    $self->{ScmErrorCount}  =  $ScmErrorCount;
-
 
279
    $self->{ScmExitCode}    =  $ScmExitCode;
-
 
280
    $self->{EName}          =  $EName;
-
 
281
    $self->{EFn}            =  $EFn;
-
 
282
    
-
 
283
    bless ($self, __PACKAGE__);
-
 
284
 
-
 
285
    #
-
 
286
    #   Invoke ErrorConfig to do the hard work
-
 
287
    #
-
 
288
    ErrorConfig (@_);
-
 
289
 
-
 
290
    #
-
 
291
    #   Return ref to stored data
-
 
292
    #
-
 
293
    return $self;
-
 
294
    
-
 
295
}
-
 
296
 
-
 
297
#-------------------------------------------------------------------------------
-
 
298
# Function        : DESTROY
-
 
299
#
-
 
300
# Description     : Called when the handle retruned by ErrorConfig goes out of
-
 
301
#                   scope.
-
 
302
#
-
 
303
#                   Restores the state of the Error Reporting information
-
 
304
#
-
 
305
# Inputs          : $self               - Created by ErrorReConfig
-
 
306
#
-
 
307
# Returns         : Nothing
-
 
308
#
-
 
309
 
-
 
310
sub DESTROY
-
 
311
{
-
 
312
    my ($self) = @_;
-
 
313
    $::ScmWho         = $self->{ScmWho};
-
 
314
    $::ScmVerbose     = $self->{ScmVerbose};
-
 
315
    $::ScmDebug       = $self->{ScmDebug};
-
 
316
    $::ScmQuiet       = $self->{ScmQuiet};
-
 
317
    $ScmOnExit        = $self->{ScmOnExit};
-
 
318
    $ScmDelayExit     = $self->{ScmDelayExit};
-
 
319
    $ScmErrorCount    = $self->{ScmErrorCount};
-
 
320
    $ScmExitCode      = $self->{ScmExitCode};
-
 
321
    $EFn              = $self->{EFn};
-
 
322
    $EName            = $self->{EName};
-
 
323
}
-
 
324
 
232
 
325
 
233
#-------------------------------------------------------------------------------
326
#-------------------------------------------------------------------------------
234
# Function        : Information
327
# Function        : Information
235
#                   Message
328
#                   Message
236
#                   Question
329
#                   Question
Line 617... Line 710...
617
# Function        : DebugPush
710
# Function        : DebugPush
618
#
711
#
619
# Description     : Save the current debug level and then use a new name and
712
# Description     : Save the current debug level and then use a new name and
620
#                   debug level for future reporting
713
#                   debug level for future reporting
621
#
714
#
-
 
715
#                   Provided for backward compatability
-
 
716
#                   Preferred solution is ErrorReConfig
-
 
717
#
622
# Inputs          : $name       - Nwe program name
718
# Inputs          : $name       - New program name
623
#                   $level      - New program debug level
719
#                   $level      - New program debug level
624
#
720
#
625
# Returns         : Current debug level
721
# Returns         : Current debug level
626
#
722
#
627
 
723
 
628
my @DebugStack = ();
724
my @DebugStack = ();
629
sub DebugPush
725
sub DebugPush
630
{
726
{
631
    my ($name, $new_level) = @_;
727
    my ($name, $new_level) = @_;
-
 
728
    my %args;
632
 
729
 
-
 
730
    #
633
    push @DebugStack, $::ScmDebug;
731
    #   Save current state on a stack
-
 
732
    #
-
 
733
    my $estate = ErrorReConfig ();
634
    push @DebugStack, $::ScmWho;
734
    push @DebugStack, $estate;
635
 
735
    
636
    $::ScmDebug = $new_level if ( defined $new_level && $new_level );
736
    $::ScmDebug = $new_level if ( defined $new_level && $new_level );
637
    $::ScmWho =   $name      if ( defined $name && $name );
737
    $::ScmWho =   $name      if ( defined $name && $name );
638
 
738
 
639
    return $::ScmDebug;
739
    return $::ScmDebug;
640
}
740
}
Line 646... Line 746...
646
#
746
#
647
# Inputs          : None
747
# Inputs          : None
648
#
748
#
649
sub DebugPop
749
sub DebugPop
650
{
750
{
651
    $::ScmWho   = pop @DebugStack;
-
 
652
    $::ScmDebug = pop @DebugStack;
751
    pop @DebugStack;
653
}
752
}
654
 
753
 
655
#-------------------------------------------------------------------------------
754
#-------------------------------------------------------------------------------
656
# Function        : DebugDumpPackage
755
# Function        : DebugDumpPackage
657
#
756
#