################################################################################
#
#  kPerl Core Library Group
#  Library for Internet Related Stuff
#
#  copyright (c)
#    UPenn Philadelphia, Center for Bioinformatics, 2004
#    Institute of Molecular Biotechnology Jena, Dept. Genome Analysis, 1998-2001
#    Karol Szafranski and Inst. Physiol. Chem., Univ. Düsseldorf, 1997-1998
#  author
#    Karol Szafranski, karol.szafranski@leibniz-fli.de
#
################################################################################
#
#  DESCRIPTION
#
# - functions beginning with a letter are exported, those with a leading
#   underscore are not. Those are meant for internal use only. Variables with
#   a leading underscore are declared with "my", therefore inaccessible from
#   outside the package.
#
# - individual description of functions at the beginning of the code blocks
#
################################################################################
#
#  FUNCTIONS, DATA
#
#   @EXPORT
#   %_LibParam
#
# - HTTP and related protocols
#   %_LibParam{http}
#   &EncodeURL
#   &EncodeMpartBound
#   &FormdatEncodeURL
#   &FormdatEncodeMpart
#
# - HTML
#   &HtmlCharEncode
#   %_TranslHtml2Char
#   &HtmlCharDecode
#   &HtmlGreekEncode
#
# - mail
#   %_LibParam{mail}
#   &MailSimple
#
################################################################################

package MainLib::Internet;

# includes
#use strict; use warnings;  # worked 20040726
use MainLib::StrRegexp;
use MainLib::Path qw(%CorePath);

# symbol export
use Exporter qw(import);
our @EXPORT = qw (
  &EncodeURL &EncodeMpartBound &FormdatEncodeURL
  &HtmlCharEncode &HtmlCharDecode &HtmlGreekEncode
  &MailSimple
  );

# package-wide constants and variables
my %_LibParam;


################################################################################
# HTTP and related protocols
################################################################################

$_LibParam{http}{reload} = 5;


# return URL-encoded string
#
# INTERFACE
# - argument 1: string
# - return val: URL-encoded string
#
sub EncodeURL {
  my $str = shift;

  # what must be changed first
  $str =~ s/\%/\%25/g;
  $str =~ s/\+/\%2B/g;

  # other special characters
  $str =~ s/$reEndl/\%0D\%0A/g;
  $str =~ s/\#/\%23/g;
  $str =~ s/\$/\%24/g;
  $str =~ s/\&/\%26/g;
  $str =~ s/\//\%2F/g;
  $str =~  s/=/\%3D/g;
  $str =~  s/>/\%3E/g;
  $str =~ s/\[/\%5B/g;
  $str =~ s/\]/\%5D/g;
  $str =~ s/\|/\%7C/g;
  $str =~ tr/ /+/;

  return $str;
}


# work out boundary string for multipart encoding
#
# INTERFACE
# - return val: boundary string
#
sub EncodeMpartBound {
  require Math::kRandom; Math::kRandom->import('&RandStr');
  return ('-'x 15) . &RandStr(20,-chars=>join('',0..9)) . '_';
}


# work out URL-encoded query string from hash of filled form fields
#
# INTERFACE
# - argument 1: reference to hash for fieldname-value pairs
# - return val: URL-encoded string
#
sub FormdatEncodeURL {
  my ($pFormdat) = @_;
  my (@fields);

  # join key-value pairs
  foreach (sort keys %$pFormdat) {
    push @fields, &EncodeURL($_) .'='. &EncodeURL($$pFormdat{$_});
  }

  # exit SUB
  return join ('&', @fields);
}


# work out multipart-encoded query string from hash of filled form fields
# *** implement me ***
#
# INTERFACE
# - argument 1: reference to hash for fieldname-value pairs
# - return val: depending on wantscalar / wantarray
#               - multipart-encoded string
#               - multipart-encoded string, boundary string
#
sub FormdatEncodeMpart {
  my ($pFormdat) = @_;
  my ($StrBound, @fields);

  # function parameters
  $StrBound = &EncodeMpartBound();

  # join key-value pairs
  foreach (sort keys %$pFormdat) {
    # *** implement me ***
    push @FormSeg, '';
  }

  # exit SUB
  return join ($StrBound."\n", @FormSeg);
}


################################################################################
# HTML
################################################################################


# change plain text to HTML converting special characters
#
# INTERFACE
# - argument 1: string containing special characters
# - return val: converted string
#
sub HtmlCharEncode {
  my ($DocPlain) = shift;
  my $StrUnique = 'HuiOarf-';

  # this must be first
  $DocPlain =~ s/\&/$StrUnique/g;
  $DocPlain =~ s/</\&lt;/g;
  $DocPlain =~ s/$StrUnique/\&amp;/g;

  # and the rest
  $DocPlain =~ s/>/\&gt;/g;

  # return formatted string
  return $DocPlain;
}


our %_TranslHtml2Char = (
  'aacute' => 225,
  'Aacute' => 193,
  'agrave' => 224,
  'Agrave' => 192,
  'amp'    =>  38,
  'auml'   => 228,
  'Auml'   => 196,
  'eacute' => 233,
  'egrave' => 232,
  'gt'     =>  62,
  'iacute' => 237,
  'Iacute' => 205,
  'lt'     =>  60,
  'nbsp'   =>  32,
  'oacute' => 243,
  'Oacute' => 211,
  'ograve' => 242,
  'Ograve' => 210,
  'uuml'   => 252,
  'Uuml'   => 220,
  );

