Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation


by epoptai (Curate)
on Dec 22, 2000 at 00:11 UTC ( #47886=sourcecode: print w/replies, xml ) Need Help??
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.

use strict;

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

my$use_sqz='0'; # set to 1 to use
# next line uses (modified) (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 ""} 

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';

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
#    @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($act){ foreach(@codez){ unless($_ eq /one|/){ if($act eq $_){ do{\&

if(!$title){ # define title according to action if any
    if($act){$title = $codes{$act}}
    if($acto){$title = $codes{$acto}}
    if(($ips)&&(!$act)){$title='IP Mode';

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

sub line{ #oneline
$output = decode_entities($output);
$ocheck=' checked';

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

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);
$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
$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
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{
unless($var){@o=split(/\./,$input)} else {@o=split(/\./,$var)}
        push @output, $_;
foreach(@output){$output += $_}
if($var){ return $output}

sub octl{
    $_=oct($_);                    #
    $_='0'. $_ .'.';            #
    push @output, $_;
    @outy=split(//,$_); $outy=scalar(@outy); $done='1'; # hmm

sub hexa{
    $_= sprintf "%1X", $_;        ##
    unless($_=~/../){$_='0'.$_}    ##
    $_= '0x'.$_.'.';            #
    push @output, $_;

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

sub looku{ # ip to hostname and vice versa, invalid address ok
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);
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;
if($input=~/^\?|^https?:/){ # decontruct query string
        @put = split(/&/,$path);
        @put = split(/&/,$input);
    elsif($input!~/^\?|^https?|[^\?]/){ $path='must supply a url with 
+a ?'; push @put, $path}
    foreach (@put){
        $_ = $_."\n";
        push @output, $_;

sub form2{
$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=scalar(@inny); # count input chrs
    unless($done==1){ # count output chrs if string
        $outy = $output;#) =~ s/\n|\r//g; # don't count these
if(@output){ # count output chrs if array
    foreach (@output){
        push @o, $o;
    foreach(@o){$outy=($outy+$_)} # bug in here somewhere or above... 
+octal count is wrong.
    $prcnt=sprintf("%.2f", ($outy/$inny)*100) # output is what percent
+age of input?
<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
<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="
</td><td rowspan="2">
<select name="act" size="$cz">
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 =~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~;
<tr><td align="left" valign="bottom">
<input type="submit" value="Go">
<input type="submit" name="acto" value=" ? ">
<input type="submit" name="acto" value=" ! ">
<tr><td valign="bottom" bgcolor="#303030">
<font size="+2" color="#606060">Input $inny chrs</font></td></tr>
<tr><td valign="bottom" bgcolor="#303030" colspan="2">
<font size="+1">Coder encodes text and IP addresses in various formats
<font size="-1"><a href="">
+&lt;coder&gt;</a> by <a href="
<tr><td colspan="2" bgcolor="#606060">
<textarea cols="78" rows="12" name="input" wrap="virtual">$input</text
<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>$
<td align="right"><font size="-1">
<input type="button" onclick="resetin()" value="Clear Input" align="ri
<form action="$script" method="post">
<td align="left"><font size="-1">
<input type="button" onclick="resetout()" value="Clear Output"></font>
</td></tr><tr><td colspan="2" bgcolor="#606060">
<textarea cols="78" rows="12" wrap="virtual">
    print "$output";
    $output = encode_entities($output); # must encode again for hidden
+ input tag
    print qq~</textarea>\n<input type="hidden" name="input" value="$ou
    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~;
<tr><td colspan="2" bgcolor="#606060" align="center">
<input type="hidden" name="act" value="copy">
if($ips){ print qq~<input type="hidden" name="ips" value="1">~}
print qq~<input type="submit" value="copy output to input"></td></form
print end_html;

sub help{
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."}
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()}
$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 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{
<SCRIPT LANGUAGE="JavaScript"><!--//
function resetin(){
document.forms[0].elements[6].value = "";}
function resetout(){
document.forms[1].elements[1].value = "";}
<body bgcolor="#000000" text="#c0c0c0" link="#ffffff" vlink="#ffffff">
Replies are listed 'Best First'.
Re: coder
by marius (Hermit) on Dec 22, 2000 at 07:15 UTC
    I may be crazy here, but I've noticed if I plug in an IP address, and request either dword or hex1/hex2, the character count is off tremendously.

      I didn't think it important, will fix it.

      thanks - epoptai

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://47886]
[Cosmic37]: greetings earthlings please can someone improve my pathetic perl knowledge
[Cosmic37]: I have 2 files each with datetime and other data in unknown order and I want to find rows from both files matching by datetime and output them combined/ concatenated
[Corion]: Sure
[Corion]: Do you have any specific interests or general Perl knowledge?
[Cosmic37]: should I slurp? should I grep? Noble Lords I wish you good karma and beg your advice
[Corion]: Cosmic37: Ah, see perlfaq4, about How do I compute the intersection of two arrays
[Cosmic37]: I am out of practice; I use Perl for scientific programming for number crunching
[Corion]: Cosmic37: Basically, you read one file into a hash, keyed by your key, and then match the lines from the second file to that hash
[Cosmic37]: note that the two files only have datetimes which may match whereas other data per line is different format in file1 and file2 - is that really intersection?
[jedikaiti]: Hi Monks

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (8)
As of 2017-06-29 16:18 GMT
Find Nodes?
    Voting Booth?
    How many monitors do you use while coding?

    Results (672 votes). Check out past polls.