[Bio] / FigKernelPackages / Tracer.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Tracer.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.95, Fri Apr 18 18:06:12 2008 UTC revision 1.98, Thu May 1 07:52:10 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing ScriptSetup ScriptFinish Insure ChDir Emergency);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency);
24      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
25      use strict;      use strict;
26      use Carp qw(longmess croak);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
29      use FIG_Config;      use FIG_Config;
# Line 160  Line 160 
160    
161  Sometimes, you need a way for tracing to happen automatically without putting parameters  Sometimes, you need a way for tracing to happen automatically without putting parameters
162  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing
163  from the debug form, which is accessed from I<MySeedInstance>C</FIG/Html/SetPassword.html>.  from the debug form, which is accessed from the [[DebugConsole]]. Emergency tracing requires
164  Emergency tracing requires you specify a tracing key. For command-line tools, the key is  that you specify a tracing key. For command-line tools, the key is
165  taken from the C<TRACING> environment variable. For web services, the key is taken from  taken from the C<TRACING> environment variable. For web services, the key is taken from
166  a cookie. Either way, the key tells the tracing facility who you are, so that you control  a cookie. Either way, the key tells the tracing facility who you are, so that you control
167  the tracing in your environment without stepping on other users.  the tracing in your environment without stepping on other users.
# Line 184  Line 184 
184    
185  The web script will look for the tracing key in the cookies, and the command-line  The web script will look for the tracing key in the cookies, and the command-line
186  script will look for it in the C<TRACING> environment variable. If you are  script will look for it in the C<TRACING> environment variable. If you are
187  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardSetup> method or a [[WebApplication]], emergency tracing
188  will be configured automatically.  will be configured automatically.
189    
 NOTE: to configure emergency tracing from the command line instead of the Debugging  
 Control Panel (see below), use the C<trace.pl> script.  
   
 =head3 Debugging Control Panel  
   
 The debugging control panel provides several tools to assist in development of  
 SEED and Sprout software. You access the debugging control panel from the URL  
 C</FIG/Html/SetPassword.html> in whichever seed instance you're using. (So,  
 for example, the panel access point for the development NMPDR system is  
 C<http://web-1.nmpdr.org/next/FIG/Html/SetPassword.html>. Contact Bruce to  
 find out what the password is. From this page, you can also specify a tracing  
 key. If you don't specify a key, one will be generated for you.  
   
 =head4 Emergency Tracing Form  
   
 At the bottom of the debugging control panel is a form that allows you to  
 specify a trace level and tracing categories. Special and common categories  
 are listed with check boxes. You can hold your mouse over a check box to see  
 what its category does. In general, however, a category name is the same as  
 the name of the package in which the trace message occurs.  
   
 Additional categories can be entered in an input box, delimited by spaces or commas.  
   
 The B<Activate> button turns on Emergency tracing at the level you specify with the  
 specified categories active. The B<Terminate> button turns tracing off. The  
 B<Show File> button displays the current contents of the trace file. The tracing  
 form at the bottom of the control panel is designed for emergency tracing, so it  
 will only affect programs that call L</ETracing>, L</StandardScript>,  
 or L</StandardSetup>.  
   
 =head4 Script Form  
   
 The top form of the debugging control panel allows you to enter a tiny script and  
 have the output generated in a formatted table. Certain object variables are  
 predefined in the script, including a FIG object (C<$fig>), a CGI object (C<$cgi>),  
 and-- if Sprout is active-- Sprout (C<$sprout>) and SFXlate (C<$sfx>) objects.  
   
 The last line of the script must be a scalar, but it can be a reference to a hash,  
 a list, a list of lists, and various other combinations. If you select the appropriate  
 data type in the dropdown box, the output will be formatted accordingly. The form  
 also has controls for specifying tracing. These controls override any emergency  
 tracing in effect.  
   
 =head4 Database Query Forms  
   
 The forms between the script form and the emergency tracing form allow you to  
 make queries against the database. The FIG query form allows simple queries against  
 a single FIG table. The Sprout query form uses the B<GetAll> method to do a  
 multi-table query against the Sprout database. B<GetAll> is located in the B<ERDB>  
 package, and it takes five parameters.  
   
     GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count);  
   
 Each of the five parameters corresponds to a text box on the query form:  
   
 =over 4  
   
 =item Objects  
   
 Comma-separated list containing the names of the entity and relationship objects to be retrieved.  
   
 =item Filter  
   
 WHERE/ORDER BY clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can  
 be parameterized with parameter markers (C<?>). Each field used must be specified in the standard form  
 B<I<objectName>(I<fieldName>)> or B<$I<number>(I<fieldName>)> where I<fieldName> is the name of a  
 field, I<objectName> is the name of the entity or relationship object containing the field, and  
 I<number> is the 1-based position of the object in the object list. Any parameters  
 specified in the filter clause should be specified in the B<Params> field.  
 The fields in a filter clause can come from primary entity relations,  
 relationship relations, or secondary entity relations; however, all of the  
 entities and relationships involved must be included in the list of object names.  
   
 =item Params  
   
 List of the parameters to be substituted in for the parameters marks in the filter clause. This  
 is a comma-separated list without any quoting or escaping.  
   
 =item fields  
   
 Comma-separated list of the fields to be returned in each element of the list returned. Fields  
 are specified in the same manner as in the filter clause.  
   
 =item count  
   
 Maximum number of records to return. If omitted or 0, all available records will be returned.  
   
 =back  
   
 B<GetAll> automatically joins together the entities and relationships listed in the object  
 names. This simplifies the coding of the filter clause, but it means that some queries are  
 not possible, since they cannot be expressed in a linear sequence of joins. This is a limitation  
 that has yet to be addressed.  
   
