#!/usr/bin/perl
#getmailwp.pl 
# ---------------------------------------------------------------
# WAP Getmail
# A WAP based POP email client
# Copyright (C) 2003  Dmitry Gavrilenko <mitjok@starline.ee>
# Licensed under terms of GNU General Public License
# ---------------------------------------------------------------
# v 0.1 15/01/2003
# ---------------------------------------------------------------

use strict;

use Net::POP3;

#== Define Variables =====================================================
my $loginDir="../temp/";   #Directory for temporary files
my $baseUrl="http://carbon.nu/wap/getmail.wml";   #Base URL for getmail.wml
my $cgiName="getmailwp.cgi";           #Script name
my $maxsizemsg=1024*2;                 #Max size of message (Default 2kb)
#=========================================================================

my $endstr="</p></card></wml>";

my @required = ('s','n');
my %FORM;

my $startHd=0;

my $buffer;

if ($ENV{'QUERY_STRING'} ne '') {
   $buffer = "$ENV{'QUERY_STRING'}";}
   
else {
   read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
  }
   
my @pairs;
my $pair;
my $name;
my $value;

   @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;
        $FORM{$name} = $value;
 }



#print wap header
print "Content-type:text/vnd.wap.wml \n\n\n";
print "<?xml version=\"1.0\"?>
<!DOCTYPE wml PUBLIC \"-//WAPFORUM//DTD WML 1.1//EN\" \"http://www.wapforum.org/DTD/wml_1.1.xml\">
<wml>";



my $rdmsgn;
my $loginfst;#login first time
my $cencod=0;#Encoding 1-WIN1251 2-KOI8R 3-UTF8

if($FORM{'c'}){#Read mail after login
	
 $loginfst=0;	
 
 $FORM{'v'}=substr($FORM{'v'},0,5); #Text limit 
 
 $FORM{'c'}=substr($FORM{'c'},0,7); #Text limit (Identificator max 6 chars)
 if(!($FORM{'c'}=~/^[0-9A-F]{6}$/)){
 &printwml("Incorrect parameter! $endstr");
  exit;       	
}

#--Show page for encoding---
if($FORM{'en'}){
 print "<card id=\"cr\" title=\"Encoding\">
      <p>
         <select name=\"e\" title=\"Encoding:\">
            <option value=\"1\" onpick=\"$cgiName?v=\$(v)&amp;c=\$(c)&amp;e=\$(e)\">WIN1251</option>
            <option value=\"2\" onpick=\"$cgiName?v=\$(v)&amp;c=\$(c)&amp;e=\$(e)\">KOI8-R</option>
            <option value=\"3\" onpick=\"$cgiName?v=\$(v)&amp;c=\$(c)&amp;e=\$(e)\">UTF-8</option>
         </select> 
     $endstr";
     exit;	
}	


my $str = "$FORM{'c'}";

#Number for first header
 $FORM{'h'}=substr($FORM{'h'},0,5); #Text limit 
 if ($FORM{'h'} ne '') {$startHd=$FORM{'h'}};
 
#Encoding  
if($FORM{'e'}>=1 && $FORM{'e'}<=3){
  $cencod=$FORM{'e'};
}


($maxsizemsg,$FORM{'s'},$FORM{'n'},$FORM{'p'}) = &chlogin($str);
 
 #Log Off
 if(($FORM{'v'} eq 'l') && ($FORM{'s'} ne '')){
 	 unlink "$loginDir$str";
 	 print "<card id=\"cr\" title=\"MAIL\" newcontext=\"true\">
 	 <p>You is disconnected.<br/><a href=\"$baseUrl\">[log In]</a>
         $endstr";
         exit;       
 	}
 
 
 chop($FORM{'p'}) if $FORM{'p'} =~ /\n$/; 
 
 $rdmsgn=$FORM{'v'};
}
else{#Login first time
 &chlogin;
 $loginfst=1;
 $rdmsgn=0;
} 

