#!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 or 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,$blksize,$blocks) = stat $ENV{'SCRIPT_FILENAME'};
if($IN::rd eq '1'){$check_rdir = ' checked'}

print header,start_html(-title=>'perlvars',-bgcolor=>"$bgc",-text=>"$btext",-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" bgcolor="$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" name="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 { print 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">&nbsp;</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">&nbsp;</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">&nbsp;</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>$envtotal 

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>$_&nbsp;</TD><TD bgcolor=$tc>&nbsp;<a href=\"file://" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
			}
			elsif($_=~/PATH/){
%ENV->{$_}=~s/;/; /g;
print "<TR><TD bgcolor=$tb>$_&nbsp;</TD><TD bgcolor=$tc>&nbsp;" . %ENV->{$_} . "</TD></TR>";
			}
			elsif($_=~/REMOTE_ADDR/){
print "<TR><TD bgcolor=$tb>$_&nbsp;</TD><TD bgcolor=$tc>&nbsp;<a href=\"http://" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
			}
			elsif($_=~/SERVER_ADMIN/){
print "<TR><TD bgcolor=$tb>$_&nbsp;</TD><TD bgcolor=$tc>&nbsp;<a href=\"mailto:" . %ENV->{$_} . "\">" . %ENV->{$_} . "</a></TD></TR>";
			}
			elsif($_!~/DOCUMENT_ROOT|PWD|WINDIR|SCRIPT_FILENAME|PATH|REMOTE_ADDR|SERVER_ADMIN/){
print "<TR><TD bgcolor=$tb>$_&nbsp;</TD><TD bgcolor=$tc>&nbsp;" . %ENV->{$_} . "</TD></TR>";
			}
		}
	}
}
print "</table>";
print<<HTML;
<TABLE BORDER="$tbd" CELLPADDING=3 cellspacing=1 WIDTH=100%><TR BGCOLOR="$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 the 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" CELLPADDING=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=100%>~;
	}
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/programs/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 modules"),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"),pre("$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",-bgcolor=>"$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=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('Unsupported Binary'),p('Only GIF and JPEG binaries can be viewed.'),hr,("<noscript><strike></noscript><a href='javascript:history.go(-1)'>Ok</a><noscript></strike></noscript>");
	}
exit;
}

sub edit_file{
&check_type();
if($type =~ /image/){ 
	print header,start_html(-title=>'Feature not yet implemented',-bgcolor=>"$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=>"$bgc",-text=>"$btext",-link=>"$blink",-vlink=>"$bvlink"),h1('Unsupported Binary'),p('Only text files can be edited.'),hr("<noscript><strike></noscript><a href='javascript:history.go(-1)'>Ok</a><noscript></strike></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=>"$bgc",-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="post"><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 appears 
	on files >= 30k.<br></small></blockquote>
HTML
	}
print<<HTML;
<textarea name="filebody" rows="40" cols="80" wrap="virtual">$file<\/textarea>
</td></form></tr></table>
HTML
print end_html;
exit;
}

sub stat_file{
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$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 &nbsp;</td></tr><tr><td> 
Inode number </td><td>$ino &nbsp;</td></tr><tr><td> 
File mode (type and permissions) </td><td>$mode &nbsp;</td></tr><tr><td> 
Number of (hard) links to the file </td><td>$nlink &nbsp;</td></tr><tr><td> 
Numeric user ID of file's owner </td><td>$uid &nbsp;</td></tr><tr><td> 
Numeric group ID of file's owner </td><td>$gid &nbsp;</td></tr><tr><td> 
The device identifier (special files only) </td><td>$rdev &nbsp;</td></tr><tr><td> 
Total size of file, in bytes </td><td>$size &nbsp;</td></tr><tr><td> 
Last access time since the epoch </td><td>$atime &nbsp;</td></tr><tr><td> 
Last modify time since the epoch </td><td>$mtime &nbsp;</td></tr><tr><td> 
Inode change time <small>(NOT creation time!)</small> since the epoch </td><td>$ctime &nbsp;</td></tr><tr><td> 
Preferred blocksize for file system I/O </td><td>$blksize &nbsp;</td></tr><tr><td> 
Actual number of blocks allocated </td><td>$blocks &nbsp;</td></tr>
<tr><td bgcolor="$ta"> 
Current time since the epoch </td><td>
$^T &nbsp;</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',-cellpadding=>'4'},
Tr([td({-colspan=>'2',-bgcolor=>"$ta"},font({-size=>'+2'},b(tt('Full Path 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><strike></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=>"$bgc",-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" width="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">&nbsp;</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" maxlength="1"></td>
</tr><tr>
    <td><ul><li><small>windowname for mod docs</ul></td>
    <td><input type="text" name="target" value="$target" size="10"></td>
</tr><tr>
    <td><ul><li>filter modules <input type="checkbox" name="filter" value="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=>"$btext",-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.scriptsolutions.com/programs/free/perldiver/" target="_blank">ScriptSolutions'</a> great free unix-oriented 
<i>perl diver</i> which lists useful environment variables and installed perl modules. 
It was written so these functions could be expanded upon and enjoyed under Win32 as well as Unix systems.
<p>
<h2>Also in perlvars:</h2>
<ul>
<li>Listed modules are linked to their documentation. Either an html rendering 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 not found in the current directory.<p>
<li>Directory browser that can view, edit and stat local files. Stat applies to all files, 
text files with any extension can be viewed and edited, jpeg and gif images can be viewed. 
Unfortunately, text files larger than a given browser software's textarea 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/" target="_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></noscript><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">&nbsp;</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&nbsp;</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">&nbsp;</td></tr></table>
HTML
print end_html;
exit
}

sub install{
print header,start_html(-title=>'install perlvars.pm'),h1('Installation');
if($IN::go eq 'restore default'){ print 'Default configuration restored' }
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">configure</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);