#!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 => '<coder>',);
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='<coder>';
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='<coder>'}
&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> </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">
+<coder></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='<coder>.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" or "!" 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
}
In reply to coder
by epoptai
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.