#print "Server: $FORM{'s'}<br/>";
#print "User: $FORM{'n'}<br/>";
#print "Password: $FORM{'p'}<br/>";
#print "Log: $loginfst<br/>";

my $check;

foreach $check(@required) {
          unless ($FORM{$check}) {
          &printwml ("Please relogin!.<br/><a href=\"$baseUrl\">[log In]</a>$endstr",1);
          exit;          
         }
 }
 

$FORM{'s'}=substr($FORM{'s'},0,20); #Text limit 
$FORM{'n'}=substr($FORM{'n'},0,20); #Text limit 

unless ($FORM{'p'}){#Input password
 
 &printwml("",1);
 print "Password :<input type=\"password\" name=\"p\"/>
    <anchor>
    Enter <go href=\"$cgiName\" method=\"post\">
    <postfield name=\"s\" value=\"$FORM{'s'}\"/>
    <postfield name=\"n\" value=\"$FORM{'n'}\"/>
    <postfield name=\"p\" value=\"\$(p)\"/>
    </go>
    </anchor>
    $endstr";
    exit;
}	
 
 
$FORM{'p'}=substr($FORM{'p'},0,20); #Text limit 
  

my $server_name = $FORM{'s'};
my $user_name = $FORM{'n'};
my $user_pass = $FORM{'p'};

#Connecting to server
my $pop3 = Net::POP3->new($server_name, Timeout => 60) || &errexit("Cannot create connection");
$pop3->login($user_name, $user_pass) or &errexit("Auth failed");

my $msgs = $pop3->list;

if((keys %$msgs)==0){
   &errexit("Mailbox is empty");  
}


my $test_passwd = $FORM{'c'};

if($loginfst == 1){#if first time login
  
  #Get max size of message 
   if($FORM{'sz'}=~/^[0-9]{1,}$/){
   	 $maxsizemsg=$FORM{'sz'}*1024;
   }	

   
   $test_passwd =&wrlog($maxsizemsg,$FORM{'s'},$FORM{'n'},$FORM{'p'});
   print "<card newcontext=\"true\">
  <onevent type=\"ontimer\">
  <go href=\"$cgiName?v=0\&amp;c=$test_passwd\" method=\"post\">
  <setvar name=\"c\" value=\"$test_passwd\"/>
  </go>
  </onevent>
<timer value=\"1\"/>
<p>
Loading...
</p>
</card>
</wml>";
 
 $pop3->quit; 
 
 exit;
}

if($rdmsgn == 0){#Read mail headers
 
 if($startHd > 0){
   &printwml;
 }	
 else{
   &printwml("",1);
 }
 
 my $i=0;
 my $endNmbM=$startHd+3;#show 3 messages on screen
 
 
 # Sort messages by date
 my %HdrMsg; #Hash of headers
 my @RdHdr;
  
 foreach (keys %$msgs){
  @RdHdr=&read_mail ($_);
  @RdHdr[4]=$_;
  #$HdrMsg{$RdHdr[0]}=join '||',$RdHdr[1],$RdHdr[2],$RdHdr[3],$_;
  @{$HdrMsg{$RdHdr[0]}}=@RdHdr; 
 }
 
my @srtmsgs = sort { $b cmp $a } keys %HdrMsg;  
 
#---------------------- 
foreach (@srtmsgs){
  
  if($i>=$startHd){
    if($i>=$endNmbM) {last;}
    #@RdHdr = split (/\|\|/,$HdrMsg{$_});
    @RdHdr = @{ $HdrMsg{$_} };
    print "$RdHdr[1]";
    print "$RdHdr[2]";
    print "$RdHdr[3]";
    print "<a href=\"$cgiName?v=$RdHdr[4]\&amp;c=\$(c)\">[SHOW]</a><br/><br/>";   
  }
  $i++;  
 }
 if($i< scalar @srtmsgs){
 	print "<a href=\"$cgiName?h=$endNmbM\&amp;c=\$(c)\">[Next]</a><br/>";
 }	
}

