#-*-perl-*-
#
# Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser
#
#      Wirtschaftsuniversitaet Wien,
#      Abteilung fuer Wirtschaftsinformatik
#      Augasse 2-6,
#      A-1090 Vienna, Austria
#      neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appears in all copies and that both that
# copyright notice and this permission notice appear in all supporting
# documentation.  This software is provided "as is" without expressed or
# implied warranty.
#
# Date: Mon, Apr 13 1992
# Author: Gustaf Neumann
# Version: 0.9
#

package wafe_mu;
#
# mail utilities for wafe
#
# the following procedures must be defined: 
#      &main'Xui:   low level wafe communication
#      &main'info:  update status line in the Label widget named info
#      &main'sendMode:  hook for mainprogram to provide code for switching
#            sendmode on and off


$main'mailIncludePrefix = $main'mailIncludePrefix || " |> ";
$main'signatureFile = $main'opt_s || $main'signatureFile ||  "$ENV{HOME}/.elm/signature";
$main'printCommand = $main'opt_p || $main'printCommand || "mp | multi | lpr";
$main'elmAliases = $main'elmAliases || "$ENV{'HOME'}/.elm/aliases.text";
$main'localHost = $ENV{'HOST'} || 
     chop($main'localHost = `/bin/hostname`) && $main'localHost; #'
$user = $ENV{'USER'} || 
     chop($user = `/usr/bin/whoami`) && $user;
#
# read in signature file into global variable $wafe_mu'signature 
#
if (open(SIGNATURE,"<$main'signatureFile")) {
    undef($/); $signature = <SIGNATURE>; $/="\n";
    close(SIGNATURE);
}

#
# maps a name into a foldername
#
sub folderName {
    local($Type,$_) = @_;
    return $_ if m/^[\.\/\|].*/;	# it is a path or a pipe
    return "$ENV{HOME}/$1"  if m/^\~\/(.*)/; # it starts with a tilde slash
    return (getpwnam($1))[7] . $2 if (m/^\~(\w+)(\/.+)/);  # it starts with a tilde name slash
    local($incoming) = "$ENV{HOME}/$Type/$_";
    unless((-d "$ENV{HOME}/$Type") || mkdir("$ENV{HOME}/$Type",0755)) {
                      &main'info("cannot create incoming directory $incoming"); #'
               }
    return $incoming;    # must be in the mail- or news-directory
}

sub mailDateNow {
    local($_);
    undef $ENV{'LANG'};
    chop($_ = `/bin/date`);
    local($wday,$month,$day,$time,$tz,$dst,$year) = split;
    $year = $dst unless $year;
    ($year,$tz) = ($tz,$ENV{'TZ'}) unless $year;
    local($yearNC) = $year % 100;
    return "$wday, $day $month $yearNC $time $tz";
}

sub widgetContent {
    local($filename,$widget) = @_;
    local($ds,$content) = ($/);

    &main'Xui("XawAsciiSaveAsFile $widget $filename;echo done");
    $_ = &wafe'read; # we have to wait, until the file is saved!

    undef $/;  open(F,"<$filename") && ($content = <F>) && close(F); $/ = $ds;
    $content;
}

sub printArgInto {
    local($article,$target) = @_;
    $article .= "\n" if $article !~ /\n$/;
    open(PRINT,$target) &&
	((print PRINT $article), close(PRINT), return 1)|| return 0;
}

sub fromHeader {
    local($_);
    undef $ENV{'LANG'};
    chop($_ = `/bin/date`);
    local($wday,$month,$day,$time,$tz,$year) = split; 
   "\nFrom $_[0] $wday $month $day $time $year\n$_[1]";
}

sub TeXEncode {
    local($_) = @_;
    local($count);
    $count += s/ä/{\\"a}/g;  $count += s/ö/{\\"o}/g;  $count += s/ü/{\\"u}/g;
    $count += s/Ä/{\\"A}/g;  $count += s/Ö/{\\"O}/g;  $count += s/Ü/{\\"U}/g;
    $count += s/ß/{\\"ss}/g; #"
    s/\n\n/\nX-Encoding: TeX\n\n/ if $count;
    $_;
}
sub TeXdecode {
    local($_) = @_;
    s/{\\"a}/ä/g;     s/{\\"o}/ö/g;     s/{\\"u}/ü/g;
    s/{\\"A}/Ä/g;     s/{\\"O}/Ö/g;     s/{\\"U}/Ü/g;
    s/{\\"ss}/ß/g; #"
    $_;
}

sub SweEncode {
    local($_) = @_;
    local($count);
    $count=tr/\345\344\366\305\304\326\351\311/}{|][\\~@/;
    s/\n\n/\nX-Encoding: SweAscii\n\n/ if $count;
    $_;
}

sub SweDecode {
    local($_) = @_;
    local($count);
    $count=tr/}{|][\\~@/\345\344\366\305\304\326\351\311/;
    $_;
}


sub MimeDecode {
    local($typeAndEncoding,$_) = @_;
    local($type,$encoding);
    eval $typeAndEncoding;
    local($body,$partHead);
    # is it a multi part document?
    if ($type =~ m/Boundary=\"(\w*)\"/i) { 
#   just take the first part for the time being (very "experimental")
	local($boundary) = $1;
#	print "Boundary = <$boundary>\n";
#	$contentEncoding = $1 
#                     if m/^Content\-[Tt]ransfer\-[Ee]ncoding: *(.*)$/;
	$_ = $' if m/\r?\n\-\-$boundary\r?\n/;
	$body = $` if m/\r?\n\-\-$boundary\r?\n/;
	$partHead = $` if $body =~ m/\r?\n\r?\n/;
        $body = $';
	$partHead =~ s/\n\s+//g;
	$body = &qpDecode($body) 
	    if $partHead =~ /Content\-Transfer\-Encoding:.*quoted\-printable/i;
	$body = &decode64($body) 
	    if $partHead =~ /Content\-Transfer\-Encoding:.*Base64/i;
	return $body;
    } else {
	# just one part
	$_ = &qpDecode($_) 
	    if $encoding =~ m/quoted\-printable/i;
	$_ = &decode64($_) 
	    if $encoding =~ m/Base64/i;
    }
    print "mime content type <$type> not implemented\n" 
	unless $type eq "" || $type =~ /text/i;
    return $_;
}

sub qpEncode {
    local($_) = @_;
    local($count) = /[\000-\010\013\014\016-\037\177-\377]/;
    $count += s/([\000-\010\013\014\016-\037\075\177-\377])/sprintf("=%.2X",unpack('C',$1))/ge if $count;
    s/.*/&qp_my_split($&)/eg;
    $count += m/=\n/ if $count;
    s/\n\n/\nContent\-Transfer\-Encoding: Quoted\-Printable\nContent\-type: text\/plain; charset=ISO\-8859\-1\n\n/ if $count;
    $_;
}

sub qp_my_split {
    local($_) = @_;
    return $_ if length($_)<75;
    for $i (reverse 1..int(length($_)/75)) {
	substr($_,$i*75,0) = "=\n";
	$count ++; # in callers environment
    }
    $_;
}

sub qpDecode {
    local($_) = @_;
    s/=\r?\n//g;
    s/=([0-9A-F][0-9A-F])/pack('C',hex($1))/ge;
    $_;
}



sub decode64 {
    local($_) = @_;
    local($e,$c,$result) = (-1,",");
#    print "before\n",unpack("a80",$_),"**\n\n";
#    print "after\n",join(",",unpack("c10",$_)),"**\n\n";
    for(split("\n")) {
	tr/A-Za-z0-9\+\//\000-\377/;
	for (split("")) {
	    $e++;
#	    print unpack("b6",$_),": ", sprintf("%3d",ord($_)), " ", 
#	          unpack("b8",pack("c",$c)), " <$e> <$string>\n";
	    if ($e==0) {$c = ord($_)<<2; next;}
	    if ($e==1) {$c |= ord($_)>>4; $string .= pack('c',$c);
#			print "\t    ",unpack("b8",pack("c",$c)),
#			      " ",pack("c",$c)," ",$c&255," <1\n";
			$c = ord($_) << 4; next;}
	    if ($e==2) {$c |= ord($_)>>2; $string .= pack('c',$c); 
#		print "\t    ",unpack("b8",pack("c",$c)),
#			      " ",pack("c",$c)," ",$c&255," <2\n";
			$c = ord($_) << 6; next;}
	    if ($e==3) {$c |= ord($_); $string .= pack('c',$c); 
#			print "\t    ",unpack("b8",pack("c",$c)),
#			      " ",pack("c",$c)," ",$c&255," <3\n";
			$e = -1;}
	}
    }
    return $string;
}

sub exclusiveLock {
    local($fh) = @_;
    eval 'flock($fh,2);';
    fcntl($fh,7,pack('sslll',2,0,0,0,0)) if $@ =~ /unimplemented/;   #hpux
}
sub unLock {
    local($fh) = @_;
    eval 'flock($fh,8);';
    fcntl($fh,7,pack('sslll',3,0,0,0,0)) if $@ =~ /unimplemented/;   #hpux
}

# send a mailmessage 
# in the asciiTextwidget $widget 
# by saving its contents into $filename to check headers
# the maildistribution is done via /usr/lib/sendmail 
# returns 1 on success or 0 on failure
#
sub send {
    local($filename,$widget) = @_;
    local($date,$address,$toaddr,$theMail,$allAdresses,$_,$target,$header);
    local($adressedTo,$adressedCc);

    $theMail = &widgetContent($filename,$widget);

    $header = (split(/\n\s*\n/,$theMail))[0];
    $*=1; $header =~ s/\n\s+/ /g; $* = 0;

    $date = $address = "";
    for (split("\n",$header)) {
	last unless $_;
	$address .= ",$1", $adressedTo = $1 if m/^To:\s*(\S.*)$/;
	$address .= ",$1", $adressedCc = $1 if m/^Cc:\s*(\S.*)$/;
	$address .= ",$1" if m/^Bcc:\s*(\S.*)$/;
	$date = $1 if m/^Date:\s*(\S.*)$/;
    }
       
    unless ($address) { 
	&main'info("Mail has Invalid Header, To-Field is missing"); return(0); #'
    }
    unless ($date) { 
        &main'info("Mail has Invalid Header, Date-Field is missing"); return(0); #'
    }

    $theMail =~ s/^Bcc: .*//;
    $theMail = &qpEncode($theMail) if $main'defaultMailEncoding =~ /Mime/i; #'
    $theMail = &TeXEncode($theMail) if $main'defaultMailEncoding =~ /TeX/i; #'
    $theMail = &SweEncode($theMail) if $main'defaultMailEncoding =~ /Swe/i; #'
        
    $allAdresses = join(" ",&resolveAliases($address,1));

    $* = 1;
    $theMail =~ s/^To:\s*(\S.*)$/"To: ".&fillInNames($1)/e;
    $theMail =~ s/^Cc:\s*(\S.*)$/"Cc: ".&fillInNames($1)/e;
    $* = 0;

#    print "\nthe mail: <<$theMail>>\n\n <<$allAdresses>>\n";
#    return(0);

    &main'info("sending mail message ..."); #'
    open(MAIL, "|/usr/lib/sendmail -oi $allAdresses") ||
	(&main'info("can't execute /usr/lib/sendmail"), return(0)); #"
    print MAIL $theMail;
    close(MAIL);
    &main'info("mail message sent to $allAdresses"); #'
    &main'sendMode(0); #'

#      use account name instead of nick name as folder name 
#      (assumes, that To: address is befor Cc: and Bcc:)
#    $adressedTo =~ m/(\w+)@?/;
    $allAdresses =~ m/([^\s@]+)@?/;
    $target = &folderName("Mail",$1);
    &printArgInto(&fromHeader($user,$theMail),">> $target");
}

sub defaultAddress {
    local($_) = @_;
    return $_ if /[@!]/ || !$main'defaultMailHost; #'
    s/ $//;
    return "$_\@$main'defaultMailHost"; 
}

sub resolveAlias {
    local($a,%sofar) = @_;
    local(@aliases,@local);
    for $k (split(/, */,$alias{$a})) {
	next if $sofar{$k};
	@local = &resolveAlias($k,$a,1,%sofar);
	@local = ($k) unless @local;
        push(@aliases,@local);
    }
    @aliases;
}

sub resolveAliases {
    local($_,$withoutName) = @_;
    local(@allAdresses,%seen);
    s/,\s+/,/g;
    # yes, there are people having a "," in their names
    s/(\"[^"]*)\,([^"]*\")/$1 $2/g; 
    s/(\([^)]*)\,([^)]*\))/$1 $2/g; 
    for $a (split(/,/)) {
	next unless $a;
	local(@toAddr) = &resolveAlias($a);
	@toAddr[$[] = 
	    &defaultAddress($withoutName ? (&nameAddress($a))[1] : $a)
	    unless @toAddr; 
	push(@allAdresses,grep(!$seen{$_},@toAddr)) if @toAddr;
	grep($seen{$_}++,@toAddr);
    }
    return(@allAdresses);
}    

sub fillInNames {
    local($addresses) = @_;
    local(@subst,$string,$nString,$length);
    for (&resolveAliases($addresses,0)) {
#	print"fill in: <$_> name = <$aliasName{$_}>\n";
	push(@subst, ($aliasName{$_} ? "$_ ($aliasName{$_})" : $_));
    }
    for (@subst) {
	local($nLength) = $length + length;
	($nString,$length) = $nLength > 65 ? ("\n\t$_",length) : ($_,$nLength);
	$string .= $nString.", ";
    }
    chop($string);chop($string);
    return $string;
}



#
# returnMail
# composes a new mail message from an existing one
# in file $filename in $widget, where $type is "reply*" or "forward"
# $urgent is boolean; 

sub returnMail {
    local($filename,$widget,$type,
	  $urgent,$from,$cc,$subject,$date,$mailbody) = @_;
    local($name,$fromaddr,$fullfromaddr);

    ($name,$fromaddr)=&nameAddress($from);
    $fullfromaddr = $name ? "$fromaddr ($name)" : $fromaddr;

    open(MAILTEXT,">$filename") || 
	(&main'info("can't open $filename for writing"), return(0)); #"

    if ($type =~ /^reply/) {
	print MAILTEXT "To: $fullfromaddr\n";
	print MAILTEXT "Subject: ".($subject =~ /^[Rr]e:/ ? $subject : "Re: $subject")."\n"
                  if $subject;
	print MAILTEXT "Cc: $cc\n" if $cc;
	print MAILTEXT "Priority: Urgent\n" if $urgent;
	print MAILTEXT "Date: ", &mailDateNow(), "\n\n",
 		   "In your message from [$date] you wrote:\n";
    } else {
	print MAILTEXT "To: \n";
	print MAILTEXT "Subject: [forwarded] $subject\n";
	print MAILTEXT "Priority: Urgent\n" if $urgent;
	print MAILTEXT "Date: ", &mailDateNow(), "\n\n",
 		   "Forwarded message from [$fullfromaddr]:\n";
     }
     for (split("\n",$mailbody)) {print MAILTEXT "$main'mailIncludePrefix$_\n";} 
     print MAILTEXT "\n\n--\n$signature" if $signature;
     close(MAILTEXT);

     &main'Xui("sV $widget type file string $filename"); #'
     &main'sendMode(1); #'
     if ($type =~ /^reply/) {
	&main'Xui("callActionProc $widget {} forward-paragraph"); #'
	&main'Xui("callActionProc $widget {} next-line"); #'
	&main'Xui("callActionProc $widget {} next-line"); #'
     } else {
#	&main'Xui("callActionProc $widget {} next-line"); #'
	&main'Xui("callActionProc $widget {} end-of-line"); #'
     }
    return 1;
}

#
# split name and address of a From:-line
#
sub nameAddress {
    local($address) = @_;
    local($name,$addr) = ();
    ($name,$addr) = ($2,$1) if ($address =~ m/^([^(]*)\s+\((.*)\)\s*$/); 
    ($name,$addr) = ($1,$2) if ($address =~ m/^(.*)\s*<(.*)>.*/);
    $name = $1 if $name =~ m/^\s+(\S.*)$/;
    $name = $1 if $name =~ m/^(.*\S)\s+$/;
    $addr = $address unless $addr;
    ($name,$addr);
}


sub createConfig {
    local($father,$b,@buttons) = @_;
    &main'Xui("SimpleMenu config $father $main'menueAtts;set p {}"); #"
    foreach (@buttons) {
	($w = $_) =~ tr/*. /---/;
	&main'Xui("SmeBSB config$w config label {$_} $main'normalFont " #"'
                 ."callback {set p {$_};echo setconfig $_}");
    }
   &main'Xui(<<"__");
      TransientShell configsetvalmenu topLevel allowShellResize true
      callback configsetvalmenu popupCallback positionCursor 45
      Dialog configsetvaltext configsetvalmenu \\
         label {Value} value {} $main'backGround
      sV configsetvaltext.label $main'backGround $main'boldFont
      Command configsetvalquit configsetvaltext \\
         label {Cancel} $main'buttonAtts callback {popdown configsetvalmenu}
      action configsetvaltext.value override {\\
         <Key>Return: exec(echo setPerl \$p [gV configsetvaltext value]) \\
                      XtMenuPopdown(configsetvalmenu)}
__
}


if (open(ELMALIASES,"<$main'elmAliases")) {
    while(<ELMALIASES>) {
	local($nick,$name,$mail);
	if (($nick,$name,$mail) = /^\s*(\S+)\s*=\s*(.*\S)\s*=\s*(.*\S)\s*/) { 
	    $mail =~ s/,\s+/,/g;
	    $alias{$nick} = $mail;
#	    print "setting aliasname of <$mail> to <$name>\n";
	    $aliasName{$mail} = $name;
	}
    }
    close(ELMALIASES);
}


1;
