#!perl

use strict;

use CGI qw(:standard);
use Compress::Zlib;
use HTML::Entities;
use MIME::Base64;

my$use_sqz='0'; # set to 1 to use squeeze.pm
# next line uses (modified) squeeze.pm (first line commented out) in same dir as script
# change "require" to "use" (see squeeze pod) if you installed module in root!
if($use_sqz==1){ require "Squeeze.pm"} 

use vars qw($output @output $c $ocheck $icheck $outy @outy @out @o $o $inny @inny $n $host $path $p $pre $title $ifsqz);
my$ltime = localtime();
my$script = url();

my$input = param('input');
my$act   = param('act');
my$acto  = param('acto');
my$help  = param('help');
my$home  = param('home');
my$one   = param('one');
my$czh   = param('czh');
my$ips   = param('ips');
my$sel   = ' selected';

my$done='0';
my%codes=(
ent       => 'Enitities',
low       => 'Lowercase',
upp       => 'Uppercase',
uue       => 'UU Encode',
uud       => 'uu decode',
urle      => 'URL Encode',
urld      => 'url decode',
querystr  => 'Query',
rot13     => 'ROT13',
base64    => 'MIME Base64',
base64u   => 'mime dbase64',
zlibc     => 'ZLIB Compress',
zlibu     => 'zlib uncompress',
sqz       => 'Squeeze',
sqzz      => 'Squeeze1',
octl      => 'Octal',
dword     => 'Dword',
looku     => 'Lookup',
hexa	  => 'Hex<small><sup>1</sup></small>',
hexb	  => 'Hex<small><sup>2</sup></small>',
help      => '.nfo',
home      => '&lt;coder&gt;',);

my@codez  = qw(low upp uue uud base64 base64u zlibc zlibu urle urld ent rot13 looku querystr dword octl hexa hexb help home copy one sqz sqzz); # menu display order
my@except = qw(one copy help home looku querystr dword octl hexa hexb); # don't list in menu
if($ips){ # if ip is checked display ip menu instead
	@codez = splice(@codez, 12, 6); # replace array with 6 elements of itself, starting at the 13th
	undef(@except);
#	@except = qw(); # don't list in menu
	unless(($help or $home)){$icheck=' checked'}
	} 
unless($czh){ $czh= '1'} # DEFAULT divisor for menu height, 1 to show all, 2 to show half, 10 to show 1.
my$dc = ''; # DEFAULT code to select
if($use_sqz !=1){ pop @codez; pop @codez}

print header;
if($acto=~/\?/){&help()}
if($acto=~/!/){&genius()}

if($act){ foreach(@codez){ unless($_ eq /one|/){ if($act eq $_){ do{\&{$_}}->()}}}}

if($one){&line()}
if(!$title){ # define title according to action if any
	$title='&lt;coder&gt;';
	if($act){$title = $codes{$act}}
	if($acto){$title = $codes{$acto}}
	if(($ips)&&(!$act)){$title='IP Mode';
	}
}
&form2;
exit;

sub genius{$input='';$output=''}