else{#Read mail body
  
  #&printwml;
  print "<card id=\"cr\" title=\"MAIL\">
  <do type=\"prev\" label=\"back\"><prev/></do>
  <do type=\"accept\" label=\"Encoding\" name=\"Enc\">
      <go href=\"$cgiName?en=1\&amp;c=\$(c)\">
       <setvar name=\"v\" value=\"$rdmsgn\"/>
      </go>
  </do>
  <p>"; 
  
  &read_mail ($rdmsgn);
}

print "<a href=\"$cgiName?v=l\&amp;c=\$(c)\">[Log Off]</a><br/>";

print "$endstr";
$pop3->quit; 


sub errexit{
 my $str = shift;
 
 &printwml("$str $endstr");
 
 exit;
 
}

#=====================================================
sub read_mail{
   
   my $id = shift; 
  
   my $line;
   my $msg; 
   my $txml = 0; #message body is
   my $str;
   my $pltx=0; #plane text is
   my $dqp=0;  #quoted-printable is
   my $multp=0;#multipart message is
   my $multhd; #multipart header
   
   my $TimeCr;
   my $Dt;
   my $Subj;
   my $From;
   
   if($rdmsgn==0)
   {
    $msg = $pop3->top($id);
   }
   else
   { 
    $msg = $pop3->top($id,100);
   } 
  
  foreach  $line(@$msg){ 
   
   
   if( !($line =~/\w+/)){#End of Header
      #$txml=1;	
      last;          
   }
   
   if($rdmsgn > 0 ) {#Read body
   	if($line=~/Content-Type\: multipart/){#check for multipart
   	  $multp=1;
   	}
   	if($multp=1 && $line=~/boundary\=\"(.*)\"/){
   	  $multhd=$1;	
   	}	
   	
   	next;}#goto read body
   
   if($line=~s/From: (.*)/$1/){
     	if($line=~/(.*)<(.*)>/){
        $str=&CheckDecode($1)."<br/>$2";    
       }
       else{
        $str=$line;
       }
       	
   	$From = "From: $str<br/>";
   }
   elsif($line=~/Date: (.*)/){
   	#Wed, 18 Dec 2002 11:19:17 +0200
   	$str=$1;
   	$TimeCr=&TimeMailDate($str);
   	$str=~/(\w*,)(.*)(\d\d):(\d\d):(\d\d)(.*)/;
   	$Dt = "$2$3:$4<br/>";  	
   }
   elsif($line=~/Subject: (.*)/){
   	$str=&CheckDecode($1);
   	$Subj = "Subj: $str<br/>";
   }             	     
  }
  
  if($rdmsgn==0){#Print Header
  	   
   #print $Dt;
   #print $From;
   #print $Subj;
   
   my @retHdr;
   
   $retHdr[0]=$TimeCr;
   $retHdr[1]=$Dt;
   $retHdr[2]=$From;
   $retHdr[3]=$Subj;
         
  return @retHdr;
 }

#-------body of message  ------------ 
   
   my $tss=0; #Header plane/text found
   my $sizemsg=0; #Size of Message
   my $prline;
   
   foreach  $line(@$msg){
     if($line =~ m/text\/plain\;/g){
     $tss=1; 
     last;} 	  
  }
  
  if($tss==0) {$pltx=1;} #If plane text have not
      
   foreach  $line(@$msg){
   
   if($txml==1){          
     
     if($multhd ne ''){ #clear header for multipart
      $line =~ s/$multhd//;}
     	
     
     if($line =~/Content\-Type\:/){#End of plain text
       last;}
     
     if($dqp==1){#Quoted printable
     	$line=MIMEDecodeQP($line);
     }	
     
     if($pltx==2){#koi-8r
     	$line=koi2win($line);
     }
     
     if($pltx==3){#utf-8
     	$line=utf2win($line);
     	#print "UTF-8 do not show<br/>";
        #last;     
     }
     	   	  
     
     $line =~ s/\&/&amp;/g; 
     #$line =~ s//\cM/g;
      $line =~ s/</&lt;/g; 
     $line =~ s/>/&gt;/g; 
     $line =~ s/\"/&quot;/g;
     $line =~ s/\n/<br\/>/g;
    
     
     $prline=&detranslit($line);
     $sizemsg+=length($prline);     
     
     if($sizemsg > $maxsizemsg){#check size
      
      print "<br/>...THE MESSAGE IS MORE THEN $maxsizemsg B<br/>";
      last;}	 
     
     print $prline; 
         	
     next;	
   }	
   
   if(($pltx > 0) && (!($line =~/\w+/))){#End of header
    $txml=1;}       	  
  
   if($line =~/Content\-Type\: text\/plain\;/){ 
     $pltx=1;}
     
   if($cencod==0){
    if($pltx==1){       
     if($line =~/.*charset\=(.*)/){
     	  
       if($1 =~/koi8-r/) {$pltx=2;}
     
       if($1 =~/utf-8/) {$pltx=3;}
      } 
                   
     }
    }
    else{
     $pltx=$cencod;
    }
    
    if(($line =~ /Content-Transfer-Encoding: quoted-printable/) && $pltx > 0){
     	$dqp=1;
     }	
    		
  }
   
        
}

#=====================================
sub printwml{#if second parameter is 1 then do not show "back" 

my($txt, $shbk) = @_;

print "<card id=\"cr\" title=\"MAIL\">";

if(!$shbk){
print "<do type=\"prev\" label=\"back\"><prev/>
</do>";
}

print "<p>$txt"; 

}

#===========Koi8-r to win============
sub koi2win{

my $str = shift;                     # copy the arguments

$str =~ tr/ÁÂ×ÇÄÅ£ÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝßÙØÜÀÑáâ÷çäå³öúéêëìíîïðòóôõæèãþûýÿùøüàñ/àáâãäå¸æçèéêëìíîïðñòóôõö÷øùúûüýþÿÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞß/;

return $str;
}

#Convert cyrilic character to latin
sub detranslit{
   my $text = shift;
   $text =~ s/¸/e/g; $text =~ s/¨/E/g; 
   $text =~ s/æ/zh/g; $text =~ s/Æ/ZH/g; 
   $text =~ s/õ/h/g; $text =~ s/Õ/H/g; 
   $text =~ s/÷/ch/g; $text =~ s/×/CH/g;
   $text =~ s/ù/sc/g; $text =~ s/Ù/SC/g; 
   $text =~ s/ø/sh/g; $text =~ s/Ø/SH/g; 
   $text =~ s/ý/e/g; $text =~ s/Ý/E/g; 
   $text =~ s/þ/ju/g; $text =~ s/Þ/JU/g; 
   $text =~ s/ÿ/ja/g; $text =~ s/ß/JA/g; 

   $text =~ tr/àáâãäåçèéêëìíîïðñòóôöûüú/abvgdezijklmnoprstufcy'`/;
   $text =~ tr/ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÖÛ/ABVGDEZIJKLMNOPRSTUFCY/;
   return $text;
}

#====================================
sub CheckDecode{

 
 my $str = shift;
 my $result=$str;
 
  
 if($str=~/.*\?(.*)\?B\?(.*)\?\=/){
  
  $result = &MIMEDecode($2); # ïîëó÷àåì ðåçóëüòàò
  
    
  if($1 eq "koi8-r"){
   $result = &koi2win($result);}
 }
 
 if($1 eq "utf-8"){
   $result = &utf2win($result);
   #return $result;
   #return "UTF-8 do not show";
 }	

 return &detranslit($result);
}

#================ UTF-8 to WIN 1251 =======================
sub utf2win{

my @mychr=split //,shift;

my $utfdd="\xD0\xB0\xD0\xB1\xD0\xB2\xD0\xB3\xD0\xB4\xD0\xB5\xD1\x91\xD0\xB6\xD0\xB7\xD0\xB8\xD0\xB9\xD0\xBA\xD0\xBB\xD0\xBC\xD0\xBD\xD0\xBE\xD0\xBF\xD1\x80\xD1\x81\xD1\x82\xD1\x83\xD1\x84\xD1\x85\xD1\x86\xD1\x87\xD1\x88\xD1\x89\xD1\x8A\xD1\x8B\xD1\x8C\xD1\x8D\xD1\x8E\xD1\x8F\xD0\x90\xD0\x91\xD0\x92\xD0\x93\xD0\x94\xD0\x95\xD0\x81\xD0\x96\xD0\x97\xD0\x98\xD0\x99\xD0\x9A\xD0\x9B\xD0\x9C\xD0\x9D\xD0\x9E\xD0\x9F\xD0\xA0\xD0\xA1\xD0\xA2\xD0\xA3\xD0\xA4\xD0\xA5\xD0\xA6\xD0\xA7\xD0\xA8\xD0\xA9\xD0\xAA\xD0\xAB\xD0\xAC\xD0\xAD\xD0\xAE\xD0\xAF";
my @strutf=split //,$utfdd;




my @strwin=('à','á','â','ã','ä','å','¸','æ','ç','è','é','ê','ë','ì','í','î','ï','ð','ñ','ò','ó','ô','õ','ö','÷',
         'ø','ù','ú','û','ü','ý','þ','ÿ','À','Á','Â','Ã','Ä','Å','¨','Æ','Ç','È','É','Ê','Ë','Ì','Í','Î','Ï',
         'Ð','Ñ','Ò','Ó','Ô','Õ','Ö','×','Ø','Ù','Ú','Û','Ü','Ý','Þ','ß');



my $nwstr="";
my $len = scalar(@mychr);
my $k;
my $i;
my $j;

for($i=0;$i<$len;$i++){
	
	if($mychr[$i] lt '\x7F'){
        $nwstr="$nwstr$mychr[$i]";
        next;
        }
	
	$k=0;
	for($j=0;$j<132;$j+=2){
	
	if(($mychr[$i] eq $strutf[$j]) && ($mychr[$i+1] eq $strutf[$j+1])){
	 $nwstr="$nwstr$strwin[$k]"; last;}
	 
	 
	 $k++;
	}
	$i++;

 }

 return $nwstr;

}
#=====================================
sub TimeMailDate {

use Time::Local; 	
	
    my @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my %MoY;
    @MoY{@MoY} = (1..12);
    if ($_[0] =~ /\s*(\d\d?)\s*([JFMASOND][a-z][a-z])\s*(\d\d\d\d)\s*(\d\d):(\d\d):?(\d\d)?\s*([\w+-]{1,5})?/)
      {
	  my $zone_offset = 0;
	  return eval {
	      my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3-1900);
	      if ($7) {
		  my $time_adjust = $7;
		  
		  if ($time_adjust !~ /^[+-]\d{4}$/) {$time_adjust = '+0000'};
		  my ($sign, $hour_off, $min_off) = unpack("a a2 a2",$time_adjust);
		  $zone_offset = ($min_off * 60) + ($hour_off * 3600) * (($sign eq '+') ? 1 : -1);
	      }
	      $t < 0 ? time : ($t - $zone_offset);   
	  }
      }
    else { return time }
}  

