#!/usr/bin/perl

use strict;
use warnings;

=head1 NAME

    pkt.pm - perl library for creating FTN PKT.

=head1 DESCRIPTION

    This library is designed to creating FTN PKT 2.0+ (FSC-0048.002).

=head1 SYNOPSIS

   txt2pkt($pkt_from,$pkt_to,$password,$msg_fromname, $msg_toname,
           $msg_fromaddr,$msg_toaddr, $attr, $msg_txt, $msg_subj, $msg_ara,
           $msg_chrs);

            $pkt_from     - pkt from address
            $pkt_to       - pkt to address
            $password     - pkt password if any, undef otherwise
            @msgs         - array of packed messages
            $msg_fromname - sender name
            $msg_fromaddr - sender address
            $msg_toname   - recipient's name
            $msg_toaddr   - recipient address for netmail or undef
            $attr         - message attributes. Supported attributes are
                            PVT, CRA, ATT, K_S, LOC, HLD, REQ, RRQ,
                            RRD, AUD, UPD.
            $msg_area     - area for echomail, otherwise undef
            $msg_subj     - subject of the message
            $msg_txt      - text of the message
            $msg_chrs     - charset (codepage) of the message, 
                            may be omitted


   packpkt($pkt_from,$pkt_to,$password, @msgs);

             $pkt_from    - pkt from address
             $pkt_to      - pkt to address
             $password    - pkt password if any, undef otherwise
             @msgs        - an array of packed messages

   packedmsg($msg_fromname, $msg_toname, $msg_fromaddr, $msg_toaddr, $attr
             $msg_txt, $msg_subj, $msg_area, $msg_chrs);

             $msg_fromname - sender name
             $msg_fromaddr - sender address
             $msg_toname   - recipient's name
             $msg_toaddr   - recipient address for netmail or undef
             $attr         - message attributes. Supported attributes are
                             PVT, CRA, ATT, K_S, LOC, HLD, REQ, RRQ,
                             RRD, AUD, UPD.
             $msg_area     - area for echomail, otherwise undef
             $msg_subj     - subject of the message
             $msg_txt      - text of the message
             $msg_chrs     - charset (codepage) of the message,
                             may be omitted

   writepkt( $dir, $pkt );
             $dir          - the full path to the directory where the 
                             pkt should be tagged.
             $pkt          - pkt body.



=head1 AUTHOR

   Stas Mishchenkov 2:460/58

=head1 COPYRIGHT AND LICENSE

   This library is free software; you may redistribute it and/or
   modify it under the same terms as Perl itself.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=head1 SEE ALSO

B<FSC-0048.002> http://ftsc.org/docs/fsc-0048.002

=cut

use Time::TZOffset qw/tzoffset/;
use File::Path qw( make_path );
use File::Spec::Functions;
use File::Copy;
require Exporter;


our @EXPORT = qw( PVT CRA ATT K_S LOC HLD REQ RRQ RRD AUD UPD );

use constant PVT => 0x0001;
use constant CRA => 0x0002;
use constant ATT => 0x0010;
use constant K_S => 0x0080;
use constant LOC => 0x0100;
use constant HLD => 0x0200;
use constant REQ => 0x0800;
use constant RRQ => 0x1000;
use constant RRD => 0x2000;
use constant AUD => 0x4000;
use constant UPD => 0x8000;


