[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.18, Mon Aug 15 17:10:27 2005 UTC revision 1.84, Thu May 3 12:28:00 2007 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package Tracer;  package Tracer;
19    
20      require Exporter;      require Exporter;
21      @ISA = ('Exporter');      @ISA = ('Exporter');
22      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing ScriptSetup ScriptFinish Insure ChDir Emergency);
23      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24      use strict;      use strict;
25      use Carp qw(longmess croak);      use Carp qw(longmess croak);
26      use CGI;      use CGI;
27        use Cwd;
28      use FIG_Config;      use FIG_Config;
29      use PageBuilder;      use PageBuilder;
30        use Digest::MD5;
31        use File::Basename;
32        use File::Path;
33        use File::stat;
34        use LWP::UserAgent;
35        use Time::HiRes 'gettimeofday';
36        use URI::Escape;
37        use Time::Local;
38    
39  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
40    
41  =head2 Introduction  =head2 Tracing
42    
43  This package provides simple tracing for debugging and reporting purposes. To use it simply call the  This package provides simple tracing for debugging and reporting purposes. To use it simply call the
44  L</TSetup> method to set the options and call L</Trace> to write out trace messages. Each trace  L</TSetup> or L</ETracing> method to set the options and call L</Trace> to write out trace messages.
45  message has a I<trace level> and I<category> associated with it. In addition, the tracing package itself  L</TSetup> and L</ETracing> both establish a I<trace level> and a list of I<categories>. Similarly,
46  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace  each trace message has a I<trace level> and I<category> associated with it. Only messages whose trace
47  level is less than or equal to this package's trace level and whose category is activated will  level is less than or equal to the setup trace level and whose category is activated will
48  be written. Thus, a higher trace level on a message indicates that the message  be written. Thus, a higher trace level on a message indicates that the message
49  is less likely to be seen. A higher trace level passed to B<TSetup> means more trace messages will  is less likely to be seen, while a higher trace level passed to B<TSetup> means more trace messages will
50  appear. To generate a trace message, use the following syntax.  appear.
51    
52    =head3 Putting Trace Messages in Your Code
53    
54  C<< Trace($message) if T(errors => 4); >>  To generate a trace message, use the following syntax.
55    
56        Trace($message) if T(errors => 4);
57    
58  This statement will produce a trace message if the trace level is 4 or more and the C<errors>  This statement will produce a trace message if the trace level is 4 or more and the C<errors>
59  category is active. Note that the special category C<main> is always active, so  category is active. There is a special category C<main> that is always active, so
60    
61  C<< Trace($message) if T(main => 4); >>      Trace($message) if T(main => 4);
62    
63  will trace if the trace level is 4 or more.  will trace if the trace level is 4 or more.
64    
# Line 36  Line 66 
66  following call is made in the B<Sprout> package, it will appear if the C<Sprout> category is  following call is made in the B<Sprout> package, it will appear if the C<Sprout> category is
67  active and the trace level is 2 or more.  active and the trace level is 2 or more.
68    
69  C<< Trace($message) if T(2); >>      Trace($message) if T(2);
70    
71    In scripts, where no package name is available, the category defaults to C<main>.
72    
73  To set up tracing, you call the L</TSetup> method. The method takes as input a trace level, a list  =head3 Custom Tracing
74  of category names, and a set of options. The trace level and list of category names are  
75    Many programs have customized tracing configured using the L</TSetup> method. This is no longer
76    the preferred method, but a knowledge of how custom tracing works can make the more modern
77    L</Emergency Tracing> easier to understand.
78    
79    To set up custom tracing, you call the L</TSetup> method. The method takes as input a trace level,
80    a list of category names, and a destination. The trace level and list of category names are
81  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
82    
83  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>      TSetup('3 errors Sprout ERDB', 'TEXT');
84    
85  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
86  specifies that messages should be output as HTML paragraphs.  specifies that messages should be sent to the standard output.
87    
88  To turn on tracing for ALL categories, use an asterisk. The call below sets every category to  To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
89  level 3 and writes the output to the standard error output. This sort of thing might be  level 3 and writes the output to the standard error output. This sort of thing might be
90  useful in a CGI environment.  useful in a CGI environment.
91    
92  C<< TSetup('3 *', 'WARN'); >>      TSetup('3 *', 'WARN');
93    
94  In addition to HTML and file output for trace messages, you can specify that the trace messages  In addition standard error and file output for trace messages, you can specify that the trace messages
95  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach
96  is useful if you are building a web page. Instead of having the trace messages interspersed with  is useful if you are building a web page. Instead of having the trace messages interspersed with
97  the page output, they can be gathered together and displayed at the end of the page. This makes  the page output, they can be gathered together and displayed at the end of the page. This makes
98  it easier to debug page formatting problems.  it easier to debug page formatting problems.
99    
100  Finally, you can specify that all trace messages be emitted as warnings.  Finally, you can specify that all trace messages be emitted to a file, or the standard output and
101    a file at the same time. To trace to a file, specify the filename with an output character in front
102    of it.
103    
104        TSetup('4 SQL', ">$fileName");
105    
106    To trace to the standard output and a file at the same time, put a C<+> in front of the angle
107    bracket.
108    
109        TSetup('3 *', "+>$fileName");
110    
111  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.
112  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.
113  Thus, debugging information is available and easily retrieved even when the application is  Thus, debugging information is available and easily retrieved even when the application is
114  being used out in the field.  being used out in the field.
115    
116    =head3 Trace Levels
117    
118  There is no hard and fast rule on how to use trace levels. The following is therefore only  There is no hard and fast rule on how to use trace levels. The following is therefore only
119  a suggestion.  a suggestion.
120    
121  =over 4  =over 4
122    
123  =item 0 Error  =item Error 0
124    
125  Message indicates an error that may lead to incorrect results or that has stopped the  Message indicates an error that may lead to incorrect results or that has stopped the
126  application entirely.  application entirely.
127    
128  =item 1 Warning  =item Warning 1
129    
130  Message indicates something that is unexpected but that probably did not interfere  Message indicates something that is unexpected but that probably did not interfere
131  with program execution.  with program execution.
132    
133  =item 2 Notice  =item Notice 2
134    
135  Message indicates the beginning or end of a major task.  Message indicates the beginning or end of a major task.
136    
137  =item 3 Information  =item Information 3
138    
139  Message indicates a subtask. In the FIG system, a subtask generally relates to a single  Message indicates a subtask. In the FIG system, a subtask generally relates to a single
140  genome. This would be a big loop that is not expected to execute more than 500 times or so.  genome. This would be a big loop that is not expected to execute more than 500 times or so.
141    
142  =item 4 Detail  =item Detail 4
143    
144  Message indicates a low-level loop iteration.  Message indicates a low-level loop iteration.
145    
146  =back  =back
147    
148    The format of trace messages is important because some utilities analyze trace files.
149    There are three fields-- the time stamp, the category name, and the text.
150    The time stamp is between square brackets and the category name between angle brackets.
151    After the category name there is a colon (C<:>) followed by the message text.
152    If the square brackets or angle brackets are missing, then the trace management
153    utilities assume that they are encountering a set of pre-formatted lines.
154    
155    Note, however, that this formatting is done automatically by the tracing functions. You
156    only need to know about it if you want to parse a trace file.
157    
158    =head3 Emergency Tracing
159    
160    Sometimes, you need a way for tracing to happen automatically without putting parameters
161    in a form or on the command line. Emergency tracing does this. You invoke emergency tracing
162    from the debug form, which is accessed from I<MySeedInstance>C</FIG/Html/SetPassword.html>.
163    Emergency tracing requires you specify a tracing key. For command-line tools, the key is
164    taken from the C<TRACING> environment variable. For web services, the key is taken from
165    a cookie. Either way, the key tells the tracing facility who you are, so that you control
166    the tracing in your environment without stepping on other users.
167    
168    The key can be anything you want. If you don't have a key, the C<SetPassword> page will
169    generate one for you.
170    
171    You can activate and de-activate emergency tracing from the debugging control panel, as
172    well as display the trace file itself.
173    
174    To enable emergency tracing in your code, call
175    
176        ETracing($cgi)
177    
178    from a web script and
179    
180        ETracing()
181    
182    from a command-line script.
183    
184    The web script will look for the tracing key in the cookies, and the command-line
185    script will look for it in the C<TRACING> environment variable. If you are
186    using the L</StandardScript> or L</StandardSetup> methods, emergency tracing
187    will be configured automatically.
188    
189    NOTE: to configure emergency tracing from the command line instead of the Debugging
190    Control Panel (see below), use the C<trace.pl> script.
191    
192    =head3 Debugging Control Panel
193    
194    The debugging control panel provides several tools to assist in development of
195    SEED and Sprout software. You access the debugging control panel from the URL
196    C</FIG/Html/SetPassword.html> in whichever seed instance you're using. (So,
197    for example, the panel access point for the development NMPDR system is
198    C<http://web-1.nmpdr.org/next/FIG/Html/SetPassword.html>. Contact Bruce to
199    find out what the password is. From this page, you can also specify a tracing
200    key. If you don't specify a key, one will be generated for you.
201    
202    =head4 Emergency Tracing Form
203    
204    At the bottom of the debugging control panel is a form that allows you to
205    specify a trace level and tracing categories. Special and common categories
206    are listed with check boxes. You can hold your mouse over a check box to see
207    what its category does. In general, however, a category name is the same as
208    the name of the package in which the trace message occurs.
209    
210    Additional categories can be entered in an input box, delimited by spaces or commas.
211    
212    The B<Activate> button turns on Emergency tracing at the level you specify with the
213    specified categories active. The B<Terminate> button turns tracing off. The
214    B<Show File> button displays the current contents of the trace file. The tracing
215    form at the bottom of the control panel is designed for emergency tracing, so it
216    will only affect programs that call L</ETracing>, L</StandardScript>,
217    or L</StandardSetup>.
218    
219    =head4 Script Form
220    
221    The top form of the debugging control panel allows you to enter a tiny script and
222    have the output generated in a formatted table. Certain object variables are
223    predefined in the script, including a FIG object (C<$fig>), a CGI object (C<$cgi>),
224    and-- if Sprout is active-- Sprout (C<$sprout>) and SFXlate (C<$sfx>) objects.
225    
226    The last line of the script must be a scalar, but it can be a reference to a hash,
227    a list, a list of lists, and various other combinations. If you select the appropriate
228    data type in the dropdown box, the output will be formatted accordingly. The form
229    also has controls for specifying tracing. These controls override any emergency
230    tracing in effect.
231    
232    =head4 Database Query Forms
233    
234    The forms between the script form and the emergency tracing form allow you to
235    make queries against the database. The FIG query form allows simple queries against
236    a single FIG table. The Sprout query form uses the B<GetAll> method to do a
237    multi-table query against the Sprout database. B<GetAll> is located in the B<ERDB>
238    package, and it takes five parameters.
239    
240        GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count);
241    
242    Each of the five parameters corresponds to a text box on the query form:
243    
244    =over 4
245    
246    =item Objects
247    
248    Comma-separated list containing the names of the entity and relationship objects to be retrieved.
249    
250    =item Filter
251    
252    WHERE/ORDER BY clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can
253    be parameterized with parameter markers (C<?>). Each field used must be specified in the standard form
254    B<I<objectName>(I<fieldName>)> or B<$I<number>(I<fieldName>)> where I<fieldName> is the name of a
255    field, I<objectName> is the name of the entity or relationship object containing the field, and
256    I<number> is the 1-based position of the object in the object list. Any parameters
257    specified in the filter clause should be specified in the B<Params> field.
258    The fields in a filter clause can come from primary entity relations,
259    relationship relations, or secondary entity relations; however, all of the
260    entities and relationships involved must be included in the list of object names.
261    
262    =item Params
263    
264    List of the parameters to be substituted in for the parameters marks in the filter clause. This
265    is a comma-separated list without any quoting or escaping.
266    
267    =item fields
268    
269    Comma-separated list of the fields to be returned in each element of the list returned. Fields
270    are specified in the same manner as in the filter clause.
271    
272    =item count
273    
274    Maximum number of records to return. If omitted or 0, all available records will be returned.
275    
276    =back
277    
278    B<GetAll> automatically joins together the entities and relationships listed in the object
279    names. This simplifies the coding of the filter clause, but it means that some queries are
280    not possible, since they cannot be expressed in a linear sequence of joins. This is a limitation
281    that has yet to be addressed.
282    
283  =cut  =cut
284    
285  # Declare the configuration variables.  # Declare the configuration variables.
# Line 156  Line 340 
340      # Presume category-based tracing until we learn otherwise.      # Presume category-based tracing until we learn otherwise.
341      $AllTrace = 0;      $AllTrace = 0;
342      # Build the category hash. Note that if we find a "*", we turn on non-category      # Build the category hash. Note that if we find a "*", we turn on non-category
343      # tracing.      # tracing. We must also clear away any pre-existing data.
344        %Categories = ( main => 1 );
345      for my $category (@categoryData) {      for my $category (@categoryData) {
346          if ($category eq '*') {          if ($category eq '*') {
347              $AllTrace = 1;              $AllTrace = 1;
# Line 174  Line 359 
359          }          }
360          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
361              open TRACEFILE, $target;              open TRACEFILE, $target;
362              print TRACEFILE Now() . " Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";
363              close TRACEFILE;              close TRACEFILE;
364              $Destination = ">$target";              $Destination = ">$target";
365          } else {          } else {
# Line 187  Line 372 
372      $SetupCount++;      $SetupCount++;
373  }  }
374    
375    =head3 StandardSetup
376    
377    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
378    
379    This method performs standard command-line parsing and tracing setup. The return
380    values are a hash of the command-line options and a list of the positional
381    parameters. Tracing is automatically set up and the command-line options are
382    validated.
383    
384    This is a complex method that does a lot of grunt work. The parameters can
385    be more easily understood, however, once they are examined individually.
386    
387    The I<categories> parameter is the most obtuse. It is a reference to a list of
388    special-purpose tracing categories. Most tracing categories are PERL package
389    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
390    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
391    
392        ["Sprout", "SproutLoad", "ERDB"]
393    
394    This would cause trace messages in the specified three packages to appear in
395    the output. There are two special tracing categories that are automatically
396    handled by this method. In other words, if you used L</TSetup> you would need
397    to include these categories manually, but if you use this method they are turned
398    on automatically.
399    
400    =over 4
401    
402    =item SQL
403    
404    Traces SQL commands and activity.
405    
406    =item Tracer
407    
408    Traces error messages and call stacks.
409    
410    =back
411    
412    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
413    The trace level is specified using the C<-trace> command-line option. For example,
414    the following command line for C<TransactFeatures> turns on SQL tracing and runs
415    all tracing at level 3.
416    
417        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
418    
419    Standard tracing is output to the standard output and echoed to the file
420    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
421    process ID. You can also specify the C<user> parameter to put a user ID
422    instead of a process ID in the trace file name. So, for example
423    
424    The default trace level is 2. To get all messages, specify a trace level of 4.
425    For a genome-by-genome update, use 3.
426    
427        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
428    
429    would send the trace output to C<traceBruce.log> in the temporary directory.
430    
431    The I<options> parameter is a reference to a hash containing the command-line
432    options, their default values, and an explanation of what they mean. Command-line
433    options may be in the form of switches or keywords. In the case of a switch, the
434    option value is 1 if it is specified and 0 if it is not specified. In the case
435    of a keyword, the value is separated from the option name by an equal sign. You
436    can see this last in the command-line example above.
437    
438    You can specify a different default trace level by setting C<$options->{trace}>
439    prior to calling this method.
440    
441    An example at this point would help. Consider, for example, the command-line utility
442    C<TransactFeatures>. It accepts a list of positional parameters plus the options
443    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
444    the following code.
445    
446        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
447                            { safe => [0, "use database transactions"],
448                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
449                              start => [' ', "start with this genome"],
450                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
451                            "<command> <transactionDirectory> <IDfile>",
452                          @ARGV);
453    
454    
455    The call to C<ParseCommand> specifies the default values for the options and
456    stores the actual options in a hash that is returned as C<$options>. The
457    positional parameters are returned in C<@parameters>.
458    
459    The following is a sample command line for C<TransactFeatures>.
460    
461        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
462    
463    Single and double hyphens are equivalent. So, you could also code the
464    above command as
465    
466        TransactFeatures --trace=2 --noAlias register ../xacts IDs.tbl
467    
468    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
469    parameters, and would find themselves in I<@parameters> after executing the
470    above code fragment. The tracing would be set to level 2, and the categories
471    would be C<Tracer>, and <DocUtils>. C<Tracer> is standard,
472    and C<DocUtils> was included because it came in within the first parameter
473    to this method. The I<$options> hash would be
474    
475        { trace => 2, sql => 0, safe => 0,
476          noAlias => 1, start => ' ', tblFiles => 0 }
477    
478    Use of C<StandardSetup> in this way provides a simple way of performing
479    standard tracing setup and command-line parsing. Note that the caller is
480    not even aware of the command-line switches C<-trace> and C<-sql>, which
481    are used by this method to control the tracing. If additional tracing features
482    need to be added in the future, they can be processed by this method without
483    upsetting the command-line utilities.
484    
485    If the C<background> option is specified on the command line, then the
486    standard and error outputs will be directed to files in the temporary
487    directory, using the same suffix as the trace file. So, if the command
488    line specified
489    
490        -user=Bruce -background
491    
492    then the trace output would go to C<traceBruce.log>, the standard output to
493    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
494    simplify starting a command in the background.
495    
496    The user name is also used as the tracing key for L</Emergency Tracing>.
497    Specifying a value of C<E> for the trace level causes emergency tracing to
498    be used instead of custom tracing. If the user name is not specified,
499    the tracing key is taken from the C<Tracing> environment variable. If there
500    is no value for that variable, the tracing key will be computed from the PID.
501    
502    Finally, if the special option C<-help> is specified, the option
503    names will be traced at level 0 and the program will exit without processing.
504    This provides a limited help capability. For example, if the user enters
505    
506        TransactFeatures -help
507    
508    he would see the following output.
509    
510        TransactFeatures [options] <command> <transactionDirectory> <IDfile>
511            -trace    tracing level (default E)
512            -sql      trace SQL commands
513            -safe     use database transactions
514            -noAlias  do not expect aliases in CHANGE transactions
515            -start    start with this genome
516            -tblFiles output TBL files containing the corrected IDs
517    
518    The caller has the option of modifying the tracing scheme by placing a value
519    for C<trace> in the incoming options hash. The default value can be overridden,
520    or the tracing to the standard output can be turned off by suffixing a minus
521    sign to the trace level. So, for example,
522    
523        { trace => [0, "tracing level (default 0)"],
524           ...
525    
526    would set the default trace level to 0 instead of E, while
527    
528        { trace => ["2-", "tracing level (default 2)"],
529           ...
530    
531    would set the default to 2, but trace only to the log file, not to the
532    standard output.
533    
534    The parameters to this method are as follows.
535    
536    =over 4
537    
538    =item categories
539    
540    Reference to a list of tracing category names. These should be names of
541    packages whose internal workings will need to be debugged to get the
542    command working.
543    
544    =item options
545    
546    Reference to a hash containing the legal options for the current command mapped
547    to their default values and descriptions. The user can override the defaults
548    by specifying the options as command-line switches prefixed by a hyphen.
549    Tracing-related options may be added to this hash. If the C<-h> option is
550    specified on the command line, the option descriptions will be used to
551    explain the options. To turn off tracing to the standard output, add a
552    minus sign to the value for C<trace> (see above).
553    
554    =item parmHelp
555    
556    A string that vaguely describes the positional parameters. This is used
557    if the user specifies the C<-h> option.
558    
559    =item argv
560    
561    List of command line parameters, including the option switches, which must
562    precede the positional parameters and be prefixed by a hyphen.
563    
564    =item RETURN
565    
566    Returns a list. The first element of the list is the reference to a hash that
567    maps the command-line option switches to their values. These will either be the
568    default values or overrides specified on the command line. The remaining
569    elements of the list are the position parameters, in order.
570    
571    =back
572    
573    =cut
574    
575    sub StandardSetup {
576        # Get the parameters.
577        my ($categories, $options, $parmHelp, @argv) = @_;
578        # Get the default tracing key.
579        my $tkey = EmergencyKey();
580        # Add the tracing options.
581        if (! exists $options->{trace}) {
582            $options->{trace} = ['E', "tracing level (E for emergency tracing)"];
583        }
584        $options->{sql} = [0, "turn on SQL tracing"];
585        $options->{help} = [0, "display command-line options"];
586        $options->{user} = [$tkey, "tracing key"];
587        $options->{background} = [0, "spool standard and error output"];
588        # Create a parsing hash from the options hash. The parsing hash
589        # contains the default values rather than the default value
590        # and the description. While we're at it, we'll memorize the
591        # length of the longest option name.
592        my $longestName = 0;
593        my %parseOptions = ();
594        for my $key (keys %{$options}) {
595            if (length $key > $longestName) {
596                $longestName = length $key;
597            }
598            $parseOptions{$key} = $options->{$key}->[0];
599        }
600        # Parse the command line.
601        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
602        # Get the logfile suffix.
603        my $suffix = $retOptions->{user};
604        # Check for background mode.
605        if ($retOptions->{background}) {
606            my $outFileName = "$FIG_Config::temp/out$suffix.log";
607            my $errFileName = "$FIG_Config::temp/err$suffix.log";
608            open STDOUT, ">$outFileName";
609            open STDERR, ">$errFileName";
610        }
611        # Now we want to set up tracing. First, we need to know if the user
612        # wants emergency tracing.
613        if ($retOptions->{trace} eq 'E') {
614            ETracing($retOptions->{user});
615        } else {
616            # Here the tracing is controlled from the command line.
617            my @cats = @{$categories};
618            if ($retOptions->{sql}) {
619                push @cats, "SQL";
620            }
621            # Add the default categories.
622            push @cats, "Tracer";
623            # Next, we create the category string by joining the categories.
624            my $cats = join(" ", @cats);
625            # Check to determine whether or not the caller wants to turn off tracing
626            # to the standard output.
627            my $traceLevel = $retOptions->{trace};
628            my $textOKFlag = 1;
629            if ($traceLevel =~ /^(.)-/) {
630                $traceLevel = $1;
631                $textOKFlag = 0;
632            }
633            # Now we set up the trace mode.
634            my $traceMode;
635            # Verify that we can open a file in the FIG temporary directory.
636            my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
637            if (open TESTTRACE, ">$traceFileName") {
638                # Here we can trace to a file.
639                $traceMode = ">$traceFileName";
640                if ($textOKFlag) {
641                    # Echo to standard output if the text-OK flag is set.
642                    $traceMode = "+$traceMode";
643                }
644                # Close the test file.
645                close TESTTRACE;
646            } else {
647                # Here we can't trace to a file. We trace to the standard output if it's
648                # okay, and the error log otherwise.
649                if ($textOKFlag) {
650                    $traceMode = "TEXT";
651                } else {
652                    $traceMode = "WARN";
653                }
654            }
655            # Now set up the tracing.
656            TSetup("$traceLevel $cats", $traceMode);
657        }
658        # Check for the "h" option. If it is specified, dump the command-line
659        # options and exit the program.
660        if ($retOptions->{help}) {
661            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
662            print "$1 [options] $parmHelp\n";
663            for my $key (sort keys %{$options}) {
664                my $name = Pad($key, $longestName, 0, ' ');
665                my $desc = $options->{$key}->[1];
666                if ($options->{$key}->[0]) {
667                    $desc .= " (default " . $options->{$key}->[0] . ")";
668                }
669                print "  $name $desc\n";
670            }
671            exit(0);
672        }
673        # Trace the options, if applicable.
674        if (T(3)) {
675            my @parms = grep { $retOptions->{$_} } keys %{$retOptions};
676            Trace("Selected options: " . join(", ", sort @parms) . ".");
677        }
678        # Return the parsed parameters.
679        return ($retOptions, @retParameters);
680    }
681    
682  =head3 Setups  =head3 Setups
683    
684  C<< my $count = Tracer::Setups(); >>  C<< my $count = Tracer::Setups(); >>
# Line 347  Line 839 
839    
840  =head3 OpenDir  =head3 OpenDir
841    
842  C<< my @files = OpenDir($dirName, $filtered); >>  C<< my @files = OpenDir($dirName, $filtered, $flag); >>
843    
844  Open a directory and return all the file names. This function essentially performs  Open a directory and return all the file names. This function essentially performs
845  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
846  set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of  set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
847  the return list. If the directory does not open, an exception is thrown. So,  or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
848  for example,  filtered out of the return list. If the directory does not open and I<$flag> is not
849    set, an exception is thrown. So, for example,
850    
851      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
852    
853  is effectively the same as  is effectively the same as
854    
855      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
856      my @files = grep { $_ !~ /^\./ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
857    
858  Similarly, the following code  Similarly, the following code
859    
860      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
861    
862  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
863  automatically throws an error if the directory fails to open.  automatically returns an empty list if the directory fails to open.
864    
865  =over 4  =over 4
866    
# Line 380  Line 873 
873  TRUE if files whose names begin with a period (C<.>) should be automatically removed  TRUE if files whose names begin with a period (C<.>) should be automatically removed
874  from the list, else FALSE.  from the list, else FALSE.
875    
876    =item flag
877    
878    TRUE if a failure to open is okay, else FALSE
879    
880  =back  =back
881    
882  =cut  =cut
883  #: Return Type @;  #: Return Type @;
884  sub OpenDir {  sub OpenDir {
885      # Get the parameters.      # Get the parameters.
886      my ($dirName, $filtered) = @_;      my ($dirName, $filtered, $flag) = @_;
887      # Declare the return variable.      # Declare the return variable.
888      my @retVal;      my @retVal = ();
889      # Open the directory.      # Open the directory.
890      if (opendir(my $dirHandle, $dirName)) {      if (opendir(my $dirHandle, $dirName)) {
891          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
892          # strictures of the filter parameter.          # strictures of the filter parameter.
893          if ($filtered) {          if ($filtered) {
894              @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
895          } else {          } else {
896              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
897          }          }
898      } else {      } elsif (! $flag) {
899          # Here the directory would not open.          # Here the directory would not open and it's considered an error.
900          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
901      }      }
902      # Return the result.      # Return the result.
# Line 448  Line 945 
945      return $value;      return $value;
946  }  }
947    
948    =head3 ParseTraceDate
949    
950    C<< my $time = Tracer::ParseTraceDate($dateString); >>
951    
952    Convert a date from the trace file into a PERL timestamp.
953    
954    =over 4
955    
956    =item dateString
957    
958    The date string from the trace file. The format of the string is determined by the
959    L</Now> method.
960    
961    =item RETURN
962    
963    Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
964    the time string is invalid.
965    
966    =back
967    
968    =cut
969    
970    sub ParseTraceDate {
971        # Get the parameters.
972        my ($dateString) = @_;
973        # Declare the return variable.
974        my $retVal;
975        # Parse the date.
976        if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {
977            # Create a time object. Note we need to convert the day, month,
978            # and year to a different base. Years count from 1900, and
979            # the internal month value is relocated to January = 0.
980            $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);
981        }
982        # Return the result.
983        return $retVal;
984    }
985    
986  =head3 LogErrors  =head3 LogErrors
987    
988  C<< Tracer::LogErrors($fileName); >>  C<< Tracer::LogErrors($fileName); >>
# Line 650  Line 1185 
1185      # Get the timestamp.      # Get the timestamp.
1186      my $timeStamp = Now();      my $timeStamp = Now();
1187      # Format the message. Note we strip off any line terminators at the end.      # Format the message. Note we strip off any line terminators at the end.
1188      my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);      my $formatted = "[$timeStamp] <$LastCategory>: " . Strip($message);
1189      # Process according to the destination.      # Process according to the destination.
1190      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
1191          # Write the message to the standard output.          # Write the message to the standard output.
# Line 737  Line 1272 
1272          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
1273          $category = lc $category;          $category = lc $category;
1274          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
1275            if (ref $traceLevel) {
1276                Confess("Bad trace level.");
1277            } elsif (ref $TraceLevel) {
1278                Confess("Bad trace config.");
1279            }
1280          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1281      }      }
1282      # Return the computed result.      # Return the computed result.
# Line 754  Line 1294 
1294    
1295  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>
1296    
1297  In this case, the list @words will be treated as a command line. There are two options available,  In this case, the list @words will be treated as a command line and there are two options available,
1298  B<errors> and B<logFile>. If @words has the following format  B<errors> and B<logFile>. If @words has the following format
1299    
1300  C<< -logFile=error.log apple orange rutabaga >>  C<< -logFile=error.log apple orange rutabaga >>
# Line 768  Line 1308 
1308  C<< apple orange rutabaga >>  C<< apple orange rutabaga >>
1309    
1310  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no
1311  support for quote characters.  support for quote characters. Options can be specified with single or double hyphens.
1312    
1313  =over 4  =over 4
1314    
# Line 793  Line 1333 
1333      my ($optionTable, @inputList) = @_;      my ($optionTable, @inputList) = @_;
1334      # Process any options in the input list.      # Process any options in the input list.
1335      my %overrides = ();      my %overrides = ();
1336      while ((@inputList > 0) && ($inputList[0] =~ /^-/)) {      while ((@inputList > 0) && ($inputList[0] =~ /^--?/)) {
1337          # Get the current option.          # Get the current option.
1338          my $arg = shift @inputList;          my $arg = shift @inputList;
1339          # Pull out the option name.          # Pull out the option name.
1340          $arg =~ /^-([^=]*)/g;          $arg =~ /^--?([^=]*)/g;
1341          my $name = $1;          my $name = $1;
1342          # Check for an option value.          # Check for an option value.
1343          if ($arg =~ /\G=(.*)$/g) {          if ($arg =~ /\G=(.*)$/g) {
# Line 823  Line 1363 
1363    
1364  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1365    
1366  Escape a string for use in a command length. Spaces will be replaced by C<\b>,  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1367  tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1368  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1369    
1370  =over 4  =over 4
1371    
# Line 849  Line 1389 
1389      # Loop through the parameter string, looking for sequences to escape.      # Loop through the parameter string, looking for sequences to escape.
1390      while (length $realString > 0) {      while (length $realString > 0) {
1391          # Look for the first sequence to escape.          # Look for the first sequence to escape.
1392          if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1393              # Here we found it. The text preceding the sequence is in $1. The sequence              # Here we found it. The text preceding the sequence is in $1. The sequence
1394              # itself is in $2. First, move the clear text to the return variable.              # itself is in $2. First, move the clear text to the return variable.
1395              $retVal .= $1;              $retVal .= $1;
1396              # Strip the processed section off the real string.              # Strip the processed section off the real string.
1397              $realString = substr $realString, (length $2) + (length $1);              $realString = substr $realString, (length $2) + (length $1);
1398              # Encode the escape sequence.              # Get the matched character.
1399              my $char = $2;              my $char = $2;
1400              $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1401                if ($char ne "\r") {
1402                    # It's not a CR, so encode the escape sequence.
1403                    $char =~ tr/\t\n/tn/;
1404              $retVal .= "\\" . $char;              $retVal .= "\\" . $char;
1405                }
1406          } else {          } else {
1407              # Here there are no more escape sequences. The rest of the string is              # Here there are no more escape sequences. The rest of the string is
1408              # transferred unmodified.              # transferred unmodified.
# Line 874  Line 1418 
1418    
1419  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1420    
1421  Replace escape sequences with their actual equivalents. C<\b> will be replaced by a space,  Replace escape sequences with their actual equivalents. C<\t> will be replaced by
1422  C<\t> by a tab, C<\n> by a new-line character, and C<\\> by a back-slash.  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will
1423    be deleted.
1424    
1425  =over 4  =over 4
1426    
# Line 900  Line 1445 
1445      # Only proceed if the incoming string is nonempty.      # Only proceed if the incoming string is nonempty.
1446      if (defined $codedString) {      if (defined $codedString) {
1447          # Loop through the parameter string, looking for escape sequences. We can't do          # Loop through the parameter string, looking for escape sequences. We can't do
1448          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1449          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1450          while (length $codedString > 0) {          while (length $codedString > 0) {
1451              # Look for the first escape sequence.              # Look for the first escape sequence.
1452              if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1453                  # Here we found it. The text preceding the sequence is in $1. The sequence                  # Here we found it. The text preceding the sequence is in $1. The sequence
1454                  # itself is in $2. First, move the clear text to the return variable.                  # itself is in $2. First, move the clear text to the return variable.
1455                  $retVal .= $1;                  $retVal .= $1;
1456                  $codedString = substr $codedString, (2 + length $1);                  $codedString = substr $codedString, (2 + length $1);
1457                  # Decode the escape sequence.                  # Get the escape value.
1458                  my $char = $2;                  my $char = $2;
1459                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1460                    if ($char ne 'r') {
1461                        # Here it's not an 'r', so we convert it.
1462                        $char =~ tr/\\tn/\\\t\n/;
1463                  $retVal .= $char;                  $retVal .= $char;
1464                    }
1465              } else {              } else {
1466                  # Here there are no more escape sequences. The rest of the string is                  # Here there are no more escape sequences. The rest of the string is
1467                  # transferred unmodified.                  # transferred unmodified.
# Line 1018  Line 1567 
1567      return @inputList;      return @inputList;
1568  }  }
1569    
1570    =head3 Percent
1571    
1572    C<< my $percent = Tracer::Percent($number, $base); >>
1573    
1574    Returns the percent of the base represented by the given number. If the base
1575    is zero, returns zero.
1576    
1577    =over 4
1578    
1579    =item number
1580    
1581    Percent numerator.
1582    
1583    =item base
1584    
1585    Percent base.
1586    
1587    =item RETURN
1588    
1589    Returns the percentage of the base represented by the numerator.
1590    
1591    =back
1592    
1593    =cut
1594    
1595    sub Percent {
1596        # Get the parameters.
1597        my ($number, $base) = @_;
1598        # Declare the return variable.
1599        my $retVal = 0;
1600        # Compute the percent.
1601        if ($base != 0) {
1602            $retVal = $number * 100 / $base;
1603        }
1604        # Return the result.
1605        return $retVal;
1606    }
1607    
1608  =head3 GetFile  =head3 GetFile
1609    
1610  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1611    
1612  Return the entire contents of a file.      or
1613    
1614    C<< my $fileContents = Tracer::GetFile($fileName); >>
1615    
1616    Return the entire contents of a file. In list context, line-ends are removed and
1617    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1618    
1619  =over 4  =over 4
1620    
# Line 1033  Line 1625 
1625  =item RETURN  =item RETURN
1626    
1627  In a list context, returns the entire file as a list with the line terminators removed.  In a list context, returns the entire file as a list with the line terminators removed.
1628  In a scalar context, returns the entire file as a string.  In a scalar context, returns the entire file as a string. If an error occurs opening
1629    the file, an empty list will be returned.
1630    
1631  =back  =back
1632    
# Line 1045  Line 1638 
1638      # Declare the return variable.      # Declare the return variable.
1639      my @retVal = ();      my @retVal = ();
1640      # Open the file for input.      # Open the file for input.
1641      my $ok = open INPUTFILE, "<$fileName";      my $handle = Open(undef, "<$fileName");
     if (!$ok) {  
         # If we had an error, trace it. We will automatically return a null value.  
         Trace("Could not open \"$fileName\" for input: $!") if T(0);  
     } else {  
1642          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1643          # characters.          # characters.
1644          my $lineCount = 0;          my $lineCount = 0;
1645          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1646              $lineCount++;              $lineCount++;
1647              $line = Strip($line);              $line = Strip($line);
1648              push @retVal, $line;              push @retVal, $line;
1649          }          }
1650          # Close it.          # Close it.
1651          close INPUTFILE;      close $handle;
1652          my $actualLines = @retVal;          my $actualLines = @retVal;
1653      }      Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1654      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1655      if (wantarray) {      if (wantarray) {
1656          return @retVal;          return @retVal;
# Line 1070  Line 1659 
1659      }      }
1660  }  }
1661    
1662    =head3 PutFile
1663    
1664    C<< Tracer::PutFile($fileName, \@lines); >>
1665    
1666    Write out a file from a list of lines of text.
1667    
1668    =over 4
1669    
1670    =item fileName
1671    
1672    Name of the output file.
1673    
1674    =item lines
1675    
1676    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1677    new-line characters. Alternatively, may be a string, in which case the string will be written without
1678    modification.
1679    
1680    =back
1681    
1682    =cut
1683    
1684    sub PutFile {
1685        # Get the parameters.
1686        my ($fileName, $lines) = @_;
1687        # Open the output file.
1688        my $handle = Open(undef, ">$fileName");
1689        # Count the lines written.
1690        if (ref $lines ne 'ARRAY') {
1691            # Here we have a scalar, so we write it raw.
1692            print $handle $lines;
1693            Trace("Scalar put to file $fileName.") if T(File => 3);
1694        } else {
1695            # Write the lines one at a time.
1696            my $count = 0;
1697            for my $line (@{$lines}) {
1698                print $handle "$line\n";
1699                $count++;
1700            }
1701            Trace("$count lines put to file $fileName.") if T(File => 3);
1702        }
1703        # Close the output file.
1704        close $handle;
1705    }
1706    
1707  =head3 QTrace  =head3 QTrace
1708    
1709  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1117  Line 1751 
1751    
1752  C<< Confess($message); >>  C<< Confess($message); >>
1753    
1754  Trace the call stack and abort the program with the specified message. The stack  Trace the call stack and abort the program with the specified message. When used with
 trace will only appear if the trace level for this package is 1 or more. When used with  
1755  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1756  So, for example  So, for example
1757    
# Line 1140  Line 1773 
1773      # Get the parameters.      # Get the parameters.
1774      my ($message) = @_;      my ($message) = @_;
1775      # Trace the call stack.      # Trace the call stack.
1776      Cluck($message) if T(1);      Cluck($message);
1777      # Abort the program.      # Abort the program.
1778      croak(">>> $message");      croak(">>> $message");
1779  }  }
# Line 1150  Line 1783 
1783  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1784    
1785  Return TRUE if all the conditions are true. This method can be used in conjunction with  Return TRUE if all the conditions are true. This method can be used in conjunction with
1786  the OR operator and the L</Confess> method, B<Assert> can function as a debugging assert.  the OR operator and the L</Confess> method as a debugging assert.
1787  So, for example  So, for example
1788    
1789  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1271  Line 1904 
1904    
1905  =head3 AddToListMap  =head3 AddToListMap
1906    
1907  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1908    
1909  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1910  is created for the key. Otherwise, the new value is pushed onto the list.  is created for the key. Otherwise, the new value is pushed onto the list.
# Line 1286  Line 1919 
1919    
1920  Key for which the value is to be added.  Key for which the value is to be added.
1921    
1922  =item value  =item value1, value2, ... valueN
1923    
1924  Value to add to the key's value list.  List of values to add to the key's value list.
1925    
1926  =back  =back
1927    
# Line 1296  Line 1929 
1929    
1930  sub AddToListMap {  sub AddToListMap {
1931      # Get the parameters.      # Get the parameters.
1932      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1933      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1934      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1935          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1936      } else {      } else {
1937          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1938      }      }
1939  }  }
1940    
# Line 1309  Line 1942 
1942    
1943  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1944    
1945  Return TRUE if debug mode has been turned on in FIG_Config, else output  Return TRUE if debug mode has been turned on, else abort.
 an error page and return FALSE.  
