http://qs1969.pair.com?node_id=47886
Category: Text Processing
Author/Contact Info epoptai
Description: coder encodes text and IP addresses in various formats. Text can be encoded to and from uppercase, lowercase, uuencoding, MIME Base64, Zlib compression (binary output is also uuencoded, uncompress expects uuencoded input), urlencoding, entities, ROT13, and Squeeze. IP addresses can have their domain names looked up and vice versa, converts IPs to octal, dword, and hex formats. Query strings can also be decoded or constructed.
#!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
}