#!/usr/local/bin/perl -w
#
# No copyright (NC) 1997-98 by Andrey Chernov, Moscow, Russia.
# No rights reserved.
#
# windows-1251 -> koi8-r on-line browsing decoder v2.8
#
# Redistribution and use, with or without modification, are permitted
# if this notice not removed.
#

$decoder_host = "koi8.pp.ru";
$decoder_path = "/cgi-bin/w2k.cgi?";
#$fromcharset = "windows-1251";
$tocharset = "koi8-r";
$get_limit = 512 * 1024; # bytes

package Decoder;

require HTML::Parser;
use URI;
use URI::Escape;
use URI::WithBase;
@ISA = qw(HTML::Parser);

%link_elements =
(
 'a'    => 'href',
 'img'  => 'alt',
 'area' => 'href',
 'link' => 'href',
 'meta' => 'content',
 'form' => 'action',
 'frame' => 'src',
 'input' => 'value',
);

%bin_ext = map { $_ => 1 }
qw(gif jpeg jpg jpe jfif bmp xbm mpg mpe mpeg mid midi
   avi pdf zip lha arj ha tgz gz tar z au snd aif aiff aifc mp2 mp3 wav png
   tif tiff qt mov);

%isHeadElement = map { $_ => 1 }
qw(title base link meta isindex script style nextid);

%isGuestbook = map { $_ => 1 }
qw(www.lpage.com www.spin.de www.guestpage.com my.guestpage.com);

sub new
{
   my $class = shift;
   my %attr = @_;
   for (keys %attr) {
      if ($_ eq 'base') {
	 $base = $attr{$_};
      }
   }
   $gothead = 0;
   $gotbase = 0;
   $closehead = 0;
   $headtext = 0;
   my $self = $class->SUPER::new;
   $self;
}

sub addhead
{
   if (!$gothead) {
      print "<HEAD><BASE HREF=\"$base\"></HEAD>";
      $gothead = 1;
      $headtext = 0;
      $gotbase = 1;
      $closehead = 0;
   }
}

sub start
{
   my($self, $tag, $attr, $aseq, $orig) = @_;
   my $opt;
   if ($tag eq 'head') {
      $gothead = 1;
   } elsif ($tag eq 'base') {
      $gotbase = 1 if defined $attr->{'href'};
   } elsif ($tag eq 'meta') {
      return if defined $attr->{'charset'};
      $opt = $attr->{'http-equiv'};
      return if (defined $opt && lc($opt) eq 'content-type');
   } elsif ($tag eq 'title' || $tag eq 'script' || $tag eq 'style') {
      $headtext = 1;
   }
   if (!$gothead && $tag ne 'html') {
      if ($isHeadElement{$tag}) {
	 print "<HEAD>";
	 $gothead = 1;
	 $closehead = 1;
      } else {
	 addhead();
      }
   } elsif ($closehead && !$isHeadElement{$tag}) {
      $self->end('head');
   }
   my $expect = $link_elements{$tag};
   my $val = $attr->{$expect} if defined $expect;
   if (!defined $expect || !defined $val) {
      print $orig;
      return;
   }
   if ($tag eq 'img' || $tag eq 'input' || $tag eq 'meta') {
      $attr->{$expect} = main::out($val);
      goto PIT;
   } elsif ($tag eq 'form') {
      $opt = $attr->{'method'};
      if (!defined $opt || lc($opt) ne 'get') {
	 print $orig;
	 return;
      }
   }
   my $hurl = URI->new($val);
   if (!  defined $hurl->scheme
	|| $hurl->scheme eq "http"
	|| $hurl->scheme eq "ftp"
      ) {
      $hurl = URI::WithBase->new($val, $base);
      my $lhost = lc($hurl->host);
      if ((!  defined $hurl->scheme
	    || (   $hurl->port eq $main::url->port
		&& $lhost eq $main::host
		|| $isGuestbook{$lhost}
	       )
	  )
	 && !($hurl->abs->as_string =~ /^$main::qdecoder/)
	 && !($val =~ /\.([a-zA-Z]{1,4})$/ && $bin_ext{lc($1)})
      ) {
	 my $rurl = $main::decoder_cgi . uri_escape($hurl->abs->as_string, "=+");
	 $attr->{$expect} = $rurl;
PIT:
	 print "<" . uc($tag);
	 for (@$aseq) {
	   print " " . uc($_) . "=\"$attr->{$_}\"";
	 }
	 print ">";
      } else {
	 goto XIT;
      }
   } else {
XIT:
      print $orig;
   }
}