190  =cut  =cut
191    
192  # Declare the configuration variables.  # Declare the configuration variables.
# Line 290  Line 196 
196                              # standard output                              # standard output
197  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
198                              # hash of active category names                              # hash of active category names
199    my @LevelNames = qw(error warn notice info detail);
200  my $TraceLevel = 0;         # trace level; a higher trace level produces more  my $TraceLevel = 0;         # trace level; a higher trace level produces more
201                              # messages                              # messages
202  my @Queue = ();             # queued list of trace messages.  my @Queue = ();             # queued list of trace messages.
203  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
204    my $LastLevel = 0;          # level of the last test call
205  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
206  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
207    
# Line 366  Line 274 
274          }          }
275      }      }
276      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
277      # cases are the single ">", which requires we clear the file first, and the      # case is when we're writing to a file. This is indicated by ">" (overwrite) and
278      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
279        # the standard output (tee mode).
280      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
281          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
282              $TeeFlag = 1;              $TeeFlag = 1;
283              $target = substr($target, 1);              $target = substr($target, 1);
284          }          }
285          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
286                # We need to initialize the file (which clears it).
287              open TRACEFILE, $target;              open TRACEFILE, $target;
288              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
289              close TRACEFILE;              close TRACEFILE;
290                # Set to append mode now that the file has been cleared.
291              $Destination = ">$target";              $Destination = ">$target";
292          } else {          } else {
293              $Destination = $target;              $Destination = $target;
# Line 408  Line 319 
319      $TraceLevel = $_[0];      $TraceLevel = $_[0];
320  }  }
321    
322  =head3 ParseTraceDate  =head3 ParseDate
323    
324        my $time = Tracer::ParseDate($dateString);
325    
326    Convert a date into a PERL time number. This method expects a date-like string
327    and parses it into a number. The string must be vaguely date-like or it will
328    return an undefined value. Our requirement is that a month and day be
329    present and that three pieces of the date string (time of day, month and day,
330    year) be separated by likely delimiters, such as spaces, commas, and such-like.
331    
332      my $time = Tracer::ParseTraceDate($dateString);  If a time of day is present, it must be in military time with two digits for
333    everything but the hour.
334    
335  Convert a date from the trace file into a PERL timestamp.  The year must be exactly four digits.
336    
337    Additional stuff can be in the string. We presume it's time zones or weekdays or something
338    equally innocuous. This means, however, that a sufficiently long sentence with date-like
339    parts in it may be interpreted as a date. Hopefully this will not be a problem.
340    
341    It should be guaranteed that this method will parse the output of the L</Now> function.
342    
343    The parameters are as follows.
344    
345  =over 4  =over 4
346    
347  =item dateString  =item dateString
348    
349  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
350    
351  =item RETURN  =item RETURN
352    
353  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
354  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
355    
356  =back  =back
357    
358  =cut  =cut
359    
360  sub ParseTraceDate {  # Universal month conversion table.
361    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
362                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
363                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
364                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
365                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
366                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
367                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
368                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
369                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
370                                Oct =>  9, October  =>   9, '10' =>  9,
371                                Nov => 10, November =>  10, '11' => 10,
372                                Dec => 11, December =>  11, '12' => 11
373                            };
374    
375    sub ParseDate {
376      # Get the parameters.      # Get the parameters.
377      my ($dateString) = @_;      my ($dateString) = @_;
378      # Declare the return variable.      # Declare the return variable.
379      my $retVal;      my $retVal;
380      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
381      if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {      # numeric style first. That way, if the user's done something like "Sun 12/22", then we
382          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
383          # and year to a different base. Years count from 1900, and      if ($dateString =~ m#\b(\d{1,2})/(\d{1,2})\b# || $dateString =~ m#\b(\w+)\s(\d{1,2})\b#) {
384          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
385          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
386            if (defined($mon) && $2 >= 1 && $2 <= 31) {
387                # Find the time.
388                my ($hour, $min, $sec) = (0, 0, 0);
389                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
390                    ($hour, $min, $sec) = ($1, $2, $3);
391                }
392                # Find the year.
393                my $year;
394                if ($dateString =~ /\b(\d{4})\b/) {
395                    $year = $1;
396                } else {
397                    # Get the default year, which is this one. Note we must convert it to
398                    # the four-digit value expected by "timelocal".
399                    (undef, undef, undef, undef, undef, $year) = localtime();
400                    $year += 1900;
401                }
402                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
403            }
404      }      }
405      # Return the result.      # Return the result.
406      return $retVal;      return $retVal;
# Line 489  Line 449 
449  sub Trace {  sub Trace {
450      # Get the parameters.      # Get the parameters.
451      my ($message) = @_;      my ($message) = @_;
452        # Strip off any line terminators at the end of the message. We will add
453        # new-line stuff ourselves.
454        my $stripped = Strip($message);
455        # Compute the caller information.
456        my ($callPackage, $callFile, $callLine) = caller();
457        my $callFileTitle = basename($callFile);
458        # Check the caller.
459        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
460      # Get the timestamp.      # Get the timestamp.
461      my $timeStamp = Now();      my $timeStamp = Now();
462      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
463      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
464      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
465        # Format the message.
466        my $formatted = "$prefix $stripped";
467      # Process according to the destination.      # Process according to the destination.
468      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
469          # Write the message to the standard output.          # Write the message to the standard output.
470          print "$formatted\n";          print "$formatted\n";
471      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
472          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
473          print STDERR "$formatted\n";          print STDERR "$formatted\n";
474        } elsif ($Destination eq "WARN") {
475            # Emit the message to the standard error output. It is presumed that the
476            # error logger will add its own prefix fields, the notable exception being
477            # the caller info.
478            print STDERR "$callerInfo$stripped\n";
479      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
480          # Push the message into the queue.          # Push the message into the queue.
481          push @Queue, "$formatted";          push @Queue, "$formatted";
482      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
483          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
484          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
485          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";          print "<p>$timeStamp $LastCategory $LastLevel: $escapedMessage</p>\n";
     } elsif ($Destination eq "WARN") {  
        # Emit the message as a warning.  
        carp $message;  
486      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
487          # Write the trace message to an output file.          # Write the trace message to an output file.
488          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
489          print TRACING "$formatted\n";          print TRACING "$formatted\n";
490          close TRACING;          close TRACING;
491          # If the Tee flag is on, echo it to the standard output.          # If the Tee flag is on, echo it to the standard output.
# Line 576  Line 548 
548                  $category = $cats[$#cats];                  $category = $cats[$#cats];
549              }              }
550          }          }
551          # Save the category name.          # Save the category name and level.
552          $LastCategory = $category;          $LastCategory = $category;
553            $LastLevel = $traceLevel;
554          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
555          $category = lc $category;          $category = lc $category;
556          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
# Line 660  Line 633 
633  sub Confess {  sub Confess {
634      # Get the parameters.      # Get the parameters.
635      my ($message) = @_;      my ($message) = @_;
636        # Set up the category and level.
637        $LastCategory = "(confess)";
638        $LastLevel = 0;
639      if (! defined($FIG_Config::no_tool_hdr)) {      if (! defined($FIG_Config::no_tool_hdr)) {
640          # Here we have a tool header. Display its length so that the user can adjust the line numbers.          # Here we have a tool header. Display its length so that the user can adjust the line numbers.
641          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";
642          # Only proceed if the tool header file is actually present.          # Only proceed if the tool header file is actually present.
643          if (-f $toolHeaderFile) {          if (-f $toolHeaderFile) {
644              my @lines = GetFile($toolHeaderFile);              my $fh;
645                if (open $fh, "<$toolHeaderFile") {
646                    my @lines = <$fh>;
647              Trace("Tool header has " . scalar(@lines) . " lines.");              Trace("Tool header has " . scalar(@lines) . " lines.");
648          }          }
649      }      }
650        }
651      # Trace the call stack.      # Trace the call stack.
652      Cluck($message);      Cluck($message);
653      # Abort the program.      # Abort the program.
# Line 726  Line 705 
705      # Trace what's happening.      # Trace what's happening.
706      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
707      my $confession = longmess($message);      my $confession = longmess($message);
708      # Convert the confession to a series of trace messages. Note we skip any      # Convert the confession to a series of trace messages.
     # messages relating to calls into Tracer.  
709      for my $line (split /\s*\n/, $confession) {      for my $line (split /\s*\n/, $confession) {
710          Trace($line) if ($line !~ /Tracer\.pm/);          # Only proceed if this call trace is for a method outside Tracer itself.
711            if ($line !~ /Tracer\.pm/) {
712                # Replace the leading tab with a series of spaces.
713                $line =~ s/\t/    /;
714                # Trace the line.
715                Trace($line);
716            }
717      }      }
718  }  }
719    
720  =head3 ScriptSetup  =head3 ScriptSetup (deprecated)
721    
722      my ($cgi, $varHash) = ScriptSetup($noTrace);      my ($cgi, $varHash) = ScriptSetup($noTrace);
723    
# Line 958  Line 942 
942          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
943      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
944          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
945        } elsif ($myDest eq 'WARN') {
946            $retVal = "WARN";
947      }      }
948      # Return the result.      # Return the result.
949      return $retVal;      return $retVal;
# Line 1086  Line 1072 
1072      my ($cgi) = @_;      my ($cgi) = @_;
1073      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1074          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script.
1075          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));
1076      }      }
1077      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1078          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1081 
1081              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1082              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1083                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1084                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1085              }              }
1086          }          }
1087          # Display the request method.          # Display the request method.
# Line 1105  Line 1091 
1091      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1092          # Here we want the environment data too.          # Here we want the environment data too.
1093          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1094              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1095          }          }
1096      }      }
1097  }  }
# Line 1162  Line 1148 
1148  }  }
1149    
1150    
1151  =head3 ScriptFinish  =head3 ScriptFinish (deprecated)
1152    
1153      ScriptFinish($webData, $varHash);      ScriptFinish($webData, $varHash);
1154    
# Line 1620  Line 1606 
1606              # Close the test file.              # Close the test file.
1607              close TESTTRACE;              close TESTTRACE;
1608          } else {          } else {
1609              # Here we can't trace to a file. We trace to the standard output if it's              # Here we can't trace to a file. Complain about this.
1610                warn "Could not open trace file $traceFileName: $!\n";
1611                # We trace to the standard output if it's
1612              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1613              if ($textOKFlag) {              if ($textOKFlag) {
1614                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 2584  Line 2572 
2572  }  }
2573    
2574    
2575    =head3 PrintLine
2576    
2577        Tracer::PrintLine($line);
2578    
2579    Print a line of text with a trailing new-line.
2580    
2581    =over 4
2582    
2583    =item line
2584    
2585    Line of text to print.
2586    
2587    =back
2588    
2589    =cut
2590    
2591    sub PrintLine {
2592        # Get the parameters.
2593        my ($line) = @_;
2594        # Print the line.
2595        print "$line\n";
2596    }
2597    
2598    
2599  =head2 Other Useful Methods  =head2 Other Useful Methods
2600    
# Line 2624  Line 2635 
2635      return $retVal;      return $retVal;
2636  }  }
2637    
   
   
   
