#!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 s
+ame 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 en
+t rot13 looku querystr dword octl hexa hexb help home copy one sqz sq
+zz); # 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 en
+coding
$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",o
+rd($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 @outp
+ut @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} # prepen
+d 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 se
+lect 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 percent
+age 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" hr
+ef="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=epop
+tai">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</text
+area></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="ri
+ght"></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="$ou
+tput">\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 loc
+ally on Win32."}
$help="bob";
if($ips==1){$input = "IP Mode performs a selected action upon a suppli
+ed IP address.\n\n- Lookup will find the domain name for an IP, or th
+e IP for a domain name. When run on the local computer, pressing &quo
+t;Go&quot; or &quot;!&quot; with Lookup selected returns your current
+ IP address if this textarea is empty.\n\n- Query String builds or de
+codes query strings depending on input.\n\nIf name=value pairs are en
+tered one per line then output is a query string for appending to a u
+rl. If a query string starting with ? or http is entered then the str
+ing is decoded into name=value pairs.\n\nConversions:\n\nEnter one re
+gular dotted decimal IP address and select the conversion desired. Co
+nversion back to decimal isn't currently implemented.\n\nExample inpu
+t:\n\n192.168.255.10 (decimal)\n\nOutput:\n3232300810 (Dword)\n01.014
+.0173.08 (Octal)\n0xC0.0xA8.0xFF.0x0A (Hex1)\n0xC0A8FF0A (Hex2)";$tit
+le='IP help';$sel='';&form2()}
if($use_sqz==1){
$ifsqz = "\n\n5. Squeeze compresses english text to the most compact f
+ormat possible that is still readable. Convert input text to lowercas
+e for maximum compression (30-40%). Read about rules and abbreviation
+s used by squeeze() in squeeze.pm as pod.\n\n6. Squeeze1 performs a s
+queeze, capitalizes the first letter of each word, and strips all spa
+ces 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
}
[download]