1946    
1947  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1948  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1949  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1950  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1951  is not turned on, an error web page will be output.  is not turned on, an error will occur.
1952    
1953  =cut  =cut
1954    
1955  sub DebugMode {  sub DebugMode {
1956      # Declare the return variable.      # Declare the return variable.
1957      my $retVal;      my $retVal = 0;
1958      # Check the debug configuration.      # Check the debug configuration.
1959      if (1) { # HACK $FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1960        my $encrypted = Digest::MD5::md5_hex($password);
1961        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1962          $retVal = 1;          $retVal = 1;
1963      } else {      } else {
1964          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error.
1965          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          Confess("Cannot use this facility without logging in.");
         print $pageString;  
1966      }      }
1967      # Return the determination indicator.      # Return the determination indicator.
1968      return $retVal;      return $retVal;
# Line 1360  Line 1993 
1993  sub Strip {  sub Strip {
1994      # Get a copy of the parameter string.      # Get a copy of the parameter string.
1995      my ($string) = @_;      my ($string) = @_;
1996      my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1997      # Strip the line terminator characters.      # Strip the line terminator characters.
1998      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1999      # Return the result.      # Return the result.
# Line 1391  Line 2024 
2024    
2025  =item padChar (optional)  =item padChar (optional)
2026    
2027    Character to use for padding. The default is a space.
2028    
2029  =item RETURN  =item RETURN
2030    
2031  Returns a copy of the original string with the spaces added to the specified end so  Returns a copy of the original string with the pad character added to the
2032  that it achieves the desired length.  specified end so that it achieves the desired length.
2033    
2034  =back  =back
2035    
# Line 1426  Line 2061 
2061      return $retVal;      return $retVal;
2062  }  }
2063    
2064    =head3 EOF
2065    
2066    This is a constant that is lexically greater than any useful string.
2067    
2068    =cut
2069    
2070    sub EOF {
2071        return "\xFF\xFF\xFF\xFF\xFF";
2072    }
2073    
2074  =head3 TICK  =head3 TICK
2075    
2076  C<< my @results = TICK($commandString); >>  C<< my @results = TICK($commandString); >>
# Line 1467  Line 2112 
2112      return `$commandString`;      return `$commandString`;
2113  }  }
2114    
2115    =head3 ScriptSetup
2116    
2117    C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
2118    
2119    Perform standard tracing and debugging setup for scripts. The value returned is
2120    the CGI object followed by a pre-built variable hash. At the end of the script,
2121    the client should call L</ScriptFinish> to output the web page.
2122    
2123    This method calls L</ETracing> to configure tracing, which allows the tracing
2124    to be configured via the emergency tracing form on the debugging control panel.
2125    Tracing will then be turned on automatically for all programs that use the L</ETracing>
2126    method, which includes every program that uses this method or L</StandardSetup>.
2127    
2128    =over 4
2129    
2130    =item noTrace (optional)
2131    
2132    If specified, tracing will be suppressed. This is useful if the script wants to set up
2133    tracing manually.
2134    
2135    =item RETURN
2136    
2137    Returns a two-element list consisting of a CGI query object and a variable hash for
2138    the output page.
2139    
2140    =back
2141    
2142    =cut
2143    
2144    sub ScriptSetup {
2145        # Get the parameters.
2146        my ($noTrace) = @_;
2147        # Get the CGI query object.
2148        my $cgi = CGI->new();
2149        # Set up tracing if it's not suppressed.
2150        ETracing($cgi) unless $noTrace;
2151        # Create the variable hash.
2152        my $varHash = { results => '' };
2153        # Return the query object and variable hash.
2154        return ($cgi, $varHash);
2155    }
2156    
2157    =head3 ETracing
2158    
2159    C<< ETracing($parameter); >>
2160    
2161    Set up emergency tracing. Emergency tracing is tracing that is turned
2162    on automatically for any program that calls this method. The emergency
2163    tracing parameters are stored in a a file identified by a tracing key.
2164    If this method is called with a CGI object, then the tracing key is
2165    taken from a cookie. If it is called with no parameters, then the tracing
2166    key is taken from an environment variable. If it is called with a string,
2167    the tracing key is that string.
2168    
2169    =over 4
2170    
2171    =item parameter
2172    
2173    A parameter from which the tracing key is computed. If it is a scalar,
2174    that scalar is used as the tracing key. If it is a CGI object, the
2175    tracing key is taken from the C<IP> cookie. If it is omitted, the
2176    tracing key is taken from the C<TRACING> environment variable. If it
2177    is a CGI object and emergency tracing is not on, the C<Trace> and
2178    C<TF> parameters will be used to determine the type of tracing.
2179    
2180    =back
2181    
2182    =cut
2183    
2184    sub ETracing {
2185        # Get the parameter.
2186        my ($parameter) = @_;
2187        # Check for CGI mode.
2188        my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);
2189        # Default to no tracing except errors.
2190        my ($tracing, $dest) = ("0", "WARN");
2191        # Check for emergency tracing.
2192        my $tkey = EmergencyKey($parameter);
2193        my $emergencyFile = EmergencyFileName($tkey);
2194        if (-e $emergencyFile) {
2195            # We have the file. Read in the data.
2196            my @tracing = GetFile($emergencyFile);
2197            # Pull off the time limit.
2198            my $expire = shift @tracing;
2199            # Convert it to seconds.
2200            $expire *= 3600;
2201            # Check the file data.
2202            my $stat = stat($emergencyFile);
2203            my ($now) = gettimeofday;
2204            if ($now - $stat->mtime > $expire) {
2205                # Delete the expired file.
2206                unlink $emergencyFile;
2207            } else {
2208                # Emergency tracing is on. Pull off the destination and
2209                # the trace level;
2210                $dest = shift @tracing;
2211                my $level = shift @tracing;
2212                # Convert the destination to a real tracing destination.
2213                # temp directory.
2214                $dest = EmergencyTracingDest($tkey, $dest);
2215                # Insure Tracer is specified.
2216                my %moduleHash = map { $_ => 1 } @tracing;
2217                $moduleHash{Tracer} = 1;
2218                # Set the trace parameter.
2219                $tracing = join(" ", $level, sort keys %moduleHash);
2220            }
2221        } elsif (defined $cgi) {
2222            # There's no emergency tracing, but we have a CGI object, so check
2223            # for tracing from the form parameters.
2224            if ($cgi->param('Trace')) {
2225                # Here the user has requested tracing via a form.
2226                $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
2227                $tracing = $cgi->param('Trace') . " Tracer";
2228            }
2229        }
2230        # Setup the tracing we've determined from all the stuff above.
2231        TSetup($tracing, $dest);
2232        # If we're a web script, trace the parameter and environment data.
2233        if (defined $cgi) {
2234            TraceParms($cgi);
2235        }
2236    }
2237    
2238    =head3 EmergencyFileName
2239    
2240    C<< my $fileName = Tracer::EmergencyFileName($tkey); >>
2241    
2242    Return the emergency tracing file name. This is the file that specifies
2243    the tracing information.
2244    
2245    =over 4
2246    
2247    =item tkey
2248    
2249    Tracing key for the current program.
2250    
2251    =item RETURN
2252    
2253    Returns the name of the file to contain the emergency tracing information.
2254    
2255    =back
2256    
2257    =cut
2258    
2259    sub EmergencyFileName {
2260        # Get the parameters.
2261        my ($tkey) = @_;
2262        # Compute the emergency tracing file name.
2263        return "$FIG_Config::temp/Emergency$tkey.txt";
2264    }
2265    
2266    =head3 EmergencyFileTarget
2267    
2268    C<< my $fileName = Tracer::EmergencyFileTarget($tkey); >>
2269    
2270    Return the emergency tracing target file name. This is the file that receives
2271    the tracing output for file-based tracing.
2272    
2273    =over 4
2274    
2275    =item tkey
2276    
2277    Tracing key for the current program.
2278    
2279    =item RETURN
2280    
2281    Returns the name of the file to contain the trace output.
2282    
2283    =back
2284    
2285    =cut
2286    
2287    sub EmergencyFileTarget {
2288        # Get the parameters.
2289        my ($tkey) = @_;
2290        # Compute the emergency tracing file name.
2291        return "$FIG_Config::temp/trace$tkey.log";
2292    }
2293    
2294    =head3 EmergencyTracingDest
2295    
2296    C<< my $dest = Tracer::EmergencyTracingDest($tkey, $myDest); >>
2297    
2298    This method converts an emergency tracing destination to a real
2299    tracing destination. The main difference is that if the
2300    destination is C<FILE> or C<APPEND>, we convert it to file
2301    output. If the destination is C<DUAL>, we convert it to file
2302    and standard output.
2303    
2304    =over 4
2305    
2306    =item tkey
2307    
2308    Tracing key for this environment.
2309    
2310    =item myDest
2311    
2312    Destination from the emergency tracing file.
2313    
2314    =item RETURN
2315    
2316    Returns a destination that can be passed into L</TSetup>.
2317    
2318    =back
2319    
2320    =cut
2321    
2322    sub EmergencyTracingDest {
2323        # Get the parameters.
2324        my ($tkey, $myDest) = @_;
2325        # Declare the return variable.
2326        my $retVal;
2327        # Process according to the destination value.
2328        if ($myDest eq 'FILE') {
2329            $retVal = ">" . EmergencyFileTarget($tkey);
2330        } elsif ($myDest eq 'APPEND') {
2331            $retVal = ">>" . EmergencyFileTarget($tkey);
2332        } elsif ($myDest eq 'DUAL') {
2333            $retVal = "+>" . EmergencyFileTarget($tkey);
2334        }
2335        # Return the result.
2336        return $retVal;
2337    }
2338    
2339    =head3 Emergency
2340    
2341    C<< Emergency($key, $hours, $dest, $level, @modules); >>
2342    
2343    Turn on emergency tracing. This method is normally invoked over the web from
2344    a debugging console, but it can also be called by the C<trace.pl> script.
2345    The caller specifies the duration of the emergency in hours, the desired tracing
2346    destination, the trace level, and a list of the trace modules to activate.
2347    For the length of the duration, when a program in an environment with the
2348    specified tracing key active invokes a Sprout CGI script, tracing will be
2349    turned on automatically. See L</TSetup> for more about tracing setup and
2350    L</ETracing> for more about emergency tracing.
2351    
2352    =over 4
2353    
2354    =item tkey
2355    
2356    The tracing key. This is used to identify the control file and the trace file.
2357    
2358    =item hours
2359    
2360    Number of hours to keep emergency tracing alive.
2361    
2362    =item dest
2363    
2364    Tracing destination. If no path information is specified for a file
2365    destination, it is put in the FIG temporary directory.
2366    
2367    =item level
2368    
2369    Tracing level. A higher level means more trace messages.
2370    
2371    =item modules
2372    
2373    A list of the tracing modules to activate.
2374    
2375    =back
2376    
2377    =cut
2378    
2379    sub Emergency {
2380        # Get the parameters.
2381        my ($tkey, $hours, $dest, $level, @modules) = @_;
2382        # Create the emergency file.
2383        my $specFile = EmergencyFileName($tkey);
2384        my $outHandle = Open(undef, ">$specFile");
2385        print $outHandle join("\n", $hours, $dest, $level, @modules, "");
2386    }
2387    
2388    =head3 EmergencyKey
2389    
2390    C<< my $tkey = EmergencyKey($parameter); >>
2391    
2392    Return the Key to be used for emergency tracing. This could be an IP address,
2393     a session ID, or a user name, depending on the environment.
2394    
2395    =over 4
2396    
2397    =item parameter
2398    
2399    Parameter defining the method for finding the tracing key. If it is a scalar,
2400    then it is presumed to be the tracing key itself. If it is a CGI object, then
2401    the tracing key is taken from the C<IP> cookie. Otherwise, the tracing key is
2402    taken from the C<TRACING> environment variable.
2403    
2404    =item RETURN
2405    
2406    Returns the key to be used for labels in emergency tracing.
2407    
2408    =back
2409    
2410    =cut
2411    
2412    sub EmergencyKey {
2413        # Get the parameters.
2414        my ($parameter) = @_;
2415        # Declare the return variable.
2416        my $retVal;
2417        # Determine the parameter type.
2418        if (! defined $parameter) {
2419            # Here we're supposed to check the environment.
2420            $retVal = $ENV{TRACING};
2421        } else {
2422            my $ptype = ref $parameter;
2423            if ($ptype eq 'CGI') {
2424                # Here we were invoked from a web page. Look for a cookie.
2425                $retVal = $parameter->cookie('IP');
2426            } elsif (! $ptype) {
2427                # Here the key was passed in.
2428                $retVal = $parameter;
2429            }
2430        }
2431        # If no luck finding a key, use the PID.
2432        if (! defined $retVal) {
2433            $retVal = $$;
2434        }
2435        # Return the result.
2436        return $retVal;
2437    }
2438    
2439    
2440    =head3 TraceParms
2441    
2442    C<< Tracer::TraceParms($cgi); >>
2443    
2444    Trace the CGI parameters at trace level CGI => 3 and the environment variables
2445    at level CGI => 4.
2446    
2447    =over 4
2448    
2449    =item cgi
2450    
2451    CGI query object containing the parameters to trace.
2452    
2453    =back
2454    
2455    =cut
2456    
2457    sub TraceParms {
2458        # Get the parameters.
2459        my ($cgi) = @_;
2460        if (T(CGI => 3)) {
2461            # Here we want to trace the parameter data.
2462            my @names = $cgi->param;
2463            for my $parmName (sort @names) {
2464                # Note we skip the Trace parameters, which are for our use only.
2465                if ($parmName ne 'Trace' && $parmName ne 'TF') {
2466                    my @values = $cgi->param($parmName);
2467                    Trace("CGI: $parmName = " . join(", ", @values));
2468                }
2469            }
2470            # Display the request method.
2471            my $method = $cgi->request_method();
2472            Trace("Method: $method");
2473        }
2474        if (T(CGI => 4)) {
2475            # Here we want the environment data too.
2476            for my $envName (sort keys %ENV) {
2477                Trace("ENV: $envName = $ENV{$envName}");
2478            }
2479        }
2480    }
2481    
2482    =head3 ScriptFinish
2483    
2484    C<< ScriptFinish($webData, $varHash); >>
2485    
2486    Output a web page at the end of a script. Either the string to be output or the
2487    name of a template file can be specified. If the second parameter is omitted,
2488    it is assumed we have a string to be output; otherwise, it is assumed we have the
2489    name of a template file. The template should have the variable C<DebugData>
2490    specified in any form that invokes a standard script. If debugging mode is turned
2491    on, a form field will be put in that allows the user to enter tracing data.
2492    Trace messages will be placed immediately before the terminal C<BODY> tag in
2493    the output, formatted as a list.
2494    
2495    A typical standard script would loook like the following.
2496    
2497        BEGIN {
2498            # Print the HTML header.
2499            print "CONTENT-TYPE: text/html\n\n";
2500        }
2501        use Tracer;
2502        use CGI;
2503        use FIG;
2504        # ... more uses ...
2505    
2506        my ($cgi, $varHash) = ScriptSetup();
2507        eval {
2508            # ... get data from $cgi, put it in $varHash ...
2509        };
2510        if ($@) {
2511            Trace("Script Error: $@") if T(0);
2512        }
2513        ScriptFinish("Html/MyTemplate.html", $varHash);
2514    
2515    The idea here is that even if the script fails, you'll see trace messages and
2516    useful output.
2517    
2518    =over 4
2519    
2520    =item webData
2521    
2522    A string containing either the full web page to be written to the output or the
2523    name of a template file from which the page is to be constructed. If the name
2524    of a template file is specified, then the second parameter must be present;
2525    otherwise, it must be absent.
2526    
2527    =item varHash (optional)
2528    
2529    If specified, then a reference to a hash mapping variable names for a template
2530    to their values. The template file will be read into memory, and variable markers
2531    will be replaced by data in this hash reference.
2532    
2533    =back
2534    
2535    =cut
2536    
2537    sub ScriptFinish {
2538        # Get the parameters.
2539        my ($webData, $varHash) = @_;
2540        # Check for a template file situation.
2541        my $outputString;
2542        if (defined $varHash) {
2543            # Here we have a template file. We need to determine the template type.
2544            my $template;
2545            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2546                $template = "$FIG_Config::template_url/$webData";
2547            } else {
2548                $template = "<<$webData";
2549            }
2550            $outputString = PageBuilder::Build($template, $varHash, "Html");
2551        } else {
2552            # Here the user gave us a raw string.
2553            $outputString = $webData;
2554        }
2555        # Check for trace messages.
2556        if ($Destination ne "NONE" && $TraceLevel > 0) {
2557            # We have trace messages, so we want to put them at the end of the body. This
2558            # is either at the end of the whole string or at the beginning of the BODY
2559            # end-tag.
2560            my $pos = length $outputString;
2561            if ($outputString =~ m#</body>#gi) {
2562                $pos = (pos $outputString) - 7;
2563            }
2564            # If the trace messages were queued, we unroll them. Otherwise, we display the
2565            # destination.
2566            my $traceHtml;
2567            if ($Destination eq "QUEUE") {
2568                $traceHtml = QTrace('Html');
2569            } elsif ($Destination =~ /^>>(.+)$/) {
2570                # Here the tracing output it to a file. We code it as a hyperlink so the user
2571                # can copy the file name into the clipboard easily.
2572                my $actualDest = $1;
2573                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
2574            } else {
2575                # Here we have one of the special destinations.
2576                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
2577            }
2578            substr $outputString, $pos, 0, $traceHtml;
2579        }
2580        # Write the output string.
2581        print $outputString;
2582    }
2583    
2584    =head3 Insure
2585    
2586    C<< Insure($dirName); >>
2587    
2588    Insure a directory is present.
2589    
2590    =over 4
2591    
2592    =item dirName
2593    
2594    Name of the directory to check. If it does not exist, it will be created.
2595    
2596    =back
2597    
2598    =cut
2599    
2600    sub Insure {
2601        my ($dirName) = @_;
2602        if (! -d $dirName) {
2603            Trace("Creating $dirName directory.") if T(File => 2);
2604            eval { mkpath $dirName; };
2605            if ($@) {
2606                Confess("Error creating $dirName: $@");
2607            }
2608        }
2609    }
2610    
2611    =head3 ChDir
2612    
2613    C<< ChDir($dirName); >>
2614    
2615    Change to the specified directory.
2616    
2617    =over 4
2618    
2619    =item dirName
2620    
2621    Name of the directory to which we want to change.
2622    
2623    =back
2624    
2625    =cut
2626    
2627    sub ChDir {
2628        my ($dirName) = @_;
2629        if (! -d $dirName) {
2630            Confess("Cannot change to directory $dirName: no such directory.");
2631        } else {
2632            Trace("Changing to directory $dirName.") if T(File => 4);
2633            my $okFlag = chdir $dirName;
2634            if (! $okFlag) {
2635                Confess("Error switching to directory $dirName.");
2636            }
2637        }
2638    }
2639    
2640    =head3 SendSMS
2641    
2642    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2643    
2644    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2645    user name, password, and API ID for the relevant account in the hash reference variable
2646    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2647    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2648    is C<2561022>, then the FIG_Config file must contain
2649    
2650        $phone =  { user => 'BruceTheHumanPet',
2651                    password => 'silly',
2652                    api_id => '2561022' };
2653    
2654    The original purpose of this method was to insure Bruce would be notified immediately when the
2655    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2656    when you call this method.
2657    
2658    The message ID will be returned if successful, and C<undef> if an error occurs.
2659    
2660    =over 4
2661    
2662    =item phoneNumber
2663    
2664    Phone number to receive the message, in international format. A United States phone number
2665    would be prefixed by "1". A British phone number would be prefixed by "44".
2666    
2667    =item msg
2668    
2669    Message to send to the specified phone.
2670    
2671    =item RETURN
2672    
2673    Returns the message ID if successful, and C<undef> if the message could not be sent.
2674    
2675    =back
2676    
2677    =cut
2678    
2679    sub SendSMS {
2680        # Get the parameters.
2681        my ($phoneNumber, $msg) = @_;
2682        # Declare the return variable. If we do not change it, C<undef> will be returned.
2683        my $retVal;
2684        # Only proceed if we have phone support.
2685        if (! defined $FIG_Config::phone) {
2686            Trace("Phone support not present in FIG_Config.") if T(1);
2687        } else {
2688            # Get the phone data.
2689            my $parms = $FIG_Config::phone;
2690            # Get the Clickatell URL.
2691            my $url = "http://api.clickatell.com/http/";
2692            # Create the user agent.
2693            my $ua = LWP::UserAgent->new;
2694            # Request a Clickatell session.
2695            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2696                                         password => $parms->{password},
2697                                         api_id => $parms->{api_id},
2698                                         to => $phoneNumber,
2699                                         text => $msg});
2700            # Check for an error.
2701            if (! $resp->is_success) {
2702                Trace("Alert failed.") if T(1);
2703            } else {
2704                # Get the message ID.
2705                my $rstring = $resp->content;
2706                if ($rstring =~ /^ID:\s+(.*)$/) {
2707                    $retVal = $1;
2708                } else {
2709                    Trace("Phone attempt failed with $rstring") if T(1);
2710                }
2711            }
2712        }
2713        # Return the result.
2714        return $retVal;
2715    }
2716    
2717    =head3 CommaFormat
2718    
2719    C<< my $formatted = Tracer::CommaFormat($number); >>
2720    
2721    Insert commas into a number.
2722    
2723    =over 4
2724    
2725    =item number
2726    
2727    A sequence of digits.
2728    
2729    =item RETURN
2730    
2731    Returns the same digits with commas strategically inserted.
2732    
2733    =back
2734    
2735    =cut
2736    
2737    sub CommaFormat {
2738        # Get the parameters.
2739        my ($number) = @_;
2740        # Pad the length up to a multiple of three.
2741        my $padded = "$number";
2742        $padded = " " . $padded while length($padded) % 3 != 0;
2743        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2744        # cause the delimiters to be included in the output stream. The
2745        # GREP removes the empty strings in between the delimiters.
2746        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2747        # Clean out the spaces.
2748        $retVal =~ s/ //g;
2749        # Return the result.
2750        return $retVal;
2751    }
2752    =head3 SetPermissions
2753    
2754    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2755    
2756    Set the permissions for a directory and all the files and folders inside it.
2757    In addition, the group ownership will be changed to the specified value.
2758    
2759    This method is more vulnerable than most to permission and compatability
2760    problems, so it does internal error recovery.
2761    
2762    =over 4
2763    
2764    =item dirName
2765    
2766    Name of the directory to process.
2767    
2768    =item group
2769    
2770    Name of the group to be assigned.
2771    
2772    =item mask
2773    
2774    Permission mask. Bits that are C<1> in this mask will be ORed into the
2775    permission bits of any file or directory that does not already have them
2776    set to 1.
2777    
2778    =item otherMasks
2779    
2780    Map of search patterns to permission masks. If a directory name matches
2781    one of the patterns, that directory and all its members and subdirectories
2782    will be assigned the new pattern. For example, the following would
2783    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2784    
2785        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2786    
2787    The list is ordered, so the following would use 0777 for C<tmp1> and
2788    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2789    
2790        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2791                                                       '^tmp' => 0666);
2792    
2793    Note that the pattern matches are all case-insensitive, and only directory
2794    names are matched, not file names.
2795    
2796    =back
2797    
2798    =cut
2799    
2800    sub SetPermissions {
2801        # Get the parameters.
2802        my ($dirName, $group, $mask, @otherMasks) = @_;
2803        # Set up for error recovery.
2804        eval {
2805            # Switch to the specified directory.
2806            ChDir($dirName);
2807            # Get the group ID.
2808            my $gid = getgrnam($group);
2809            # Get the mask for tracing.
2810            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2811            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(File => 2);
2812            my $fixCount = 0;
2813            my $lookCount = 0;
2814            # @dirs will be a stack of directories to be processed.
2815            my @dirs = (getcwd());
2816            while (scalar(@dirs) > 0) {
2817                # Get the current directory.
2818                my $dir = pop @dirs;
2819                # Check for a match to one of the specified directory names. To do
2820                # that, we need to pull the individual part of the name off of the
2821                # whole path.
2822                my $simpleName = $dir;
2823                if ($dir =~ m!/([^/]+)$!) {
2824                    $simpleName = $1;
2825                }
2826                Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2827                # Search for a match.
2828                my $match = 0;
2829                my $i;
2830                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2831                    my $pattern = $otherMasks[$i];
2832                    if ($simpleName =~ /$pattern/i) {
2833                        $match = 1;
2834                    }
2835                }
2836                # Check for a match. Note we use $i-1 because the loop added 2
2837                # before terminating due to the match.
2838                if ($match && $otherMasks[$i-1] != $mask) {
2839                    # This directory matches one of the incoming patterns, and it's
2840                    # a different mask, so we process it recursively with that mask.
2841                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2842                } else {
2843                    # Here we can process normally. Get all of the non-hidden members.
2844                    my @submems = OpenDir($dir, 1);
2845                    for my $submem (@submems) {
2846                        # Get the full name.
2847                        my $thisMem = "$dir/$submem";
2848                        Trace("Checking member $thisMem.") if T(4);
2849                        $lookCount++;
2850                        if ($lookCount % 1000 == 0) {
2851                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(File => 3);
2852                        }
2853                        # Fix the group.
2854                        chown -1, $gid, $thisMem;
2855                        # Insure this member is not a symlink.
2856                        if (! -l $thisMem) {
2857                            # Get its info.
2858                            my $fileInfo = stat $thisMem;
2859                            # Only proceed if we got the info. Otherwise, it's a hard link
2860                            # and we want to skip it anyway.
2861                            if ($fileInfo) {
2862                                my $fileMode = $fileInfo->mode;
2863                                if (($fileMode & $mask) != $mask) {
2864                                    # Fix this member.
2865                                    $fileMode |= $mask;
2866                                    chmod $fileMode, $thisMem;
2867                                    $fixCount++;
2868                                }
2869                                # If it's a subdirectory, stack it.
2870                                if (-d $thisMem) {
2871                                    push @dirs, $thisMem;
2872                                }
2873                            }
2874                        }
2875                    }
2876                }
2877            }
2878            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2879        };
2880        # Check for an error.
2881        if ($@) {
2882            Confess("SetPermissions error: $@");
2883        }
2884    }
2885    
2886    =head3 CompareLists
2887    
2888    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2889    
2890    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2891    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2892    The return value contains a list of items that are only in the new list
2893    (inserted) and only in the old list (deleted).
2894    
2895    =over 4
2896    
2897    =item newList
2898    
2899    Reference to a list of new tuples.
2900    
2901    =item oldList
2902    
2903    Reference to a list of old tuples.
2904    
2905    =item keyIndex (optional)
2906    
2907    Index into each tuple of its key field. The default is 0.
2908    
2909    =item RETURN
2910    
2911    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2912    list (inserted) followed by a reference to the list of items that are only in the old
2913    list (deleted).
2914    
2915    =back
2916    
2917    =cut
2918    
2919    sub CompareLists {
2920        # Get the parameters.
2921        my ($newList, $oldList, $keyIndex) = @_;
2922        if (! defined $keyIndex) {
2923            $keyIndex = 0;
2924        }
2925        # Declare the return variables.
2926        my ($inserted, $deleted) = ([], []);
2927        # Loop through the two lists simultaneously.
2928        my ($newI, $oldI) = (0, 0);
2929        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2930        while ($newI < $newN || $oldI < $oldN) {
2931            # Get the current object in each list. Note that if one
2932            # of the lists is past the end, we'll get undef.
2933            my $newItem = $newList->[$newI];
2934            my $oldItem = $oldList->[$oldI];
2935            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2936                # The old item is not in the new list, so mark it deleted.
2937                push @{$deleted}, $oldItem;
2938                $oldI++;
2939            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2940                # The new item is not in the old list, so mark it inserted.
2941                push @{$inserted}, $newItem;
2942                $newI++;
2943            } else {
2944                # The item is in both lists, so push forward.
2945                $oldI++;
2946                $newI++;
2947            }
2948        }
2949        # Return the result.
2950        return ($inserted, $deleted);
2951    }
2952    
2953    =head3 GetLine
2954    
2955    C<< my @data = Tracer::GetLine($handle); >>
2956    
2957    Read a line of data from a tab-delimited file.
2958    
2959    =over 4
2960    
2961    =item handle
2962    
2963    Open file handle from which to read.
2964    
2965    =item RETURN
2966    
2967    Returns a list of the fields in the record read. The fields are presumed to be
2968    tab-delimited. If we are at the end of the file, then an empty list will be
2969    returned. If an empty line is read, a single list item consisting of a null
2970    string will be returned.
2971    
2972    =back
2973    
2974    =cut
2975    
2976    sub GetLine {
2977        # Get the parameters.
2978        my ($handle) = @_;
2979        # Declare the return variable.
2980        my @retVal = ();
2981        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2982        # Read from the file.
2983        my $line = <$handle>;
2984        # Only proceed if we found something.
2985        if (defined $line) {
2986            # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2987            # upload control and have a nonstandard EOL combination.
2988            $line =~ s/(\r|\n)+$//;
2989            # Here we do some fancy tracing to help in debugging complicated EOL marks.
2990            if (T(File => 4)) {
2991                my $escapedLine = $line;
2992                $escapedLine =~ s/\n/\\n/g;
2993                $escapedLine =~ s/\r/\\r/g;
2994                $escapedLine =~ s/\t/\\t/g;
2995                Trace("Line read: -->$escapedLine<--");
2996            }
2997            # If the line is empty, return a single empty string; otherwise, parse
2998            # it into fields.
2999            if ($line eq "") {
3000                push @retVal, "";
3001            } else {
3002                push @retVal, split /\t/,$line;
3003            }
3004        } else {
3005            # Trace the reason the read failed.
3006            Trace("End of file: $!") if T(File => 3);
3007        }
3008        # Return the result.
3009        return @retVal;
3010    }
3011    
3012    =head3 PutLine
3013    
3014    C<< Tracer::PutLine($handle, \@fields, $eol); >>
3015    
3016    Write a line of data to a tab-delimited file. The specified field values will be
3017    output in tab-separated form, with a trailing new-line.
3018    
3019    =over 4
3020    
3021    =item handle
3022    
3023    Output file handle.
3024    
3025    =item fields
3026    
3027    List of field values.
3028    
3029    =item eol (optional)
3030    
3031    End-of-line character (default is "\n").
3032    
3033    =back
3034    
3035    =cut
3036    
3037    sub PutLine {
3038        # Get the parameters.
3039        my ($handle, $fields, $eol) = @_;
3040        # Write the data.
3041        print $handle join("\t", @{$fields}) . ($eol || "\n");
3042    }
3043    
3044    =head3 GenerateURL
3045    
3046    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
3047    
3048    Generate a GET-style URL for the specified page with the specified parameter
3049    names and values. The values will be URL-escaped automatically. So, for
3050    example
3051    
3052        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
3053    
3054    would return
3055    
3056        form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3057    
3058    =over 4
3059    
3060    =item page
3061    
3062    Page URL.
3063    
3064    =item parameters
3065    
3066    Hash mapping parameter names to parameter values.
3067    
3068    =item RETURN
3069    
3070    Returns a GET-style URL that goes to the specified page and passes in the
3071    specified parameters and values.
3072    
3073    =back
3074    
3075    =cut
3076    
3077    sub GenerateURL {
3078        # Get the parameters.
3079        my ($page, %parameters) = @_;
3080        # Prime the return variable with the page URL.
3081        my $retVal = $page;
3082        # Loop through the parameters, creating parameter elements in a list.
3083        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3084        # If the list is nonempty, tack it on.
3085        if (@parmList) {
3086            $retVal .= "?" . join(";", @parmList);
3087        }
3088        # Return the result.
3089        return $retVal;
3090    }
3091    
3092    =head3 ApplyURL
3093    
3094    C<< Tracer::ApplyURL($table, $target, $url); >>
3095    
3096    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3097    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3098    URL column will be deleted by this process and the target column will be HTML-escaped.
3099    
3100    This provides a simple way to process the results of a database query into something
3101    displayable by combining a URL with text.
3102    
3103    =over 4
3104    
3105    =item table
3106    
3107    Reference to a list of lists. The elements in the containing list will be updated by
3108    this method.
3109    
3110    =item target
3111    
3112    The index of the column to be converted into HTML.
3113    
3114    =item url
3115    
3116    The index of the column containing the URL. Note that the URL must have a recognizable
3117    C<http:> at the beginning.
3118    
3119    =back
3120    
3121    =cut
3122    
3123    sub ApplyURL {
3124        # Get the parameters.
3125        my ($table, $target, $url) = @_;
3126        # Loop through the table.
3127        for my $row (@{$table}) {
3128            # Apply the URL to the target cell.
3129            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3130            # Delete the URL from the row.
3131            delete $row->[$url];
3132        }
3133    }
3134    
3135    =head3 CombineURL
3136    
3137    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3138    
3139    This method will convert the specified text into HTML hyperlinked to the specified
3140    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3141    is defined and begins with an C<http:> header.
3142    
3143    =over 4
3144    
3145    =item text
3146    
3147    Text to return. This will be HTML-escaped automatically.
3148    
3149    =item url
3150    
3151    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3152    will be returned without any hyperlinking.
3153    
3154    =item RETURN
3155    
3156    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3157    doesn't look right, the HTML-escaped text will be returned without any further
3158    modification.
3159    
3160    =back
3161    
3162    =cut
3163    
3164    sub CombineURL {
3165        # Get the parameters.
3166        my ($text, $url) = @_;
3167        # Declare the return variable.
3168        my $retVal = CGI::escapeHTML($text);
3169        # Verify the URL.
3170        if (defined($url) && $url =~ m!http://!i) {
3171            # It's good, so we apply it to the text.
3172            $retVal = "<a href=\"$url\">$retVal</a>";
3173        }
3174        # Return the result.
3175        return $retVal;
3176    }
3177    
3178  1;  1;

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.84

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3