Bio/Root/Global.pm

   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 A. Chervitz (sac@genome.stanford.edu)
   6 # CREATED : 3 Sep 1996
   7 # REVISION: $Id$
   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
  65 BEGIN {
  66     use vars qw($CGI $TIMEOUT_SECS);
  67
  68     # $CGI is a boolean to indicate if the script is running as a CGI.
  69     # Useful for conditionally producing HTML-formatted messages
  70     # or suppressing messages appropriate only for interactive sessions.
  71
  72     $CGI = 1 if $ENV{REMOTE_ADDR} || $ENV{REMOTE_HOST};
  73 }
  74
  75 use Exporter ();
  76 use vars qw($BASE_YEAR @DAYS @MONTHS);
  77
  78 @ISA       = qw( Exporter );
  79 @EXPORT_OK = qw($AUTHORITY $NEWLINE
  80                 $DEBUG $MONITOR $TESTING
  81                 $DONT_WARN $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
  82                 $STRICTNESS $VERBOSITY $TIMEOUT_SECS
  83                 $CGI $GLOBAL
  84                 $BASE_YEAR %ROMAN_NUMS @MONTHS @DAYS
  85                 &roman2int &debug &monitor &testing &dont_warn &record_err
  86                 &warn_on_fatal &fatal_on_warn &strictness &verbosity
  87                 );
  88
  89 %EXPORT_TAGS = (
  90
  91                 std   =>[qw($DEBUG $MONITOR $TESTING $NEWLINE
  92                             $DONT_WARN $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
  93                             $STRICTNESS $VERBOSITY
  94                             &debug &monitor &testing &dont_warn
  95                             &warn_on_fatal &fatal_on_warn &record_err
  96                             &strictness &verbosity
  97                             &roman2int $AUTHORITY $CGI $GLOBAL)],
  98
  99                 obj   =>[qw($GLOBAL)],
 100
 101                 devel =>[qw($DEBUG $MONITOR $TESTING $DONT_WARN
 102                             $WARN_ON_FATAL $FATAL_ON_WARN $RECORD_ERR
 103                             $STRICTNESS $VERBOSITY $NEWLINE
 104                             &debug &monitor &testing &dont_warn
 105                             &strictness &verbosity
 106                             &warn_on_fatal &fatal_on_warn)],
 107
 108                 data  =>[qw($BASE_YEAR %ROMAN_NUMS @MONTHS @DAYS)],
 109
 110                 );
 111
 112 # Note: record_err() is not included in the devel tag to allow Bio::Root:Object.pm
 113 #       to define it without a name clash.
 114
 115 ######################################
 116 ##             Data                 ##
 117 ######################################
 118
 119 # Who should receive feedback from users and possibly automatic error messages.
 120 $AUTHORITY     = 'sac@genome.stanford.edu';
 121
 122 $DEBUG         = 0;
 123 $MONITOR       = 0;
 124 $TESTING       = 0;
 125 $DONT_WARN     = 0;
 126 $WARN_ON_FATAL = 0;
 127 $FATAL_ON_WARN = 0;
 128 $RECORD_ERR    = 0;
 129 $STRICTNESS    = 0;
 130 $VERBOSITY     = 0;
 131 $TIMEOUT_SECS  = 30;  # Number of seconds to wait for input in I/O functions.
 132
 133 $BASE_YEAR = 1900;
 134 $NEWLINE   = $ENV{'NEWLINE'} || undef;
 135
 136 %ROMAN_NUMS  = ('1'=>'I',    '2'=>'II',    '3'=>'III',    '4'=>'IV',    '5'=>'V',
 137                 '6'=>'VI',   '7'=>'VII',   '8'=>'VIII',   '9'=>'IX',   '10'=>'X',
 138                '11'=>'XI',  '12'=>'XII',  '13'=>'XIII',  '14'=>'XIV',  '15'=>'XV',
 139                '16'=>'XVI', '17'=>'XVII', '18'=>'XVIII', '19'=>'XIX',  '20'=>'XX',
 140                '21'=>'XXI', '22'=>'XXII',
 141                 );
 142
 143 @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 144 @DAYS   = qw(Sun Mon Tue Wed Thu Fri Sat);
 145
 146 # The implicit global object. Used for trapping miscellaneous errors/exceptions.
 147 # Created without using or requiring Bio::Root::Object.pm, because Object.pm uses Global.pm.
 148 # Just be sure to use Bio::Root::Object.pm, or a module that uses it.
 149
 150 $GLOBAL = {};
 151 bless $GLOBAL, 'Bio::Root::Object';
 152 $GLOBAL->{'_name'} = 'Global object';
 153
 154
 155 ######################################
 156 ##         Methods                  ##
 157 ######################################
 158
 159 sub roman2int {
 160     my $roman = uc(shift);
 161     foreach (keys %ROMAN_NUMS) {
 162         return $_ if $ROMAN_NUMS{$_} eq $roman;
 163     }
 164 # Alternatively:
 165 #    my @int = grep $ROMAN_NUMS{$_} eq $roman, keys %ROMAN_NUMS;
 166 #    return $int[0];
 167     undef;
 168 }
 169
 170 sub debug {
 171     my $level = shift;
 172     if( defined $level) { $DEBUG = $level }
 173     else { $DEBUG = 0 }
 174 #    $MONITOR and do{ print STDERR $DEBUG ? "Debug on ($DEBUG).\n\n" : "Debug off.\n\n"; };
 175     $MONITOR and do{ print STDERR $DEBUG ? "Debug on ($DEBUG).\n\n" : ""; };
 176     $DEBUG;
 177 }
 178
 179 sub monitor {
 180     my $level = shift;
 181     if( defined $level) { $MONITOR = $level }
 182     else { $MONITOR = 0 }
 183     $DEBUG and (print STDERR "Monitor on ($MONITOR).\n\n");
 184     $MONITOR;
 185 }
 186
 187 sub testing {
 188     my $level = shift;
 189     if( defined $level) { $TESTING = $level }
 190     else { $TESTING = 0 }
 191     $TESTING ? ($MONITOR && print STDERR "Testing on ($TESTING).\n\n") : ($MONITOR && print STDERR "Testing off.\n\n");
 192     $TESTING;
 193 }
 194
 195 sub strictness {
 196 # Values can integers from -2 to 2
 197 # See Bio::Root::Object::strict() for more explanation.
 198     my $arg = shift;
 199     if( defined $arg) { $STRICTNESS = $arg}
 200     $DEBUG && print STDERR "\n*** STRICTNESS: $arg ***\n\n";
 201     $STRICTNESS;
 202 }
 203
 204 sub verbosity {
 205 # Values can integers from -1 to 1
 206 # See Bio::Root::Object::verbose() for more explanation.
 207     my $arg = shift;
 208     if( defined $arg) { $VERBOSITY = $arg}
 209     $DEBUG && print STDERR "\n*** VERBOSITY: $arg ***\n\n";
 210     $VERBOSITY;
 211 }
 212
 213 sub record_err {
 214     if( defined shift) { $RECORD_ERR = 1}
 215     else { $RECORD_ERR = 0 }
 216     $RECORD_ERR ? ($DEBUG && print STDERR "\n*** RECORD_ERR on. ***\n\n") : ($DEBUG && print STDERR "RECORD_ERR off.\n\n");
 217     $RECORD_ERR;
 218 }
 219
 220 ##
 221 ## The following methods are deprecated and will eventually be removed.
 222 ##
 223
 224 sub dont_warn {
 225     my $arg = shift;
 226     !$CGI and print STDERR "\n$0: Deprecated method dont_warn() called. Use verbosity(-1) instead\n";
 227     if( $arg) { verbosity(-1)}
 228     else { verbosity(0); }
 229 }
 230
 231 sub warn_on_fatal {
 232     my $arg = shift;
 233     !$CGI and print STDERR "\n$0: Deprecated method warn_on_fatal() called. Use strictness(-2) instead\n";
 234     if( $arg) { strictness(-2)}
 235     else { strictness(0); }
 236 }
 237
 238 sub fatal_on_warn {
 239     my $arg = shift;
 240     !$CGI and print STDERR "\n$0: Deprecated method fatal_on_warn() called. Use strictness(2) instead\n";
 241     if( $arg) { strictness(2)}
 242     else { strictness(0); }
 243 }
 244
 245 #####################################################################################
 246 #                            END OF PACKAGE
 247 #####################################################################################
 248
 249 1;