l33t cgi- for Sharing Code and Text.

PERL 74

l33t cgi

Guest on 19th August 2022 04:35:00 PM

#!/usr/bin/perl
# This program ist published under GPL
# Copyright by Lennart Poettering, lennart@poettering.de
# With some important changes by Gerhard Blum, gerhard@smoking.de
# Maximum size of a page to l33t
$Max = 1000000; # set higher if you have enough RAM to use
# Send forms to l33t web?
$FORMon = 1 ; # leave undefined or set to 0 to cancel
# Translate 'strings' with these endings in javascript & option tags to point to us
# Leave first $wwwrsc_scr undefined to cancel
$wwwrsc_scr= '(\.plX|\.cgiX|\.aspX|\.s?html?X|\.php\d?X|[\w\~\/\.-]+\/)';
$wwwrsc= '(\.gif|\.jpe?g|\.swf|\.mp3|\.mid|\.zip)'; # do NOT translate these endings
$_='(\?[^\'\"]+|#[^\'\"]+)?';
$wwwrsc_scr =~ s/X/$_/go;
use CGI;
use LWP::UserAgent;
use HTTP::Request;
# Translates a phrase from readable to l33t text. Ignores all special tags.
sub make_phrase_leet()
{
my ($s) = @_;
$s =~ s/s\b/Z/gio if $skill >= 5;
$s =~ tr/aAeEoO/443300/;
$s =~ tr/iItTbB/117788/ if $skill >= 2;
$s =~ tr/sSgG/5\$96/ if $skill >= 3;
$s =~ tr/lLz/||2/ if $skill >= 4;
$s =~ s/c/</gio if $skill >= 5;
$s =~ s/K/\[</gio if $skill >= 5;
$s =~ s/W/VV/gio if $skill >= 5;
return $s;
}
# Translates a phrase from readable to l33t text. Handles umlauts and special characters.
sub make_text_leet()
{
my ($text) = @_;
my ($result, @blocks) = split(/&/, $text);
my ($item, $char, $trailing);
$result = &make_phrase_leet($result);
foreach $item (@blocks)
{
if ($item =~ /;/)
{
($char, $trailing) = ($`,$'); # prematch, postmatch
$result .= "&".$char.";".&make_phrase_leet($trailing);
}
else
{
$result .= "&" . &make_phrase_leet($item);
}
}
return $result;
}
# Fixes a given URL for is. Prepends hostname on relative URLs. Prepends the URL of this script for nto letting the user escape from our l33t web.
# Arguments are the url and a value that indicates if and how our script-address should be prepended or not.
sub fix_url()
{
my ($u, $v) = @_;
my $b, $anchor = '';
if ($u =~ /^http:/io || not ($u =~ /^(\w{1,10}):/o) )
{
if (not $u =~ /^http:/o) # same server
{
if ($u =~ /^\//o) #Absolute, same server
{
$b = $url;
$b =~ s/^(........*?)\/.*$/$1/o;
$u = $b.$u;
}
else #Relative, same server
{
$b = $url;
$b =~ s/^(.*\/)(.*)$/$1/o unless ($u =~ /^#/o);
while ($u =~ s/^\.\.\///o) # Evaluate ../
{ # and think of people pointing higher than document_root
$b =~ s/^(.*\/)(.*)\/$/$1/o if ($b =~ /(.*\/){4,}/o);
}
$u = $b.$u;
}
}
# move #anchor to ourselves; NOT MSIE (cuts parameters when #present)
if($ENV{'HTTP_USER_AGENT'} !~ /MSIE/o)
{
$anchor = $2 if ($u =~ s/^(.*)(#[^\?]*)/$1/o) ;
}
if ($v>1) #send forms to l33t web
{
$hidden_fields = "\n<input type=\"hidden\" name=\"_skill_\" value=\"$skill\">";
$hidden_fields .= "\n<input type=\"hidden\" name=\"_url_\" value=\"$u\">";
$hidden_fields .= "\n<input type=\"hidden\" name=\"_isform_\" value=\"l33t\">\n";
$u = $ourselves.$anchor ;
}
elsif ($v)
{
$u = $ourselves.$anchor."?_skill_=".$skill."&_url_=".$query->escape($u) ;
}
}
return $u;
}
# Translates each tag which needs it.
sub handle_tag()
{
my ($tag) = @_;
# These need the script-address to be prepended (because they point to HTML-data)
# a href | area href
$tag =~ s/((a|area)(\s|\s.*\s)href\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($5,1).$6/seio;
# frame src
$tag =~ s/(frame(\s|\s.*\s)src\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,1).$5/seio;
# script src
$tag =~ s/(script(\s|\s.*\s)src\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,1).$5/seio if $wwwrsc_scr ;
# meta refresh
$tag =~ s/(meta(\s|\s.*\s)http-equiv\s*=\s*(\"|\')refresh\3.+?url=)(.*?)\3/$1.&fix_url($4,1).$3/seio;
# form action
$tag =~ s/(form(\s|\s.*\s)action\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,2).$5/seio if $FORMon;
# These need make_javascript() to prepend script-address
# javascript: in href
$tag =~ s/((a|area)(\s|\s.*\s)href\s*=\s*\"\s*javascript:[^\"]+?)(\'[^\n]+?\')(.*?\")/$1.&make_javascript($4).$5/seiog ;
# javascript inside tag
$tag =~ s/(.+?\son\w+\s*=\s*\"[^\"]+?)(\'.+?\')(.*?\")/$1.&make_javascript($2).$3/eiog ;
# url in option tag
$tag =~ s/(option(\s|\s.*\s)value\s*=\s*)((\"|\').+?\4)/$1.&make_javascript($3)/seio ;
# l33t alternate-text in img tag
$tag =~ s/(img(\s|\s.*\s)alt\s*=\s*(\"|\'))(.*?)\3/$1.&make_text_leet($4).$3/seio;
# l33t alternate-text in image map
$tag =~ s/(area(\s|\s.*\s)alt\s*=\s*(\"|\'))(.*?)\3/$1.&make_text_leet($4).$3/seio;
return $tag;
}
# We do not want to be called recursively
sub deiterate_url()
{
my ($url) = @_;
$url =~ s/^$ourselves\?.*?_url_=(.*?)(&.*|$)/$query->unescape($1)/goe;
return $url;
}
# Prepend script-url in javascript-code
sub make_javascript()
{
my ($script) = @_;
# check for wwwrsc_scr ending
$script =~ s/(\"|\')([^\'\"]+?$wwwrsc_scr)\1/$1.&fix_url($2,1).$1/eiog if $wwwrsc_scr ;
# check for leftover http://abc.de/ef
$script =~ s/(\"|\')(http:\/\/[^\?\"\']+)\1/$1.&make_javascript2($2).$1/eiog if $wwwrsc_scr ;
return $script;
}
sub make_javascript2()
{
my ($script) = @_;
$script = &fix_url($script,1) if ($script !~ /$wwwrsc$/io) ;
return $script;
}
# check request for content_type and _length, redirect immediate if not convenient
# otherwise, collect packet
sub handle_request()
{
$result .= @_[0];
return if $R_Checked; # must be global
$res = @_[1]; # might be local
if(($res->content_type !~ /(text\/html|text\/plain|javascript)/)||($res->content_length > $Max))
{
print $query->redirect($url);
exit;
}
$R_Checked = 1;
}
$query = new CGI;
$url = $query->param('_url_') || $query->param('url');
$skill = int($query->param('_skill_')) || int($query->param('skill'));
$ISform = $query->param('_isform_');
$skill = 3 if $skill == 0;
$skill = 5 if $skill > 5;
$skill = 1 if $skill < 1;
$ourselves = $query->url();
if ($url =~ /^h?t?t?p?:?\/?\/?w?w?w?\.?$/)
{
print $query->header;
print $query->start_html(-title => "Error");
print "<h2>You did not specify an URL. '".$url."'</h2>";
print $query->end_html;
}
else
{
$url = "http://".$url if not $url =~ /^http:\/\//o;
$url = &deiterate_url($url);
$ua = new LWP::UserAgent;
$ua->agent($query->user_agent() ne "" ? $query->user_agent() : "beL33t!/0.1");
if (($query->request_method eq "POST") && ($ISform eq 'l33t'))
{
my @list1 = $query->param ;
my (@list2,$i) = 0;
foreach (@list1)
{
next if /^_(skill|url|isform)_$/o;
$list2[$i++] = "$_=" . $query->param($_) ;
}
$req = new HTTP::Request POST => $url;
$req->content(join('&', @list2)) ;
$req->content_type('application/x-www-form-urlencoded') ;
}
elsif (($query->request_method eq "GET") && ($ISform eq 'l33t'))
{
my $param = $ENV{'QUERY_STRING'};
$param =~ s/_(skill|url|isform)_.+?&|$//go;
$req = new HTTP::Request GET => "$url?$param" ;
}
else
{
$req = new HTTP::Request GET => $url;
}
$_ = &deiterate_url($query->referer());
$_ = $url if ($_ eq $ourselves);
$req->headers->header("Referer" => $_);
$res = $ua->request($req,\&handle_request);
$result = $res->content unless $result;
unless ($res->is_success || ($res->content_type eq 'text/html'))
{
print $query->header;
print $query->start_html(-title => "Error");
print "<p><b>Could not retrieve URL:</b> <i>".$res->error_as_HTML."</i></p>";
print $query->end_html;
}
else
{
# Only the server knows the real URL
$url = $res->base->as_string;
if ($res->content_type eq 'text/html')
{
# Translate HTML data
print $query->header;
$result =~ s/<\s*base\s+href.*?>//gio; # substitute or set base href
$result = "<base href=\"$url\">\n".$result ;
$result = "\n\n".$result ;
$overlongcomment = 0;
($result, @blocks) = split(/</, $result);
$result = &make_text_leet($result);
foreach $item (@blocks)
{
if (($item =~ /^!--/o) || $overlongcomment)
{
if ($item =~ /(.*)-->/so) # finds last -->
{
($comment, $trailing) = ($1,$'); # backref, postmatch
$result .= "<" .$comment."-->".&make_text_leet($trailing);
$overlongcomment = 0;
}
else
{
$overlongcomment = 1;
$result .= "<".$item;
}
}
elsif ($item =~ /(.*)>/so) # finds last >
{
($tag, $trailing) = ($1,$'); # backref, postmatch
$hidden_fields = "";
$result .= "<".&handle_tag($tag).">$hidden_fields".&make_text_leet($trailing);
}
else
{
$result .= "<$item";
}
}
# translate urls in script-section
$result =~ s/(<script.*?>)(.*?)(<\/script>)/$1.&make_javascript($2).$3/seiog if $wwwrsc_scr ;
print $result;
}
elsif ($res->content_type eq 'text/plain')
{
print "Content-Type: text/plain\n\n".&make_phrase_leet($result) ;
}
elsif ($res->content_type =~ /javascript/o) # extern js
{
print "Content-Type: ".$res->content_type."\n\n".&make_javascript($result) ;
}
else
{
# When we do not have our type of data we send a redirect to the real resource
print $query->redirect($url);
}
}
}

Raw Paste

#!/usr/bin/perl

# This program ist published under GPL
# Copyright  by Lennart Poettering, lennart@poettering.de
# With some important changes by Gerhard Blum, gerhard@smoking.de

# Maximum size of a page to l33t
$Max = 1000000; # set higher if you have enough RAM to use

# Send forms to l33t web?
$FORMon = 1 ; # leave undefined or set to 0 to cancel

use CGI;
use LWP::UserAgent;
use HTTP::Request;

# Translates a phrase from readable to l33t text. Ignores all special tags.
sub make_phrase_leet()
  {
    my ($s) = @_;

$s =~ s/s\b/Z/gio if $skill >= 5;

$s =~ tr/aAeEoO/443300/;

$s =~ tr/iItTbB/117788/ if $skill >= 2;

$s =~ tr/sSgG/5\$96/ if $skill >= 3;

$s =~ tr/lLz/||2/ if $skill >= 4;

$s =~ s/c/&lt;/gio if $skill >= 5;
    $s =~ s/K/\[&lt;/gio if $skill >= 5;
    $s =~ s/W/VV/gio if $skill >= 5;

return $s;
  }

# Translates a phrase from readable to l33t text. Handles umlauts and special characters.
sub make_text_leet()
  {
    my ($text) = @_;
    my ($result, @blocks) = split(/&/, $text);
    my ($item, $char, $trailing);

$result = &make_phrase_leet($result);

foreach $item (@blocks)
      {
        if ($item =~ /;/)
          {
            ($char, $trailing) = ($`,$');  # prematch, postmatch
            $result .= "&".$char.";".&make_phrase_leet($trailing);
          }
        else
          {
            $result .= "&" . &make_phrase_leet($item);
          }
      }
    
    return $result;
  }

# Fixes a given URL for is. Prepends hostname on relative URLs. Prepends the URL of this script for nto letting the user escape from our l33t web.
# Arguments are the url and a value that indicates if and how our script-address should be prepended or not.
sub fix_url()
  {
    my ($u, $v) = @_;
    my $b, $anchor = '';
    
    if ($u =~ /^http:/io || not ($u =~ /^(\w{1,10}):/o) )
      {
        if (not $u =~ /^http:/o) # same server
          {
            if ($u =~ /^\//o)  #Absolute, same server
              {
                $b = $url;
                $b =~ s/^(........*?)\/.*$/$1/o;
                $u = $b.$u;
              }
            else              #Relative, same server
              {
                $b = $url;
                $b =~ s/^(.*\/)(.*)$/$1/o unless ($u =~ /^#/o);

while ($u =~ s/^\.\.\///o)  # Evaluate ../
                  {          # and think of people pointing higher than document_root
                    $b =~ s/^(.*\/)(.*)\/$/$1/o if ($b =~ /(.*\/){4,}/o);
                  }
                $u = $b.$u;
              }
          }
        # move #anchor to ourselves; NOT MSIE (cuts parameters when #present)
        if($ENV{'HTTP_USER_AGENT'} !~ /MSIE/o)
          {
            $anchor = $2 if ($u =~ s/^(.*)(#[^\?]*)/$1/o) ;
          }
        if ($v>1)  #send forms to l33t web
          {
            $hidden_fields  = "\n<input type=\"hidden\" name=\"_skill_\" value=\"$skill\">";
            $hidden_fields .= "\n<input type=\"hidden\" name=\"_url_\" value=\"$u\">";
            $hidden_fields .= "\n<input type=\"hidden\" name=\"_isform_\" value=\"l33t\">\n";
            $u = $ourselves.$anchor ;
          }
        elsif ($v)
          {
            $u = $ourselves.$anchor."?_skill_=".$skill."&_url_=".$query->escape($u) ;
          }
      }
    
    return $u;
  }

# Translates each tag which needs it. 
sub handle_tag()
  {
    my ($tag) = @_;

# These need the script-address to be prepended (because they point to HTML-data)
    # a href | area href
    $tag =~ s/((a|area)(\s|\s.*\s)href\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($5,1).$6/seio;
    # frame src
    $tag =~ s/(frame(\s|\s.*\s)src\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,1).$5/seio;
    # script src
    $tag =~ s/(script(\s|\s.*\s)src\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,1).$5/seio if $wwwrsc_scr ;
    # meta refresh
    $tag =~ s/(meta(\s|\s.*\s)http-equiv\s*=\s*(\"|\')refresh\3.+?url=)(.*?)\3/$1.&fix_url($4,1).$3/seio;

# form action
    $tag =~ s/(form(\s|\s.*\s)action\s*=\s*(\"|\')?)(.*?)(\"|\'|\s|$)/$1.&fix_url($4,2).$5/seio if $FORMon;

# These need make_javascript() to prepend script-address
    # javascript: in href
    $tag =~ s/((a|area)(\s|\s.*\s)href\s*=\s*\"\s*javascript:[^\"]+?)(\'[^\n]+?\')(.*?\")/$1.&make_javascript($4).$5/seiog ;
    # javascript inside tag
    $tag =~ s/(.+?\son\w+\s*=\s*\"[^\"]+?)(\'.+?\')(.*?\")/$1.&make_javascript($2).$3/eiog ;
    # url in option tag
    $tag =~ s/(option(\s|\s.*\s)value\s*=\s*)((\"|\').+?\4)/$1.&make_javascript($3)/seio ;

# l33t alternate-text in img tag
    $tag =~ s/(img(\s|\s.*\s)alt\s*=\s*(\"|\'))(.*?)\3/$1.&make_text_leet($4).$3/seio;
    # l33t alternate-text in image map
    $tag =~ s/(area(\s|\s.*\s)alt\s*=\s*(\"|\'))(.*?)\3/$1.&make_text_leet($4).$3/seio;
    return $tag;
  }

# We do not want to be called recursively
sub deiterate_url()
  {
    my ($url) = @_;

$url =~ s/^$ourselves\?.*?_url_=(.*?)(&.*|$)/$query->unescape($1)/goe;

return $url;
  }

# Prepend script-url in javascript-code
sub make_javascript()
  {
    my ($script) = @_;

# check for wwwrsc_scr ending
    $script =~ s/(\"|\')([^\'\"]+?$wwwrsc_scr)\1/$1.&fix_url($2,1).$1/eiog if $wwwrsc_scr ;
    # check for leftover http://abc.de/ef
    $script =~ s/(\"|\')(http:\/\/[^\?\"\']+)\1/$1.&make_javascript2($2).$1/eiog if $wwwrsc_scr ;

return $script;
  }
sub make_javascript2()
  {
    my ($script) = @_;

$script = &fix_url($script,1) if ($script !~ /$wwwrsc$/io) ;

return $script;
  }

# check request for content_type and _length, redirect immediate if not convenient
# otherwise, collect packet
sub handle_request()
  {
    $result .= @_[0];
    return if $R_Checked; # must be global
    $res = @_[1]; # might be local
    if(($res->content_type !~ /(text\/html|text\/plain|javascript)/)||($res->content_length > $Max))
      {
        print $query->redirect($url);
        exit;
      }
    $R_Checked = 1;
  }

$query = new CGI;

$url = $query->param('_url_') || $query->param('url');
$skill = int($query->param('_skill_')) || int($query->param('skill'));
$ISform = $query->param('_isform_');

$skill = 3 if $skill == 0;
$skill = 5 if $skill > 5;
$skill = 1 if $skill < 1;

$ourselves = $query->url();

if ($url =~ /^h?t?t?p?:?\/?\/?w?w?w?\.?$/)
  {
    print $query->header;
    print $query->start_html(-title => "Error");
    print "<h2>You did not specify an URL. '".$url."'</h2>";
    print $query->end_html;
  }
else
  {
    $url = "http://".$url if not $url =~ /^http:\/\//o;

$url = &deiterate_url($url);

$ua = new LWP::UserAgent;
    $ua->agent($query->user_agent() ne "" ? $query->user_agent() : "beL33t!/0.1");

if (($query->request_method eq "POST") && ($ISform eq 'l33t'))
      {
        my @list1 = $query->param ;
        my (@list2,$i) = 0;
        foreach (@list1)
          {
            next if /^_(skill|url|isform)_$/o;
            $list2[$i++] =  "$_=" . $query->param($_) ;
          }
        $req = new HTTP::Request POST => $url;
        $req->content(join('&', @list2)) ;
        $req->content_type('application/x-www-form-urlencoded') ;
      }
    elsif (($query->request_method eq "GET") && ($ISform eq 'l33t'))
      {
        my $param = $ENV{'QUERY_STRING'};
        $param =~ s/_(skill|url|isform)_.+?&|$//go;
        $req = new HTTP::Request GET => "$url?$param" ;
      }
    else
      {
        $req = new HTTP::Request GET => $url;
      }

$_ = &deiterate_url($query->referer());
    $_ = $url if ($_ eq $ourselves);
    $req->headers->header("Referer" => $_);

$res = $ua->request($req,\&handle_request);
    $result = $res->content unless $result;

unless ($res->is_success || ($res->content_type  eq 'text/html'))
      {
        print $query->header;

print $query->start_html(-title => "Error");
        print "<p><b>Could not retrieve URL:</b> <i>".$res->error_as_HTML."</i></p>";
        print $query->end_html;
      }
    else
      {
        # Only the server knows the real URL
        $url = $res->base->as_string;

if ($res->content_type eq 'text/html')
          {
            # Translate HTML data
            print $query->header;

$result =~ s/<\s*base\s+href.*?>//gio; # substitute or set base href
            $result = "<base href=\"$url\">\n".$result ;

$result = "\n\n".$result ;

$overlongcomment = 0;
            ($result, @blocks) = split(/</, $result);
            $result = &make_text_leet($result);

foreach $item (@blocks)
              {
                if (($item =~ /^!--/o) || $overlongcomment)
                  {
                    if ($item =~ /(.*)-->/so) # finds last -->
                      {
                        ($comment, $trailing) = ($1,$');  # backref, postmatch
                        
                        $result .= "<" .$comment."-->".&make_text_leet($trailing);
                        $overlongcomment = 0;
                      }
                    else
                      {
                        $overlongcomment = 1;
                        $result .= "<".$item;
                      }
                  }
                elsif ($item =~ /(.*)>/so) # finds last >
                  {
                    ($tag, $trailing) = ($1,$');  # backref, postmatch
                    $hidden_fields = "";
                    $result .= "<".&handle_tag($tag).">$hidden_fields".&make_text_leet($trailing);
                  }
                else
                  {
                    $result .= "<$item";
                  }
              }

# translate urls in script-section
            $result =~ s/(<script.*?>)(.*?)(<\/script>)/$1.&make_javascript($2).$3/seiog if $wwwrsc_scr ;
            
            print $result;
          }
        elsif ($res->content_type eq 'text/plain')
          {
            print "Content-Type: text/plain\n\n".&make_phrase_leet($result) ;
          }
        elsif ($res->content_type =~ /javascript/o) # extern js 
          {
            print "Content-Type: ".$res->content_type."\n\n".&make_javascript($result) ;
          }
        else
          {
            # When we do not have our type of data we send a redirect to the real resource
            print $query->redirect($url);
          }
      }
  }