sub end
{
   my ($self, $tag) = @_;
   if ($tag eq 'head') {
      $closehead = 0;
      $headtext = 0;
      if (!$gotbase) {
	 print "<BASE HREF=\"$base\">";
	 $gotbase = 1;
      }
   } elsif ($tag eq 'title' || $tag eq 'script' || $tag eq 'style') {
      $headtext = 0;
   }
   print "</" . uc($tag) . ">";
}

sub declaration
{
   my ($self, $decl) = @_;
   print "<!$decl>";
}

sub text
{
   my ($self, $text) = @_;
   if (!$gothead && $text =~ /\S/o) {
      addhead();
   } elsif (!$headtext && $closehead) {
      $self->end('head');
   }
   print main::out($text);
}

sub comment
{
   my ($self, $text) = @_;
   print "<!--" . main::out($text) . "-->";
}

###########################################################################

package main;

use URI;
use LWP::UserAgent;

$tfile = "/tmp/koi$$" . time;

if ($#ARGV>-1) {
   $surl=$ARGV[0];
} else {
   $CONTENT_LENGTH = $ENV{'CONTENT_LENGTH'};
   if (!defined $CONTENT_LENGTH) {
      print "Status: 411 Length Required\n";
      print "Content-Type: text/html\n\n";
      print "<P>Passed FORM lacks of CONTENT_LENGTH!\n";
      exit 0;
   }
   if ($CONTENT_LENGTH < 1 || $CONTENT_LENGTH > 512) {
      print "Status: 400 Bad Request\n";
      print "Content-Type: text/html\n\n";
      print "<P>Passed FORM CONTENT_LENGTH outside 1..512 range!\n";
      exit 0;
   }
   read(STDIN, $buffer, $CONTENT_LENGTH);
   @pairs = split(/&/, $buffer);
   foreach $pair (@pairs) {
      ($name, $value) = split(/=/, $pair);
      $value =~ tr/+/ /;
      $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
      $value =~ s/\0//g;
      $FORM{$name} = $value;
   }
   $surl = $FORM{'url'};        # for <FORM> interface, name 'url'
   $ENV{'REQUEST_METHOD'} = "GET"
	if $ENV{'REQUEST_METHOD'} eq "POST";
}
if (!defined $surl || !($surl =~ /\S/o)) {
   print "Status: 204 No responce\n";
   print "Content-Type: text/html\n\n";
   print "<P>No start URL!\n";
   exit 0;
}

$surl =~ tr/\\//d;      # Netscape add it for unknown reason
$URI::mark .= "|";               # Hack to help counters
$URI::unreserved .= "\xC0-\xFF"; # Hack for Russian letters

$url = URI->new($surl);

if (! defined $url->scheme) {
   my $prf = ($surl =~ /^ftp\./o) ? "ftp://" : "http://";
   $url = URI->new($prf . $surl);
}
if (! defined $url->scheme) {
   print "Status: 400 Bad Request\n";
   print "Content-Type: text/html\n\n";
   print "<P>Start URL $surl lacks a scheme!\n";
   exit 0;
}
if (! defined $url->host) {
   print "Status: 400 Bad Request\n";
   print "Content-Type: text/html\n\n";
   print "<P>Start URL $surl lacks a host!\n";
   exit 0;
}
if ($url->scheme ne 'ftp' && $url->scheme ne 'http') {
   print "Status: 400 Bad Request\n";
   print "Content-Type: text/html\n\n";
   print "<P>" . $url->scheme . " scheme not supported.\n";
   exit 0;
}

$HTTP_USER_AGENT = $ENV{'HTTP_USER_AGENT'};

