Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!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 }

In reply to coder by epoptai

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others chanting in the Monastery: (7)
    As of 2019-11-20 09:08 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Strict and warnings: which comes first?



      Results (96 votes). Check out past polls.

      Notices?