#!perl -l
# perlvars by epoptai
# thanks to japhy for modlist.pl
$start=(times)[0];
use strict qw(subs refs);
use CGI ':standard';
use Pod::Html;
use HTML::Entities;
use FindBin qw($Bin);
use File::Find;
use File::Spec::Functions 'rel2abs';
$ltime= localtime();
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time
+);
$url = url();
$rurl = url(-relative=>'1');
$qurl = url(-path_info=>'1',-query=>'1');
($name= $rurl)=~s/(.*)\..*/$1/;
$cfg = $name.'.cfg';
$dat = $name.'.dat';
$path = $0;
$path =~ s/\/$rurl//o;
&import_names('IN');
unless(eval "require '$dat'"){$nodat=1} else {$nodat=0}
unless(eval "require '$cfg'"){$init=1} else {$init=0}
if(($nodat==1) or ($init==1)){&install()} # find required data files o
+r install
if($IN::go eq 'perlmod'){&perlmod()}
if($IN::go eq 'perldoc'){&perldoc($IN::pm,$IN::title)}
if($IN::go eq 'restore default'){&install()}
if($IN::go eq 'save config'){&config_save();exit}
if($IN::go eq 'home'){ print "Location: $url\n\n"}
if($IN::go eq 'refresh'){ print "Location: $url?rd=1\n\n"}
if($IN::go eq 'update'){&updatedat();exit}
if($IN::go eq 'config'){&configure();exit}
if($IN::go eq ' ? '){&info();exit}
if($IN::go eq ' url '){&selfurls();exit}
if(($IN::file eq 'view') && ($IN::filename)){&view_file()}
if(($IN::file eq 'edit') && ($IN::filename)){&edit_file()}
if(($IN::file eq 'save') && ($IN::filename)){&save_file()}
if(($IN::file eq 'stat') && ($IN::filename)){&stat_file()}
if(($IN::mods eq '1') or ($show_mod eq '1')){&findmodules()}
if( ($IN::env eq '1') or ($show_env eq '1') ){
foreach $key (keys(%ENV)){ unless($ENV{$key} eq '') {$envtotal++}}
$check_env = ' checked';
}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$bl
+ksize,$blocks) = stat $ENV{'SCRIPT_FILENAME'};
if($IN::rd eq '1'){$check_rdir = ' checked'}
print header,start_html(-title=>'perlvars',-bgcolor=>"$bgc",-text=>"$b
+text",-link=>"$blink",-vlink=>"$bvlink");
print<<HTML;
<form method="get">
<p><TABLE BORDER="$tbd" CELLPADDING=3 cellspacing=1 WIDTH=100% align="
+center">
<tr BGCOLOR="$ta"><th colspan="2" align="left" valign="bottom"><big>
<table border="$tbd" align="right" cellpadding="0" cellspacing="0" bgc
+olor="$tb">
HTML
if(($IN::env eq '1') or ($show_env eq '1')){
print<<HTML;
<tr><td align="right"> <small><b>$envtotal</b> </td>
<td> <small>Environment Variables </td></tr>
HTML
}
if(($IN::mods eq '1') or ($show_mod eq '1')){
print<<HTML;
<tr><td align="right"> <font size="-1"><b>$modtotal</b> </td>
<td> <small>Installed Modules </td></tr>
HTML
}
for(@INC){ if($_ eq '.'){ pop(@INC)}}
print<<HTML;
</table><p><br>
Perl Variables </small>
<input type="submit" name="go" value="config"> <input type="submit" na
+me="go" value=" ? ">
</th></tr>
<TR><TD bgcolor=$tb width=100><b>version</b></TD><TD bgcolor=$tc><tt>$
+]</TD></TR>
<TR><TD bgcolor=$tb><b>executable</b></TD><TD bgcolor=$tc><tt>$^X</TD>
+</TR>
<TR><TD bgcolor=$tb><b>INC</b> </TD><TD bgcolor=$tc><tt>
HTML
for(@INC){ print qq~<a href="file://$_">$_</a>~}
print<<HTML;
<a href=".">.</a></TD></TR>
<TR><TD bgcolor=$tb valign="top"><b>readdir</b></tt>
HTML
unless($show_dir eq '1'){
print<<HTML;
<input type="submit" value=" . ">
<input type="checkbox" name="rd" value="1"$check_rdir><p>
HTML
}
if(($IN::rd eq '1') or ($show_dir eq '1')){
print<<HTML;
<table border="$tbd" cellspacing=0 cellpadding=0 width=160>
<tr><td><font size="-2">
File size in bytes is shown for
text files larger than 30k as a
warning that they may exceed
a common html browser
textarea limit.<p></font></td></tr>
HTML
if($ENV{'HTTP_USER_AGENT'}=~/MSIE/){
print<<HTML;
<tr><td><font size="-2">
IE may attempt to execute
perl scripts if the file extension
is associated with perl when
"view" is used. Try "edit"
instead.<br></font></td></tr>
HTML
}
print '</table>';
}
print qq~</TD><TD bgcolor=~;
if(($IN::rd eq '1') or ($show_dir eq '1')){ print qq~$tb>~} else { pri
+nt qq~$tc>~}
if(($IN::rd eq '1') or ($show_dir eq '1')){
opendir THIS, "." or die "$!";
while(defined ($_ = readdir(THIS))){
next if $_ =~ /^\.\.?$/;
next if -d $_;
# if(-d $_){$_='/'.$_}; # list dirs
push @dir, $_;
}
closedir THIS;
@dir = sort { lc($a) cmp lc($b) } @dir;
print<<HTML;
<table border="$tbd" cellpadding=3 cellspacing=0 bgcolor=$tb>
<tr><td rowspan=2 width="10"> </td>
<td><small><b>Current directory</b></small><br>
<select name="filename" size="10">
HTML
for(@dir){
my$fs = -s $_;
if($fs <= 30000){$fss=''}
if($fs >= 30000){
unless(-B $_){
$fs =~ s/(\d{1,3})(?=(?:\d\d\d)+(?!\d))/$1,/gx;
$fss="($fs bytes)";
}
}
print qq~<option value="$_">$_ $fss~;
}
print<<HTML;
</select></td><td rowspan=2 width="10"> </td></tr>
<tr><td><input type="submit" name="file" value="view">
<input type="submit" name="file" value="edit">
<input type="submit" name="file" value="stat">
<input type="submit" value="refresh">
</td></tr></table>
HTML
}
unless(($IN::rd) or ($show_dir eq '1')){ print "$Bin" }
print<<HTML;
</TD></TR>
<TR><TD bgcolor=$tb><input type="submit" name="go" value=" url "></TD>
<TD bgcolor=$tc><a href="$url">$url</a></TD></TR>
<TR><TD bgcolor=$tb width=100><b>OS</b> </TD><TD bgcolor=$tc><tt>$^O</
+TD></TR>
<TR><TD bgcolor=$tb><b>localtime</b> </TD><TD bgcolor=$tc><tt>$ltime</
+TD></TR>
<TR><TD bgcolor=$tb align="right"> </TD><TD bgcolor=$tc>
<small><tt>sec=$sec, min=$min, hour=$hour, mday=$mday, mon=$mon, year=
+$year, wday=$wday, yday=$yday, isdst=$isdst</small></TD></TR>
</table>
<TABLE BORDER="$tbd" CELLPADDING=3 cellspacing=1 WIDTH=100%>
<tr BGCOLOR="$ta"><th colspan="2" align="left"><big><p><br><nobr>$envt
+otal
Environment Variables
</big>
HTML
unless($show_env eq '1'){
print<<HTML;
<input type="checkbox" name="env" value="1"$check_env>
<input type="submit" value="show">
HTML
}
print '</th></tr>';
if(($IN::env eq '1') or ($show_env eq '1')){
for(keys(%ENV)){
unless($ENV{$_} eq ''){
if($_=~/DOCUMENT_ROOT|PWD|WINDIR|SCRIPT_FILENAME/){
print "<TR><TD bgcolor=$tb>$_ </TD><TD bgcolor=$tc> <a href=
+\"file://" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
}
elsif($_=~/PATH/){
%ENV->{$_}=~s/;/; /g;
print "<TR><TD bgcolor=$tb>$_ </TD><TD bgcolor=$tc> " . %ENV
+->{$_} . "</TD></TR>";
}
elsif($_=~/REMOTE_ADDR/){
print "<TR><TD bgcolor=$tb>$_ </TD><TD bgcolor=$tc> <a href=
+\"http://" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
}
elsif($_=~/SERVER_ADMIN/){
print "<TR><TD bgcolor=$tb>$_ </TD><TD bgcolor=$tc> <a href=
+\"mailto:" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
}
elsif($_!~/DOCUMENT_ROOT|PWD|WINDIR|SCRIPT_FILENAME|PATH|R
+EMOTE_ADDR|SERVER_ADMIN/){
print "<TR><TD bgcolor=$tb>$_ </TD><TD bgcolor=$tc> " . %ENV
+->{$_} . "</TD></TR>";
}
}
}
}
print "</table>";
print<<HTML;
<TABLE BORDER="$tbd" CELLPADDING=3 cellspacing=1 WIDTH=100%><TR BGCOLO
+R="$ta"><TH colspan=3 align="left"><big><p><br>$modtotal
Installed Modules
</b></big>
HTML
unless($show_mod eq '1'){
print<<HTML;
<input type="checkbox" name="mods" value="1"$check_mods>
<input type="submit" value="show">
HTML
}
if(($IN::mods eq '1') or ($show_mod eq '1')){
print qq~<input type="submit" name="go" value="update"> ~;
}
if(($filter eq '1') && (($IN::mods eq '1') or ($show_mod eq '1'))){
print qq~<br><small><b>$mt2</b> displayed, <b>$mt3</b> filtered (~
+;
for(@filtered){ print "$_ "}
print ')</small>';
}
if(($IN::mods eq '1') or ($show_mod eq '1')){
print qq~<br><small>Modules without pod * are linked directly to t
+he module.~;
}
print '</td></tr>';
unless(($IN::mods eq '1') or ($show_mod eq '1')){ print '</table>'}
if(($IN::mods eq '1') or ($show_mod eq '1')){
if($filter eq '1'){$modtotal=$mt2}
$third = $modtotal/3;
$count=0;
print qq~<TR><TD WIDTH=33% VALIGN=TOP><TABLE BORDER="$tbd" CELLPAD
+DING=3 width=100%>~;
foreach $mod(@foundmods){
&make($mod);
$count++;
if($count <= $third){
print qq~<TR><TD bgcolor="$tc">$root</TD></TR>~;
}
else{
push (@mod1,$mod)
}
}
print qq~</TABLE></TD><TD WIDTH=33% VALIGN=TOP><TABLE BORDER="$tbd
+" CELLPADDING=3 width=100%>~;
$count=0;
foreach $mod1(@mod1){
&make($mod1);
$count++;
if($count <= $third){
print qq~<TR><TD bgcolor="$tc">$root</TD></TR>~;
}
else{
push (@mod2,$mod1)
}
}
print qq~</TABLE></TD><TD WIDTH=33% VALIGN=TOP><TABLE BORDER="$tbd
+" CELLPADDING=3 width=100%>~;
$count=0;
foreach $mod2(@mod2){
&make($mod2);
$count++;
if($count <= $third){
print qq~<TR><TD bgcolor="$tc">$root</TD></TR>~;
}
}
print qq~</TABLE></td></tr>~;
}
unless(($IN::mods eq '1') or ($show_mod eq '1')){
print qq~<TABLE BORDER="$tbd" CELLPADDING=3 cellspacing=1 WIDTH=10
+0%>~;
}
print qq~<TR><TD bgcolor="$ta" colspan="3" align="center">~;
$end=(times)[0];
printf "<small><b>That took %.2F CPU seconds.", $end - $start;
print qq~</TD></TR></TABLE></form>~;
print end_html;
exit(0);
sub findmodules{
for(@INC){ if($_ eq '.'){ pop(@INC)}}
@path{@INC} = (); # modlist.pl - http://www.crusoe.net/~jeffp/programs
+/modlist
for $base (@INC) { find(\&modules, $base) } # ditto
$check_mods = ' checked';
$modtotal = @foundmods;
if($filter eq '1'){
for(@foundmods){
$off=0;
$mname=$_;
@fm = split(/::/,$_);
$fm = shift(@fm);
for(@filtered){ if($_ eq $fm){$off=1}}
unless($off==1){$fms{$mname}=1}
}
@foundmods = keys(%fms);
$mt2 = @foundmods;
$mt3 = ($modtotal-$mt2);
# $modtotal = $mt2;
}
@foundmods = sort { lc($a) cmp lc($b) } (@foundmods);
}
sub modules { # sub from modlist.pl - http://www.crusoe.net/~jeffp/pro
+grams/modlist
$File::Find::prune = 1, return if
exists $path{$File::Find::dir} and $File::Find::dir ne $base;
$f = $File::Find::name; # < added
if($f=~/\.pm$/){ #
push @files, $f; #
} #
@files = sort @files; # <
my $module = substr $File::Find::name, length $base;
return unless $module =~ s/\.pm$//;
$module =~ s!^/+!!;
$module =~ s!/!::!g;
# $module =~ tr!A-Z!a-z!;
push @foundmods, $module;
# print qq~<li>$module~;
}
sub make{
my$var = shift;
my@smn = split(/::/,$var);
my$name = pop(@smn);
my$foo = shift(@smn);
for(@files){
if($_=~/$foo.*$name\.pm/){
unless($modpath{$var}){$modpath{$var}=$_}
}
}
for(keys(%moddat)){
if($_ eq $var){
if($moddat{$_}==1){
$root=qq(<small><a href="$url?go=perldoc&pm=$modpath{$var}
+&title=$var" target="$target">$var</a>);
}
if($moddat{$_}==0){
$root=qq(<small><a href="$url?go=perlmod&pm=$modpath{$var}
+&title=$var" target="$target">$var</a>$markpm);
}
}
}
}
sub updatedat{
&makedat();
print header,start_html(-title=>"module list updated",-bgcolor=>"$bgc"
+,-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('Updated'),p("
+Module list <a href='$dat'><i>$dat</i></a> updated with $modtotal mod
+ules"),hr,p(a({-href=>"$url"},'Reload'));
}
sub makedat{
&findmodules();
for(@foundmods){
my$var = $_;
my@smn = split(/::/,$var);
my$lname = pop(@smn);
my$foo = pop(@smn);
for(@files){
if($_=~/$foo.$lname\.pm/){
open(IT,"< $_") or next;
local $/ = undef;
my$it=<IT>;
close(IT) or die "Couldn't close module: $!";
if($it=~/=cut/ or /=head/ or /=item/){$rec{$var}=1}
else{$rec{$var}=0}
}
}
}
open(FILE,"> $dat") or die "$!";
print FILE qq~%moddat=(~;
for(sort { lc($a) cmp lc($b) } keys(%rec)){
print FILE qq~$_=>$rec{$_},~;
}
print FILE qq~);~;
close(FILE) or die "$!";
}
sub perlmod{
open(MU,"< $IN::pm") or die "$!";
local $/ = undef;
my$it=<MU>;
close(MU) or die "$!";
print header(-type=>'text/html'),start_html(-title=>"$IN::title",-
+bgcolor=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),pr
+e("$it");exit
}
sub perldoc{
$pod = $^T;
pod2html( "--htmlroot=$Bin",
"--infile=$_[0]",
"--outfile=$pod.html",
"--title=$_[1]",
);
open(IT,"< $pod.html") or die "$!";
local $/ = undef;
my$it=<IT>;
close(IT) or die "$!";
unlink "$pod.html";
print header(-type=>'text/html'),start_html(-title=>"$IN::title",-bgco
+lor=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),p("$it
+");exit
}
sub check_type{
$file=$IN::filename;
if(-B $file){$type='binary'}
if(-T $file){$type='text/plain'}
if( $file=~/\.s?html?/i){$type='text/html'}
if($file=~/\.gif/i){$type='image/gif'}
if($file=~/.jpe?g?/i){$type='image/jpeg'}
}
sub view_file{
&check_type();
if($type=~/text/){
print header(-type=>"$type");
if($type=~/html/){ print start_html(-title=>"viewing $IN::filename
+",-bgcolor=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink")
+}
open(FILE, "< $file") or die "$!";
local $/ = undef;
my$data = <FILE>;
close(FILE) or die "$!";
print $data;
}
if($type=~/image/){
print "Location: $file\n\n";
}
if($type=~/binary/){
print header,start_html(-title=>'Unsupported Binary',-bgcolor=>"$b
+gc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('Unsupporte
+d Binary'),p('Only GIF and JPEG binaries can be viewed.'),hr,("<noscr
+ipt><strike></noscript><a href='javascript:history.go(-1)'>Ok</a><nos
+cript></strike></noscript>");
}
exit;
}
sub edit_file{
&check_type();
if($type =~ /image/){
print header,start_html(-title=>'Feature not yet implemented',-bgc
+olor=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),p,br,
+blockquote,p("Images can only be <a href='$url?filename=$IN::filename
+&file=view'>viewed</a>");
exit;
}
if($type=~/binary/){
print header,start_html(-title=>'Unsupported Binary',-bgcolor=>"$b
+gc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('Unsupporte
+d Binary'),p('Only text files can be edited.'),hr("<noscript><strike>
+</noscript><a href='javascript:history.go(-1)'>Ok</a><noscript></stri
+ke></noscript>");
exit;
}
$fs = -s $IN::filename;
open (FILE, "< $IN::filename") or die "$!";
local $/ = undef;
my$file = <FILE>;
close(FILE) or die "$!";
&encode_entities($file);
print header,start_html(-title=>"editing $IN::filename",-bgcolor=>"$bg
+c",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink");
my$fc = (length($IN::filename)+3);
($fL = $0) =~ s/$rurl$//o;
print<<HTML;
<table border="$tbd" cellpadding=0 cellspacing=0><tr><form method="pos
+t"><td>
<input type="hidden" name="file" value="save">
<input type="submit" value="save file as">
<input type="text" name="filename" value="$IN::filename" size="$fc">
HTML
if($fs <= 30000){
print qq~<small>($fs bytes) in <a href="file://$fL">$fL</a></small
+>~;
}
if($fs >= 30000){
print<<HTML;
<font size="-1" color="#ff0000">($fs bytes) in <a href="file://$fL
+">$fL</a></font></font><blockquote>
<small>If a large text file was selected and the textarea
is empty your browser<br>has a textarea limit. This warning appear
+s
on files >= 30k.<br></small></blockquote>
HTML
}
print<<HTML;
<textarea name="filebody" rows="40" cols="80" wrap="virtual">$file<\/t
+extarea>
</td></form></tr></table>
HTML
print end_html;
exit;
}
sub stat_file{
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$bl
+ksize,$blocks) = stat $IN::filename;
print header,start_html(-title=>"stat $IN::filename",-bgcolor=>"$bgc",
+-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink");
print<<HTML;
<table border="$tbd" cellspacing=1 cellpadding=3 bgcolor="$tb">
<tr><td colspan=2 bgcolor="$ta"><h2>results of <tt>stat $IN::filename<
+/tt></h2></td></tr>
<tr><th align=left>
Field</th><th align=left>Value</th></tr>
<tr><td>
Device number of filesystem </td><td>$dev </td></tr><tr><td>
Inode number </td><td>$ino </td></tr><tr><td>
File mode (type and permissions) </td><td>$mode </td></tr><tr><t
+d>
Number of (hard) links to the file </td><td>$nlink </td></tr><tr
+><td>
Numeric user ID of file's owner </td><td>$uid </td></tr><tr><td>
+
Numeric group ID of file's owner </td><td>$gid </td></tr><tr><td
+>
The device identifier (special files only) </td><td>$rdev </td><
+/tr><tr><td>
Total size of file, in bytes </td><td>$size </td></tr><tr><td>
Last access time since the epoch </td><td>$atime </td></tr><tr><
+td>
Last modify time since the epoch </td><td>$mtime </td></tr><tr><
+td>
Inode change time <small>(NOT creation time!)</small> since the epoch
+</td><td>$ctime </td></tr><tr><td>
Preferred blocksize for file system I/O </td><td>$blksize </td><
+/tr><tr><td>
Actual number of blocks allocated </td><td>$blocks </td></tr>
<tr><td bgcolor="$ta">
Current time since the epoch </td><td>
$^T </td></tr>
<tr><td colspan=2 bgcolor="$ta" align="right">
<noscript><strike></noscript><a href="javascript:history.go(-1)">ok</a
+><noscript></strike></noscript></td></tr>
</table>
HTML
print end_html;
exit;
}
sub save_file{
&decode_entities($IN::filebody);
open (FILE, "> $IN::filename") or die "$!";
print FILE $IN::filebody;
close(FILE) or die "$!";
print header,start_html(-title=>'File Saved',-bgcolor=>"$bgc",-text=>"
+$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('File Saved');
print qq~<a href="$IN::filename">$IN::filename</a> saved in <i>$Bin</i
+><hr><noscript><strike></noscript><a href="javascript:history.go(-2)"
+>return</a><noscript></strike></noscript>~;
exit;
}
sub selfurls{
$url3 = url(-absolute=>1);
$url4 = url(-path_info=>1);
$url5 = url(-path_info=>1,-query=>1);
($url5 = $url5) =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/eg;
$url5 =~ tr/ /+/;
print header,start_html(-title=>'urls',-bgcolor=>"$bgc",-text=>"$btext
+",-link=>"$blink",-vlink=>"$bvlink");
print table({-border=>"$tbd",-bgcolor=>"$tc",-cellspacing=>'1',-cellpa
+dding=>'4'},
Tr([td({-colspan=>'2',-bgcolor=>"$ta"},font({-size=>'+2'},b(tt('Full P
+ath to this script by various methods'))))]),
Tr({-align=>'left',-bgcolor=>'dddddd'},[th('method').th('result')]),
+
Tr([td({-colspan=>'2',-bgcolor=>"$tb"},small(b('system paths')))]),
Tr([td(tt('$0')).td($0)]),
Tr([td(tt('FindBin($Bin)')).td($Bin)]),
Tr([td(tt('rel2abs($0)')).td(rel2abs($0))]),
Tr([td({-colspan=>'2',-bgcolor=>"$tb"},small(b('web paths')))]),
Tr([td("<tt>\$ENV{'SCRIPT_NAME'}").td($ENV{'SCRIPT_NAME'})]),
Tr([td(tt('$q->url()')).td($url)]),
Tr([td(tt('$q->url(-relative=>1)')).td($rurl)]),
Tr([td(tt('$q->url(-absolute=>1)')).td($url3)]),
Tr([td(tt('$q->url(-path_info=>1)')).td($url4)]),
Tr([td(tt('$q->url(-path_info=>1,-query=>1)')).td(small("$url5"))]),
+
Tr([td({-colspan=>'2',-bgcolor=>"$tb",-align=>'right'},"<noscript><str
+ike></noscript><a href='javascript:history.go(-1)'>ok</a><noscript></
+strike></noscript>")]),
);
print end_html;
}
sub configure{
if($show_dir eq '1'){$checkp_dir=' checked'}
if($show_env eq '1'){$checkp_env=' checked'}
if($show_mod eq '1'){$checkp_mod=' checked'}
if($filter eq '1'){$checkp_filter=' checked'}
print header,start_html(-title=>'configure perlvars.pm',-bgcolor=>"$bg
+c",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink");
print<<HTML;
<table border="$tbd" width="100%" cellpadding="4" cellspacing="1">
<tr bgcolor="$ta"><form method="post"><td>
<h1>
Configure perlvars</h1></td><td align=right>
<input type="submit" name="go" value="save config">
<input type="submit" name="go" value="home"></td></tr>
<tr><td colspan="2" bgcolor="$tb"><h3>
Display Preferences</td></tr>
<tr bgcolor="$tc"><td align="center">
<table cellspacing="1" cellpadding="2" border="$tbd" bgcolor="$tb" wid
+th="80%">
<tr><td colspan="2"><small>If expand is checked the section
will be expanded by default, otherwise a check box and expand button
will appear near the section title.<br>
</td></tr>
<tr align="left"><th>section</th><th>expand</th></tr><tr>
<td>readdir</td>
<td><input type="checkbox" name="show_dir" value="1"$checkp_dir></
+td>
</tr><tr>
<td>environment variables</td>
<td><input type="checkbox" name="show_env" value="1"$checkp_env></
+td>
</tr><tr>
<td>installed modules</td>
<td><input type="checkbox" name="show_mod" value="1"$checkp_mod></
+td>
</tr>
<tr><td colspan="2" height="10"> </td></tr>
<tr>
<td><ul><li><small>mark non-pod links with a</ul></td>
<td><input type="text" name="markpm" value="$markpm" size="1" maxl
+ength="1"></td>
</tr><tr>
<td><ul><li><small>windowname for mod docs</ul></td>
<td><input type="text" name="target" value="$target" size="10"></t
+d>
</tr><tr>
<td><ul><li>filter modules <input type="checkbox" name="filter" va
+lue="1"$checkp_filter><br>
<font size="-1">module dirs excluded from display</font><br></td>
<td><input type="text" name="filtered" value="@filtered" size="22"
+></td>
</tr><tr>
<td colspan="2"></td>
</tr>
</table>
</td><td>
<table cellspacing="1" cellpadding="2" border="$tbd" bgcolor="$tb">
<tr align="left"><th>element</th><th>value</th></tr><tr>
<td><small>background color</td>
<td><input type="text" name="bgc" value="$bgc"></td>
</tr><tr>
<td><small>text color</td>
<td><input type="text" name="btext" value="$btext"></td>
</tr><tr>
<td><small>link color</td>
<td><input type="text" name="blink" value="$blink"></td>
</tr><tr>
<td><small>visited link color</td>
<td><input type="text" name="bvlink" value="$bvlink"></td>
</tr><tr>
<td><small>table shade light</td>
<td><input type="text" name="tc" value="$tc"></td>
</tr><tr>
<td><small>table shade medium</td>
<td><input type="text" name="tb" value="$tb"></td>
</tr><tr>
<td><small>table shade dark</td>
<td><input type="text" name="ta" value="$ta"></td>
</tr><tr>
<td><small>table border</td>
<td><input type="text" name="tbd" value="$tbd" size="2"></td>
</tr></table>
</td></tr>
<tr><td colspan="2" bgcolor="$tb"><input type="submit" name="go" value
+="restore default">
<small> will overwrite current config with a fresh default.</td></form
+></tr></table>
HTML
exit;
}
sub info{
print header,start_html(-title=>"$rurl",-bgcolor=>"$bgc",-text=>"$btex
+t",-link=>"$blink",-vlink=>"$bvlink");
print<<HTML;
<body bgcolor="$bgc">
<table border="$tbd" cellspacing=1 cellpadding=3 bgcolor="$tb" width="
+70%" align="center">
<tr><td bgcolor="$ta"><h1>$rurl</h1></td></tr>
<tr><td><p><br><blockquote>
<b>perlvars</b> is based on the concept of <a href="http://www.scripts
+olutions.com/programs/free/perldiver/" target="_blank">ScriptSolution
+s'</a> great free unix-oriented
<i>perl diver</i> which lists useful environment variables and install
+ed perl modules.
It was written so these functions could be expanded upon and enjoyed u
+nder Win32 as well as Unix systems.
<p>
<h2>Also in perlvars:</h2>
<ul>
<li>Listed modules are linked to their documentation. Either an html r
+endering of the pod
or raw module source code.<p>
<li>Control panel to customize preferences.<p>
<li>Automatic configuration file creation if either $cfg or $dat are n
+ot found in the current directory.<p>
<li>Directory browser that can view, edit and stat local files. Stat a
+pplies to all files,
text files with any extension can be viewed and edited, jpeg and gif i
+mages can be viewed.
Unfortunately, text files larger than a given browser software's texta
+rea limit cannot be
edited.<p>
</ul>
<h3>Credits:</h3>
Coded by <a href="http://perlmonks.org/index.pl?node=epoptai" target="
+_blank">epoptai</a><br>
<a href="http://www.crusoe.net/~jeffp/programs/modlist" target="_blank
+">modlist.pl</a> - getting a list of modules<br>
<a href="http://www.scriptsolutions.com/programs/free/perldiver/" targ
+et="_blank">
perldiver.pl</a>- splitting module table into thirds<br><p><br></td></
+tr>
<tr><td bgcolor="$ta" align="right"><noscript><strike></noscript>
<a href="javascript:history.go(-1)">Ok</a><noscript></strike></noscrip
+t><noscript> or
<a href="$url">Ok</a></noscript></td></tr>
</table>
<p>
HTML
print end_html;
}
sub config_save{
%cfg = (
bgc => "\$bgc='$IN::bgc';",
btext => "\$btext='$IN::btext';",
blink => "\$blink='$IN::blink';",
bvlink => "\$bvlink='$IN::bvlink';",
tc => "\$tc='$IN::tc';",
tb => "\$tb='$IN::tb';",
ta => "\$ta='$IN::ta';",
tbd => "\$tbd='$IN::tbd';",
dir => "\$show_dir='$IN::show_dir';",
env => "\$show_env='$IN::show_env';",
mod => "\$show_mod='$IN::show_mod';",
target => "\$target='$IN::target';",
markpm => "\$markpm='$IN::markpm';",
filter => "\$filter='$IN::filter';",
filtered => "\@filtered=qw($IN::filtered);",
);
open (FILE, "> $cfg") or die "Problem saving config file: $!";
for(keys(%cfg)){
print FILE qq($cfg{$_})
}
print FILE "\n1;\n";
close(FILE) or die "$!";
print header,start_html(-title=>'Configuration Saved',-bgcolor=>"$bgc"
+,-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink");
if($IN::show_dir eq '1'){$showdir='yes'} else {$showdir='no'}
if($IN::show_env eq '1'){$showenv='yes'} else {$showenv='no'}
if($IN::show_mod eq '1'){$showmod='yes'} else {$showmod='no'}
if($IN::filter eq '1'){$filt='yes'} else {$filt='no'}
if($IN::diag eq '1'){$dia='On'} elsif($IN::diag eq '0'){$dia='Off'
+}
print<<HTML;
<table border="$tbd" width="100%" cellpadding="4" cellspacing="1"><tr
+bgcolor="$ta"><form><td>
<h1>
Configuration Saved
</h1></td><td align=right>
<input type="submit" name="go" value="config">
<input type="submit" name="go" value="home"></td></tr>
<tr><td colspan="2" bgcolor="$tb"><h3>
Display Preferences</td></tr>
<tr bgcolor="$tc"><td align="center">
<table cellspacing="1" cellpadding="4" border="$tbd" bgcolor="$tb">
<tr align="left"><th>section</th><th>expand</th></tr><tr>
<td>readdir</td><td><tt>$showdir</td></tr>
<tr><td>environment variables</td><td><tt>$showenv</td></tr>
<tr><td>installed modules</td><td><tt>$showmod</td></tr>
<tr><td colspan="2" height="10"> </td></tr>
<tr><td>display window</td><td><tt>$target</td></tr>
<tr><td>marking non-pod links with a</td><td><tt>$IN::markpm</td></tr>
<tr><td>filter modules</td><td><tt>$filt</td></tr>
<tr><td>filtered modules</td><td><tt>$IN::filtered </td></tr>
</table>
</td><td align="center">
<table cellspacing="1" cellpadding="4" border="$tbd" bgcolor="$tb">
<tr align="left"><th>element</th><th>value</th></tr>
<tr><td><small>background color</td><td><tt>$IN::bgc</td></tr>
<tr><td><small>text color</td><td><tt>$IN::btext</td></tr>
<tr><td><small>link color</td><td><tt>$IN::blink</td></tr>
<tr><td><small>visited link color</td><td><tt>$IN::bvlink</td></tr>
<tr><td><small>table shade light</td><td><tt>$IN::tc</td></tr>
<tr><td><small>table shade medium</td><td><tt>$IN::tb</td></tr>
<tr><td><small>table shade dark</td><td><tt>$IN::ta</td></tr>
<tr><td><small>table border</td><td><tt>$IN::tbd</td></tr>
</table>
</td></tr>
<tr><td colspan="2" bgcolor="$tb"> </td></tr></table>
HTML
print end_html;
exit
}
sub install{
print header,start_html(-title=>'install perlvars.pm'),h1('Installatio
+n');
if($IN::go eq 'restore default'){ print 'Default configuration restore
+d' }
print ol;
if(($init==1)){
print qq~<li>Data file <i>$cfg</i> not detected in <i>$path</i><br
+>~;
}
if(($init==1) or ($IN::go eq 'restore default')){
while(<DATA>){$df .= $_} # read data
open (FILE, "> $cfg") or die "$!";
print FILE $df;
close(FILE) or die "$!";
print qq~<li><b>Created data file <i>$path/<a href="$cfg">$cfg</a>
+</i></b>~;
}
if($nodat==1){
print qq~<li>Data file <i>$dat</i> not detected in <i>$path</i><br
+>~;
&makedat();
print qq~<li><b>Created data file <i>$path/<a href="$dat">$dat</a>
+</i></b>~;
}
print<<HTML;
</ol><hr>
Ready to <a href="$url">reload</a> or <a href="$url?go=config">configu
+re</a>
HTML
exit
}
__END__
$bgc='#d0d0d0';
$btext='#000000';
$blink='#0000ff';
$bvlink='#6600aa';
$tbd='0';
$tc='#c0c0c0';
$tb='#b0b0b0';
$ta='#a0a0a0';
$show_dir='';
$show_env='1';
$show_mod='1';
$markpm='*';
$target='docs';
$filter='';
@filtered=qw(Tk);
|