#=====================================
sub MIMEDecodeQP{

use MIME::QuotedPrint();

my $result=shift;

$result = MIME::QuotedPrint::decode($result);

return $result;
}

#=====================================
sub MIMEDecode{

use MIME::Base64();

my $result=shift;

$result = MIME::Base64::decode($result);

return $result;
}

#=====================================
sub MIMEEncode{

use MIME::Base64();

my $result=shift;

$result = MIME::Base64::encode($result);
return $result;
}

#=========== Check login =============

sub chlogin{

 use Fcntl ':flock'; # import LOCK_* constants
 
 my $Id = shift;
 
 my $IdL;
 my $IpL;
 my $BrL;
 my $SrL;
 my $UsL;
 my $PsL;

 my $maxszR;
 my $SrR;
 my $UsR;
 my $PsR;

#--- Erase old files -----
 my $count=0;
 opendir(DIR, $loginDir);

	while ($_ = readdir DIR) {
		$_ =~ /^\./ and next;
		$_ = $loginDir.$_;

		if (((-M $_) * (24.0*60.0)) > 10) {
			unlink $_;
			last if ($count++ > 100);# Stop after ~100 deleted files
		}
	}

	close DIR;
#---------------- 
 my $dataLogin;
 
 open(LOGN,"<$loginDir$Id") or return;

 flock(LOGN,"LOCK_EX");
 $dataLogin=<LOGN>;
 flock(LOGN,"LOCK_UN");

 close(LOGN);
 
 my $cur_ip=$ENV{'REMOTE_ADDR'};  
 
  
  ($maxszR, $IpL, $BrL, $SrL, $UsL, $PsL) = split / \| /,$dataLogin;
  
   #print "$TmL, $IpL, $BrL, $SrL, $UsL, $PsL<br>";
     
  if(($IpL eq $cur_ip) && ($BrL eq $ENV{'HTTP_USER_AGENT'})){
   	 	 $SrR=$SrL; $UsR=$UsL; $PsR=passdecode($PsL);
   	 	}
 
 
 if($Id eq ''){
  return;	
 }
 return ($maxszR, $SrR, $UsR, $PsR); 
}