if (defined($HTTP_USER_AGENT) &&
($HTTP_USER_AGENT =~ /^Teleport/o ||
 $HTTP_USER_AGENT =~ /^Yandex/o ||
 $HTTP_USER_AGENT =~ /^LECodeChecker/o
)
) {
   print "Status: 403 Forbidden\n";
   print "Content-Type: text/html\n\n";
   print "<P>" . $HTTP_USER_AGENT . " browser is not allowed due to its abuse of /robots.txt\n";
   exit 0;
}

$host = lc($url->host);

$ua = new LWP::UserAgent;

# Env needed for ftp module negotiation
# text/html must present and have priority over */*
if (! defined $ENV{'HTTP_ACCEPT'} || ! ($ENV{'HTTP_ACCEPT'} =~ /\S/o)) {
   $ENV{'HTTP_ACCEPT'} = "text/html, */*;q=0.001";
} else {
   if ($url->scheme eq 'ftp') {
      if (! ($ENV{'HTTP_ACCEPT'} =~ /text\/html/io)) {
	 $ENV{'HTTP_ACCEPT'} = "text/html, " . $ENV{'HTTP_ACCEPT'};
      }
      if (! ($ENV{'HTTP_ACCEPT'} =~ /\*\/\*\s*;\s*q\s*=\s*\d\.?\d{0,3}/io)) {
	 $ENV{'HTTP_ACCEPT'} =~ s/\*\/\*/$&;q=0.001/;
      }
   }
}
if (! defined $ENV{'HTTP_ACCEPT_LANGUAGE'} || ! ($ENV{'HTTP_ACCEPT_LANGUAGE'} =~ /\S/o)) {
   $ENV{'HTTP_ACCEPT_LANGUAGE'} = "ru, en";
}

# Right way, but not work sometimes due to broken servers setup
#
#$ENV{'HTTP_ACCEPT_CHARSET'} = "$tocharset, $fromcharset;q=0.5, iso-8859-1;q=0.001";
#$HTTP_USER_AGENT = "KOI8-only/2.0" if !defined($HTTP_USER_AGENT);

# Alternative way
#
# Disalbed, can cause double encoding
#$ENV{'HTTP_ACCEPT_CHARSET'} = "$fromcharset, iso-8859-1;q=0.001";
if (! defined $HTTP_USER_AGENT || $HTTP_USER_AGENT =~ /Lynx/o) {
   $HTTP_USER_AGENT = "Mozilla/4.04 [en] (Win95; I)";
} else {
   $HTTP_USER_AGENT =~ s/X11/Win95/;
}

$ua->agent($HTTP_USER_AGENT);

$HTTP_REFERER = $ENV{'HTTP_REFERER'};
$HTTP_FORWARDED = $ENV{'HTTP_FORWARDED'};
$ua->max_size($get_limit);

$REQUEST_METHOD = $ENV{'REQUEST_METHOD'};
# For command-line interface
$REQUEST_METHOD = "GET"
   if ! defined $REQUEST_METHOD;
if ($REQUEST_METHOD ne "GET" && $REQUEST_METHOD ne "HEAD") {
   print "Status: 400 Bad Request\n";
   print "Content-Type: text/html\n\n";
   print "<P>Wrong method $REQUEST_METHOD, only GET and HEAD are implemented.\n";
   exit 0;
}

$req = new HTTP::Request $REQUEST_METHOD => $url;
$req->header('Accept' => $ENV{'HTTP_ACCEPT'});
$req->header('Accept-Language' => $ENV{'HTTP_ACCEPT_LANGUAGE'});
# Disalbed, can cause double encoding
#$req->header('Accept-Charset' => $ENV{'HTTP_ACCEPT_CHARSET'});
$req->header('Forwarded' => $HTTP_FORWARDED)
	if defined $HTTP_FORWARDED;

