[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.9, Wed May 4 03:05:12 2005 UTC revision 1.47, Thu Jun 8 13:52:23 2006 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);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure ChDir);
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    
34  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
35    
# Line 20  Line 41 
41  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace
42  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 this package's trace level and whose category is activated will
43  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
44  is less likely to be seen. A higher trace level passed to B<Setup> means more trace messages will  is less likely to be seen. A higher trace level passed to B<TSetup> means more trace messages will
45  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
46    
47  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 38  Line 59 
59    
60  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
61    
62  To set up tracing, you call the C</Setup> method. The method takes as input a trace level, a list  To set up tracing, you call the L</TSetup> method. The method takes as input a trace level, a list
63  of category names, and a set of options. The trace level and list of category names are  of category names, and a set of options. The trace level and list of category names are
64  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
65    
66  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
67    
68  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
69  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
70  to make it easier to input tracing configuration on a web form.  
71    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
72    level 3 and writes the output to the standard error output. This sort of thing might be
73    useful in a CGI environment.
74    
75    C<< TSetup('3 *', 'WARN'); >>
76    
77  In addition to HTML and file output for trace messages, you can specify that the trace messages  In addition to HTML and file output for trace messages, you can specify that the trace messages
78  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
# Line 61  Line 87 
87  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
88  being used out in the field.  being used out in the field.
89    
90    There is no hard and fast rule on how to use trace levels. The following is therefore only
91    a suggestion.
92    
93    =over 4
94    
95    =item Error 0
96    
97    Message indicates an error that may lead to incorrect results or that has stopped the
98    application entirely.
99    
100    =item Warning 1
101    
102    Message indicates something that is unexpected but that probably did not interfere
103    with program execution.
104    
105    =item Notice 2
106    
107    Message indicates the beginning or end of a major task.
108    
109    =item Information 3
110    
111    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
112    genome. This would be a big loop that is not expected to execute more than 500 times or so.
113    
114    =item Detail 4
115    
116    Message indicates a low-level loop iteration.
117    
118    =back
119    
120  =cut  =cut
121    
122  # Declare the configuration variables.  # Declare the configuration variables.
123    
124  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
125    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
126                                # standard output
127  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
128                                                          # hash of active category names                                                          # hash of active category names
129  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
130                                                          # messages                                                          # messages
131  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
132  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
133    my $SetupCount = 0;         # number of times TSetup called
134    my $AllTrace = 0;           # TRUE if we are tracing all categories.
135    
136  =head2 Public Methods  =head2 Public Methods
137    
# Line 93  Line 153 
153    
154  The destination for the trace output. To send the trace output to a file, specify the file  The destination for the trace output. To send the trace output to a file, specify the file
155  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended
156  to the file. Otherwise the file is cleared before tracing begins. In addition to sending  to the file. Otherwise the file is cleared before tracing begins. Precede the first ">"
157  the trace messages to a file, you can specify a special destination. C<HTML> will cause  symbol with a C<+> to echo output to a file AND to the standard output. In addition to
158  tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  sending the trace messages to a file, you can specify a special destination. C<HTML> will
159    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
160  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
161  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
162  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
# Line 113  Line 174 
174          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
175          # Extract the trace level.          # Extract the trace level.
176          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
177          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
178        $AllTrace = 0;
179        # Build the category hash. Note that if we find a "*", we turn on non-category
180        # tracing. We must also clear away any pre-existing data.
181        %Categories = ( main => 1 );
182          for my $category (@categoryData) {          for my $category (@categoryData) {
183                  $Categories{$category} = 1;          if ($category eq '*') {
184                $AllTrace = 1;
185            } else {
186                $Categories{lc $category} = 1;
187            }
188          }          }
189          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
190          # case is the single ">", which requires we clear the file first. After doing      # cases are the single ">", which requires we clear the file first, and the
191          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
192        if ($target =~ m/^\+?>>?/) {
193            if ($target =~ m/^\+/) {
194                $TeeFlag = 1;
195                $target = substr($target, 1);
196            }
197          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
198                  open TRACEFILE, $target;                  open TRACEFILE, $target;
199                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
200                  close TRACEFILE;                  close TRACEFILE;
201                  $Destination = ">$target";                  $Destination = ">$target";
202          } else {          } else {
203                $Destination = $target;
204            }
205        } else {
206                  $Destination = uc($target);                  $Destination = uc($target);
207          }          }
208        # Increment the setup counter.
209        $SetupCount++;
210    }
211    
212    =head3 StandardSetup
213    
214    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
215    
216    This method performs standard command-line parsing and tracing setup. The return
217    values are a hash of the command-line options and a list of the positional
218    parameters. Tracing is automatically set up and the command-line options are
219    validated.
220    
221    This is a complex method that does a lot of grunt work. The parameters can
222    be more easily understood, however, once they are examined individually.
223    
224    The I<categories> parameter is the most obtuse. It is a reference to a list of
225    special-purpose tracing categories. Most tracing categories are PERL package
226    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
227    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
228    
229        ["Sprout", "SproutLoad", "ERDB"]
230    
231    This would cause trace messages in the specified three packages to appear in
232    the output. There are threer special tracing categories that are automatically
233    handled by this method. In other words, if you used L</TSetup> you would need
234    to include these categories manually, but if you use this method they are turned
235    on automatically.
236    
237    =over 4
238    
239    =item FIG
240    
241    Turns on trace messages inside the B<FIG> package.
242    
243    =item SQL
244    
245    Traces SQL commands and activity.
246    
247    =item Tracer
248    
249    Traces error messages and call stacks.
250    
251    =back
252    
253    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
254    The trace level is specified using the C<-trace> command-line option. For example,
255    the following command line for C<TransactFeatures> turns on SQL tracing and runs
256    all tracing at level 3.
257    
258        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
259    
260    Standard tracing is output to the standard output and echoed to the file
261    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
262    process ID. You can also specify the C<user> parameter to put a user ID
263    instead of a process ID in the trace file name. So, for example
264    
265    The default trace level is 2. To get all messages, specify a trace level of 4.
266    For a genome-by-genome update, use 3.
267    
268        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
269    
270    would send the trace output to C<traceBruce.log> in the temporary directory.
271    
272    The I<options> parameter is a reference to a hash containing the command-line
273    options, their default values, and an explanation of what they mean. Command-line
274    options may be in the form of switches or keywords. In the case of a switch, the
275    option value is 1 if it is specified and 0 if it is not specified. In the case
276    of a keyword, the value is separated from the option name by an equal sign. You
277    can see this last in the command-line example above.
278    
279    You can specify a different default trace level by setting C<$options->{trace}>
280    prior to calling this method.
281    
282    An example at this point would help. Consider, for example, the command-line utility
283    C<TransactFeatures>. It accepts a list of positional parameters plus the options
284    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
285    the following code.
286    
287        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
288                            { safe => [0, "use database transactions"],
289                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
290                              start => [' ', "start with this genome"],
291                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
292                            "command transactionDirectory IDfile",
293                          @ARGV);
294    
295    
296    The call to C<ParseCommand> specifies the default values for the options and
297    stores the actual options in a hash that is returned as C<$options>. The
298    positional parameters are returned in C<@parameters>.
299    
300    The following is a sample command line for C<TransactFeatures>.
301    
302        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
303    
304    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
305    parameters, and would find themselves in I<@parameters> after executing the
306    above code fragment. The tracing would be set to level 2, and the categories
307    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
308    and C<DocUtils> was included because it came in within the first parameter
309    to this method. The I<$options> hash would be
310    
311        { trace => 2, sql => 0, safe => 0,
312          noAlias => 1, start => ' ', tblFiles => 0 }
313    
314    Use of C<StandardSetup> in this way provides a simple way of performing
315    standard tracing setup and command-line parsing. Note that the caller is
316    not even aware of the command-line switches C<-trace> and C<-sql>, which
317    are used by this method to control the tracing. If additional tracing features
318    need to be added in the future, they can be processed by this method without
319    upsetting the command-line utilities.
320    
321    If the C<background> option is specified on the command line, then the
322    standard and error outputs will be directed to files in the temporary
323    directory, using the same suffix as the trace file. So, if the command
324    line specified
325    
326        -user=Bruce -background
327    
328    then the trace output would go to C<traceBruce.log>, the standard output to
329    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
330    simplify starting a command in the background.
331    
332    Finally, if the special option C<-h> is specified, the option names will
333    be traced at level 0 and the program will exit without processing.
334    This provides a limited help capability. For example, if the user enters
335    
336        TransactFeatures -h
337    
338    he would see the following output.
339    
340        TransactFeatures [options] command transactionDirectory IDfile
341            -trace    tracing level (default 2)
342            -sql      trace SQL commands
343            -safe     use database transactions
344            -noAlias  do not expect aliases in CHANGE transactions
345            -start    start with this genome
346            -tblFiles output TBL files containing the corrected IDs
347    
348    The caller has the option of modifying the tracing scheme by placing a value
349    for C<trace> in the incoming options hash. The default value can be overridden,
350    or the tracing to the standard output can be turned off by suffixing a minus
351    sign to the trace level. So, for example,
352    
353        { trace => [0, "tracing level (default 0)"],
354           ...
355    
356    would set the default trace level to 0 instead of 2, while
357    
358        { trace => ["2-", "tracing level (default 2)"],
359           ...
360    
361    would leave the default at 2, but trace only to the log file, not to the
362    standard output.
363    
364    The parameters to this method are as follows.
365    
366    =over 4
367    
368    =item categories
369    
370    Reference to a list of tracing category names. These should be names of
371    packages whose internal workings will need to be debugged to get the
372    command working.
373    
374    =item options
375    
376    Reference to a hash containing the legal options for the current command mapped
377    to their default values and descriptions. The user can override the defaults
378    by specifying the options as command-line switches prefixed by a hyphen.
379    Tracing-related options may be added to this hash. If the C<-h> option is
380    specified on the command line, the option descriptions will be used to
381    explain the options. To turn off tracing to the standard output, add a
382    minus sign to the value for C<trace> (see above).
383    
384    =item parmHelp
385    
386    A string that vaguely describes the positional parameters. This is used
387    if the user specifies the C<-h> option.
388    
389    =item argv
390    
391    List of command line parameters, including the option switches, which must
392    precede the positional parameters and be prefixed by a hyphen.
393    
394    =item RETURN
395    
396    Returns a list. The first element of the list is the reference to a hash that
397    maps the command-line option switches to their values. These will either be the
398    default values or overrides specified on the command line. The remaining
399    elements of the list are the position parameters, in order.
400    
401    =back
402    
403    =cut
404    
405    sub StandardSetup {
406        # Get the parameters.
407        my ($categories, $options, $parmHelp, @argv) = @_;
408        # Add the tracing options.
409        if (! exists $options->{trace}) {
410            $options->{trace} = [2, "tracing level"];
411        }
412        $options->{sql} = [0, "turn on SQL tracing"];
413        $options->{h} = [0, "display command-line options"];
414        $options->{user} = [$$, "trace log file name suffix"];
415        $options->{background} = [0, "spool standard and error output"];
416        # Create a parsing hash from the options hash. The parsing hash
417        # contains the default values rather than the default value
418        # and the description. While we're at it, we'll memorize the
419        # length of the longest option name.
420        my $longestName = 0;
421        my %parseOptions = ();
422        for my $key (keys %{$options}) {
423            if (length $key > $longestName) {
424                $longestName = length $key;
425            }
426            $parseOptions{$key} = $options->{$key}->[0];
427        }
428        # Parse the command line.
429        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
430        # Get the logfile suffix.
431        my $suffix = $retOptions->{user};
432        # Check for background mode.
433        if ($retOptions->{background}) {
434            my $outFileName = "$FIG_Config::temp/out$suffix.log";
435            my $errFileName = "$FIG_Config::temp/err$suffix.log";
436            open STDOUT, ">$outFileName";
437            open STDERR, ">$errFileName";
438        }
439        # Now we want to set up tracing. First, we need to know if SQL is to
440        # be traced.
441        my @cats = @{$categories};
442        if ($retOptions->{sql}) {
443            push @cats, "SQL";
444        }
445        # Add the default categories.
446        push @cats, "Tracer", "FIG";
447        # Next, we create the category string by joining the categories.
448        my $cats = join(" ", @cats);
449        # Check to determine whether or not the caller wants to turn off tracing
450        # to the standard output.
451        my $traceLevel = $retOptions->{trace};
452        my $textOKFlag = 1;
453        if ($traceLevel =~ /^(.)-/) {
454            $traceLevel = $1;
455            $textOKFlag = 0;
456        }
457        # Now we set up the trace mode.
458        my $traceMode;
459        # Verify that we can open a file in the FIG temporary directory.
460        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
461        if (open TESTTRACE, ">$traceFileName") {
462            # Here we can trace to a file.
463            $traceMode = ">$traceFileName";
464            if ($textOKFlag) {
465                # Echo to standard output if the text-OK flag is set.
466                $traceMode = "+$traceMode";
467            }
468            # Close the test file.
469            close TESTTRACE;
470        } else {
471            # Here we can't trace to a file. We trace to the standard output if it's
472            # okay, and the error log otherwise.
473            if ($textOKFlag) {
474                $traceMode = "TEXT";
475            } else {
476                $traceMode = "WARN";
477            }
478        }
479        # Now set up the tracing.
480        TSetup("$traceLevel $cats", $traceMode);
481        # Check for the "h" option. If it is specified, dump the command-line
482        # options and exit the program.
483        if ($retOptions->{h}) {
484            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
485            Trace("$1 [options] $parmHelp") if T(0);
486            for my $key (sort keys %{$options}) {
487                my $name = Pad($key, $longestName, 0, ' ');
488                my $desc = $options->{$key}->[1];
489                if ($options->{$key}->[0]) {
490                    $desc .= " (default " . $options->{$key}->[0] . ")";
491                }
492                Trace("  $name $desc") if T(0);
493            }
494            exit(0);
495        }
496        # Return the parsed parameters.
497        return ($retOptions, @retParameters);
498    }
499    
500    =head3 Setups
501    
502    C<< my $count = Tracer::Setups(); >>
503    
504    Return the number of times L</TSetup> has been called.
505    
506    This method allows for the creation of conditional tracing setups where, for example, we
507    may want to set up tracing if nobody else has done it before us.
508    
509    =cut
510    
511    sub Setups {
512        return $SetupCount;
513    }
514    
515    =head3 Open
516    
517    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
518    
519    Open a file.
520    
521    The I<$fileSpec> is essentially the second argument of the PERL C<open>
522    function. The mode is specified using Unix-like shell information. So, for
523    example,
524    
525        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
526    
527    would open for output appended to the specified file, and
528    
529        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
530    
531    would open a pipe that sorts the records written and removes duplicates. Note
532    the use of file handle syntax in the Open call. To use anonymous file handles,
533    code as follows.
534    
535        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
536    
537    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
538    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
539    failed open will throw an exception and the third parameter will be used to construct
540    an error message. If the parameter is omitted, a standard message is constructed
541    using the file spec.
542    
543        Could not open "/usr/spool/news/twitlog"
544    
545    Note that the mode characters are automatically cleaned from the file name.
546    The actual error message from the file system will be captured and appended to the
547    message in any case.
548    
549        Could not open "/usr/spool/news/twitlog": file not found.
550    
551    In some versions of PERL the only error message we get is a number, which
552    corresponds to the C++ C<errno> value.
553    
554        Could not open "/usr/spool/news/twitlog": 6.
555    
556    =over 4
557    
558    =item fileHandle
559    
560    File handle. If this parameter is C<undef>, a file handle will be generated
561    and returned as the value of this method.
562    
563    =item fileSpec
564    
565    File name and mode, as per the PERL C<open> function.
566    
567    =item message (optional)
568    
569    Error message to use if the open fails. If omitted, a standard error message
570    will be generated. In either case, the error information from the file system
571    is appended to the message. To specify a conditional open that does not throw
572    an error if it fails, use C<0>.
573    
574    =item RETURN
575    
576    Returns the name of the file handle assigned to the file, or C<undef> if the
577    open failed.
578    
579    =back
580    
581    =cut
582    
583    sub Open {
584        # Get the parameters.
585        my ($fileHandle, $fileSpec, $message) = @_;
586        # Attempt to open the file.
587        my $rv = open $fileHandle, $fileSpec;
588        # If the open failed, generate an error message.
589        if (! $rv) {
590            # Save the system error message.
591            my $sysMessage = $!;
592            # See if we need a default message.
593            if (!$message) {
594                # Clean any obvious mode characters and leading spaces from the
595                # filename.
596                my ($fileName) = FindNamePart($fileSpec);
597                $message = "Could not open \"$fileName\"";
598            }
599            # Terminate with an error using the supplied message and the
600            # error message from the file system.
601            Confess("$message: $!");
602        }
603        # Return the file handle.
604        return $fileHandle;
605    }
606    
607    =head3 FindNamePart
608    
609    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
610    
611    Extract the portion of a file specification that contains the file name.
612    
613    A file specification is the string passed to an C<open> call. It specifies the file
614    mode and name. In a truly complex situation, it can specify a pipe sequence. This
615    method assumes that the file name is whatever follows the first angle bracket
616    sequence.  So, for example, in the following strings the file name is
617    C</usr/fig/myfile.txt>.
618    
619        >>/usr/fig/myfile.txt
620        </usr/fig/myfile.txt
621        | sort -u > /usr/fig/myfile.txt
622    
623    If the method cannot find a file name using its normal methods, it will return the
624    whole incoming string.
625    
626    =over 4
627    
628    =item fileSpec
629    
630    File specification string from which the file name is to be extracted.
631    
632    =item RETURN
633    
634    Returns a three-element list. The first element contains the file name portion of
635    the specified string, or the whole string if a file name cannot be found via normal
636    methods. The second element contains the start position of the file name portion and
637    the third element contains the length.
638    
639    =back
640    
641    =cut
642    #: Return Type $;
643    sub FindNamePart {
644        # Get the parameters.
645        my ($fileSpec) = @_;
646        # Default to the whole input string.
647        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
648        # Parse out the file name if we can.
649        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
650            $retVal = $2;
651            $len = length $retVal;
652            $pos = (length $fileSpec) - (length $3) - $len;
653        }
654        # Return the result.
655        return ($retVal, $pos, $len);
656    }
657    
658    =head3 OpenDir
659    
660    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
661    
662    Open a directory and return all the file names. This function essentially performs
663    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
664    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
665    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
666    filtered out of the return list. If the directory does not open and I<$flag> is not
667    set, an exception is thrown. So, for example,
668    
669        my @files = OpenDir("/Volumes/fig/contigs", 1);
670    
671    is effectively the same as
672    
673        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
674        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
675    
676    Similarly, the following code
677    
678        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
679    
680    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
681    automatically returns an empty list if the directory fails to open.
682    
683    =over 4
684    
685    =item dirName
686    
687    Name of the directory to open.
688    
689    =item filtered
690    
691    TRUE if files whose names begin with a period (C<.>) should be automatically removed
692    from the list, else FALSE.
693    
694    =item flag
695    
696    TRUE if a failure to open is okay, else FALSE
697    
698    =back
699    
700    =cut
701    #: Return Type @;
702    sub OpenDir {
703        # Get the parameters.
704        my ($dirName, $filtered, $flag) = @_;
705        # Declare the return variable.
706        my @retVal = ();
707        # Open the directory.
708        if (opendir(my $dirHandle, $dirName)) {
709            # The directory opened successfully. Get the appropriate list according to the
710            # strictures of the filter parameter.
711            if ($filtered) {
712                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
713            } else {
714                @retVal = readdir $dirHandle;
715            }
716        } elsif (! $flag) {
717            # Here the directory would not open and it's considered an error.
718            Confess("Could not open directory $dirName.");
719        }
720        # Return the result.
721        return @retVal;
722  }  }
723    
724  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 985 
985         warn $message;         warn $message;
986          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
987                  # Write the trace message to an output file.                  # Write the trace message to an output file.
988                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
989                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
990                  close TRACING;                  close TRACING;
991            # If the Tee flag is on, echo it to the standard output.
992            if ($TeeFlag) {
993                print "$formatted\n";
994            }
995          }          }
996  }  }
997    
# Line 439  Line 1034 
1034                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
1035                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
1036                          # Here we have no category, so we need to get the calling package.                          # Here we have no category, so we need to get the calling package.
1037                # The calling package is normally the first parameter. If it is
1038                # omitted, the first parameter will be the tracelevel. So, the
1039                # first thing we do is shift the so-called category into the
1040                # $traceLevel variable where it belongs.
1041                          $traceLevel = $category;                          $traceLevel = $category;
1042                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
1043              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 1049 
1049                  }                  }
1050          # Save the category name.          # Save the category name.
1051          $LastCategory = $category;          $LastCategory = $category;
1052            # Convert it to lower case before we hash it.
1053            $category = lc $category;
1054                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
1055                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          if (ref $traceLevel) {
1056                Confess("Bad trace level.");
1057            } elsif (ref $TraceLevel) {
1058                Confess("Bad trace config.");
1059            }
1060            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1061      }      }
1062          # Return the computed result.          # Return the computed result.
1063      return $retVal;      return $retVal;
# Line 537  Line 1143 
1143    
1144  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1145    
1146  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
1147  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
1148  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1149    
1150  =over 4  =over 4
1151    
# Line 563  Line 1169 
1169          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
1170          while (length $realString > 0) {          while (length $realString > 0) {
1171                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
1172                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1173                          # 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
1174                          # 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.
1175                          $retVal .= $1;                          $retVal .= $1;
1176                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
1177                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
1178                # Get the matched character.
1179                          my $char = $2;                          my $char = $2;
1180                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1181                if ($char ne "\r") {
1182                    # It's not a CR, so encode the escape sequence.
1183                    $char =~ tr/\t\n/tn/;
1184                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
1185                }
1186                  } else {                  } else {
1187                          # 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
1188                          # transferred unmodified.                          # transferred unmodified.
# Line 587  Line 1198 
1198    
1199  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1200    
1201  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
1202  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
1203    be deleted.
1204    
1205  =over 4  =over 4
1206    
# Line 613  Line 1225 
1225          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
1226          if (defined $codedString) {          if (defined $codedString) {
1227                  # 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
1228                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1229                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1230                  while (length $codedString > 0) {                  while (length $codedString > 0) {
1231                          # Look for the first escape sequence.                          # Look for the first escape sequence.
1232                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1233                                  # 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
1234                                  # 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.
1235                                  $retVal .= $1;                                  $retVal .= $1;
1236                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
1237                                  # Decode the escape sequence.                  # Get the escape value.
1238                                  my $char = $2;                                  my $char = $2;
1239                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1240                    if ($char ne 'r') {
1241                        # Here it's not an 'r', so we convert it.
1242                        $char =~ tr/\\tn/\\\t\n/;
1243                                  $retVal .= $char;                                  $retVal .= $char;
1244                    }
1245                          } else {                          } else {
1246                                  # 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
1247                                  # transferred unmodified.                                  # transferred unmodified.
# Line 735  Line 1351 
1351    
1352  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1353    
1354  Return the entire contents of a file.      or
1355    
1356    C<< my $fileContents = Tracer::GetFile($fileName); >>
1357    
1358    Return the entire contents of a file. In list context, line-ends are removed and
1359    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1360    
1361  =over 4  =over 4
1362    
# Line 746  Line 1367 
1367  =item RETURN  =item RETURN
1368    
1369  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.
1370  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
1371    the file, an empty list will be returned.
1372    
1373  =back  =back
1374    
# Line 761  Line 1383 
1383          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1384          if (!$ok) {          if (!$ok) {
1385                  # If we had an error, trace it. We will automatically return a null value.                  # If we had an error, trace it. We will automatically return a null value.
1386                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1387          } else {          } else {
1388                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1389          # characters.          # characters.
# Line 774  Line 1396 
1396                  # Close it.                  # Close it.
1397                  close INPUTFILE;                  close INPUTFILE;
1398          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1399          }          }
1400          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1401      if (wantarray) {      if (wantarray) {
# Line 805  Line 1426 
1426          my ($format) = @_;          my ($format) = @_;
1427          # Create the return variable.          # Create the return variable.
1428          my $retVal = "";          my $retVal = "";
1429        # Only proceed if there is an actual queue.
1430        if (@Queue) {
1431          # Process according to the format.          # Process according to the format.
1432          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1433                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1443 
1443          }          }
1444          # Clear the queue.          # Clear the queue.
1445          @Queue = ();          @Queue = ();
1446        }
1447          # Return the formatted list.          # Return the formatted list.
1448          return $retVal;          return $retVal;
1449  }  }
# Line 828  Line 1452 
1452    
1453  C<< Confess($message); >>  C<< Confess($message); >>
1454    
1455  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  
1456  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.
1457  So, for example  So, for example
1458    
# Line 851  Line 1474 
1474          # Get the parameters.          # Get the parameters.
1475          my ($message) = @_;          my ($message) = @_;
1476          # Trace the call stack.          # Trace the call stack.
1477          Cluck($message) if T(1);      Cluck($message);
1478          # Abort the program.          # Abort the program.
1479          croak(">>> $message");          croak(">>> $message");
1480  }  }
# Line 861  Line 1484 
1484  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1485    
1486  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
1487  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.
1488  So, for example  So, for example
1489    
1490  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1020  Line 1643 
1643    
1644  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1645    
1646  Return TRUE if debug mode has been turned on in FIG_Config, else output  Return TRUE if debug mode has been turned on, else output an error
1647  an error page and return FALSE.  page and return FALSE.
1648    
1649  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1650  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1651  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1652  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1653  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1654    user to enter in the correct password.
1655    
1656  =cut  =cut
1657    
1658  sub DebugMode {  sub DebugMode {
1659          # Declare the return variable.          # Declare the return variable.
1660          my $retVal;      my $retVal = 0;
1661          # Check the debug configuration.          # Check the debug configuration.
1662          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1663        my $encrypted = Digest::MD5::md5_hex($password);
1664        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1665                  $retVal = 1;                  $retVal = 1;
1666          } else {          } else {
1667                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1071  Line 1697 
1697  sub Strip {  sub Strip {
1698          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1699          my ($string) = @_;          my ($string) = @_;
1700          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1701      # Strip the line terminator characters.      # Strip the line terminator characters.
1702      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1703          # Return the result.          # Return the result.
# Line 1102  Line 1728 
1728    
1729  =item padChar (optional)  =item padChar (optional)
1730    
1731    Character to use for padding. The default is a space.
1732    
1733  =item RETURN  =item RETURN
1734    
1735  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
1736  that it achieves the desired length.  specified end so that it achieves the desired length.
1737    
1738  =back  =back
1739    
# Line 1137  Line 1765 
1765          return $retVal;          return $retVal;
1766  }  }
1767    
1768    =head3 EOF
1769    
1770    This is a constant that is lexically greater than any useful string.
1771    
1772    =cut
1773    
1774    sub EOF {
1775        return "\xFF\xFF\xFF\xFF\xFF";
1776    }
1777    
1778    =head3 TICK
1779    
1780    C<< my @results = TICK($commandString); >>
1781    
1782    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1783    dot-slash (C<./> will be removed. So, for example, if you were doing
1784    
1785        `./protein.cgi`
1786    
1787    from inside a CGI script, it would work fine in Unix, but would issue an error message
1788    in Windows complaining that C<'.'> is not a valid command. If instead you code
1789    
1790        TICK("./protein.cgi")
1791    
1792    it will work correctly in both environments.
1793    
1794    =over 4
1795    
1796    =item commandString
1797    
1798    The command string to pass to the system.
1799    
1800    =item RETURN
1801    
1802    Returns the standard output from the specified command, as a list.
1803    
1804    =back
1805    
1806    =cut
1807    #: Return Type @;
1808    sub TICK {
1809        # Get the parameters.
1810        my ($commandString) = @_;
1811        # Chop off the dot-slash if this is Windows.
1812        if ($FIG_Config::win_mode) {
1813            $commandString =~ s!^\./!!;
1814        }
1815        # Activate the command and return the result.
1816        return `$commandString`;
1817    }
1818    
1819    =head3 ScriptSetup
1820    
1821    C<< my ($query, $varHash) = ScriptSetup(); >>
1822    
1823    Perform standard tracing and debugging setup for scripts. The value returned is
1824    the CGI object followed by a pre-built variable hash.
1825    
1826    The C<Trace> query parameter is used to determine whether or not tracing is active and
1827    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1828    the C<CGI> trace module will trace parameter and environment information. Parameters are
1829    traced at level 3 and environment variables at level 4. At the end of the script, the
1830    client should call L</ScriptFinish> to output the web page.
1831    
1832    =cut
1833    
1834    sub ScriptSetup {
1835        # Get the CGI query object.
1836        my $query = CGI->new();
1837        # Check for tracing. Set it up if the user asked for it.
1838        if ($query->param('Trace')) {
1839            # Set up tracing to be queued for display at the bottom of the web page.
1840            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1841            # Trace the parameter and environment data.
1842            if (T(CGI => 3)) {
1843                # Here we want to trace the parameter data.
1844                my @names = $query->param;
1845                for my $parmName (sort @names) {
1846                    # Note we skip "Trace", which is for our use only.
1847                    if ($parmName ne 'Trace') {
1848                        my @values = $query->param($parmName);
1849                        Trace("CGI: $parmName = " . join(", ", @values));
1850                    }
1851                }
1852            }
1853            if (T(CGI => 4)) {
1854                # Here we want the environment data too.
1855                for my $envName (sort keys %ENV) {
1856                    Trace("ENV: $envName = $ENV{$envName}");
1857                }
1858            }
1859        } else {
1860            # Here tracing is to be turned off. All we allow is errors traced into the
1861            # error log.
1862            TSetup("0", "WARN");
1863        }
1864        # Create the variable hash.
1865        my $varHash = { DebugData => '' };
1866        # If we're in DEBUG mode, set up the debug mode data for forms.
1867        if (Tracer::DebugMode) {
1868            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1869        }
1870        # Return the query object and variable hash.
1871        return ($query, $varHash);
1872    }
1873    
1874    =head3 ScriptFinish
1875    
1876    C<< ScriptFinish($webData, $varHash); >>
1877    
1878    Output a web page at the end of a script. Either the string to be output or the
1879    name of a template file can be specified. If the second parameter is omitted,
1880    it is assumed we have a string to be output; otherwise, it is assumed we have the
1881    name of a template file. The template should have the variable C<DebugData>
1882    specified in any form that invokes a standard script. If debugging mode is turned
1883    on, a form field will be put in that allows the user to enter tracing data.
1884    Trace messages will be placed immediately before the terminal C<BODY> tag in
1885    the output, formatted as a list.
1886    
1887    A typical standard script would loook like the following.
1888    
1889        BEGIN {
1890            # Print the HTML header.
1891            print "CONTENT-TYPE: text/html\n\n";
1892        }
1893        use Tracer;
1894        use CGI;
1895        use FIG;
1896        # ... more uses ...
1897    
1898        my ($query, $varHash) = ScriptSetup();
1899        eval {
1900            # ... get data from $query, put it in $varHash ...
1901        };
1902        if ($@) {
1903            Trace("Script Error: $@") if T(0);
1904        }
1905        ScriptFinish("Html/MyTemplate.html", $varHash);
1906    
1907    The idea here is that even if the script fails, you'll see trace messages and
1908    useful output.
1909    
1910    =over 4
1911    
1912    =item webData
1913    
1914    A string containing either the full web page to be written to the output or the
1915    name of a template file from which the page is to be constructed. If the name
1916    of a template file is specified, then the second parameter must be present;
1917    otherwise, it must be absent.
1918    
1919    =item varHash (optional)
1920    
1921    If specified, then a reference to a hash mapping variable names for a template
1922    to their values. The template file will be read into memory, and variable markers
1923    will be replaced by data in this hash reference.
1924    
1925    =back
1926    
1927    =cut
1928    
1929    sub ScriptFinish {
1930        # Get the parameters.
1931        my ($webData, $varHash) = @_;
1932        # Check for a template file situation.
1933        my $outputString;
1934        if (defined $varHash) {
1935            # Here we have a template file. We need to apply the variables to the template.
1936            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1937        } else {
1938            # Here the user gave us a raw string.
1939            $outputString = $webData;
1940        }
1941        # Check for trace messages.
1942        if ($Destination eq "QUEUE") {
1943            # We have trace messages, so we want to put them at the end of the body. This
1944            # is either at the end of the whole string or at the beginning of the BODY
1945            # end-tag.
1946            my $pos = length $outputString;
1947            if ($outputString =~ m#</body>#gi) {
1948                $pos = (pos $outputString) - 7;
1949            }
1950            substr $outputString, $pos, 0, QTrace('Html');
1951        }
1952        # Write the output string.
1953        print $outputString;
1954    }
1955    
1956    =head3 Insure
1957    
1958    C<< Insure($dirName); >>
1959    
1960    Insure a directory is present.
1961    
1962    =over 4
1963    
1964    =item dirName
1965    
1966    Name of the directory to check. If it does not exist, it will be created.
1967    
1968    =back
1969    
1970    =cut
1971    
1972    sub Insure {
1973        my ($dirName) = @_;
1974        if (! -d $dirName) {
1975            Trace("Creating $dirName directory.") if T(2);
1976            eval { mkpath $dirName; };
1977            if ($@) {
1978                Confess("Error creating $dirName: $@");
1979            }
1980        }
1981    }
1982    
1983    =head3 ChDir
1984    
1985    C<< ChDir($dirName); >>
1986    
1987    Change to the specified directory.
1988    
1989    =over 4
1990    
1991    =item dirName
1992    
1993    Name of the directory to which we want to change.
1994    
1995    =back
1996    
1997    =cut
1998    
1999    sub ChDir {
2000        my ($dirName) = @_;
2001        if (! -d $dirName) {
2002            Confess("Cannot change to directory $dirName: no such directory.");
2003        } else {
2004            Trace("Changing to directory $dirName.") if T(4);
2005            my $okFlag = chdir $dirName;
2006            if (! $okFlag) {
2007                Confess("Error switching to directory $dirName.");
2008            }
2009        }
2010    }
2011    
2012    =head3 SetPermissions
2013    
2014    C<< Tracer::SetPermissions($dirName, $group, $mask); >>
2015    
2016    Set the permissions for a directory and all the files and folders inside it.
2017    In addition, the group ownership will be changed to the specified value.
2018    
2019    This method is more vulnerable than most to permission and compatability
2020    problems, so it does internal error recovery.
2021    
2022    =over 4
2023    
2024    =item dirName
2025    
2026    Name of the directory to process.
2027    
2028    =item group
2029    
2030    Name of the group to be assigned.
2031    
2032    =item mask
2033    
2034    Permission mask. Bits that are C<1> in this mask will be ORed into the
2035    permission bits of any file or directory that does not already have them
2036    set to 1.
2037    
2038    =back
2039    
2040    =cut
2041    
2042    sub SetPermissions {
2043        # Get the parameters.
2044        my ($dirName, $group, $mask) = @_;
2045        # Set up for error recovery.
2046        eval {
2047            ChDir($dirName);
2048            # Get the group ID.
2049            my $gid = getgrnam($group);
2050            Trace("Fixing permissions for directory $dirName using group $group($gid).") if T(2);
2051            my $fixCount = 0;
2052            my $lookCount = 0;
2053            # @dirs will be a stack of directories to be processed.
2054            my @dirs = (getcwd());
2055            while (scalar(@dirs) > 0) {
2056                # Get the current directory.
2057                my $dir = pop @dirs;
2058                # Get all its non-hidden members.
2059                my @submems = OpenDir($dir, 1);
2060                for my $submem (@submems) {
2061                    # Get the full name.
2062                    my $thisMem = "$dir/$submem";
2063                    Trace("Checking member $thisMem.") if T(4);
2064                    $lookCount++;
2065                    if ($lookCount % 1000 == 0) {
2066                        Trace("$lookCount members examined. Current is $thisMem.") if T(3);
2067                    }
2068                    # Fix the group.
2069                    chown -1, $gid, $thisMem;
2070                    # Insure this member is not a symlink.
2071                    if (! -l $thisMem) {
2072                        # Get its info.
2073                        my $fileInfo = stat $thisMem;
2074                        # Only proceed if we got the info. Otherwise, it's a hard link
2075                        # and we want to skip it anyway.
2076                        if ($fileInfo) {
2077                            my $fileMode = $fileInfo->mode;
2078                            if (($fileMode & $mask) == 0) {
2079                                # Fix this member.
2080                                $fileMode |= $mask;
2081                                chmod $fileMode, $thisMem;
2082                                $fixCount++;
2083                            }
2084                            # If it's a subdirectory, stack it.
2085                            if (-d $thisMem) {
2086                                push @dirs, $thisMem;
2087                            }
2088                        }
2089                    }
2090                }
2091            }
2092            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2093        };
2094        # Check for an error.
2095        if ($@) {
2096            Confess("SetPermissions error: $@");
2097        }
2098    }
2099    
2100  1;  1;

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.47

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3