# change HTML special characters in HTML text to real character
#
# INTERFACE
# - argument 1: string containing HTML character codes
# - return val: converted string
#
# DEVELOPER'S NOTES
# - a nice list of the ISO character set can be obtained with:
#   perl -e 'binmode STDOUT; for(32..255){ printf q(%d %s%s%s).qq(\n),$_,pack(q(c),39),pack(q(c),$_),pack(q(c),39) }'
#
sub HtmlCharDecode {
  my $DocHtml = shift;

  # translate special characters
  while ($DocHtml =~ m/\&(#)?(\w+);/g) {
    my $ch=$2;
    my $lp=length($`);
    my $lm=length($&);
    my $cn;  # the numeric character code we're looking for
    # numeric code
    if (length($1)) {
      if ($ch!~m/^(\d+)$/ and ($cn=int($ch))<256) {
        printf STDERR "malformed HTML character code: \&%s;, pos. %d\n", $ch, $lp;
        next;
      }
    }
    # letter code
    else {
      $cn=$_TranslHtml2Char{$ch};
      if (!$cn) {
        printf STDERR "malformed or unknown HTML character code: \&%s;, pos. %d\n", $ch, $lp;
        next;
      }
    }
    # change document
    substr($DocHtml,$lp,$lm) = pack('c',$cn);
    pos($DocHtml) = $lp+1;
  }

  # return formatted string
  return $DocHtml;
}


# convert greek symbol names to HTML-style symbol notation featuring tag <FONT ...>
#
# INTERFACE
# - argument 1: string to be converted
# - return val: converted string
#
# DESCRIPTION
# - Currently, this is nowhere in use.
#
sub HtmlGreekEncode {
  my $str = shift;
  my $SymbolPre  = '^|[\W\d]';
  my $SymbolPost = '[\W\dA-Z]|$';

  $str =~ s#($SymbolPre)alpha($SymbolPost)#$1<FONT FACE="Symbol">a</FONT>$2#go;
  $str =~ s#($SymbolPre)beta($SymbolPost)#$1&szlig;$2#go;
  $str =~ s#($SymbolPre)gamma($SymbolPost)#$1<FONT FACE="Symbol">g</FONT>$2#go;
  $str =~ s#($SymbolPre)delta($SymbolPost)#$1<FONT FACE="Symbol">d</FONT>$2#go;
  $str =~ s#($SymbolPre)epsilon($SymbolPost)#$1<FONT FACE="Symbol">e</FONT>$2#go;
  $str =~ s#($SymbolPre)kappa($SymbolPost)#$1<FONT FACE="Symbol">k</FONT>$2#go;
  $str =~ s#($SymbolPre)pi($SymbolPost)#$1<FONT FACE="Symbol">p</FONT>$2#go;
  $str =~ s#($SymbolPre)sigma($SymbolPost)#$1<FONT FACE="Symbol">s</FONT>$2#go;
  $str =~ s#($SymbolPre)zeta($SymbolPost)#$1<FONT FACE="Symbol">z</FONT>$2#go;

  # return converted string
  return $str;
}


################################################################################
# mail
################################################################################

$_LibParam{mail} = {
  from => $CorePath{mail}{sFromDft},
  to   => $CorePath{mail}{sToDft},
  };


# send a mail using mailx
#
# INTERFACE
# - options: 
#   -bcc        blind carbon copy recipients
#   -body       body of the message
#   -cc         carbon copy recipients
#   -debug      print debug protocol to STDERR
#   -from       this feature is only simulated doing the same like option
#               -ReturnTo
#   -ReturnTo   return address, default: $_LibParam{mail}{from}
#   -subject    subject text, default: NULL-string
#   -to         address of the recipient, default: $_LibParam{mail}{to}
#
# - return val: - success status (boolean)
#
# DESCRIPTION
# - address of the sender is automatically set to user ID, but see option
#   -ReturnTo.
#
sub MailSimple {
  my (%opt) = @_;
  my ($debug, $bcc, $body, $cc, $subject, $ReturnTo, $to);
  my ($call);

  # function parameters
  $debug = $opt{-debug} || 1;
  $bcc = $opt{-bcc} ? "-b '$opt{-bcc}'" : '';
  $body = $opt{-body} || '';
  $cc = $opt{-cc} ?  "-c '$opt{-cc}'" : '';
  $opt{-subject} =~ s/'/\\'/g;
  $subject = "-s '$opt{-subject}'";
  $ReturnTo = ($opt{-ReturnTo} || $opt{-from}) ?
    ('-r '. ($opt{-ReturnTo} || $opt{-from})) : '';
  $to = $opt{-to} || $_LibParam{mail}{to};

  # call program
  $call = "$CorePath{call}{mailx} $bcc $cc $subject $ReturnTo  $to";
  unless (open (OUTMAIL, "| $call")) {
    $debug and printf STDERR "ERROR: call of mailing program failed, call was:\n  %s\n", $call;
    return undef;
  }
  print OUTMAIL "$body";
  close OUTMAIL;
  
  # exit successfully
  return 1;
}


1;
# $Id: Internet.pm,v 1.13 2018/06/05 18:02:56 szafrans Exp $
