Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

comment on
( [id://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

[download]

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":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (4)
As of 2024-04-25 16:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found