#!/usr/bin/perl use strict; use warnings; #print @INC; my $module_cache = '/tmp/readpod.cache'; my $script_pid = '/tmp/readpod.pid'; my $cache_updates_now = 0; $cache_updates_now = 1 if -f $script_pid and kill (0, file_contents($script_pid)) == 1; # now we must check for availability of cache file or # pid of script, who wrote now this file my $cache_mtime = (stat $module_cache) [9]; my $cache_outdated = 0; my @INC_sorted = sort { length ( $b ) cmp length ( $a ) } @INC; foreach (@INC) { my $mtime = (stat) [9]; $cache_outdated = 1 if $mtime > $cache_mtime; } my $inc_dirs_re = "(" . join ( '|', @INC_sorted ) . ")"; my $inc_dirs_pod = join ':', @INC_sorted; # preparation complete, now logic begins #list_all_modules (@INC); # QUERY ANALYZE my $query = $ENV{QUERY_STRING}; $query = '' unless defined $query; if ($query eq 'css') { print "Content-Type: text/css\n\n"; while () { print $_; } exit; } print "Content-Type: text/html\nCache-Control: no-store\n\n"; my $referrer; if ( defined $ENV{HTTP_REFERER} ) { ( $referrer = $ENV{HTTP_REFERER} ) =~ s#http://[\w\-/]*/([\w\.]+)(?:\?.*|$)#$1# ; } my $script = ( $ENV{SCRIPT_NAME} =~ /.*\/(.*)/ )[0]; #print "referrer: '$referrer'\nscript: '$script'"; #exit; if (($referrer eq '' or $referrer !~ /$script(?:$|\?)/) and not $query) { print < pod reader <h1>sorry!</h1> <h3>this page must be viewed by a browser that is capable of viewing frames.</h3> FRAMESET exit; } #print ''; #print $filename, $referrer; my $pod2html_params = { cachedir => '/tmp', css => "$script?css", header => undef, }; sub make_pod_cmd { my $query = shift; my @params = (); foreach (sort keys %$pod2html_params) { my $value = $pod2html_params->{$_}; if (defined $value) { push @params, "--$_=$value"; } else { push @params, "--$_"; } } my $command = "cd /tmp && perldoc -u $query 2>&1 | pod2html " . join (' ', @params) . " 2>&1"; } if ($query) { if ($query =~ /^\//) { if (-d $query) { &html_template ( "

\n

\n", list_modules ($script, $query)); } if ( -f $query) { #print `cd /tmp && perldoc -u $query | pod2html 2>&1 `; my $cmd = make_pod_cmd ($query); print `$cmd`; #print `cd /tmp && perldoc -u $query 2>&1 | pod2html --cachedir=/tmp -css=/css/cpan.css --header 2>&1`; } } elsif ($query =~ /^query/i) { my ($document) = ($query =~ /query=(.*)/i); if ($document) { $document = decode ($document); my $cmd = make_pod_cmd ($document); print `$cmd`; } else { &html_template ( "

\n

\n"); } } else { my $cmd = make_pod_cmd ($query); print `$cmd`; } } elsif ( $query eq '' or not defined $query) { my $cache_contents = ''; if ($cache_updates_now) { $cache_contents = "

please reload page within 30 seconds, module list cache updating

\n"; } elsif ($cache_outdated or -f $script_pid) { file_contents ($script_pid, $$); $cache_contents = generate_cache ($script, @INC); file_contents ($module_cache, $cache_contents); unlink $script_pid; } else { $cache_contents = file_contents ($module_cache); } &html_template ( "

\n

\n", $cache_contents); } sub file_contents { my $file_name = shift; my $file_contents = shift; my $mode = '<'; $mode = '>' if defined $file_contents and $file_contents ne ''; if (open (FILE, $mode, $file_name)) { if (defined $file_contents and $file_contents ne '') { print FILE $file_contents; return ''; } else { local $/; return ; } close FILE; } return ''; } sub generate_cache { my $script = shift; my @dirs = @_; my $dirs = {}; # print "sorted \@INC:

", join "\n", @INC_sorted;
#  print "

"; foreach my $dir (@dirs) { my @out = split /\n/, `grep -lsrE "=(pod|head)" $dir `; # $,="\n"; # print "found ", scalar @out, "
\n"; foreach ( @out ) { my $module_path = $_; my $module_name = $module_path; $module_name =~ s!$inc_dirs_re/!!; # print $module_path, " ($_)
"; $module_name =~ s/^(.+)\.w+?$/$1/; my @parts = split /\//, $module_name; # my $orig_=$_; my $hash = $dirs; while( 1 ) { my $part = shift @parts; if( not scalar @parts ) { $hash ->{ $part } = "$module_path?$module_name"; last; } else { if ( not exists $hash ->{ $part } ) { $hash = $hash->{$part} = {}; } else { $hash = $hash->{$part}; } } } } } # use Data::Dumper; # print "

\n" , Dumper( $dirs ) , "

\n\n"; my $html = dir_to_html ($script, $dirs, 'mktree'); return $html; } sub list_modules { my $script = shift; my $dir = shift; # print $dir, '
'; my @out = split /\n/, `grep -lsE "=(pod|head)" $dir/* `; my @dirs; $,="\n
"; if (opendir (DIR_HANDLE, $dir)) { $dir .= '/' unless ( $dir =~ /\/$/ ); @dirs = grep { !/^\./ && -d ($dir.$_) } readdir (DIR_HANDLE); closedir DIR_HANDLE; } my $html = ''; foreach ( @dirs ) { $html .= "$_
\n"; } foreach ( @out ) { my ($file_name) = (/.*\/(.*)/); $html .= "$file_name
\n"; } @dirs = split /\//, $dir; my $current_path = ''; my $file_path = ''; # print scalar @dirs, "
"; unshift @dirs, '' if not @dirs; my $counter = scalar @dirs; foreach ( @dirs ) { $counter--; $current_path.= $_.'/'; $_ = '(root)' unless $_; if ( $counter ) { $file_path .= "$_/"; } else { $file_path .= $_; } } #my $html = dir_to_html ( $dir ); #print "

$file_path

"; return $html; } sub html_template { my @body = @_; print < @body HTML } sub dir_to_html { my $script = shift; my $dir = shift; my $class = shift || ''; my $html = $class eq '' ? "

} .$key.''.dir_to_html ($script, $dir -> {$key})."
$key