Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!perl -w # MODULATOR by epoptai (with some crucial code from japhy's modlist.pl +) # This tool lists installed perl modules, views module pod and source +code, runs code examples*, and more. # *WARNING: THIS PROGRAM CAN EXECUTE USER SUPPLIED PERL CODE. # DO NOT ALLOW PUBLIC ACCESS TO THIS CGI SCRIPT! # http://www.perlmonks.org/index.pl?node=MODULATOR $|++; use strict; use CGI qw(Vars :standard); use CGI::Carp qw(warningsToBrowser fatalsToBrowser); use Pod::Html; use HTML::Entities; use FindBin qw($Bin); use File::Find; use File::Spec::Functions 'rel2abs'; use Data::Dumper; BEGIN{ $_ = $0; $0 = " A module tried to modify this script. " } # perlmonks.org/index.pl?node=177129 my $this = $_; use vars qw($base $found %found %path); # CONFIGURATION my $bodytag = qq~<body bgcolor="white" text="black" link="#0000aa" vli +nk="#0000aa">~; my $showlocal = 0; # 0 excludes script dir from @INC, 1 i +ncludes it my $sitemods = 'site'; # bold modules from this directory, fo +r example: 'site', leave blank for none my $synopsis_code_form = 'y'; # any value here puts the synopsis cod +e in a form, leave blank to disable (my $cache = url(-relative=>1)) =~ s|(\.).*$|$1cache|; # set scriptnam +e.cache as the cache filename eval "require '$cache'"; # use cache file if it exists %found = %{$found} if !$@ && %{$found}; my $now = time; my $url = url(); my %i = Vars; my $p = header; $p .= '<html><head><title>MODULATOR</title></head>' unless $i{perlpod} +; $p .= $bodytag if %i && !$i{perlpod}; cache('make') if $i{make}; # create cache cache('dele') if $i{dele}; # delete cache listmods() if $i{listmods}; # display left frame module list splash() if $i{splash}; # display right frame splash screen alpha() if $i{alpha}; # display alpha index env() if $i{env}; # display env vartiables selfurls() if $i{urls}; # display paths to this script synopsis() if $i{synopsis}; # eval code from synopsis form if($i{pm} && $i{title}){ # handle actions from module list perlpod($i{pm},$i{title}) if $i{perlpod}; # render pod as html perlmod($i{pm},$i{title}) if $i{perlmod}; # display module source +code } $p .= qq~ <frameset cols="30%,*"> <frameset rows="90%,40"> <frame name="mod" src="$url?listmods=1" scrolling="auto" framebord +er="1"> <frame name="dex" src="$url?alpha=1" scrolling="no" framebord +er="1"></frameset> <frame name="pod" src="$url?splash=1" scrolling="auto" framebord +er="1"> </frameset></html>~ unless %i; if($i{showhash}){ $_ = findmodules(); $p .= '<pre>'.Data::Dumper->Dump([\%found],[qw(found)]).'</pre>'; } $p .= end_html if %i && !$i{perlpod}; print $p; # there can be only one sub listmods { # display the module list my $total = findmodules(); # populate %found $p .= qq~<a name="top"> <b>Perl</b> : $]<br></a> <b>Path</b> : $^X<br> <b>INC</b> : ~; for(@INC){ next if $showlocal eq '0' && $_ eq '.'; if($sitemods && /$sitemods/){ $p .= qq~<b>$_</b> ~ } else{ $p .= qq~$_ ~ } } $p .= qq~<br><p><font size="-1"> <b><a href="$url?env=1" target="pod">Show environment variables</a></b +><br> <a href="$url?urls=1" target="pod">Paths to this script</a><br> <a href="$url?pm=$this&perlpod=1&title=MODULATOR" target="pod">About</ +a> - <a href="$url?splash=1" target="pod">top</a><br></font><p><font size=+ +2> $total Installed Modules</font> <sup><a href="$url" target="_top">re</ +a></sup><p><ol>~; my %abc = (); for(sort { lc($a) cmp lc($b) } keys %found){ my ($ltr,$tag) = ('') x 2; m|^(.)|; $ltr = lc($1) if $1; $abc{$ltr}++; $tag = "name='$ltr'" if $abc{$ltr} < 2; # name only the first link $tag = '' if $abc{$ltr} > 1; my($i1,$i2) = ('') x 2; ($i1,$i2) = ('<b>','</b>') if $sitemods && $found{$_}->{path} && + $found{$_}->{path} =~ /$sitemods/; $p .= qq(<nobr>$i1<li><a href="$url?perlpod=1&pm=$found{$_}->{path +}&title=$_" target="pod">$_</a> <a $tag href="$url?perlmod=1&pm=$found{$_}->{path}&title=$_" targe +t="pod">&deg;</a> <a href="$url?perlmod=1&pm=$found{$_}->{path}&title=$_&num=1" + target="pod">*</a>$i2</nobr>\n) if $found{$_}->{pod} && $found{$_}->{pod} == 1; # has pod $p .= qq(<nobr>$i1<li>$_ <a $tag href="$url?perlmod=1&pm=$found{$_}->{path}&title=$_" targe +t="pod">&deg;</a> <a href="$url?perlmod=1&pm=$found{$_}->{path}&title=$_&num=1" + target="pod">*</a>$i2</nobr>\n) if !$found{$_}->{pod} || $found{$_}->{pod} == 2; # has no pod } } sub findmodules { # sub adapted from from modlist.pl (lines with #modlist) # http://www.crusoe.net/~jeffp/programs/modlist if(%found){ # if a cache file is in use %found will exist $_ = keys %found; return $_ } @path{@INC} = (); #modlist for $base (@INC) { #modlist next if $showlocal eq '0' && $base eq '.'; find(\&modules, $base) #modlist } my $t = keys %found; return $t if $_[0]; # skip the pod search? for my $f (keys %found){ # identify modules with pod my $it = load($found{$f}->{path}); if($it =~ /\n=[^c]\w/){ # find a pod directive besides =cut $found{$f}->{pod} = 1 # has pod } else{ $found{$f}->{pod} = 0 # no pod } } return $t } sub modules { # sub adapted from from modlist.pl (lines with #modlist) # http://www.crusoe.net/~jeffp/programs/modlist $File::Find::prune = 1, return if exists $path{$File::Find::dir} and $File::Find::dir ne $base +; #modlist my $file = $File::Find::name; my $module = substr $File::Find::name, length $base; #modlist return unless $module =~ s|\.pm$||; #modlist $module =~ m|([\W^'])\w+$|; # discover directory delimiter returned +by File::Find my $sep = $1; $module =~ s|^\Q$sep\E+||; $module =~ s|\Q$sep\E|::|g; $found{$module}->{path} = $file; } sub load { # load a file $_ = pop; open IT,"< $_\0" or die "Could not open $_ : $!"; @_ = <IT>; close IT; return wantarray ? @_ : join '', @_; } sub perlpod { # show pod as html my $pod = $^T; if($i{title} eq $url){ # fix inter-module links $i{pm} =~ m|([\W^'])\w+\.html$|; # discover directory delimiter my $sep = $1; $i{pm} =~ s|\.html$||; $i{pm} =~ s|^\Q$sep\E||; $i{pm} =~ s|\Q$sep\E|::|g; $i{title} = $i{pm}; findmodules(); # populates %found $_[0] = $found{$i{pm}}->{path} if $found{$i{pm}}->{pod} == 1; } pod2html( "--htmlroot=$url?perlpod=1&title=$url&pm=", "--infile=$_[0]", "--outfile=$pod.html", "--title=$_[1]", "--backlink=Top", "--header", ); my $it = load("$pod.html"); unlink "$pod.html" or die "Could not delete $pod.html : $!"; $_ = 0; $_ = 1 if $it =~ m|<hr>|i; $it =~ s|<body>|$bodytag|i; $it =~ s|(<h1><a NAME="synopsis">SYNOPSIS<\/a><\/h1>)(.*?)(<a HREF="#_ +_index__"><small>Top</small></a>)|codeform($1,$2,$3)|eism if $synopsis_code_form; $p .= $it if $_ > 0; $p .= qq~No pod found in $_[0]~ if $_ < 1; } sub perlmod { # show module code $p .= '<pre>'; if($i{num}){ my @it = load($i{pm}); # TAINTED my $c = 1; for(@it){ $_ = encode_entities($_); $p .= qq~$c. $_~; $c++ } } else{ my $it = load($i{pm}); # TAINTED $it = encode_entities($it); $p .= $it } $p .= '</pre>' } sub synopsis { # eval code from a synopsis form return if $i{strip_html}; unless($i{noheader}){ $i{htmlhead} ? print header : print header('text/plain'); } # turn strict off by default for the eval form no strict; eval $i{synopsis} if $synopsis_code_form; # TAINTED, ETC print $@ if $@; exit } sub codeform { # display synopsis code in a form my($front,$coded,$rear) = @_; my @coded = split /\n/, $coded; my (%len,$c,$ex); for(@coded){ # determine width of textarea my $l = length($_); $len{$l} = $l } for(sort { $b <=> $a } keys %len){ $c = $len{$_}; last } my $r = @coded; # determine height of textarea $coded =~ s|</?pr?e?>||ig; $coded =~ s|<[^>]+>||g if $i{strip_html}; if($coded =~ m|<[^>]+>|){ $ex = qq~ <input type="Submit" name="strip_html" value="strip html"> <input type="Hidden" name="pm" value="$i{pm}"> <input type="Hidden" name="title" value="$i{title}">~; $ex .= qq~<input type="Hidden" name="perlpod" value="$i{perlpod}"> +~ if $i{perlpod}; $ex .= qq~<input type="Hidden" name="perlmod" value="$i{perlmod}"> +~ if $i{perlmod}; } $ex = '' if ! $ex; $coded = qq~$front <form><textarea name="synopsis" cols=$c rows=$r>$co +ded</textarea><p> <input type="Submit" value="eval"> $ex <input type="checkbox" name="htmlhead" value="1"> HTML <input type="checkbox" name="noheader" value="1"> No header</form><p> +$rear~; return $coded } sub view { # view file, any arg toggles text mode if(-e $i{pm}){ my $it = load($i{pm}); # TAINTED $it = encode_entities($it) and $p .= '<pre>'.$it.'</pre>' if $_[0] +; # text $p .= $it if !$_[0]; } else{ $p .= '<p>File does not exist!' } } sub env { # show environment variables my $v = keys %ENV; $p .= qq~ <p align="right"><font size="+2">$v Environment Variables</font></p> <p><table border=1 align=center cellpadding=3 cellspacing=0 width=100% +>~; for(sort { $a cmp $b } keys %ENV){ if(/DOCUMENT_ROOT|PWD|WINDIR|SCRIPT_FILENAME/){ $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> <a href="file://$ENV{$_}"> +$ENV{$_}</a></TD></TR>~; } elsif(/PATH/){ $ENV{$_} =~ s|;|;<br> |g; $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> $ENV{$_}</TD></TR>~; } elsif(/HTTP_ACCEPT/){ $ENV{$_} =~ s|,|,<br> |g; $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> $ENV{$_}</TD></TR>~; } elsif(/HTTP_COOKIE/){ $ENV{$_} =~ s|;|;<br> |g; $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> $ENV{$_}</TD></TR>~; } elsif(/REMOTE_ADDR|SERVER_ADDR|HTTP_HOST/){ $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> <a href="http://$ENV{$_}"> +$ENV{$_}</a></TD></TR>~; } elsif(/SERVER_ADMIN/){ $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> <a href="mailto:$ENV{$_}"> +$ENV{$_}</a></TD></TR>~; } elsif(/SERVER_SIGNATURE/){ $ENV{$_} =~ s|(</?)address>|$1i>|igm; $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> $ENV{$_}</TD></TR>~; } else{ $p .= qq~<TR><TD>$_ &nbsp;</TD><TD> $ENV{$_}</TD></TR>~; } } $p .= qq~</table>~; } sub divide { $_ = $_[0] / $_[1]; $_ = sprintf "%.1F", $_; return $_ } sub splash { # display splash screen (top/cache) $p .= qq~ <table border="0" align="center" width="100%" height="100%"> <tr><td align="center"><table><tr><td><h1>MODULATOR</h1><p>~; if(-e $cache){ my @stats = stat(_); my $size = $stats[7] / 1024; $size = sprintf "%.0F", $size; $size .= 'k'; my $dif = $now - $stats[9]; my $tmp = divide($dif,'86400'); # days if($tmp < 1){ $tmp = divide($dif,'3600'); # hours if($tmp < 1){ $tmp = divide($dif,'60'); # minut +es if($tmp < 1){ $tmp = $dif; $tmp = $tmp.' seconds'} # secon +ds else{ $tmp = $tmp.' minutes' }} # minut +es else{ $tmp = $tmp.' hours' }} # hours else{ $tmp = $tmp.' days' } # days $dif = $tmp; $stats[9] = localtime($stats[9]); $now = localtime($now); $p .= qq~<table border="1" cellpadding="3" cellspacing="0"> <tr><td colspan="2"> <a href="$url?make=1">refresh</a> or <a href="$url?dele=1">delete</a> the cache file ($size)</td></tr> <tr><td align="right">created &nbsp;</td><td>$stats[9]</td></tr> <tr><td align="right">now &nbsp;</td><td>$now</td></tr> <tr><td colspan="2" align="center"> <font size="-1"><b>cache file created $dif ago</b></font></td></tr +> </table>~; } else{ $p .= qq~<a href="$url?make=1">create</a> a cache file~ } $p .= qq~<!-- cpan search form from www.perlmonks.org --> <form method="get" action="http://search.cpan.org/search"> <font size="-1"> <b>CPAN Search:</b> <select name="mode"> <option value="module">Module</option> <option value="dist">Distribution</option> <option value="author">Author</option> <option value="doc">Documentation</option> </select><br> </font> <input type="text" name="query" size="32" /> <input type="submit" value="Search" /> </form> <a href="http://www.perl.com/CPAN-local/modules/00modlist.long.html" t +arget="_blank"> The Perl 5 Module List</a><p align="center"><font size="-1"> <a href="http://www.perlmonks.org/index.pl?node=MODULATOR" target="_bl +ank"> visit the homepage</a></font></td></tr></table></td></tr></table>~; } sub alpha { # display alphabet index $p .= qq~<p align="center"><b>~; findmodules(); # returns %found my %abc = (); for(keys %found){ my $ltr = ''; m|^(.)|; $ltr = lc($1) if $1; $abc{$ltr}++; # only show letters that exist } $p .= qq~<a href="$url?listmods=1#top" target="mod">^</a> &nbsp;&nbsp; +~; for(sort {$a cmp $b} keys %abc){ $p .= qq~<a href="$url?listmods=1#$_" target="mod">$_</a> ~ } $p .= qq~</b><br>~; } sub selfurls { # show paths my $rurl = url(-relative=>'1'); my $url3 = url(-absolute=>1); my $url4 = url(-path_info=>1); my $url5 = url(-path_info=>1,-query=>1); $p .= '<p><br>'; $p .= table({-border=>"1",-cellspacing=>'0',-cellpadding=>'6',-align=> +'center'}, Tr([td({-colspan=>'2',},font({-size=>'+2'},b(tt('Path to this script b +y various methods'))))]), Tr({-align=>'left'},[th('method').th('result')]), Tr([td({-colspan=>'2'},small(b('System')))]), Tr([td(tt('$0')).td($this)]), Tr([td(tt('rel2abs($0)')).td(rel2abs($this))]), Tr([td(tt('FindBin($Bin)')).td($Bin)]), Tr([td({-colspan=>'2'},small(b('Environment Variables')))]), Tr([td("<tt>\$ENV{'SCRIPT_NAME'}").td($ENV{'SCRIPT_NAME'})]), Tr([td("<tt>\$ENV{'REQUEST_URI'}").td($ENV{'REQUEST_URI'})]), Tr([td("<tt>\$ENV{'SCRIPT_FILENAME'}").td($ENV{'SCRIPT_FILENAME'})]), Tr([td("<tt>\$ENV{'PWD'}").td($ENV{'PWD'})]), Tr([td({-colspan=>'2'},small(b('CGI Module')))]), Tr([td(tt('url()')).td($url)]), Tr([td(tt('url(-relative=>1)')).td($rurl)]), Tr([td(tt('url(-absolute=>1)')).td($url3)]), Tr([td(tt('url(-path_info=>1)')).td($url4)]), Tr([td(tt('url(-path_info=>1,-query=>1)')).td($url5)])); } sub cache { # create or delete cache file if($i{make}){ %found = (); my $total = findmodules(); # repopulate %found $total = 1 if -e $cache; open FILE, "> $cache" or die "Could not create cache file $cache: + $!"; print FILE Data::Dumper->new([\%found],['$found'])->Indent(0)->Quo +tekeys(0)->Dump; close FILE; $_ = 'Created'; $_ = 'Refreshed' if $total == 1; $p .= qq~$_ cache file $cache~; } if($i{dele}){ unlink $cache; $p .= qq~Could not delete cache file $cache: $!~ if $!; $p .= qq~Deleted cache file $cache~ if !$! } $p .= qq~<p><a href="$url" target="_top">ok</a>~ } __END__ =head1 NAME MODULATOR =head1 DESCRIPTION Browse pod and code of installed perl modules. =head1 FUNCTIONS Lists each installed perl module linked to an HTML rendering of its po +d if any. The degree sign links to the source code of each module. The asterisk links to line numbered source code of each module. Option to automatically put synopsis code into a form for easy testing + via eval. Lists environment variables and result of various path and url finding + methods. Can create a cache file to improve performance. =head1 COPYRIGHT? This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR http://perlmonks.org/index.pl?node=epoptai =cut

In reply to MODULATOR by epoptai

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (3)
    As of 2019-07-21 12:39 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      If you were the first to set foot on the Moon, what would be your epigram?






      Results (8 votes). Check out past polls.

      Notices?