FIDOMAIL.pm is replaced with FTNMAIL.pm. Expect bugs.
The internal mail data structure has changed
and is documented in docs/ftn.txt now.
All Fido-specific helper functions from MISC.pm are gone.
The configuration entry "address" is renamed to "ftn_address",
and "in_charset" is gone. Always assuming CP437 seems reasonable.
--- /dev/null
+FTN Module Documentation
+========================
+
+$mail = {
+ 'area' => "MYAREA", # ECHOMAIL only
+ 'fname' => "Alice", # UTF-8
+ 'tname' => "Bob", # UTF-8
+ 'subj' => "Subject", # UTF-8
+ 'body' => "Body", # UTF-8
+ 'from' => "z:n/n.p",
+ 'to' => "z:n/n.p", # NETMAIL only
+ 'date' => [ year, month, day ],
+ 'time' => [ hour, minute, second],
+ 'msgid' => "z:n/n.p XXXXXXXX", # used for dupe-detection
+ 'reply' => "z:n/n.p YYYYYYYY", # link to previous mail
+ 'path' => "net/node ...", # ECHOMAIL only
+ 'seen' => "net/node ...", # ECHOMAIL only
+};
+
+The 'area' key never exists for NETMAIL, and always exists for ECHOMAIL.
# check mandatory keywords
my @keywords = (
- 'address', 'in_charset', 'out_charset',
+ 'ftn_address', 'out_charset',
'dbase_driver', 'dbase_path', 'dbase_user', 'dbase_pass',
'netmail', 'outbound', 'areafix',
);
}
# fix non-strings
- $config{address} = MISC::text2fido($config{address});
+ $config{ftn_address} = MISC::text2fido($config{ftn_address});
1;
+++ /dev/null
-#!/usr/bin/perl -w
-use strict;
-use v5.012;
-
-use CONFIG;
-use MISC;
-use Data::Dumper;
-
-# =========================================================================
-# Perl module to handle FTN style mail
-#
-# mails are stored in the msgbase
-# messages are stored in packet files
-#
-# read_message(): parse single message
-# $mail = read_message($message)
-# returns mail-hashref or undef on error
-#
-# write_message(): create message (TODO)
-# $message = write_message($mail)
-# takes mail-hashref
-# returns message-hashref of undef on error
-#
-# read_packet_file(): parse *.PKT file
-# $messages = read_packet_file($filename)
-# returns arrayref of message-hashrefs or undef on error
-#
-# write_packet_file(): create *.PKT file (TODO)
-# write_packet_file($filename, $messages)
-# takes arrayref of message-hashrefs
-# returns true on success, undef on error
-# =========================================================================
-
-package FIDOMAIL;
-use Encode;
-
-my $addrregex = qr/^(|(\d+):)(\d+)\/(\d+)(|\.(\d+))(|\@([\w\.]+))$/;
- # (zone, net, node, point, domain) = ($2, $3, $4, $6, $8)
-
-sub read_message($)
-{
- my ($message) = @_;
- my (%mail, @seenby, @path, $charset);
-
- # replace CRLF and CR with newlines
- $message->{body} =~ s/\x0D\x0A/\n/g;
- $message->{body} =~ s/\x0D/\n/g;
-
- # filter out area
- $mail{area} = $2 if($message->{body} =~ s/^(\x01|)AREA:(.+)(\n)//);
-
- # parse buffer line by line
- my $body = "";
- my ($intl, $fmpt, $topt);
- foreach(split(/^/, $message->{body})) {
- chomp;
-
- # PATH or SEEN-BY kludge
- if(/^(\x01|)(PATH|SEEN-BY): (.*)$/) {
- my ($net, $node);
- my $key = $2;
- foreach(split(/ /, $3)) {
- if(/(\d+)\/(\d+)/) {
- $net = $1; $node = $2;
- } else {
- $node = $_;
- }
-
- if($key eq 'PATH') {
- push(@{$mail{path}}, [$net, $node]);
- } elsif($key eq 'SEEN-BY') {
- push(@{$mail{seen}}, [$net, $node]);
- } else {
- die("Impossible keyword $key!");
- }
- }
- next;
- }
-
- # kludge lines
- if(/^\x01(\S+) (.+)$/) {
- my ($kludge, $data) = ($1, $2);
- if($kludge =~ /MSGID:/) {
- $mail{msgid} = $data;
- } elsif($kludge =~ /REPLY:/) {
- $mail{reply} = $data;
- } elsif($kludge =~ /PID:/) {
- $mail{pid} = $data;
- } elsif($kludge =~ /TID:/) {
- $mail{tid} = $data;
- } elsif($kludge =~ /(CHRS:|CHARSET)/) {
- if($MISC::charsets{from}->{$data}) {
- $charset =
- $MISC::charsets{from}->{$data};
- } else {
- say("Unknown CHRS '$data'!");
- }
- } elsif($kludge =~ /CODEPAGE/) {
- if($MISC::charsets{from}->{"CP$data 2"}) {
- $charset =
- $MISC::charsets{from}->{"CP$data 2"};
- } else {
- say("Unknown CODEPAGE '$data'");
- }
- } elsif($kludge =~ /INTL/) {
- $intl = $data;
- } elsif($kludge =~ /FMPT/) {
- $fmpt = $data;
- } elsif($kludge =~ /TOPT/) {
- $topt = $data;
- } elsif($kludge =~ /TZUTC|Via/) {
- # FIXME: ignored
- } else {
- # FIXME: generic header
- say("Unknown kludge '$kludge' '$data'");
- }
- next;
- }
-
- # not a kludge line
- $body .= "$_\n";
- }
-
- # build mail
- $mail{fname} = $message->{fname};
- $mail{tname} = $message->{tname};
- $mail{date} = $message->{date};
- $mail{time} = $message->{time};
- $mail{attr} = $message->{attr};
- $mail{packet} = $message->{packet};
-
- # decode subject and body to utf-8
- $charset = $CONFIG::config{in_charset} unless($charset);
- $mail{subj} = decode($charset, $message->{subj});
- $mail{body} = decode($charset, $body);
-
- # find FROM and TO addresses
- if(!$mail{area}) {
- # --> NETMAIL
- if($intl) {
- if($intl=~ /^(\d+):(\d+)\/(\d+) (\d+):(\d+)\/(\d+)$/) {
- if($fmpt) {
- $mail{from} = [ $4, $5, $6, $fmpt ];
- } else {
- $mail{from} = [ $4, $5, $6, 0 ];
- }
-
- if($topt) {
- $mail{to} = [ $1, $2, $3, $topt ];
- } else {
- $mail{to} = [ $1, $2, $3, 0 ];
- }
- } else {
- say("Cannot parse INTL '$intl' (fname=$mail{fname})!");
- }
- } elsif($mail{packet}) {
- say("Took FROM/TO from packet (fname=$mail{fname})!");
- $mail{from} = $mail{packet}->{from};
- $mail{to} = $mail{packet}->{to};
- } else {
- say("Don't know FROM/TO address (fname=$mail{fname})!");
- $mail{from} = [ 0, 0, 0, 0 ];
- $mail{to} = [ 0, 0, 0, 0 ];
- }
- } else {
- # --> ECHOMAIL
- if($mail{msgid} && $mail{msgid} =~ /^(\S+) \S+$/ &&
- $1 =~ $addrregex) {
- # --> use MSGID
- my @addr = ($2, $3, $4, $6, $8);
- $addr[0] = $CONFIG::config{address}[0]
- unless($addr[0]);
- $addr[3] = 0 unless($addr[3]);
- $mail{from} = [ @addr[0..3] ];
- } elsif($body =~ /\n \* Origin: (.*) \((.+?)\)\n/m &&
- $2 =~ $addrregex){
- # --> use Origin line
- my @addr = ($2, $3, $4, $6);
- $addr[0] = $CONFIG::config{address}[0]
- unless($addr[0]);
- $addr[3] = 0 unless($addr[3]);
- $mail{from} = [ @addr[0..3] ];
- } else {
- # --> use 0:0/0.0 as unknown address
- say("Don't know FROM address (fname=$mail{fname})!");
- $mail{from} = [ 0, 0, 0, 0 ];
- }
- }
-
- return(\%mail);
-}
-
-sub write_message($)
-{
- my ($mail) = @_;
-
- die("write_message not implemented");
-}
-
-sub read_packet_file($)
-{
- my ($filename) = @_;
- my ($buf, @messages);
-
- if(!$filename) {
- die("read_packet_file() called without filename!");
- return(undef);
- }
-
- if(!open(PKT, '<', "$filename")) {
- die("Can't open packet file $filename!");
- return(undef);
- }
- binmode(PKT);
-
- # read packet header
- if(read(PKT, $buf, 0x3a) != 0x3a) {
- die("Corrupted packet file $filename: Too short!");
- close(PKT);
- return(undef);
- }
-
- # parse packet header
- my ($onode, $dnode, $year, $month, $day, $hour, $minute, $second,
- $baud, $type, $onet, $dnet, $prodL, $revMaj, $password,
- $Qozone, $Qdzone, $auxnet, $cwcopy, $prodH, $revMin, $cw,
- $ozone, $dzone, $opoint, $dpoint, $data) = unpack(
- "v v v v v v v v v v v v C C Z8 v v v n C C v v v v v a4", $buf);
-
- if($type != 2) {
- die("Unsupported packet file type $type!");
- close(PKT);
- return(undef);
- }
-
- my %packet;
- if(($cw == $cwcopy) && ($cw != 0) && ($cw & 0x0001)) {
- # FSC-0048 packet type 2+
- $onet = $auxnet if($onet == 0xFFFF && $opoint != 0);
- $packet{from} = [ $ozone, $onet, $onode, $opoint ];
- $packet{to} = [ $dzone, $dnet, $dnode, $dpoint ];
- $packet{product} = ($prodH << 16) | $prodL;
- $packet{revision} = "$revMaj.$revMin";
- $packet{type} = "FSC-0048";
- } else {
- # FTS-0001 packet type 2
- $packet{from} = [ $Qozone, $onet, $onode, 0 ];
- $packet{to} = [ $Qdzone, $dnet, $dnode, 0 ];
- $packet{product} = $prodL;
- $packet{revision} = "$revMaj";
- $packet{type} = "FTS-0001";
- }
- $packet{date} = [ $year, $month, $day ];
- $packet{time} = [ $hour, $minute, $second ];
-
- # read messages
- while(1) {
- # check message type
- if(read(PKT, $buf, 2) != 2) {
- die("Corrupted packet file $filename: Too short!");
- close(PKT);
- return(undef);
- }
- my $type = unpack("v", $buf);
- if($type == 0) {
- close(PKT);
- return(\@messages);
- } elsif($type != 2) {
- die("Unsupported message type $type!");
- close(PKT);
- return(undef);
- }
-
- # read message (FTS-0001)
- if(read(PKT, $buf, 0x20) != 0x20) {
- die("Corrupted packet file $filename: Too short!");
- close(PKT);
- return(undef);
- }
-
- # parse message
- my %message;
- my ($onode, $dnode, $onet, $dnet, $attr, $cost, $dt) = unpack(
- "v v v v v v Z20", $buf);
- do {
- local $/ = "\0";
- $message{tname} = <PKT>; chop($message{tname});
- $message{fname} = <PKT>; chop($message{fname});
- $message{subj} = <PKT>; chop($message{subj});
- $message{body} = <PKT>; chop($message{body});
- };
- $message{from} = [ 0, $onet, $onode, 0 ];
- $message{to} = [ 0, $dnet, $dnode, 0 ];
-
- # generate attribute word
- $message{attr} = { };
- if($attr & 4) { # 2^2
- $message{attr}->{state} = 1; # received
- } elsif($attr & 8) { # 2^3
- $message{attr}->{state} = 2; # sent
- } else {
- $message{attr}->{state} = 0; # local
- }
-
- if($attr & 2) { # 2^1
- $message{attr}->{transfer} = 1; # crash
- } elsif($attr & 512) { # 2^9
- $message{attr}->{transfer} = 2; # hold
- } else {
- $message{attr}->{transfer} = 0; # default
- }
-
- if($attr & 16) { # 2^4
- $message{attr}->{file} = 1; # file attached
- } elsif($attr & 2048) { # 2^11
- $message{attr}->{file} = 2; # file request
- } elsif($attr & 32768) { # 2^15
- $message{attr}->{file} = 3; # update req.
- } else {
- $message{attr}->{file} = 0; # nothing
- }
-
- my @dt = MISC::read_datestring($dt);
- $message{date} = [ $dt[0], $dt[1], $dt[2] ];
- $message{time} = [ $dt[3], $dt[4], $dt[5] ];
-
- # save message
- $message{packet} = \%packet;
- push @messages, \%message;
- }
-}
-
-sub write_packet_file($$)
-{
- my ($filename, $messages) = @_;
-
- die("write_packet_file not implemented");
-}
-
-1;
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use v5.012;
+
+use CONFIG;
+
+# =========================================================================
+# Perl module to handle FTN style mail
+#
+# $string = pack_mail($mail)
+# converts a mail to a packed message string (see FTS-0001, C.1)
+# returns undef on error
+#
+# @mails = unpack_packet($filename)
+# reads a packet file (see FTS-0001, F.1) and returns an array of mails
+# returns undef on error, dies on file error
+# =========================================================================
+package FTNMAIL;
+
+use Encode;
+use Text::Wrap;
+
+# helper functions
+sub chrs2charset($); sub charset2chrs($); # charset
+sub str2datetime($); sub datetime2str(@); # datetime string
+sub str2ftn($); sub ftn2str(@); # ftn address
+
+sub pack_mail($)
+{
+ my $mail = shift;
+ my $output;
+
+ # encode subject/body correctly
+ my $charset = $CONFIG::config{out_charset};
+ my $chrs = charset2chrs($charset) or return(undef);
+ my $subj = encode($charset, $mail->{subj});
+ my $body = encode($charset, $mail->{body});
+ $body =~ s/\n/\x0D/g;
+
+ # generate kludge lines
+ my @kludges;
+ if($mail->{area}) {
+ # ECHOMAIL: AREA
+ push(@kludges, "AREA:$mail->{area}\x0D");
+ } else {
+ # NETMAIL: INTL, FMPT and TOPT
+ my @from = str2ftn($mail->{from}) or return(undef);
+
+ my @to = str2ftn($mail->{to}) or return(undef);
+ push(@kludges, "\x01INTL: $to[0]:$to[1]/$to[2] ".
+ "$from[0]:$from[1]/$from[2]\x0D");
+ push(@kludges, "\x01FMPT: $from[3]\x0D") if($from[3]);
+ push(@kludges, "\x01TOPT: $to[3]\x0D") if($to[3]);
+ }
+ push(@kludges, "\x01MSGID: $mail->{msgid}\x0D") if($mail->{msgid});
+ push(@kludges, "\x01REPLY: $mail->{reply}\x0D") if($mail->{reply});
+ push(@kludges, "\x01CHRS: $chrs\x0D");
+ push(@kludges, "\x01PID: http://sraa.de/git/?p=fido.git\x0D");
+ $output = join("", @kludges) . $body;
+
+ # additional kludge lines
+ if($mail->{area}) {
+ # ECHOMAIL: SEEN-BY and PATH
+ local($Text::Wrap::columns) = 69;
+ local($Text::Wrap::separator) = '|';
+
+ if($mail->{seen}) {
+ my @seen = split(/\|/, wrap("", "", $mail->{seen}));
+ $output .= "SEEN-BY: $_\x0D" foreach(@seen);
+ }
+
+ if($mail->{path}) {
+ my @path = split(/\|/, wrap("", "", $mail->{path}));
+ $output .= "PATH: $_\x0D" foreach(@path);
+ }
+ }
+
+ # ECHOMAIL: no destination - use origin instead
+ $mail->{to} = $mail->{from} if($mail->{area});
+
+ my $datetime = datetime2str(@{$mail->{date}}, @{$mail->{time}});
+ my @from = str2ftn($mail->{from});
+ my @to = str2ftn($mail->{to});
+
+ my $pack = pack("v v v v v v v Z20 Z* Z* Z* Z*",
+ 2, # Version
+ $from[2], $to[2], # Orig/Dest Node
+ $from[1], $to[1], # Orig/Dest Net
+ 0, # Attribute
+ 0, # Cost
+ $datetime, # Date/Time String
+ $mail->{tname}, $mail->{fname}, # From/To
+ $subj, $output # Subject/Body
+ );
+ return($pack);
+}
+
+sub unpack_body($$$$)
+{
+ my ($tname, $fname, $subj, $text) = @_;
+ my %mail;
+
+ # replace CRLF and CR with newlines
+ $text =~ s/\x0D\x0A/\n/g;
+ $text =~ s/\x0D/\n/g;
+
+ # save area
+ $mail{area} = $2 if($text =~ s/^(\x01|)AREA:(.+)\n//);
+
+ # now walk the text line by line
+ my ($intl, $fmpt, $topt, $charset);
+ my $path = ""; my $seen = ""; my $body = "";
+ foreach(split(/^/, $text)) {
+ chomp;
+
+ if(/^(\x01|)PATH: (.*)$/) { # PATH
+ $path .= "$2 "; next;
+ } elsif(/^(\x01|)SEEN-BY: (.*)$/) { # SEEN-BY
+ $seen .= "$2 "; next;
+ } elsif(/^\x01(\S+) (.+)$/) { # kludge
+ my ($kludge, $data) = ($1, $2);
+
+ if($kludge =~ /MSGID:/) {
+ $mail{msgid} = $data;
+ } elsif($kludge =~ /REPLY:/) {
+ $mail{reply} = $data;
+ } elsif($kludge =~ /INTL/) {
+ $intl = $data;
+ } elsif($kludge =~ /FMPT/) {
+ $fmpt = $data;
+ } elsif($kludge =~ /TOPT/) {
+ $topt = $data;
+ } elsif($kludge =~ /(CHRS:|CHARSET)/) {
+ $charset = chrs2charset($data);
+ } elsif($kludge =~ /CODEPAGE/) {
+ $charset = chrs2charset("CP$data 2");
+ } elsif($kludge =~ /(PID|TID|TZUTC|Via)/) {
+ # TODO: ignored
+ } else {
+ LOG::warn("Unknown kludge '$kludge' '$data'");
+ }
+ } else { # normal body line
+ $body .= "$_\n";
+ }
+ }
+
+ # decode all strings to utf-8
+ $charset = 'cp437' unless($charset);
+ $mail{fname} = decode($charset, $fname);
+ $mail{tname} = decode($charset, $tname);
+ $mail{subj} = decode($charset, $subj);
+ $mail{body} = decode($charset, $body);
+
+ # find FROM and TO addresses
+ if(!$mail{area}) {
+ # --> NETMAIL: use INTL/FMPT/TOPT
+ if($intl && $intl=~/^(\d+):(\d+)\/(\d+) (\d+):(\d+)\/(\d+)$/) {
+ if($fmpt) {
+ $mail{from} = "$4:$5/$6.$fmpt";
+ } else {
+ $mail{from} = "$4:$5/$6";
+ }
+
+ if($topt) {
+ $mail{to} = "$1:$2/$3.$topt";
+ } else {
+ $mail{to} = "$1:$2/$3";
+ }
+ } elsif($intl) {
+ LOG::warn("Invalid INTL '$intl' (from $fname)!");
+ }
+ } else {
+ # --> ECHOMAIL: use MSGID, then Origin
+ if(!$mail{from} &&
+ $mail{msgid} && $mail{msgid} =~ /^(\S+) \S+$/) {
+ $mail{from} = ftn2str(str2ftn($1));
+ }
+
+ if(!$mail{from} &&
+ $mail{body} =~ /\n \* Origin: (.*) \((.+?)\)\n/m) {
+ $mail{from} = ftn2str(str2ftn($2));
+ }
+
+ if(!$mail{from}) {
+ LOG::warn("Unknown FROM (fname=$fname)!");
+ }
+ }
+
+ return(%mail);
+}
+
+sub unpack_packet($)
+{
+ my $file = shift;
+ my $buf, my @mails;
+
+ die("No filename!") unless($file);
+ open(PKT, '<', $file) or die("Can't open $file!\n");
+ binmode(PKT);
+
+ die("Short packet!") if(read(PKT, $buf, 0x3a) != 0x3a);
+
+ # parse packet header
+ my ($onode, $dnode, $year, $month, $day, $hour, $minute, $second,
+ $baud, $type, $onet, $dnet, $prodL, $revMaj, $password,
+ $Qozone, $Qdzone, $auxnet, $cwcopy, $prodH, $revMin, $cw,
+ $ozone, $dzone, $opoint, $dpoint, $data) = unpack(
+ "v v v v v v v v v v v v C C Z8 v v v n C C v v v v v a4", $buf);
+
+ die("Unsupported packet type $type!") unless($type == 2);
+
+ my %packet;
+ if(($cw == $cwcopy) && ($cw != 0) && ($cw & 0x0001)) {
+ # FSC-0048 packet type 2+
+ $onet = $auxnet if($onet == 0xFFFF && $opoint != 0);
+ $packet{from} = [ $ozone, $onet, $onode, $opoint ];
+ $packet{to} = [ $dzone, $dnet, $dnode, $dpoint ];
+ $packet{product} = ($prodH << 16) | $prodL;
+ $packet{revision} = "$revMaj.$revMin";
+ $packet{type} = "FSC-0048";
+ } else {
+ # FTS-0001 packet type 2
+ $packet{from} = [ $Qozone, $onet, $onode, 0 ];
+ $packet{to} = [ $Qdzone, $dnet, $dnode, 0 ];
+ $packet{product} = $prodL;
+ $packet{revision} = "$revMaj";
+ $packet{type} = "FTS-0001";
+ }
+ $packet{date} = [ $year, $month, $day ];
+ $packet{time} = [ $hour, $minute, $second ];
+
+ # read packed messages
+ while(1) {
+ die("Short packet!") if(read(PKT, $buf, 2) != 2);
+
+ my $type = unpack("v", $buf);
+ if($type == 0) {
+ close(PKT);
+ return(@mails);
+ } elsif($type != 2) {
+ die("Unsupported message type $type!");
+ }
+
+ die("Short packet!") if(read(PKT, $buf, 0x20) != 0x20);
+
+ # parse message header
+ my ($tname, $fname, $subj, $text);
+ my ($onode, $dnode, $onet, $dnet, $attr, $cost, $dt) = unpack(
+ "v v v v v v Z20", $buf);
+ do {
+ local $/ = "\0";
+ $tname = <PKT>; chop($tname);
+ $fname = <PKT>; chop($fname);
+ $subj = <PKT>; chop($subj);
+ $text = <PKT>; chop($text);
+ };
+
+ # parse message body
+ my %mail = unpack_body($tname, $fname, $subj, $text);
+
+ # add time and date
+ my @dt = str2datetime($dt);
+ $mail{date} = [ $dt[0], $dt[1], $dt[2] ];
+ $mail{time} = [ $dt[3], $dt[4], $dt[5] ];
+
+ # NETMAIL: add 3D from/to from headers if missing (fallback)
+ if(!$mail{area}) {
+ if(!$mail{from}) {
+ LOG::warn("Took FROM from packet ".
+ "(fname = $fname)");
+ $mail{from}="$packet{from}->[0]:$onet/$onode";
+ }
+
+ if(!$mail{to}) {
+ LOG::warn("Took TO from packet ".
+ "(fname = $fname)");
+ $mail{to}="$packet{to}->[0]:$dnet/$dnode";
+ }
+ }
+
+ push @mails, \%mail;
+ }
+}
+
+# === Date / Time conversion ==============================================
+my %months = ("Jan" => 1, "Feb" => 2, "Mar" => 3, "Apr" => 4,
+ "May" => 5, "Jun" => 6, "Jul" => 7, "Aug" => 8,
+ "Sep" => 9, "Oct" => 10, "Nov" => 11, "Dec" => 12);
+my @months = ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+
+sub str2datetime($)
+{
+ my $str = shift;
+ my ($year, $month, $day, $hour, $minute, $second);
+ if($str =~ /(\s\d|\d\d) (\w{3}) (\d{2}) (\d{2}):(\d{2}):(\d{2})/) {
+ # Fido format: "21 Feb 14 02:30:31"
+ ($year, $month, $day) = ($3, $months{$2}, $1);
+ ($hour, $minute, $second) = ($4, $5, $6);
+ } elsif($str =~ /(\w{3}) (\s\d|\d\d) (\w{3}) (\d{2}) (\d{2}):(\d{2})/) {
+ # SEAdog format: "Mon 1 Jan 86 02:34"
+ ($year, $month, $day) = ($4, $months{$3}, $2);
+ ($hour, $minute, $second) = ($5, $6, 0);
+ } else {
+ LOG::warn("Unknown date format '$str'!");
+ return(undef);
+ }
+
+ if($year < 80) {
+ $year += 2000; # 21st century
+ } elsif($year < 200) {
+ $year += 1900; # 20st century or non-y2k 21st century
+ }
+
+ return(int($year), int($month), int($day),
+ int($hour), int($minute), int($second));
+}
+
+sub datetime2str(@)
+{
+ my @date = @_;
+
+ return(sprintf("%02d %s %02d %02d:%02d:%02d",
+ $date[2], $months[$date[1]-1], $date[0] % 100,
+ $date[3], $date[4], $date[5]));
+}
+
+# === FTN address conversion ==============================================
+sub str2ftn($)
+{
+ my $str = shift;
+
+ if($str =~ /^(\d+):(\d+)\/(\d+)\.(\d+)(|@([\.\w]+))$/) {
+ if($4) {
+ return($1, $2, $3, $4);
+ } else {
+ return($1, $2, $3);
+ }
+ } elsif($str =~ /^(\d+):(\d+)\/(\d+)(|@([\.\w]+))$/) {
+ return($1, $2, $3);
+ }
+
+ LOG::warn("Invalid FTN string '$str'!");
+ return(undef);
+}
+
+sub ftn2str(@)
+{
+ my @fido = @_;
+ if(defined $fido[0] && defined $fido[1] && defined $fido[2]) {
+ if($fido[3]) {
+ return("$fido[0]:$fido[1]/$fido[2].$fido[3]");
+ } else {
+ return("$fido[0]:$fido[1]/$fido[2]");
+ }
+ } elsif($fido[0]) {
+ LOG::warn("Invalid FTN address: " . join(":", @fido) . "!");
+ return(undef);
+ }
+
+ return(undef);
+}
+
+# === Charset conversion ==================================================
+my %charsets = (
+ 'from' => {
+ # obsolete level 1 (ascii replacement)
+ 'ASCII 1' => 'ascii', 'DUTCH 1' => 'ascii',
+ 'FINNISH 1' => 'ascii', 'FRENCH 1' => 'ascii',
+ 'CANADIAN 1' => 'ascii', 'GERMAN 1' => 'ascii',
+ 'ITALIAN 1' => 'ascii', 'NORWEIG 1' => 'ascii',
+ 'PORTU 1' => 'ascii', 'SPANISH 1' => 'ascii',
+ 'SWEDISH 1' => 'ascii', 'SWISS 1' => 'ascii',
+ 'UK 1' => 'ascii', 'ISO-10 1' => 'ascii',
+
+ # level 2 (codepage)
+ 'CP437 2' => 'cp437', 'IBMPC 2' => 'cp437',
+ 'IBMPC' => 'cp437', 'CP848 2' => 'cp848',
+ 'CP850 2' => 'cp850', 'CP852 2' => 'cp852',
+ 'CP866 2' => 'cp866', '+7_FIDO 2' => 'cp866',
+ 'CP1250 2' => 'cp1250', 'CP1251 2' => 'cp1251',
+ 'CP1252 2' => 'cp1252', 'CP10000 2' => 'MacRoman',
+ 'LATIN-1 2' => 'iso-8859-1', 'LATIN-2 2' => 'iso-8859-2',
+ 'LATIN-5 2' => 'iso-8859-9', 'LATIN-9 2' => 'iso-8859-15',
+
+ # level 4 (utf-8)
+ 'UTF-8 2' => 'utf-8', 'UTF-8 4' => 'utf-8',
+ },
+ 'to' => {
+ # if not listed here, inverse 'from' mappings
+ 'cp437' => 'CP437 2', 'cp866' => 'CP866 2',
+ 'utf-8' => 'UTF-8 4', 'ascii' => 'ASCII 1',
+ },
+);
+
+sub chrs2charset($)
+{
+ my ($c) = @_;
+ return($charsets{from}->{$c}) if($charsets{from}->{$c});
+
+ LOG::warn("Unknown CHRS '$c'!");
+ return(undef);
+}
+
+sub charset2chrs($)
+{
+ my ($c) = @_;
+ return($charsets{to}->{$c}) if($charsets{to}->{$c});
+
+ foreach(keys %{$charsets{from}}) {
+ return($_) if($charsets{from}->{$_} eq $c);
+ }
+
+ LOG::warn("Unknown CHARSET '$c'!");
+ return(undef);
+}
+
+package LOG;
+sub info { say "INFO: $_[0]"; }
+sub warn { say "WARN: $_[0]"; }
+
+1;
# =========================================================================
# miscellanous helper functions
-# %charsets: map ftn CHRS names to common charset names and back
-#
-# read_datestring(): turn a date/time string into list
-# (y,m,d,h,m,s) = read_datestring($string)
-# write_datestring(): turn a list into a date/time string
-# $str = write_datestring(y,m,d,h,m,s)
-#
-# format converters (die on error)
-# fido2text(): convert [ zone,net,node,point ] to "zone:net/node.point"
-# text2fido(): convert "zone:net/node.point" to [ zone,net,node,point ]
-# netnodelist2text(): convert [ [net,node], ... ] to "net/node,..."
-# text2netnodelist(): convert "net/node,..." to [ [net,node], ... ]
#
# date2text(): convert [ year,month,day ] to "yyyy-mm-dd"
# text2date(): convert "yyyy-mm-dd" to [ year,month,day ]
package MISC;
-# see FTS-5003
-our %charsets = (
- 'from' => {
- # obsolete ascii replacement maps (treated as ascii)
- 'ASCII 1' => 'ascii',
- 'DUTCH 1' => 'ascii',
- 'FINNISH 1' => 'ascii',
- 'FRENCH 1' => 'ascii',
- 'CANADIAN 1' => 'ascii',
- 'GERMAN 1' => 'ascii',
- 'ITALIAN 1' => 'ascii',
- 'NORWEIG 1' => 'ascii',
- 'PORTU 1' => 'ascii',
- 'SPANISH 1' => 'ascii',
- 'SWEDISH 1' => 'ascii',
- 'SWISS 1' => 'ascii',
- 'UK 1' => 'ascii',
- 'ISO-10 1' => 'ascii',
-
- # codepage mappings
- 'CP437 2' => 'cp437',
- 'IBMPC 2' => 'cp437',
- 'IBMPC' => 'cp437',
- 'CP848 2' => 'cp848',
- 'CP850 2' => 'cp850',
- 'CP852 2' => 'cp852',
- 'CP866 2' => 'cp866',
- '+7_FIDO 2' => 'cp866',
- 'CP1250 2' => 'cp1250',
- 'CP1251 2' => 'cp1251',
- 'CP1252 2' => 'cp1252',
- 'CP10000 2' => 'MacRoman',
- 'LATIN-1 2' => 'iso-8859-1',
- 'LATIN-2 2' => 'iso-8859-2',
- 'LATIN-5 2' => 'iso-8859-9',
- 'LATIN-9 2' => 'iso-8859-15',
-
- # utf-8
- 'UTF-8 2' => 'utf-8',
- 'UTF-8 4' => 'utf-8',
- },
- 'to' => {
- # if not listed here, use inverse 'from' mappings
- 'cp437' => 'CP437 2',
- 'cp866' => 'CP866 2',
- 'utf-8' => 'UTF-8 4',
- },
-);
-
-sub read_datestring($)
-{
- my %months = (
- "Jan" => 1, "Feb" => 2, "Mar" => 3, "Apr" => 4,
- "May" => 5, "Jun" => 6, "Jul" => 7, "Aug" => 8,
- "Sep" => 9, "Oct" => 10, "Nov" => 11, "Dec" => 12,
- );
-
- $_ = shift;
- my ($year, $month, $day, $hour, $minute, $second);
- if(/(\w{3}) (\s\d|\d\d) (\w{3}) (\d{2}) (\d{2}):(\d{2})/) {
- # SEAdog format: "Mon 1 Jan 86 02:34"
- ($year, $month, $day) = ($4, $months{$3}, $2);
- ($hour, $minute, $second) = ($5, $6, 0);
- } elsif(/(\s\d|\d\d) (\w{3}) (\d{2}) (\d{2}):(\d{2}):(\d{2})/) {
- # format: "21 Feb 14 02:30:31"
- ($year, $month, $day) = ($3, $months{$2}, $1);
- ($hour, $minute, $second) = ($4, $5, $6);
- } else {
- say("Unknown date format '$_'");
- return(undef);
- }
-
- if($year < 80) {
- $year += 2000; # 21st century
- } elsif($year < 200) {
- $year += 1900; # 20th century (or non-y2k 21st century)
- }
-
- # convert variables to integers and return
- ($year, $month, $day) = (int($year), int($month), int($day));
- ($hour, $minute, $second) = (int($hour), int($minute), int($second));
- return($year, $month, $day, $hour, $minute, $second);
-}
-
-sub write_datestring(@)
-{
- my @months = ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
- my @date = @_;
-
- return(sprintf("%02d %s %02d %02d:%02d:%02d",
- $date[2], $months[$date[1]-1], $date[0] % 100,
- $date[3], $date[4], $date[5])
- );
-}
-
-sub fido2text($)
-{
- return(undef) if(!defined $_[0]);
-
- my @fido = @{$_[0]};
- die("Invalid FTN address!")
- unless(defined $fido[0] && defined $fido[1] &&
- defined $fido[2]);
-
- if($fido[3] && $fido[3] != 0) {
- return("$fido[0]:$fido[1]/$fido[2].$fido[3]");
- } else {
- return("$fido[0]:$fido[1]/$fido[2]");
- }
-}
-
-sub text2fido($)
-{
- return(undef) if(!defined $_[0]);
- my $text = shift;
-
- if($text =~ /(\d+):(\d+)\/(\d+)\.(\d+)/) {
- if($4 != 0) {
- return([$1, $2, $3, $4]);
- } else {
- return([$1, $2, $3]);
- }
- } elsif($text =~ /(\d+):(\d+)\/(\d+)/) {
- return([$1, $2, $3]);
- } else {
- die("Invalid FTN address '$text'!");
- }
-}
-
-sub netnodelist2text($)
-{
- return(undef) if(!defined $_[0]);
- my @nnl = @{$_[0]};
- return(join(",", map { "$_->[0]/$_->[1]" } @nnl));
-}
-
-sub text2netnodelist($)
-{
- my @result;
- push(@result, [split(/\//, $_)]) foreach(split(/,/, $_[0]));
- return(\@result);
-}
-
sub date2text($)
{
my @date = @{$_[0]};
projects / fido.git / commitdiff