sub line{ #oneline
$output=~s/\n|\r//g;
$output = decode_entities($output);
$ocheck=' checked';
@outy=split(//,$output);
$outy=scalar(@outy);
$done=1;
}

sub ent{ # entities
if($input =~/&(\w.);/){
	$input =~s/&(\w.);/$1/eg;
	@inny=split(//,$input);
	foreach(@inny){
		push @output, $_;
		$outy++;
		}
	}
elsif($input =~/^\w{4}/){
	my@inny=split(//,$input);
	foreach(@inny){
		$_ =~ s/.{1}/ord($_)/eg;
		$_ =  '&'.$_.';';
		push @output, $_;
		$outy++;
		}
	$done='1';
	}
}

sub copy{} # zzz

sub low{($output = $input)=~ tr/A-Z/a-z/}
sub upp{($output = $input)=~ tr/a-z/A-Z/}

sub uue{ # uuencode
$output = decode_entities($input);
$output = pack ("u", $input);
@outy=split(//,$output);
$outy=scalar(@outy);$done='1';
$output = encode_entities($output);
}
sub uud{ # uudecode
$output = decode_entities($input);
$output = decode_entities($output);
$output = unpack ("u", $output)}

sub zlibc{ # zlib compress
$output = compress($input);    # compress
$output = pack ("u", $output); # uuencode
@outy=split(//,$output); $outy=scalar(@outy); $done='1'; # count b4 encoding
$output = encode_entities($output);
}
sub zlibu{ # zlib uncompress
my $o = unpack ("u", $input); # uudecode
$output = uncompress($o)}	  # uncompress

sub urle{($output=$input) =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg}
sub urld{($output=$input) =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/eg}

sub base64{$output = encode_base64($input)}
sub base64u{$output = decode_base64($input)}

sub rot13{($output=$input)=~y/A-Za-z/N-ZA-Mn-za-m/}

sub sqz{$output = SqueezeText($input)}

sub sqzz{
$output = SqueezeText($input);
$output =~s/\s+(.)/\U$1/g;  # uppercase 1st letter of every word
$output =~s/ //g; 			# strip spaces
}

sub dword{
my$var=shift(@_);
unless($var){@o=split(/\./,$input)} else {@o=split(/\./,$var)}
$output=0;
$n=1;
unless($n==4){
	foreach(@o){
		if($n==1){$_=($_*16777216)}
		if($n==2){$_=($_*65536)}
		if($n==3){$_=($_*256)}
		if($n==4){$_=($_*1)}
		push @output, $_;
		$n++;
		}
	}
foreach(@output){$output += $_}
undef(@output);
if($var){ return $output}
}

sub octl{
@o=split(/\./,$input,4);
foreach(@o){
	$_=oct($_);					#
	$_='0'. $_ .'.';			#
	if($n==3){$_=~s/\.//o}
	push @output, $_;
	$n++;
	}
foreach(@output){
	@outy=split(//,$_); $outy=scalar(@outy); $done='1'; # hmm
	}
}

sub hexa{
@o=split(/\./,$input,4);
foreach(@o){
	$_= sprintf "%1X", $_;		##
	unless($_=~/../){$_='0'.$_}	##
	$_= '0x'.$_.'.';			#
	if($n==3){$_=~s/\.//o}
	push @output, $_;
	$n++;
	}
}

sub hexb{
@o=split(/\./,$input,4);
foreach(@o){
	$_= sprintf "%1X", $_;		##
	unless($_=~/../){$_='0'.$_}	##
	if($n==0){$_= '0x'.$_}		#
	push @output, $_;
	$n++;
	}
}

sub looku{ # ip to hostname and vice versa, invalid address ok
my$var=shift(@_);
if($var){$input=$var}
unless($input=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){ # hostname to ip
	@output = unpack("C4",gethostbyname($input)); $n=0;
	foreach(@output){$_=$_.'.';	$n++; if($n==4){$_=~s|\.||o}}}
if($input=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){ # ip to hostname
	my@digits = split(/\./, $input);
	my$address = pack('C4', @digits);
	$output = gethostbyaddr($address,2);
	if ($output=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){$output=$input}}
}

sub querystr{
use vars qw($urlfd @urlfd $inputs @inputs $name $value $wha $out @output @put);
$wha=1;
unless($input=~/^\?|^https?:/){ # construct query string
	@inputs = split(/\n/,$input);
	foreach $inputs(@inputs){
		$inputs =~ s/\n|\r//g; # prepare to encode entities
		$inputs = encode_entities($inputs);
	    $inputs =~ tr/ /+/;
		if($wha==1){$out='?'.$inputs} else {$out='&'.$inputs} # prepend 1st arg with ?, rest with &
		push @output, $out;
		$wha++;
		}
	}
if($input=~/^\?|^https?:/){ # decontruct query string
	if($input=~/^https?:|[^\?]/){
		($host,$path)=split(/\?/,$input,2);
		@put = split(/&/,$path);
		}
	if($input=~/^\?/){
		$input=~s/^\?//o;
		@put = split(/&/,$input);
		}
	elsif($input!~/^\?|^https?|[^\?]/){ $path='must supply a url with a ?'; push @put, $path}
	foreach (@put){
		$_ = $_."\n";
		push @output, $_;
		$wha++;
		}
	}
}

sub form2{
if(!$title){$title='&lt;coder&gt;'}
&js_head($title);
my$prcnt='0';
my$cz=(scalar(@codez)-scalar(@except));
$cz=($cz/$czh); # show how many codes at once in select menu? makes select menu height=$cz
unless($input){$input=''} # next line doesn't like empty input
$inny = decode_entities($input); # prepare to count
if(($acto=~/help/)){$inny =~ s/\n|\r//g} # don't count these
my@inny=split(//,$inny);
my$inny=scalar(@inny); # count input chrs
if($output){
	unless($done==1){ # count output chrs if string
		$outy = $output;#) =~ s/\n|\r//g; # don't count these
		@outy=split(//,$outy);
		$outy=scalar(@outy)
		}
	}
if(@output){ # count output chrs if array
	foreach (@output){
		@outy=split(//,$_);
		$o=scalar(@outy);
		push @o, $o;
		}
	foreach(@o){$outy=($outy+$_)} # bug in here somewhere or above... octal count is wrong.
	}
unless(($outy==0)or($inny==0)){
	$prcnt=sprintf("%.2f", ($outy/$inny)*100) # output is what percentage of input?
	}
print<<HTML;
<table border="1" bordercolor="#202020" cellpadding="6" cellspacing="0" align="center">
<tr><form action="$script" method="post">
<td bgcolor="#3a3a3a" align="left" valign="top"><font size="+3">$title</font>&nbsp;</td>
<td align="right" rowspan="2" bgcolor="#3a3a3a">
<table border="1" bordercolor="#202020" cellpadding="3" cellspacing="0" bgcolor="#4a4a4a">
<tr><td valign="top">
<input type="checkbox" name="one" value="line"$ocheck><a name="top" href="javascript:alert('Check this to put output on one single\\nline (will virtually wrap in textarea).\\n\\nIn other words:\\n\\n s/\\\\n|\\\\r//g;\\n\\n')"><font size="-1">one</font></a><br>
<input type="checkbox" name="ips" value="1"$icheck><a href="javascript:alert('Check this and press a button for IP mode.\\n')"><font size="-1">IP</font></a>
HTML
print<<HTML;
</td><td rowspan="2">
<select name="act" size="$cz">
HTML
MU:foreach $c(@codez){ # build select menu
	for(@except){ # don't show in menu
		if($c =~/$_/){ next MU }
		}
	print qq~<option value="$c"~;
	if($act){
if($act =~m/help|home/){$sel=''}
		if($c eq $act){ # select chosen action
			print qq~$sel~;
			}
		}
	unless($act){ # select default action
		if($c eq $dc){
			print qq~$sel~;
			}
		}			
	print qq~>$codes{$c}\n~;
	}
print<<HTML;
</select></td></tr>
<tr><td align="left" valign="bottom">
<input type="submit" value="Go">
<input type="submit" name="acto" value=" ? ">
<input type="submit" name="acto" value=" ! ">
</td></tr></table></td></tr>
<tr><td valign="bottom" bgcolor="#303030">
<font size="+2" color="#606060">Input $inny chrs</font></td></tr>
HTML
if($help=~/bob/){
print<<HTML;
<tr><td valign="bottom" bgcolor="#303030" colspan="2">
<font size="+1">Coder encodes text and IP addresses in various formats</font><br>
<font size="-1"><a href="http://perlmonks.org/index.pl?node_id=47886">&lt;coder&gt;</a> by <a href="http://perlmonks.org/index.pl?node=epoptai">epoptai</a></a></font><br>
</td></tr>
HTML
}
print<<HTML;
<tr><td colspan="2" bgcolor="#606060">
<textarea cols="78" rows="12" name="input" wrap="virtual">$input</textarea></td></tr>
<tr bgcolor="#303030" valign="bottom"><td colspan="2">

<table border="0" cellpadding="0" cellspacing="0" width="100%"><tr><td>
<font size="+2" color="#606060">Output $outy chrs <font size="3">(<b>$prcnt</b>%)</font></font></td>
<td align="right"><font size="-1">
<input type="button" onclick="resetin()" value="Clear Input" align="right"></font></td></form>
<form action="$script" method="post">
<td align="left"><font size="-1">
<input type="button" onclick="resetout()" value="Clear Output"></font></td></tr></table>
</td></tr><tr><td colspan="2" bgcolor="#606060">
<textarea cols="78" rows="12" wrap="virtual">
HTML
if(!@output){
	print "$output";
	$output = encode_entities($output); # must encode again for hidden input tag
	print qq~</textarea>\n<input type="hidden" name="input" value="$output">\n~;
	}
if(@output){
	foreach (@output){ print qq~$_~}
	print qq~</textarea>\n~;
	print qq~<input type="hidden" name="input" value="~;
	foreach (@output){ 
		$_ = encode_entities($_); # must encode again for hidden input tag
		print qq~$_~
		}
	print qq~">\n~;
	}
print<<HTML;
</td></tr>
<tr><td colspan="2" bgcolor="#606060" align="center">
<input type="hidden" name="act" value="copy">
HTML
if($ips){ print qq~<input type="hidden" name="ips" value="1">~}
print qq~<input type="submit" value="copy output to input"></td></form></tr></table>~;
print end_html;
exit(0);
}

sub help{
$title='&lt;coder&gt;.nfo';
my$bugs = "";
if($script=~/cgiwrap/){$bugs="\n\nSomething, possibly cgiwrap or unix, on the demo server seems to cause problems with copying some output back to the input area. This doesn't occur when the script is run locally on Win32."}
$help="bob";
if($ips==1){$input = "IP Mode performs a selected action upon a supplied IP address.\n\n- Lookup will find the domain name for an IP, or the IP for a domain name. When run on the local computer, pressing &quot;Go&quot; or &quot;!&quot; with Lookup selected returns your current IP address if this textarea is empty.\n\n- Query String builds or decodes query strings depending on input.\n\nIf name=value pairs are entered one per line then output is a query string for appending to a url. If a query string starting with ? or http is entered then the string is decoded into name=value pairs.\n\nConversions:\n\nEnter one regular dotted decimal IP address and select the conversion desired. Conversion back to decimal isn't currently implemented.\n\nExample input:\n\n192.168.255.10 (decimal)\n\nOutput:\n3232300810 (Dword)\n01.014.0173.08 (Octal)\n0xC0.0xA8.0xFF.0x0A (Hex1)\n0xC0A8FF0A (Hex2)";$title='IP help';$sel='';&form2()}
if($use_sqz==1){
$ifsqz = "\n\n5. Squeeze compresses english text to the most compact format possible that is still readable. Convert input text to lowercase for maximum compression (30-40%). Read about rules and abbreviations used by squeeze() in squeeze.pm as pod.\n\n6. Squeeze1 performs a squeeze, capitalizes the first letter of each word, and strips all spaces and for a ~14% compression improvement.";
	}
$input = qq~Notes:\n\n1. Check "one" to have output all on one line.\n\n2. Check IP to enable IP mode. Then select ? again to see IP help.\n\n3. Zlib compressed binary output is also uuencoded.$ifsqz$bugs~;
}

sub js_head{
my$title=shift(@_);
print<<HTML;
<html><head><title>$title</title>
<SCRIPT LANGUAGE="JavaScript"><!--//
function resetin(){
document.forms[0].elements[6].value = "";}
function resetout(){
document.forms[1].elements[1].value = "";}
//--></SCRIPT></head>
<body bgcolor="#000000" text="#c0c0c0" link="#ffffff" vlink="#ffffff">
HTML
}