[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.73, Tue Oct 3 12:04:50 2006 UTC revision 1.89, Tue Jun 19 21:15:37 2007 UTC
# Line 34  Line 34 
34      use LWP::UserAgent;      use LWP::UserAgent;
35      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
36      use URI::Escape;      use URI::Escape;
37        use Time::Local;
38    
39  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
40    
# Line 185  Line 186 
186  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing
187  will be configured automatically.  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  =head3 Debugging Control Panel
193    
194  The debugging control panel provides several tools to assist in development of  The debugging control panel provides several tools to assist in development of
# Line 444  Line 448 
448                            noAlias => [0, "do not expect aliases in CHANGE transactions"],                            noAlias => [0, "do not expect aliases in CHANGE transactions"],
449                            start => [' ', "start with this genome"],                            start => [' ', "start with this genome"],
450                            tblFiles => [0, "output TBL files containing the corrected IDs"] },                            tblFiles => [0, "output TBL files containing the corrected IDs"] },
451                          "command transactionDirectory IDfile",                          "<command> <transactionDirectory> <IDfile>",
452                        @ARGV);                        @ARGV);
453    
454    
# Line 456  Line 460 
460    
461      TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl      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  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  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  above code fragment. The tracing would be set to level 2, and the categories
# Line 490  Line 499 
499  the tracing key is taken from the C<Tracing> environment variable. If there  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.  is no value for that variable, the tracing key will be computed from the PID.
501    
502  Finally, if the special option C<-h> is specified, the option names will  Finally, if the special option C<-help> is specified, the option
503  be traced at level 0 and the program will exit without processing.  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  This provides a limited help capability. For example, if the user enters
505    
506      TransactFeatures -h      TransactFeatures -help
507    
508  he would see the following output.  he would see the following output.
509    
510      TransactFeatures [options] command transactionDirectory IDfile      TransactFeatures [options] <command> <transactionDirectory> <IDfile>
511          -trace    tracing level (default E)          -trace    tracing level (default E)
512          -sql      trace SQL commands          -sql      trace SQL commands
513          -safe     use database transactions          -safe     use database transactions
# Line 570  Line 579 
579      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
580      # Add the tracing options.      # Add the tracing options.
581      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
582          $options->{trace} = ['E', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
583      }      }
584      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
585      $options->{h} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
586      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
587      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
588      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
# Line 648  Line 657 
657      }      }
658      # Check for the "h" option. If it is specified, dump the command-line      # Check for the "h" option. If it is specified, dump the command-line
659      # options and exit the program.      # options and exit the program.
660      if ($retOptions->{h}) {      if ($retOptions->{help}) {
661          $0 =~ m#[/\\](\w+)(\.pl)?$#i;          $0 =~ m#[/\\](\w+)(\.pl)?$#i;
662          print "$1 [options] $parmHelp\n";          print "$1 [options] $parmHelp\n";
663          for my $key (sort keys %{$options}) {          for my $key (sort keys %{$options}) {
# Line 661  Line 670 
670          }          }
671          exit(0);          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.      # Return the parsed parameters.
679      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
680  }  }
# Line 931  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 1212  Line 1264 
1264              if (!$package) {              if (!$package) {
1265                  $category = "main";                  $category = "main";
1266              } else {              } else {
1267                  $category = $package;                  my @cats = split /::/, $package;
1268                    $category = $cats[$#cats];
1269              }              }
1270          }          }
1271          # Save the category name.          # Save the category name.
# Line 1242  Line 1295 
1295    
1296  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>
1297    
1298  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,
1299  B<errors> and B<logFile>. If @words has the following format  B<errors> and B<logFile>. If @words has the following format
1300    
1301  C<< -logFile=error.log apple orange rutabaga >>  C<< -logFile=error.log apple orange rutabaga >>
# Line 1256  Line 1309 
1309  C<< apple orange rutabaga >>  C<< apple orange rutabaga >>
1310    
1311  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
1312  support for quote characters.  support for quote characters. Options can be specified with single or double hyphens.
1313    
1314  =over 4  =over 4
1315    
# Line 1281  Line 1334 
1334      my ($optionTable, @inputList) = @_;      my ($optionTable, @inputList) = @_;
1335      # Process any options in the input list.      # Process any options in the input list.
1336      my %overrides = ();      my %overrides = ();
1337      while ((@inputList > 0) && ($inputList[0] =~ /^-/)) {      while ((@inputList > 0) && ($inputList[0] =~ /^--?/)) {
1338          # Get the current option.          # Get the current option.
1339          my $arg = shift @inputList;          my $arg = shift @inputList;
1340          # Pull out the option name.          # Pull out the option name.
1341          $arg =~ /^-([^=]*)/g;          $arg =~ /^--?([^=]*)/g;
1342          my $name = $1;          my $name = $1;
1343          # Check for an option value.          # Check for an option value.
1344          if ($arg =~ /\G=(.*)$/g) {          if ($arg =~ /\G=(.*)$/g) {
# Line 1598  Line 1651 
1651      # Close it.      # Close it.
1652      close $handle;      close $handle;
1653      my $actualLines = @retVal;      my $actualLines = @retVal;
1654        Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1655      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1656      if (wantarray) {      if (wantarray) {
1657          return @retVal;          return @retVal;
# Line 1633  Line 1687 
1687      my ($fileName, $lines) = @_;      my ($fileName, $lines) = @_;
1688      # Open the output file.      # Open the output file.
1689      my $handle = Open(undef, ">$fileName");      my $handle = Open(undef, ">$fileName");
1690        # Count the lines written.
1691      if (ref $lines ne 'ARRAY') {      if (ref $lines ne 'ARRAY') {
1692          # Here we have a scalar, so we write it raw.          # Here we have a scalar, so we write it raw.
1693          print $handle $lines;          print $handle $lines;
1694            Trace("Scalar put to file $fileName.") if T(File => 3);
1695      } else {      } else {
1696          # Write the lines one at a time.          # Write the lines one at a time.
1697            my $count = 0;
1698          for my $line (@{$lines}) {          for my $line (@{$lines}) {
1699              print $handle "$line\n";              print $handle "$line\n";
1700                $count++;
1701          }          }
1702            Trace("$count lines put to file $fileName.") if T(File => 3);
1703      }      }
1704      # Close the output file.      # Close the output file.
1705      close $handle;      close $handle;
# Line 1714  Line 1773 
1773  sub Confess {  sub Confess {
1774      # Get the parameters.      # Get the parameters.
1775      my ($message) = @_;      my ($message) = @_;
1776        if (! defined($FIG_Config::no_tool_hdr)) {
1777            # Here we have a tool header. Display its length so that the user can adjust the line numbers.
1778            my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch";
1779            # Only proceed if the tool header file is actually present.
1780            if (-f $toolHeaderFile) {
1781                my @lines = GetFile($toolHeaderFile);
1782                Trace("Tool header has " . scalar(@lines) . " lines.");
1783            }
1784        }
1785      # Trace the call stack.      # Trace the call stack.
1786      Cluck($message);      Cluck($message);
1787      # Abort the program.      # Abort the program.
# Line 2059  Line 2127 
2127  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
2128    
2129  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
2130  the CGI object followed by a pre-built variable hash.  the CGI object followed by a pre-built variable hash. At the end of the script,
2131    the client should call L</ScriptFinish> to output the web page.
 The C<Trace> form parameter is used to determine whether or not tracing is active and  
 which trace modules (other than C<Tracer> itself) should be turned on. Specifying  
 the C<CGI> trace module will trace parameter and environment information. Parameters are  
 traced at level 3 and environment variables at level 4. To trace to a file instead of to  
 the web page, set C<TF> to 1. At the end of the script, the client should call  
 L</ScriptFinish> to output the web page.  
2132    
2133  In some situations, it is not practical to invoke tracing via form parameters. For this  This method calls L</ETracing> to configure tracing, which allows the tracing
2134  situation, you can turn on emergency tracing from the debugging control panel.  to be configured via the emergency tracing form on the debugging control panel.
2135  Tracing will then be turned on automatically for all programs that use the L</ETracing>  Tracing will then be turned on automatically for all programs that use the L</ETracing>
2136  method, which includes every program that uses this method or L</StandardSetup>.  method, which includes every program that uses this method or L</StandardSetup>.
2137    
# Line 2246  Line 2308 
2308  This method converts an emergency tracing destination to a real  This method converts an emergency tracing destination to a real
2309  tracing destination. The main difference is that if the  tracing destination. The main difference is that if the
2310  destination is C<FILE> or C<APPEND>, we convert it to file  destination is C<FILE> or C<APPEND>, we convert it to file
2311  output.  output. If the destination is C<DUAL>, we convert it to file
2312    and standard output.
2313    
2314  =over 4  =over 4
2315    
# Line 2270  Line 2333 
2333      # Get the parameters.      # Get the parameters.
2334      my ($tkey, $myDest) = @_;      my ($tkey, $myDest) = @_;
2335      # Declare the return variable.      # Declare the return variable.
2336      my $retVal;      my $retVal = $myDest;
2337      # Process according to the destination value.      # Process according to the destination value.
2338      if ($myDest eq 'FILE') {      if ($myDest eq 'FILE') {
2339          $retVal = ">" . EmergencyFileTarget($tkey);          $retVal = ">" . EmergencyFileTarget($tkey);
2340      } elsif ($myDest eq 'APPEND') {      } elsif ($myDest eq 'APPEND') {
2341          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
2342      } else {      } elsif ($myDest eq 'DUAL') {
2343          $retVal = $myDest;          $retVal = "+>" . EmergencyFileTarget($tkey);
2344      }      }
2345      # Return the result.      # Return the result.
2346      return $retVal;      return $retVal;
# Line 2287  Line 2350 
2350    
2351  C<< Emergency($key, $hours, $dest, $level, @modules); >>  C<< Emergency($key, $hours, $dest, $level, @modules); >>
2352    
2353  Turn on emergency tracing. This method can only be invoked over the web and is  Turn on emergency tracing. This method is normally invoked over the web from
2354  should not be called if debug mode is off. The caller specifies the duration of the  a debugging console, but it can also be called by the C<trace.pl> script.
2355  emergency in hours, the desired tracing destination, the trace level,  The caller specifies the duration of the emergency in hours, the desired tracing
2356  and a list of the trace modules to activate. For the length of the duration, when a  destination, the trace level, and a list of the trace modules to activate.
2357  program in an environment with the specified tracing key active invokes a Sprout  For the length of the duration, when a program in an environment with the
2358  CGI script, tracing will be turned on automatically. See L</TSetup> for more  specified tracing key active invokes a Sprout CGI script, tracing will be
2359  about tracing setup and L</ETracing> for more about emergency tracing.  turned on automatically. See L</TSetup> for more about tracing setup and
2360    L</ETracing> for more about emergency tracing.
2361    
2362  =over 4  =over 4
2363    
# Line 2546  Line 2610 
2610  sub Insure {  sub Insure {
2611      my ($dirName) = @_;      my ($dirName) = @_;
2612      if (! -d $dirName) {      if (! -d $dirName) {
2613          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(File => 2);
2614          eval { mkpath $dirName; };          eval { mkpath $dirName; };
2615          if ($@) {          if ($@) {
2616              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
# Line 2575  Line 2639 
2639      if (! -d $dirName) {      if (! -d $dirName) {
2640          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2641      } else {      } else {
2642          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2643          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2644          if (! $okFlag) {          if (! $okFlag) {
2645              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2754  Line 2818 
2818          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2819          # Get the mask for tracing.          # Get the mask for tracing.
2820          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2821          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(File => 2);
2822          my $fixCount = 0;          my $fixCount = 0;
2823          my $lookCount = 0;          my $lookCount = 0;
2824          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2769  Line 2833 
2833              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2834                  $simpleName = $1;                  $simpleName = $1;
2835              }              }
2836              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2837              # Search for a match.              # Search for a match.
2838              my $match = 0;              my $match = 0;
2839              my $i;              my $i;
# Line 2794  Line 2858 
2858                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2859                      $lookCount++;                      $lookCount++;
2860                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2861                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(File => 3);
2862                      }                      }
2863                      # Fix the group.                      # Fix the group.
2864                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2821  Line 2885 
2885                  }                  }
2886              }              }
2887          }          }
2888          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2889      };      };
2890      # Check for an error.      # Check for an error.
2891      if ($@) {      if ($@) {
# Line 2924  Line 2988 
2988      my ($handle) = @_;      my ($handle) = @_;
2989      # Declare the return variable.      # Declare the return variable.
2990      my @retVal = ();      my @retVal = ();
2991        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2992      # Read from the file.      # Read from the file.
2993      my $line = <$handle>;      my $line = <$handle>;
2994      # Only proceed if we found something.      # Only proceed if we found something.
2995      if (defined $line) {      if (defined $line) {
2996          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2997          chomp $line;          # upload control and have a nonstandard EOL combination.
2998            $line =~ s/(\r|\n)+$//;
2999            # Here we do some fancy tracing to help in debugging complicated EOL marks.
3000            if (T(File => 4)) {
3001                my $escapedLine = $line;
3002                $escapedLine =~ s/\n/\\n/g;
3003                $escapedLine =~ s/\r/\\r/g;
3004                $escapedLine =~ s/\t/\\t/g;
3005                Trace("Line read: -->$escapedLine<--");
3006            }
3007          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
3008          # it into fields.          # it into fields.
3009          if ($line eq "") {          if ($line eq "") {
# Line 2937  Line 3011 
3011          } else {          } else {
3012              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
3013          }          }
3014        } else {
3015            # Trace the reason the read failed.
3016            Trace("End of file: $!") if T(File => 3);
3017      }      }
3018      # Return the result.      # Return the result.
3019      return @retVal;      return @retVal;
# Line 2944  Line 3021 
3021    
3022  =head3 PutLine  =head3 PutLine
3023    
3024  C<< Tracer::PutLine($handle, \@fields); >>  C<< Tracer::PutLine($handle, \@fields, $eol); >>
3025    
3026  Write a line of data to a tab-delimited file. The specified field values will be  Write a line of data to a tab-delimited file. The specified field values will be
3027  output in tab-separated form, with a trailing new-line.  output in tab-separated form, with a trailing new-line.
# Line 2959  Line 3036 
3036    
3037  List of field values.  List of field values.
3038    
3039    =item eol (optional)
3040    
3041    End-of-line character (default is "\n").
3042    
3043  =back  =back
3044    
3045  =cut  =cut
3046    
3047  sub PutLine {  sub PutLine {
3048      # Get the parameters.      # Get the parameters.
3049      my ($handle, $fields) = @_;      my ($handle, $fields, $eol) = @_;
3050      # Write the data.      # Write the data.
3051      print $handle join("\t", @{$fields}) . "\n";      print $handle join("\t", @{$fields}) . ($eol || "\n");
3052  }  }
3053    
3054  =head3 GenerateURL  =head3 GenerateURL
# Line 2982  Line 3063 
3063    
3064  would return  would return
3065    
3066      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3067    
3068  =over 4  =over 4
3069    
# Line 3012  Line 3093 
3093      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3094      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3095      if (@parmList) {      if (@parmList) {
3096          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3097      }      }
3098      # Return the result.      # Return the result.
3099      return $retVal;      return $retVal;
3100  }  }
3101    
3102    =head3 ApplyURL
3103    
3104    C<< Tracer::ApplyURL($table, $target, $url); >>
3105    
3106    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3107    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3108    URL column will be deleted by this process and the target column will be HTML-escaped.
3109    
3110    This provides a simple way to process the results of a database query into something
3111    displayable by combining a URL with text.
3112    
3113    =over 4
3114    
3115    =item table
3116    
3117    Reference to a list of lists. The elements in the containing list will be updated by
3118    this method.
3119    
3120    =item target
3121    
3122    The index of the column to be converted into HTML.
3123    
3124    =item url
3125    
3126    The index of the column containing the URL. Note that the URL must have a recognizable
3127    C<http:> at the beginning.
3128    
3129    =back
3130    
3131    =cut
3132    
3133    sub ApplyURL {
3134        # Get the parameters.
3135        my ($table, $target, $url) = @_;
3136        # Loop through the table.
3137        for my $row (@{$table}) {
3138            # Apply the URL to the target cell.
3139            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3140            # Delete the URL from the row.
3141            delete $row->[$url];
3142        }
3143    }
3144    
3145    =head3 CombineURL
3146    
3147    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3148    
3149    This method will convert the specified text into HTML hyperlinked to the specified
3150    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3151    is defined and begins with an C<http:> header.
3152    
3153    =over 4
3154    
3155    =item text
3156    
3157    Text to return. This will be HTML-escaped automatically.
3158    
3159    =item url
3160    
3161    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3162    will be returned without any hyperlinking.
3163    
3164    =item RETURN
3165    
3166    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3167    doesn't look right, the HTML-escaped text will be returned without any further
3168    modification.
3169    
3170    =back
3171    
3172    =cut
3173    
3174    sub CombineURL {
3175        # Get the parameters.
3176        my ($text, $url) = @_;
3177        # Declare the return variable.
3178        my $retVal = CGI::escapeHTML($text);
3179        # Verify the URL.
3180        if (defined($url) && $url =~ m!http://!i) {
3181            # It's good, so we apply it to the text.
3182            $retVal = "<a href=\"$url\">$retVal</a>";
3183        }
3184        # Return the result.
3185        return $retVal;
3186    }
3187    
3188    
3189  1;  1;

Legend:
Removed from v.1.73  
changed lines
  Added in v.1.89

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3