Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

MODULATOR

by epoptai (Curate)
on Jun 21, 2002 at 01:39 UTC ( #176209=sourcecode: print w/ replies, xml ) Need Help??

Category: Utility Scripts
Author/Contact Info epoptai
Description: Browse pod and code of installed perl modules in a handy frameset. Lists each installed perl module linked to an HTML rendering of its pod if any, and to its source code. Option to automatically put synopsis code into a form for easy testing via eval (this is both powerful and dangerous, use caution). Lists environment variables and result of various path and url finding methods. Here's a screenshot.

Updates:

  • fixed problem with "refresh cache" not refreshing the cache.
  • added "no header" option to code eval, for testing output of modules like GD.
  • implemented this fix suggested by perigeeV.
  • added a link to the perl module list.
  • added function to list module source code with numbered lines.
  • Added a CPAN search form.
  • #!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
    

    Comment on MODULATOR
    Download Code

    Back to Code Catacombs

    Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Node Status?
    node history
    Node Type: sourcecode [id://176209]
    help
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others exploiting the Monastery: (7)
    As of 2014-09-17 10:34 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (72 votes), past polls