sub txt2pkt( $$$$;$$$$$$$ )
{
    my $TZUTC = sprintf( "%04d", tzoffset( localtime() ) );
    my ($pkt_from,$pkt_to,$password,$msg_fromname, $msg_toname, $msg_fromaddr,
        $msg_toaddr, $attr, $msg_txt, $msg_subj, $msg_area, $msg_chrs ) = @_;
    my ($msg_destzone,$msg_destnet,$msg_destnode,$msg_destpnt);
    
    if (length($msg_fromname) > 35){
	$msg_fromname = substr($msg_fromname,0,35);
    }
    $msg_fromname .= "\000";
    if (length($msg_toname) > 35){
	$msg_toname = substr($msg_toname,0,35);
    }
    $msg_toname .= "\000";
    if (length($msg_subj) > 71){
	$msg_subj = substr($msg_subj,0,71);
    }
    $msg_subj .= "\000";

    $pkt_from =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    my ( $pkt_origzone, $pkt_orignet, $pkt_orignode, $pkt_origpnt ) = ( $1, $2, $3, $4 );
    $pkt_origpnt = 0 if !defined $pkt_origpnt || $pkt_origpnt eq '';
    
    $pkt_to =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    my ( $pkt_destzone,$pkt_destnet,$pkt_destnode,$pkt_destpnt ) = ( $1,$2,$3,$4 );
    $pkt_destpnt = 0 if !defined $pkt_destpnt || $pkt_destpnt eq '';
    $password = '' unless defined $password;
    $password .= "\x00" while length($password) < 8;
    localtime =~ /[a-z]+ ([a-z]+)[ ]+(\d+) (\d+)\:(\d+)\:(\d+) \d\d(\d\d)/i;
    my $DateTime = sprintf("%02s", $2)." $1 $6  $3:$4:$5\000";

    my ($second,$minute,$hour,$day,$month,$year,$wday,$yday,$isdst) = localtime();
    $year = $year + 1900;
    $yday++;

    my ($pkthdr,$msgheader,$m_txt);

    $msg_fromaddr =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    
    my ( $msg_origzone, $msg_orignet, $msg_orignode, $msg_origpnt ) = ( $1, $2, $3, $4 );
    $msg_origpnt = 0 if !defined( $msg_origpnt ) || $msg_origpnt eq '';

    if (defined($msg_toaddr)) {
       $msg_toaddr =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
       ($msg_destzone,$msg_destnet,$msg_destnode,$msg_destpnt) = ( $1, $2, $3, $4 );
       $msg_destpnt = 0 if !defined($msg_destpnt) || $msg_destpnt eq '';
    } else {
       ($msg_destzone,$msg_destnet,$msg_destnode,$msg_destpnt) = ( 0, 0, 0, 0 );
    }

    $pkthdr = pack("S2S3S3 S2S2 C2A8S2S2 C2SS4I", $pkt_orignode,
    $pkt_destnode,$year,$month,
    $day,$hour,$minute,$second,0,2,$pkt_orignet,$pkt_destnet,3,3,
    $password,$pkt_origzone,$pkt_destzone,0, 0x0100,3,3,0x0001,
    $pkt_origzone,$pkt_destzone,$pkt_origpnt,$pkt_destpnt, 0 );

    $msgheader = pack( "S7Z20", 2,$msg_orignode,$msg_destnode,
    $msg_orignet,$msg_destnet,$attr,0,$DateTime ) . $msg_toname .
    $msg_fromname . $msg_subj;

    undef $msg_area if $msg_area eq '';
    $m_txt = "AREA:$msg_area\r" if defined($msg_area);
    $m_txt .= "\001MSGID: $msg_fromaddr ".sprintf("%08x", time())."\r\001TZUTC: $TZUTC\r";
    
# NO INTL in Echmail permitted
    $m_txt .= "\001INTL $msg_destzone:$msg_destnet/$msg_destnode $msg_origzone:$msg_orignet/$msg_orignode\r" if !defined $msg_area;
    $m_txt .= "\001CHRS: ". uc($msg_chrs)." 2" if defined $msg_chrs;
    $m_txt .= "\001FMPT $msg_origpnt\r" if $msg_origpnt != 0;
    $m_txt .= "\001TOPT $msg_destpnt\r" if $msg_destpnt != 0 && !defined $msg_area;
    $msg_fromaddr =~ /(\d+\:\d+\/\d+\.?\d*)/;
    $msg_txt .= "\r--- \r \* Origin: perl packPKT by Stas Mishchenkov [2:460/58] \($1\)\r";

    my ( $g_sec, $g_min, $g_hour, $g_mday,$g_month,$g_year) = (gmtime)[0...5];
    if ( defined( $msg_area ) ) {
       if ( $pkt_origpnt == 0 ) {
            $msg_txt .= "SEEN\-BY: $msg_orignet\/$msg_orignode $pkt_destnet\/$pkt_destnode\r".
	    "\x01PATH: $msg_orignet\/$msg_orignode\r";
       }
    } else {
	$msg_txt .= sprintf("\x01Via $pkt_from \@%04d%02d%02d\.%02d%02d%02d\.UTC perl packPKT by Stas Mishchenkov\r",
	$g_year+1900, $g_month+1, $g_mday, $g_hour, $g_min, $g_sec );
    }
    $msg_txt .= "\000\000\000";

return "$pkthdr$msgheader$m_txt$msg_txt";
}

sub packpkt
{
    my ($pkt_from,$pkt_to,$password, @msgs ) = @_;
    $pkt_from =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    my ( $pkt_origzone, $pkt_orignet, $pkt_orignode, $pkt_origpnt ) = ( $1, $2, $3, $4 );
    $pkt_origpnt = 0 if !defined $pkt_origpnt || $pkt_origpnt eq '';
    $pkt_to =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    my ( $pkt_destzone,$pkt_destnet,$pkt_destnode,$pkt_destpnt ) = ( $1,$2,$3,$4 );
    $pkt_destpnt = 0 if !defined $pkt_destpnt || $pkt_destpnt eq '';
    $password = '' unless defined $password;
    $password .= "\x00" while length($password) < 8;

    my ($second,$minute,$hour,$day,$month,$year,$wday,$yday,$isdst) = localtime();
    $year = $year + 1900;
    $yday++;

    my $pkthdr = pack("S2S3S3 S2S2 C2A8S2S2 C2SS4I", $pkt_orignode,
    $pkt_destnode,$year,$month,
    $day,$hour,$minute,$second,0,2,$pkt_orignet,$pkt_destnet,3,3,
    $password,$pkt_origzone,$pkt_destzone,0, 0x0100,3,3,0x0001,
    $pkt_origzone,$pkt_destzone,$pkt_origpnt,$pkt_destpnt, 0 );

    return $pkthdr . join('',@msgs) . "\000\000";
}