#======Write login=======================

sub wrlog{

 my($maxsz, $srv, $usr, $pass) = @_; 
 my $Id; 
 my $co=0;
 
 my $pass = passcode($pass);
  
 #------ Random ID-----------
 srand(time() ^ ($$ + ($$ << 15))); 
 $Id=int(rand 0xFFFFFF);

 $Id=sprintf("%06X",$Id);
 
#--------------------------
 open(LOGN,">>$loginDir$Id") or $co=1;

 if($co == 1) {print "Can't open $loginDir$Id<br>\n"; return;}

 flock(LOGN,LOCK_EX);
 
 print LOGN "$maxsz | $ENV{'REMOTE_ADDR'} | $ENV{'HTTP_USER_AGENT'} | $srv | $usr | $pass";
 
 flock(LOGN,LOCK_UN);
 close(LOGN);
 
 return $Id;
}

#======Password encode=========
sub passcode{
 
 my $PassRet;
 my $PassRes="";
 my $i;
 
 my $PassSrc = shift;
 
  
 my $len = length($PassSrc);
  
  for($i=0;$i<$len;$i++){
   $PassRes.=sprintf("%03d",unpack("c",substr($PassSrc,$i,1)) ^0xDF );  	  	
}
    
 $PassRet=MIMEEncode($PassRes);
 
 return $PassRet;	
}

#======Password decode=========
sub passdecode{
 
  my $PassRes;
  my $PassRes2;
  my $i;
  my $PassSrc=MIMEDecode(shift);
  
  my $len = length($PassSrc);
  
  for($i=0;$i<$len;$i+=3){
   $PassRes=$PassRes.(pack("c",substr($PassSrc,$i,3))); 
 }
 
  
 $len = length($PassRes);
   
  for($i=0;$i<$len;$i++){
   $PassRes2.=sprintf("%c",( unpack("C",substr($PassRes,$i,1)) ^0xDF));  	  	
}
  
 return $PassRes2;	
}