Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

MODULATOR

by epoptai (Curate)
on Jun 21, 2002 at 01:39 UTC ( [id://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
    

    Log In?
    Username:
    Password:

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

    How do I use this?Last hourOther CB clients
    Other Users?
    Others learning in the Monastery: (4)
    As of 2025-06-13 19:56 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      No recent polls found

      Notices?
      erzuuliAnonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.