From cfd1bdec1a7eb6ce9dd78fc9feb206d459e1f5ea Mon Sep 17 00:00:00 2001 From: Sebastian Date: Sun, 15 Jun 2014 03:44:41 +0200 Subject: [PATCH] fido: big cleanup 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. --- docs/ftn.txt | 20 +++ modules/CONFIG.pm | 4 +- modules/FIDOMAIL.pm | 340 ----------------------------------- modules/FTNMAIL.pm | 422 ++++++++++++++++++++++++++++++++++++++++++++ modules/MISC.pm | 156 ---------------- 5 files changed, 444 insertions(+), 498 deletions(-) create mode 100644 docs/ftn.txt delete mode 100644 modules/FIDOMAIL.pm create mode 100644 modules/FTNMAIL.pm diff --git a/docs/ftn.txt b/docs/ftn.txt new file mode 100644 index 0000000..79307af --- /dev/null +++ b/docs/ftn.txt @@ -0,0 +1,20 @@ +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. diff --git a/modules/CONFIG.pm b/modules/CONFIG.pm index 13d990b..f2833c7 100644 --- a/modules/CONFIG.pm +++ b/modules/CONFIG.pm @@ -30,7 +30,7 @@ our %config; # 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', ); @@ -41,6 +41,6 @@ our %config; } # fix non-strings - $config{address} = MISC::text2fido($config{address}); + $config{ftn_address} = MISC::text2fido($config{ftn_address}); 1; diff --git a/modules/FIDOMAIL.pm b/modules/FIDOMAIL.pm deleted file mode 100644 index 0a9c4df..0000000 --- a/modules/FIDOMAIL.pm +++ /dev/null @@ -1,340 +0,0 @@ -#!/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} = ; chop($message{tname}); - $message{fname} = ; chop($message{fname}); - $message{subj} = ; chop($message{subj}); - $message{body} = ; 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; diff --git a/modules/FTNMAIL.pm b/modules/FTNMAIL.pm new file mode 100644 index 0000000..551cee9 --- /dev/null +++ b/modules/FTNMAIL.pm @@ -0,0 +1,422 @@ +#!/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 = ; chop($tname); + $fname = ; chop($fname); + $subj = ; chop($subj); + $text = ; 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; diff --git a/modules/MISC.pm b/modules/MISC.pm index a6e7e4f..d96003a 100644 --- a/modules/MISC.pm +++ b/modules/MISC.pm @@ -4,18 +4,6 @@ use v5.012; # ========================================================================= # 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 ] @@ -25,150 +13,6 @@ use v5.012; 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]}; -- 2.30.2