home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1d39b79880349efdb407d3b2bff94b39 < prev    next >
Encoding:
Text File  |  2004-06-01  |  7.6 KB  |  281 lines
  1. #
  2. # Performs search or if a document path has been specified
  3. # serve it to the browser inserting anchors to skip straight
  4. # to the correct line.
  5. #
  6. # Contributed by John Holdsworth (c) 2001.
  7. # http://www.openpsp.org
  8. #
  9. # This code is distriubuted under the 
  10. # "Artistic" license a copy of which 
  11. # is distributed with perl.
  12. #
  13.  
  14. package ActivePerl::DocTools::PSP::Searcher;
  15. use base qw(ActivePerl::DocTools::PSP::Socket);
  16. use strict;
  17. use CGI;
  18.  
  19. my $findmax = 500; # max results
  20. my $chunk = 200; # rows per send
  21.  
  22. # recover path of this document...
  23. ( my $perltoc = $main::window->document->{url} )
  24.     =~ s@^(file:[\\/]*)@@;
  25.  
  26. # prefix of file urls
  27. my $furl = $1 || "file://";
  28.  
  29. # and get root directory of html docs
  30. ( my $base = $perltoc ) =~ s@([\\/][^\\/]+){2}$@@;
  31. my $css = "$furl$base\\html\\Active.css";
  32. my $prev = "_none_";
  33.  
  34.  
  35. my (@basic, @source);
  36. my @files; # list of files to search
  37. my @out; # buffer of lines of output
  38.  
  39. my $argh;
  40. my $pathinfo;
  41. my $fh;
  42.  
  43. sub main {
  44.     my $cgi = CGI->new();
  45.     $argh = {pattern=>$cgi->param('pattern')};
  46.     $pathinfo = "$base$ENV{PATH_INFO}";
  47.  
  48. #    $main::window->document->search->pattern->{style}{cursor} = "wait";
  49. #    $main::window->{document}{body}{style}{cursor} = "wait";
  50. #    $main::window->setTimeout( "cb()", 1 );
  51. #    $fh = $_[0];
  52. #}
  53. #
  54. #sub cb {
  55.     $argh->{pattern} =~ s/(\ \.\.\.)+$//;
  56.     my $pattern = $argh->{pattern};
  57.  
  58.     # pre-compile regexp into a closure for speed
  59.     (my $p = $pattern) =~ s@/@\\/@g;
  60.     my $matcher = eval "sub { \$_[0] =~ /\\b$p\\b/i && \$_[0] !~ /href=['\"]+$p/i }";      
  61.     # if there is no path, this is the initial search
  62.     if ( $ENV{PATH_INFO} eq "/" ) {
  63.  
  64.     print <<HTML;
  65. <html><head><title>Perl documentation search</title>
  66. <link rel='STYLESHEET' href='$css' type='text/css'>
  67. </head><body>
  68. HTML
  69.     if ( !@basic ) {
  70.         # obtain list of files in a useful order
  71.         # from pertoc.html (this file)
  72.         extractLinks( $perltoc, \@basic );
  73.         unshift @basic, "lib/Pod/perlfunc.html";
  74.         @basic = map "html/$_", @basic;
  75.  
  76.         if (0) {
  77.         # traverse "site" directory for
  78.         # any additional documentation
  79.         findFiles( $base, "html/site", \@basic );
  80.         findFiles( $base, "lib", \@source );
  81.  
  82. #        @files = grep $_ !~ m@lib/Pod@, @files;
  83.     }
  84.     }
  85.  
  86.     @files = $pattern =~ /^sub \w+/ ? @source : $pattern eq $prev ?
  87.         (@basic, @source) : @basic;
  88.         $prev = $pattern;
  89.     
  90.     warn "Searching for pattern '$pattern' in @{[scalar @files]} files";
  91.  
  92.     if( !$matcher ) {
  93.         print "<b>Invalid regular expression: $pattern</b>";
  94.         return;
  95.     }
  96.  
  97.     # grep quickly for any file name matches.
  98.     # with no pattern this lists all files.
  99.     my $matched = join ", ", map "<a href='$furl$base/$_'>$_</a>",
  100.         grep $_ =~ /\b$pattern\b/i && $_ !~ /\.$pattern/i,
  101.                    (@basic, @source);
  102.  
  103.     print <<HTML if $matched;
  104. <h4>Files with names matching "$pattern" (<a href='#pmatches'>.. content matches</a>)</h4>
  105. $matched<br><br>
  106. HTML
  107.         flush STDOUT;
  108.  
  109.     # only search if there is a pattern!
  110.     if ( $pattern ) {    
  111.         # pattern will become part of a link and needs to be escaped
  112.         $pattern =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  113.  
  114.         # scan all files for pattern
  115.         foreach my $file (@files) {
  116.         scanFile( $pattern, $matcher, $base, $file, \@out );
  117.         if ( @out > $findmax ) {
  118.             push @out, "<tr><td colspan=2>And perhaps more...</td></tr>\r\n";
  119.             last;
  120.         }
  121.         }
  122.  
  123.         # frame a table if there are any matches        
  124.         if ( @out ) {
  125.         unshift @out, <<HTML;
  126. <a name='pmatches'>
  127. <table BORDER='1' CELLSPACING='0' BGCOLOR='FFFFFF' BORDERCOLOR='000000'
  128. BORDERCOLORLIGHT='000000' BORDERCOLORDARK='000000' width='100%'><thead>
  129. <th bgcolor="C86040" align='left'> File containing pattern</th>
  130. <th bgcolor="D0D080" align='left'> Contents</th></thead>
  131. HTML
  132.         push @out, "</table>\n";
  133.         }
  134.         else { # otherwise....
  135.         push @out, "<h4>No matches found for '$argh->{pattern}'\n";
  136.         }
  137.     }
  138.  
  139.     $main::window->document->search->pattern->{value} = $argh->{pattern};
  140.     $main::window->document->search->pattern->select();
  141.     }
  142.     elsif ( open FILE, my $file = "$base/html$ENV{PATH_INFO}" ) {
  143.         # This is where a link has been clicked on
  144.     # and the server needs to insert anchors
  145.     # into the document so the links go to the
  146.     # tcorrect place where the match was found.
  147.  
  148.     # links inside the served document point
  149.     # back to the versions on the hard drive.
  150.     print "<html><head><base href='$furl$file'></head>\n";
  151.  
  152.     my $pre = $file !~ /.html$/;
  153.     print "<h4>$file:</h4><pre>\n" if $pre;
  154.  
  155.     my $occ; # occurance number
  156.         while ( defined (my $line = <FILE>) ) {
  157.         if ( $pre ) {
  158.         $line =~ s/>/>/g;
  159.         $line =~ s/</</g;
  160.         }
  161.         else {
  162.             $line =~ s@(../)*Active.css@$css@;
  163.         }
  164.         if ( &$matcher( $line ) ) {
  165.             ++$occ;
  166.             $line = "<a name='occ_$occ'></a>$line";
  167.         }
  168.         push @out, $line;
  169.     }
  170.  
  171.     warn "$occ occurances of $pattern anchored in file '$file'";
  172.    }
  173.    else {
  174.     print "<html><body>Invalid link path $base -- $ENV{PATH_INFO}";
  175.     warn "could not locate '$base -- $ENV{PATH_INFO}'";
  176.    }
  177.  
  178.    if ( @out ) {
  179.     # This is a little tricky. Attempts to print
  180.     # large amounts of HTML to the browser from
  181.     # inside the browser result in a deadlock
  182.     # so a callback is used to give other
  183.     # threads a chance to render output
  184.     open BATCH, ">&".fileno(STDOUT);
  185.     sendResponse();
  186.     }
  187. }
  188.  
  189. #
  190. # Called to output to the browser in small chunks to avoid deadlock
  191. #
  192. sub sendResponse {
  193.     print BATCH my $out = join '', splice @out, 0, $chunk, ();
  194.     warn length($out)." bytes sent at ".localtime();
  195.     if ( @out ) {
  196.       $main::window->setTimeout( "sendResponse()", 0 )
  197.     }
  198.     else {
  199. #      $main::window->{document}{body}{style}{cursor} = "default";
  200. #      close STDOUT;
  201. #      close STDIN;
  202.       close BATCH;
  203.       undef $fh;
  204.    }
  205. }
  206.  
  207. #
  208. # Extract the paths of any links in a file
  209. #
  210. sub extractLinks {
  211.     my ( $htmlfile, $links ) = @_;
  212.     open FILE, $htmlfile or warn "Could not open $htmlfile ($!)";
  213.  
  214.     while ( defined (my $line = <FILE>) ) {
  215.     push @$links, $1 if $line =~ / href=\"([^\"\#]+)/ && $1 !~ /^http:/;
  216.     }
  217. }
  218.  
  219. #
  220. # Find the paths of all files in a directory
  221. #
  222. sub findFiles {
  223.     my ( $base, $dir, $files ) = @_;
  224.     my %files = map {$_, 1} @$files;
  225.  
  226.     opendir DIR, "$base/$dir" or
  227.         warn "Could not open dir: $base/$dir";
  228.     my @files = readdir DIR;
  229.  
  230.     # warn @files." being scanned in $base/$dir";
  231.  
  232.     foreach my $file (@files) {
  233.         if ( -f "$base/$dir/$file" && !$files{"$dir/$file"} ) {
  234.        push @$files, "$dir/$file";
  235.     }
  236.     elsif ( -d _ && $file !~ /^\.\.?$/ ) {
  237.        findFiles( $base, "$dir/$file", $files );
  238.     }
  239.     }
  240. }
  241.  
  242. #
  243. # Scan a file line by line for a pattern. The match
  244. # is passed in as a function reference to avoid
  245. # recompiling the regular expression repeatedly.
  246. #
  247. sub scanFile {
  248.     my ( $pattern, $matcher, $base, $file, $out ) = @_;
  249.  
  250.     open FILE, "$base/$file" or
  251.     return warn "Could not open: $base/$file";
  252.  
  253.     # whip off the extension
  254.     ( my $f = $file ) =~ s@\.html?$@@;
  255.     $f =~ s@^html/@@;
  256.  
  257.     read FILE, my $buffer, 10_000_000;
  258.     if ( &$matcher( $buffer ) ) {
  259.     open FILE, "$base/$file";
  260.  
  261.     my ($occ, $lno); # occurance number for the anchor..
  262.     while ( defined (my $line = <FILE>) ) {
  263.         ++$lno;
  264.  
  265.         if ( &$matcher( $line ) ) {
  266.         $occ++;
  267.         $line =~ s@\s+$@@;
  268.         $line =~ s@^<\w+>|<\w+>$@@;
  269.         $line =~ s@</?(hr|h\d|p|td|tr|br|title|table)[^>]*>@@gi;
  270.         (my $dest = "$f.html?pattern=$pattern#occ_$occ")=~ s/ /+/g;
  271.         push @$out, "<tr><td><a href='$dest'>$f</a>".
  272.             "</td><td>$line</td></tr>\n\n";
  273.         }
  274.     }
  275.     }
  276.  
  277.     close FILE;
  278. }
  279.  
  280. 1;
  281.