#!/usr/bin/perl
# 755
use strict;
use LWP::Simple;
use URI::URL;
#
#
# ni v redu - definira globalne spremenljivke...
#
# pobere podatke z neta
my %urlquery = ();
my $query = $ENV{'QUERY_STRING'};
my @pairs = split (/&/, $query);
foreach my $pair (@pairs) {
(my $key, my $value) = split(/=/, $pair);
$key =~ tr/+/ /;
$key =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
if ($urlquery{$key}){
$urlquery{$key} .= ", $value";
}
else{
$urlquery{$key} = $value;
}
}
$query = "";
@pairs = ();
# url strani
my $url = $urlquery{'url'};
# spremenljivke
# pot do tega skripta
my $pot="http://www.jaka.org/2003/pretipkovalec/p2.cgi";
# pot do javascripta
my $potjs="http://www.jaka.org/2003/pretipkovalec/css-js/typescape3.js";
# preveri URL, če je nepravilen to javi in neha, če ne, da / na konec url-ja ce / tam ni
&preveriurl;
# najde domeno
my $domena = $url;
$domena =~ s!(http://*[^/]+/)([^'"]*)!$1!gi;
# odstrani vse za zadnjim / v url-ju
my $domenamapa = $url;
$domenamapa =~ s!(.+?)([^/]*)$!$1!i;
my $cssurl = "";
# program razbije kodo na tag-e in vsebine in jih po vrsti zloi v array-e:
my @virvse = ();
my @virglava = ();
my @virtelo = ();
# tevilo vseh spanov v body-ju: uporablja jih javascript, da prepise vsebine
my $spanivsi = 0;
#####
print "Content-type: text/html\n\n";
&razdelikodovarray;
&preveriframe;
&lociglavatelo;
&popravinaslove;
&ospani;
&dodajjavascript;
&popraviglavocss;
&popraviglavo;
&izpisi;
exit;
#####
sub razdelikodovarray{
my $zadeva = get($url); # vzame stran
#print "
\n";
#exit;
}
# poravi url naslove: a, img, ... - v body-ju
sub popravinaslove{
my $zadaj = "";
my $naslov = "";
foreach my $vrstica (@virtelo) {
if ($vrstica =~ /^){
# popravi 'a', razen če je 'mailto' ('name' - tega ne preverja!)
if ($vrstica =~ /^<\s*a/is && $vrstica =~ /href\s*=/is){
$vrstica =~ s/(^.+?href\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$zadaj=$3;
if ($naslov !~ /^mailto:/){
$naslov = URI->new_abs($naslov, $url);
$naslov = $pot."?url=".$naslov;
}
$vrstica=$vrstica.$naslov.$zadaj;
}
# 'img'
elsif ($vrstica =~ /^<\s*img/is && $vrstica =~ /src\s*=/is){
$vrstica =~ s/(^.+?src\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
# 'body, table, tr, td'
elsif ($vrstica =~ /^<\s*tr/i && $vrstica =~ /background\s*=/is){
$vrstica =~ s/(^.+?background\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*td/i && $vrstica =~ /background\s*=/is){
$vrstica =~ s/(^.+?background\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*table/i && $vrstica =~ /background\s*=/is){
$vrstica =~ s/(^.+?background\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*input/is && $vrstica =~ /src\s*=/is){
$vrstica =~ s/(^.+?src\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*body/i && $vrstica =~ /background\s*=/is){
$vrstica =~ s/(^.+?background\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*embed/is && $vrstica =~ /src\s*=/is){
$vrstica =~ s/(^.+?src\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
elsif ($vrstica =~ /^<\s*param/is && $vrstica =~ /movie/i && $vrstica =~ /\.swf/i){
$vrstica =~ s/(^.+?value\s*=\s*["|']?)([^\s|"|']*)([\s|"|']*.*)/$1/is;
$naslov=$2;
$naslov = URI->new_abs($naslov, $url);
$vrstica=$vrstica.$naslov.$3;
}
}
}
}
# doda spane okrog vsake crke v 'body'-ju (razen ce je vrstica sestavljena zgolj iz \n,\t in ' '
sub ospani{
my $sprememba = "";
my $zacasno = "";
foreach my $vrstica (@virtelo) {
if ($vrstica !~ /^){
my $vrsticadolgaznakov = length($vrstica);
my $novavrstica = "";
my $prememba = "ne";
my $zacasnocrka = "";
my $spremenimvrstico = "ne";
for (my $ii=0; $ii < $vrsticadolgaznakov; ++$ii){
$zacasnocrka = substr($vrstica, $ii, 1);
if ($zacasnocrka ne "\n" && $zacasnocrka ne "\t" && $zacasnocrka ne " "){
$spremenimvrstico = "da";
}
}
if ($spremenimvrstico eq "da"){
for (my $ii=0; $ii < $vrsticadolgaznakov; ++$ii){
$zacasnocrka = substr($vrstica, $ii, 1);
if ($zacasnocrka eq "&"){
$zacasno=substr($vrstica, $ii, ($vrsticadolgaznakov-$ii));
$zacasno =~ s/(&.*?;)(.*)/$1/i;
# preveri ali gre res za entiteto (imensko in/ali tevilčno)
if ($zacasno =~ /&[a-zA-Z0-9]+\;/ || $zacasno =~ /[0-9]+\;/ || $zacasno =~ /[0-9a-zA-Z]+\;/) {
$zacasnocrka = $zacasno;
$ii = $ii+length($zacasno)-1;
}
}
if ($zacasnocrka ne "\n"){
$novavrstica .= "".$zacasnocrka."";
$spanivsi = $spanivsi + 1;
$sprememba = "da";
}
}
if ($sprememba ne "ne"){$vrstica = $novavrstica; $novavrstica = ""; $prememba = "ne";}
}
}
}
}
# doda java script za pretipkavanje vsebine (najprej doda povezavo na js. datoteko, nato popravi 'onload')
sub dodajjavascript{
my @novvirglava = ();
my $zacasno = "";
# preveri ali obstaja - če ne, zadeva ne dela, torej popravi
my $konechead = "ne";
foreach my $vrstica (@virglava) {
if ($vrstica =~ /<\s*\/head\s*>/is) {$konechead = "da";}
}
if ($konechead ne "da") {
push (@virglava, "\n");
}
foreach my $vrstica (@virglava) {
if ($vrstica !~ /<\s*\/head\s*>/is) {push (@novvirglava, $vrstica);}
else {
push (@novvirglava, "\n");
push (@novvirglava, "\n");
}
}
@virglava = @novvirglava;
@novvirglava = ();
$zacasno = $virtelo[0];
if ($zacasno =~ /onload\s*=\s*/is) {
$zacasno =~ s/(.+?onload\s*=\s*['|"]*)([^'"\s>]+?)(['"\s>].*)//is;
$zacasno = $1."jt3preveri(".$spanivsi."); ".$2.$3;
}
elsif ($zacasno =~ /<\s*body\s*/is){
$zacasno =~ s/(<\s*body[^>]*)(>)//is;
$zacasno = $1." onload=\"jt3preveri(".$spanivsi.")\"".$2;
}
$virtelo[0] = $zacasno;
}
# uvozi @import css
sub popraviglavocss{
my @novvirglava = ();
foreach my $vrstica (@virglava) {
if ($vrstica =~ /<\s*style/ && $vrstica !~ /href\s*=/){
my $popravicss = 1;
my $cssnov = "";
while ($popravicss == 1){
if ($vrstica !~ /\@import/i){
$cssnov .= $vrstica;
$popravicss = 0;
}
else{
#izluči @import, do vključno ;
$vrstica =~ /(.*?)(\@import[^;]*;+)(.*)/ism; #$1: ([^\@import]*)
$cssnov .= $1;
$vrstica = $3;
$2 =~ /(\@import[^"|'|\(]+?["|'|\(])([^"|'|\)]*)(.+)/ism; # izluči URL
my $sredina2 = $2;
# css pobere samo če je media type ustrezen
if ($3 !~ /[a-zA-Z]/ || $3 =~ /all/i || $3 =~ /screen/i){
$cssurl = URI::URL->new($sredina2, $url);
$cssurl = $cssurl->abs();
$sredina2 = get($cssurl);
}
else {
$sredina2 = "\n";
}
$cssnov .= $sredina2;
}
}
$vrstica = $cssnov;
}
push (@novvirglava, $vrstica);
} # konec foreach
@virglava = @novvirglava;
@novvirglava = ();
}
# popravi URL-je v 'glavi'
sub popraviglavo{
my @novvirglava = ();
my $zacasno = "";
my $zadaj ="";
foreach my $vrstica (@virglava) {
$zacasno = "";
#popravi link rel URL-je
if ($vrstica =~ /<\s*link\s*rel\s*=/i && $vrstica =~ /href\s*=/i){
$vrstica =~ s/(.+?href\s*=\s*["|'|\s]?)([^"|'|\s]+)(.*)/$1/i;
$zacasno = $2;
$zadaj = $3;
if ($zacasno !~ /^http:\/\//){
if ($zacasno =~ /^\//){
$zacasno =~ s/^\///;
$zacasno = $url.$zacasno;
}
elsif ($zacasno =~ /^\.\//){
$zacasno =~ s/^\.\///;
$zacasno = $domenamapa.$zacasno;
}
else{
$zacasno =~ s/^\///;
$zacasno = $domenamapa.$zacasno;
}
}
$zacasno = $vrstica.$zacasno.$zadaj;
}
elsif ($vrstica =~ /<\s*style/ && $vrstica !~ /href\s*=/){
my $popravicss = 1;
my $cssvse = "";
while ($popravicss == 1){
if ($vrstica =~ /url\s*\(/){
$vrstica =~ s/(url\s*?\([\s|"|']*)(.+?[^\s|"|'|\)]*)(.*)/$1/ism;
$cssurl = URI::URL->new($2, $url); # $2 je url, ki ga je treba popravit
$cssurl = $cssurl->abs();
$cssvse .= $vrstica.$cssurl; # sem gre del pred 'url' (.) in popravljen URL
$vrstica = $3; # sem gre kar sledi (vmes je morda e kak url za popravit)
}
else {
$popravicss = 0; # če ni več URL-jev v kodi, nehaj...?
$cssvse .= $vrstica; # preostanek kode za zadnjim url-jem
}
}
$zacasno = $cssvse; # kar je v $zacasno, gre v novo glavo...
}
if ($zacasno ne ""){
push (@novvirglava, $zacasno);
}
else {
push (@novvirglava, $vrstica);
}
}
@virglava = @novvirglava;
@novvirglava = ();
}
# izpise kodo
sub izpisi{
# preveri ali stran obstaja, če ne, opozori in konča, če da, jo izpie.
if (@virglava + @virtelo == 4 && $virglava[1] =~ /^