|
0
|
1 #--------------------------------------------------------------------------------
|
|
|
2 # PACKAGE : Bio::Root::Global.pm
|
|
|
3 # PURPOSE : Provides global data, objects, and methods potentially useful to
|
|
|
4 # many different modules and scripts.
|
|
|
5 # AUTHOR : Steve Chervitz (sac@bioperl.org)
|
|
|
6 # CREATED : 3 Sep 1996
|
|
|
7 # REVISION: $Id: Global.pm,v 1.8 2002/01/11 08:05:31 sac Exp $
|
|
|
8 #
|
|
|
9 # INSTALLATION:
|
|
|
10 # This module is included with the central Bioperl distribution:
|
|
|
11 # http://bio.perl.org/Core/Latest
|
|
|
12 # ftp://bio.perl.org/pub/DIST
|
|
|
13 # Follow the installation instructions included in the README file.
|
|
|
14 #
|
|
|
15 # COMMENTS: Edit the $AUTHORITY string to a desired e-mail address.
|
|
|
16 #
|
|
|
17 # STRICTNESS, VERBOSITY, and variables containing the words WARN and FATAL
|
|
|
18 # are considered experimental. The purpose & usage of these is explained
|
|
|
19 # in Bio::Root::Object.pm.
|
|
|
20 #
|
|
|
21 # MODIFIED:
|
|
|
22 # sac --- Fri Jan 8 00:04:28 1999
|
|
|
23 # * Added BEGIN block to set $CGI if script is running as a cgi.
|
|
|
24 # sac --- Tue Dec 1 1998
|
|
|
25 # * Added $STRICTNESS and $VERBOSITY.
|
|
|
26 # * Deprecated WARN_ON_FATAL, FATAL_ON_WARN, DONT_WARN and related methods.
|
|
|
27 # These will eventually be removed.
|
|
|
28 # sac --- Fri 5 Jun 1998: Added @DAYS.
|
|
|
29 # sac --- Sun Aug 16 1998: Added $RECORD_ERR and &record_err().
|
|
|
30 #--------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 ### POD Documentation:
|
|
|
33
|
|
|
34 =head1 NAME
|
|
|
35
|
|
|
36 Bio::Root::Global - Global variables and utility functions
|
|
|
37
|
|
|
38 =head1 SYNOPSIS
|
|
|
39
|
|
|
40 # no real synopsis - see Bio::Root::Object
|
|
|
41
|
|
|
42 =head1 DESCRIPTION
|
|
|
43
|
|
|
44 The Bio::Root::Global file contains all the global flags
|
|
|
45 about erro warning etc, and also utility functions, eg
|
|
|
46 to map numbers to roman numerals.
|
|
|
47
|
|
|
48 These functions are generally called by Bio::Root::Object
|
|
|
49 or somewhere similar, and not directly
|
|
|
50
|
|
|
51
|
|
|
52 =head1 INSTALLATION
|
|
|
53
|
|
|
54 This module is included with the central Bioperl distribution:
|
|
|
55
|
|
|
56 http://bio.perl.org/Core/Latest
|
|
|
57 ftp://bio.perl.org/pub/DIST
|
|
|
58
|
|
|
59 Follow the installation instructions included in the README file.
|
|
|
60
|
|
|
61 =cut
|
|
|
62
|
|
|
63 package Bio::Root::Global;
|
|
|
64 use strict;
|
|
|
65
|
|
|
66 BEGIN {
|
|
|
67 use vars qw($CGI $TIMEOUT_SECS);
|
|
|
68
|
|
|
69 # $CGI is a boolean to indicate if the script is running as a CGI.
|
|
|
70 # Useful for conditionally producing HTML-formatted messages
|
|
|
71 # or suppressing messages appropriate only for interactive sessions.
|
|
|
72
|
|
|
73 $CGI = 1 if $ENV{REMOTE_ADDR} || $ENV{REMOTE_HOST};
|
|
|
74 }
|
|
|
75
|
|
|
76 use Exporter ();
|
|
|
77 use vars qw($BASE_YEAR @DAYS @MONTHS);
|
|
|
78
|
|
|
79 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
|
|
|
80 @ISA = qw( Exporter );
|
|
|
81 @EXPORT_OK = qw($AUTHORITY $NEWLINE
|
|
|
82 $DEBUG $MONITOR $TESTING
|
|
|
83 $DONT_WARN $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
|
|
|
84 $STRICTNESS $VERBOSITY $TIMEOUT_SECS
|
|
|
85 $CGI $GLOBAL
|
|
|
86 $BASE_YEAR %ROMAN_NUMS @MONTHS @DAYS
|
|
|
87 &roman2int &debug &monitor &testing &dont_warn &record_err
|
|
|
88 &warn_on_fatal &fatal_on_warn &strictness &verbosity
|
|
|
89 );
|
|
|
90
|
|
|
91 %EXPORT_TAGS = (
|
|
|
92
|
|
|
93 std =>[qw($DEBUG $MONITOR $TESTING $NEWLINE
|
|
|
94 $DONT_WARN $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
|
|
|
95 $STRICTNESS $VERBOSITY
|
|
|
96 &debug &monitor &testing &dont_warn
|
|
|
97 &warn_on_fatal &fatal_on_warn &record_err
|
|
|
98 &strictness &verbosity
|
|
|
99 &roman2int $AUTHORITY $CGI $GLOBAL)],
|
|
|
100
|
|
|
101 obj =>[qw($GLOBAL)],
|
|
|
102
|
|
|
103 devel =>[qw($DEBUG $MONITOR $TESTING $DONT_WARN
|
|
|
104 $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
|
|
|
105 $STRICTNESS $VERBOSITY $NEWLINE
|
|
|
106 &debug &monitor &testing &dont_warn
|
|
|
107 &strictness &verbosity
|
|
|
108 &warn_on_fatal &fatal_on_warn)],
|
|
|
109
|
|
|
110 data =>[qw($BASE_YEAR %ROMAN_NUMS @MONTHS @DAYS)],
|
|
|
111
|
|
|
112 );
|
|
|
113
|
|
|
114 # Note: record_err() is not included in the devel tag to allow Bio::Root:Object.pm
|
|
|
115 # to define it without a name clash.
|
|
|
116
|
|
|
117 ######################################
|
|
|
118 ## Data ##
|
|
|
119 ######################################
|
|
|
120
|
|
|
121 use vars qw($AUTHORITY $DEBUG $MONITOR $TESTING $DONT_WARN $WARN_ON_FATAL
|
|
|
122 $FATAL_ON_WARN $RECORD_ERR $STRICTNESS $VERBOSITY $NEWLINE
|
|
|
123 %ROMAN_NUMS $GLOBAL);
|
|
|
124
|
|
|
125 # Who should receive feedback from users and possibly automatic error messages.
|
|
|
126 $AUTHORITY = 'sac@bioperl.org';
|
|
|
127
|
|
|
128 $DEBUG = 0;
|
|
|
129 $MONITOR = 0;
|
|
|
130 $TESTING = 0;
|
|
|
131 $DONT_WARN = 0;
|
|
|
132 $WARN_ON_FATAL = 0;
|
|
|
133 $FATAL_ON_WARN = 0;
|
|
|
134 $RECORD_ERR = 0;
|
|
|
135 $STRICTNESS = 0;
|
|
|
136 $VERBOSITY = 0;
|
|
|
137 $TIMEOUT_SECS = 30; # Number of seconds to wait for input in I/O functions.
|
|
|
138
|
|
|
139 $BASE_YEAR = 1900;
|
|
|
140 $NEWLINE = $ENV{'NEWLINE'} || undef;
|
|
|
141
|
|
|
142 %ROMAN_NUMS = ('1'=>'I', '2'=>'II', '3'=>'III', '4'=>'IV', '5'=>'V',
|
|
|
143 '6'=>'VI', '7'=>'VII', '8'=>'VIII', '9'=>'IX', '10'=>'X',
|
|
|
144 '11'=>'XI', '12'=>'XII', '13'=>'XIII', '14'=>'XIV', '15'=>'XV',
|
|
|
145 '16'=>'XVI', '17'=>'XVII', '18'=>'XVIII', '19'=>'XIX', '20'=>'XX',
|
|
|
146 '21'=>'XXI', '22'=>'XXII',
|
|
|
147 );
|
|
|
148
|
|
|
149 @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
|
|
150 @DAYS = qw(Sun Mon Tue Wed Thu Fri Sat);
|
|
|
151
|
|
|
152 # The implicit global object. Used for trapping miscellaneous errors/exceptions.
|
|
|
153 # Created without using or requiring Bio::Root::Object.pm, because Object.pm uses Global.pm.
|
|
|
154 # Just be sure to use Bio::Root::Object.pm, or a module that uses it.
|
|
|
155
|
|
|
156 $GLOBAL = {};
|
|
|
157 bless $GLOBAL, 'Bio::Root::Object';
|
|
|
158 $GLOBAL->{'_name'} = 'Global object';
|
|
|
159
|
|
|
160
|
|
|
161 ######################################
|
|
|
162 ## Methods ##
|
|
|
163 ######################################
|
|
|
164
|
|
|
165 sub roman2int {
|
|
|
166 my $roman = uc(shift);
|
|
|
167 foreach (keys %ROMAN_NUMS) {
|
|
|
168 return $_ if $ROMAN_NUMS{$_} eq $roman;
|
|
|
169 }
|
|
|
170 # Alternatively:
|
|
|
171 # my @int = grep $ROMAN_NUMS{$_} eq $roman, keys %ROMAN_NUMS;
|
|
|
172 # return $int[0];
|
|
|
173 undef;
|
|
|
174 }
|
|
|
175
|
|
|
176 sub debug {
|
|
|
177 my $level = shift;
|
|
|
178 if( defined $level) { $DEBUG = $level }
|
|
|
179 else { $DEBUG = 0 }
|
|
|
180 # $MONITOR and do{ print STDERR $DEBUG ? "Debug on ($DEBUG).\n\n" : "Debug off.\n\n"; };
|
|
|
181 $MONITOR and do{ print STDERR $DEBUG ? "Debug on ($DEBUG).\n\n" : ""; };
|
|
|
182 $DEBUG;
|
|
|
183 }
|
|
|
184
|
|
|
185 sub monitor {
|
|
|
186 my $level = shift;
|
|
|
187 if( defined $level) { $MONITOR = $level }
|
|
|
188 else { $MONITOR = 0 }
|
|
|
189 $DEBUG and (print STDERR "Monitor on ($MONITOR).\n\n");
|
|
|
190 $MONITOR;
|
|
|
191 }
|
|
|
192
|
|
|
193 sub testing {
|
|
|
194 my $level = shift;
|
|
|
195 if( defined $level) { $TESTING = $level }
|
|
|
196 else { $TESTING = 0 }
|
|
|
197 $TESTING ? ($MONITOR && print STDERR "Testing on ($TESTING).\n\n") : ($MONITOR && print STDERR "Testing off.\n\n");
|
|
|
198 $TESTING;
|
|
|
199 }
|
|
|
200
|
|
|
201 sub strictness {
|
|
|
202 # Values can integers from -2 to 2
|
|
|
203 # See Bio::Root::Object::strict() for more explanation.
|
|
|
204 my $arg = shift;
|
|
|
205 if( defined $arg) { $STRICTNESS = $arg}
|
|
|
206 $DEBUG && print STDERR "\n*** STRICTNESS: $arg ***\n\n";
|
|
|
207 $STRICTNESS;
|
|
|
208 }
|
|
|
209
|
|
|
210 sub verbosity {
|
|
|
211 # Values can integers from -1 to 1
|
|
|
212 # See Bio::Root::Object::verbose() for more explanation.
|
|
|
213 my $arg = shift;
|
|
|
214 if( defined $arg) { $VERBOSITY = $arg}
|
|
|
215 $DEBUG && print STDERR "\n*** VERBOSITY: $arg ***\n\n";
|
|
|
216 $VERBOSITY;
|
|
|
217 }
|
|
|
218
|
|
|
219 sub record_err {
|
|
|
220 if( defined shift) { $RECORD_ERR = 1}
|
|
|
221 else { $RECORD_ERR = 0 }
|
|
|
222 $RECORD_ERR ? ($DEBUG && print STDERR "\n*** RECORD_ERR on. ***\n\n") : ($DEBUG && print STDERR "RECORD_ERR off.\n\n");
|
|
|
223 $RECORD_ERR;
|
|
|
224 }
|
|
|
225
|
|
|
226 ##
|
|
|
227 ## The following methods are deprecated and will eventually be removed.
|
|
|
228 ##
|
|
|
229
|
|
|
230 sub dont_warn {
|
|
|
231 my $arg = shift;
|
|
|
232 !$CGI and print STDERR "\n$0: Deprecated method dont_warn() called. Use verbosity(-1) instead\n";
|
|
|
233 if( $arg) { verbosity(-1)}
|
|
|
234 else { verbosity(0); }
|
|
|
235 }
|
|
|
236
|
|
|
237 sub warn_on_fatal {
|
|
|
238 my $arg = shift;
|
|
|
239 !$CGI and print STDERR "\n$0: Deprecated method warn_on_fatal() called. Use strictness(-2) instead\n";
|
|
|
240 if( $arg) { strictness(-2)}
|
|
|
241 else { strictness(0); }
|
|
|
242 }
|
|
|
243
|
|
|
244 sub fatal_on_warn {
|
|
|
245 my $arg = shift;
|
|
|
246 !$CGI and print STDERR "\n$0: Deprecated method fatal_on_warn() called. Use strictness(2) instead\n";
|
|
|
247 if( $arg) { strictness(2)}
|
|
|
248 else { strictness(0); }
|
|
|
249 }
|
|
|
250
|
|
|
251 #####################################################################################
|
|
|
252 # END OF PACKAGE
|
|
|
253 #####################################################################################
|
|
|
254
|
|
|
255 1;
|
|
|
256
|
|
|
257
|
|
|
258
|
|
|
259
|
|
|
260
|
|
|
261
|