2638  =head3 Now  =head3 Now
2639    
2640      my $string = Tracer::Now();      my $string = Tracer::Now();
2641    
2642  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
2643    method produces must be parseable by L</ParseDate>.
2644    
2645  =cut  =cut
2646    
2647  sub Now {  sub Now {
2648      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
2649      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
2650    
2651    =head3 DisplayTime
2652    
2653        my $string = Tracer::DisplayTime($time);
2654    
2655    Convert a time value to a displayable time stamp. Whatever format this
2656    method produces must be parseable by L</ParseDate>.
2657    
2658    =over 4
2659    
2660    =item time
2661    
2662    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
2663    
2664    =item RETURN
2665    
2666    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
2667    
2668    =back
2669    
2670    =cut
2671    
2672    sub DisplayTime {
2673        my ($time) = @_;
2674        my $retVal = "(n/a)";
2675        if (defined $time) {
2676            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
2677            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
2678                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
2679        }
2680      return $retVal;      return $retVal;
2681  }  }
2682    
# Line 2802  Line 2840 
2840      return $retVal;      return $retVal;
2841  }  }
2842    
2843    =head3 Constrain
2844    
2845        my $constrained = Constrain($value, $min, $max);
2846    
2847    Modify a numeric value to bring it to a point in between a maximum and a minimum.
2848    
2849    =over 4
2850    
2851    =item value
2852    
2853    Value to constrain.
2854    
2855    =item min (optional)
2856    
2857    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
2858    
2859    =item max (optional)
2860    
2861    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
2862    
2863    =item RETURN
2864    
2865    Returns the incoming value, constrained according to the other parameters.
2866    
2867    =back
2868    
2869    =cut
2870    
2871    sub Constrain {
2872        # Get the parameters.
2873        my ($value, $min, $max) = @_;
2874        # Declare the return variable.
2875        my $retVal = $value;
2876        # Apply the minimum constraint.
2877        if (defined $min && $retVal < $min) {
2878            $retVal = $min;
2879        }
2880        # Apply the maximum constraint.
2881        if (defined $max && $retVal > $max) {
2882            $retVal = $max;
2883        }
2884        # Return the result.
2885        return $retVal;
2886    }
2887    
2888  =head3 Min  =head3 Min
2889    
2890      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 2951 
2951      return $retVal;      return $retVal;
2952  }  }
2953    
 =head3 DebugMode  
   
     if (Tracer::DebugMode) { ...code... }  
   
 Return TRUE if debug mode has been turned on, else abort.  
   
 Certain CGI scripts are too dangerous to exist in the production  
 environment. This method provides a simple way to prevent them  
 from working unless they are explicitly turned on by creating a password  
 cookie via the B<SetPassword> script.  If debugging mode  
 is not turned on, an error will occur.  
   
 =cut  
   
 sub DebugMode {  
     # Declare the return variable.  
     my $retVal = 0;  
     # Check the debug configuration.  
     my $password = CGI::cookie("DebugMode");  
     my $encrypted = Digest::MD5::md5_hex($password);  
     if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {  
         $retVal = 1;  
     } else {  
         # Here debug mode is off, so we generate an error.  
         Confess("Cannot use this facility without logging in.");  
     }  
     # Return the determination indicator.  
     return $retVal;  
 }  
2954    
2955  =head3 Strip  =head3 Strip
2956    
# Line 3340  Line 3394 
3394  }  }
3395    
3396    
3397    =head3 TrackingCode
3398    
3399        my $html = Tracer::TrackingCode();
3400    
3401    Returns the HTML code for doing web page traffic monitoring. If the
3402    current environment is a test system, then it returns a null string;
3403    otherwise, it returns a bunch of javascript containing code for turning
3404    on SiteMeter and Google Analytics.
3405    
3406    =cut
3407    
3408    sub TrackingCode {
3409        # Declare the return variable.
3410        my $retVal = "<!-- tracking off -->";
3411        # Determine if we're in production.
3412        if ($FIG_Config::site_meter) {
3413            $retVal = <<END_HTML
3414            <!-- Site Meter -->
3415            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
3416            </script>
3417            <noscript>
3418            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
3419            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
3420            </noscript>
3421            <!-- Copyright (c)2006 Site Meter -->
3422    END_HTML
3423        }
3424        return $retVal;
3425    }
3426    
3427    
3428  1;  1;

Legend:
Removed from v.1.95  
changed lines
  Added in v.1.98

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3