sub packedmsg($$$$$$$;$$)
{
    my ( $msg_fromname, $msg_toname, $msg_fromaddr, $msg_toaddr, $attr,
         $msg_txt, $msg_subj, $msg_area, $msg_chrs ) = @_;

    my ( $msgheader,$m_txt,$msg_destzone,$msg_destnet,$msg_destnode,
         $msg_destpnt);

    if (length($msg_fromname) > 35){
	$msg_fromname = substr($msg_fromname,0,35);
    }
    $msg_fromname .= "\000";
    if (length($msg_toname) > 35){
	$msg_toname = substr($msg_toname,0,35);
    }
    $msg_toname .= "\000";
    if (length($msg_subj) > 71){
	$msg_subj = substr($msg_subj,0,71);
    }
    $msg_subj .= "\000";

    localtime =~ /[a-z]+ ([a-z]+)[ ]+(\d+) (\d+)\:(\d+)\:(\d+) \d\d(\d\d)/i;
    my $DateTime = sprintf("%02s", $2)." $1 $6  $3:$4:$5\000";

    $msg_fromaddr =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
    
    my ( $msg_origzone, $msg_orignet, $msg_orignode, $msg_origpnt ) = ( $1, $2, $3, $4 );
    $msg_origpnt = 0 if !defined( $msg_origpnt ) || $msg_origpnt eq '';

    if ( defined($msg_toaddr) ) {
       $msg_toaddr =~ /(\d+)\:(\d+)\/(\d+)\.?(\d*)/;
       ($msg_destzone,$msg_destnet,$msg_destnode,$msg_destpnt) = ( $1, $2, $3, $4 );
       $msg_destpnt = 0 if !defined($msg_destpnt) || $msg_destpnt eq '';
    } else {
       ($msg_destzone,$msg_destnet,$msg_destnode,$msg_destpnt) = ( 0, 0, 0, 0 );
    }

    $msgheader = pack( "S7Z20", 2,$msg_orignode,$msg_destnode,
    $msg_orignet,$msg_destnet,$attr,0,$DateTime ) . $msg_toname .
    $msg_fromname . $msg_subj;

    $m_txt = "AREA:$msg_area\r" if defined($msg_area);
    my $TZUTC = sprintf( "%04d", tzoffset( localtime() ) );
    $m_txt .= "\001MSGID: $msg_fromaddr ".sprintf("%08x", time())."\r\001TZUTC: $TZUTC\r";
    
# NO INTL in Echmail permitted
    $m_txt .= "\001INTL $msg_destzone:$msg_destnet/$msg_destnode $msg_origzone:$msg_orignet/$msg_orignode\r" if !defined $msg_area;
    $m_txt .= "\001CHRS: ".uc($msg_chrs)." 2\r" if defined $msg_chrs;
    $m_txt .= "\001FMPT $msg_origpnt\r" if $msg_origpnt != 0;
    $m_txt .= "\001TOPT $msg_destpnt\r" if $msg_destpnt != 0 && !defined $msg_area;
    $msg_fromaddr =~ /(\d+\:\d+\/\d+\.?\d*)/;
    $msg_txt .= "\r--- \r \* Origin: perl packPKT by Stas Mishchenkov [2:460/58] \($1\)\r";

    my ( $g_sec, $g_min, $g_hour, $g_mday,$g_month,$g_year) = (gmtime)[0...5];
    if ( defined( $msg_area ) ) {
       if ( $msg_origpnt == 0 ) {
            $msg_txt .= "SEEN\-BY: $msg_orignet\/$msg_orignode\r".
	    "\x01PATH: $msg_orignet\/$msg_orignode\r";
       }
    } else {
	$msg_txt .= sprintf("\x01Via $msg_fromaddr \@%04d%02d%02d\.%02d%02d%02d\.UTC perl packPKT by Stas Mishchenkov\r",
	$g_year+1900, $g_month+1, $g_mday, $g_hour, $g_min, $g_sec );
    }
return "$msgheader$m_txt$msg_txt\000";
}

sub writepkt($$)
{
   my ( $dir, $pkt ) = @_;

   my $tmppath = catfile( $dir, 'temp.tmp' );
   make_path( $tmppath, { mode => 0755, } );
   my $tmppktname = catfile( $tmppath, sprintf( "%08x", time() ) . '.qqq' );
   $tmppktname = catfile( $tmppath, sprintf( "%08x", time() + 1 ) . '.qqq' ) while -e $tmppktname;
   if ( open( my $fh, ">$tmppktname" ) ) {
      binmode($fh);
      print $fh $pkt;
      close($fh);
   } else {
      print STDERR "Can't open $tmppktname ($!).\n";
      return;
   }
   my $pktname = catfile( $dir, sprintf( "%08x", time() ) . '.pkt' );
   $pktname = catfile( $dir, sprintf( "%08x", time() + 1 ) . '.pkt' ) while -e $pktname;
   print STDERR "Can't rename $tmppktname to $pktname ($!)\n" unless move($tmppktname,$pktname);
}

1;