$HTTP_HOST = $ENV{'HTTP_HOST'};
if (defined $HTTP_HOST) {
	$decoder_host = $HTTP_HOST;
}
$decoder_cgi = "http://$decoder_host$decoder_path";
$qdecoder = quotemeta($decoder_cgi);
$qdecoder_host = quotemeta($decoder_host);
if ($HTTP_REFERER) {
   if (!($HTTP_REFERER =~ /$qdecoder_host\//i)) {
      print "Status: 400 Bad Request\n";
      print "Content-Type: text/html\n\n";
      print "<P>Please don't link this script! Just grab sources and run it from your site instead.\n";
      exit 0;
   }
   $HTTP_REFERER =~ s/[^?]*\?//o;
   $req->header('Referer' => $HTTP_REFERER);
}

sub handler {
   my($sig) = @_;
   unlink $tfile;
   die "win2koi: catching signal $sig\n";
};

$SIG{__DIE__} = \&handler;
$SIG{'INT'} = \&handler;
$SIG{'QUIT'} = \&handler;
$SIG{'TERM'} = \&handler;
$SIG{'HUP'} = \&handler;

$res = $ua->request($req, $tfile);

if (! $res->is_success) {
   print "Status: " . $res->status_line() . "\n";
   print "Content-Type: text/html\n\n";
   print $res->error_as_HTML();
   exit 0;
}

# invalid ones
$res->remove_header("Title");
$res->remove_header("Client-Date");
# valid ones
$res->remove_header("Link");
$res->remove_header("Connection");
$res->remove_header("Content-Length");
$res->remove_header("Accept-Ranges");


if (! open (BODY, $tfile)) {
   print "Status: 500 Internal Server Error\n";
   print "Content-Type: text/html\n\n";
   print "<P>Can't open $tfile\n";
   exit 0;
}

$dodecode = 1;
@cta = $res->header("Content-Type");
$ctfull = $cta[1];
$ctfull = $cta[0] if ! defined $ctfull;
$ctp = lc($res->content_type);
$textmode = ($ctp eq 'text/plain') ? 1 : 0;
$htmlmode = ($ctp eq 'text/html') ? 1 : 0;

if ($textmode || $htmlmode) {
#
# Some broke servers send KOI8-R charset while the page really in
# windows-1251, so ignore charset comes from the server.
# If you want to browse KOI8-R page, just don't use this decoder.
#
#   if ($ctfull =~ /;\s*charset\s*=\s*['"]?([^\s'";]+)/io) {
#      $dodecode = 0 if (lc($1) ne lc($fromcharset));
#   }
} else {
   $dodecode = 0;
}

if ($dodecode) {
#   $qfrom = quotemeta($fromcharset);
#   $ctfull =~ s/;\s*charset\s*=\s*['"]?$qfrom['"]?//gio;
   $ctfull =~ s/;\s*charset\s*=\s*"?[^" ]*"?//gio;
   $ctfull =~ s/\s*;\s*$//;
   $ctfull .= "; charset=$tocharset";
}
#needed in any case due to duplication bug
$res->header("Content-Type" => $ctfull);

if (!$dodecode && !$htmlmode) {
   print_headers();
   while (<BODY>) {
	print $_;
   }
   close BODY;
   unlink $tfile;
   exit 0;
}

print_headers();

if ($textmode) {
   while (<BODY>) {
      print out($_);
   }
} else {
   $h = new Decoder ('base' => $res->base);
   $h->parse_file(\*BODY);
}

close BODY;
unlink $tfile;

exit 0;

sub print_headers
{
   print "Status: " . $res->status_line() . "\n";
   $_ = $res->headers_as_string();
   s/\n\s+/ /sg;        # some HTTPDs not understand multi-lined headers
   print;
   print "\n";
}

sub out
{
   $_ = shift;
   if ($dodecode) {
tr/\200-\377/\xFF\xE7\x2C\xC7\x2C\x2E\x2B\x2B\x23\x25\xEC\x3C\xEE\xEB\x68\xE3\x68\x60\x27\x22\x22\x95\x2D\x2D\x23\xD4\xCC\x3E\xCE\xCB\x68\xC3\x9A\xF5\xD5\x4A\x24\xE7\x7C\x24\xB3\xBF\xE5\x22\x5E\x2D\x52\x49\x9C\x2B\x49\x69\xC7\x6D\xD0\x9E\xA3\x4E\xC5\x22\x6A\x53\x73\x69\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1/;
   }
   $_;
}

