#!/usr/bin/perl use strict; use warnings; use locale; use Getopt::Long; use File::Spec::Functions; use File::Copy; use Time::TZOffset qw/tzoffset/; use FTN::JAM; use Encode qw 'decode encode'; use Cwd 'abs_path'; use Time::HiRes; use Time::Local; use pkt; use IO::Socket::IP; use Socket qw(:addrinfo SOCK_RAW); my $vers = '0.0.0.3'; my ( %config, $needhelp, $configfile, $logfile, %areas, @files, $reply_as, $pkt2bnd ); my $curpath = abs_path($0); $curpath =~ /[\\\/]([^\\\/]+)$/; my $programfile = $1; my $TZUTC = sprintf( "%04d", tzoffset( localtime() ) ); sub readconf() { my ( $F, $line, $key ); return unless defined $configfile; print "Reading config file $configfile\n"; unless( open( $F, '<', $configfile ) ) { print STDERR "Can't open config file $configfile ($!)."; exit; } my $lines = 0; while( $line = <$F> ) { $lines++; $line =~ s/[\r\n]//g; $line =~ s/ / /g; next if $line =~ /^\s*[\#\;]/; next if $line =~ /^\s+$/; next if $line eq ''; next unless $line =~ /\s*(\S+)\s+(.*?)\s*$/; $key = lc($1); $config{$key} = $2; } close($F); print "$lines lines read.\n"; } sub testconf() { if ( defined( $config{defaultchrs} ) ) { $config{defaultchrs} = lc( $config{defaultchrs} ); } else { $config{defaultchrs} = 'cp866'; } } sub read_ndl_time($) { my ( $filename ) = @_; my ( $FH, $ndlstr, $line, $nltime, %month ); $month{January} = 0; $month{February} = 1; $month{March} = 2; $month{April} = 3; $month{May} = 4; $month{June} = 5; $month{July} = 6; $month{August} = 7; $month{September} = 8; $month{October} = 9; $month{November} = 10; $month{December} = 11; if ( open( $FH, '<', $filename ) ) { $line = readline( $FH ); close( $FH ); if ( $line =~ /\;A \S+ Nodelist for \S+, (\S+) (\d+), (\d+) -- Day number \d+ : \d+/i ) { $nltime = timelocal( 0, 0, 0, $2, $month{$1}, $3 - 1900 ); return $nltime; } else { print STDERR "Probably not a nodelist file $filename.\n"; return 0; } } else { print STDERR "Cant read $filename ($!)."; return 0; } } sub findndl($) { my ( $filemask ) = @_; my $start = Time::HiRes::time(); writelog("Finding last nodelist file from $filemask."); $filemask =~ /(.*?)([^\\\/]+)$/; my ( $ndlpath, $ndlfn ) = ( $1, $2 ); my ( $nldate, $lastdate, $lastnl ); $ndlpath = './' if !defined( $ndlpath ) || $ndlpath eq ''; unless( -e $ndlpath ){ print STDERR "\'$ndlpath\' does not exist!\n"; exit; } $ndlfn =~ s/\./\\\./g; $ndlfn =~ s/\*/\.\*/g; $ndlfn =~ s/\?/\./g; $lastdate = 0; if ( opendir( DH, $ndlpath ) ) { while( readdir(DH) ) { if( $_ =~ /^${ndlfn}$/i) { $nldate = read_ndl_time( catfile( $ndlpath, $_ ) ); if ( $nldate > $lastdate ) { $lastdate = $nldate; $lastnl = $_; } } } } else { print STDERR "Can't open $ndlpath. ($!)\n"; exit; } unless( defined( $lastnl ) ) { print STDERR "Nodelist not found.\n"; writelog( 'Nodelist not found.' ); exit; } writelog( 'Last nodelist found at ' . sprintf( "%.3f" , ( Time::HiRes::time() - $start ) ) . ' seconds.' ); return catfile( $ndlpath, $lastnl ); } our %letters = ( A => '0000', F => '0500', K => '1000', P => '1500', U => '2000', a => '0030', f => '0530', k => '1030', p => '1530', u => '2030', B => '0100', G => '0600', L => '1100', Q => '1600', V => '2100', b => '0130', g => '0630', l => '1130', q => '1630', v => '2130', C => '0200', H => '0700', M => '1200', R => '1700', W => '2200', c => '0230', h => '0730', m => '1230', r => '1730', w => '2230', D => '0300', I => '0800', N => '1300', S => '1800', X => '2300', d => '0330', i => '0830', n => '1330', s => '1830', x => '2330', E => '0400', J => '0900', O => '1400', T => '1900', e => '0430', j => '0930', o => '1430', t => '1930' ); our %ZMH_s = ( '2' => '0230', '#02' => '0230', '4' => '0800', '#08' => '0800', '1' => '0900', '#09' => '0900', '3' => '1700', '#17' => '1700' ); our %ZMH_e = ( '2' => '0330', '#02' => '0330', '4' => '0900', '#08' => '0900', '1' => '1000', '#09' => '1000', '3' => '1800', '#17' => '1800' ); my ( $nldate, %sortednodes, $lnetw, %nodelist, %sysopname, %calltime, $fzone, $hostsonly, $lreg, @lines, $handle ); my $ignoredown = 1; sub readndl($) { my ( $nlist ) = @_; my ( $zone, $net, $node, $region, $dom, $ird, $domain, $start, $sysopn ); my ( $line, $keyword, $name, $phone, $flags, $port, $lport, %port, %lport, $nodes, $i, $addr, $timetocall_s, $timetocall_e ); my (%flags, $uflag, %addr, @addr, $domzone, $domreg, $domnet, $domflag); unless ( -e $nlist ) { print( "No nodelist found!\n"); writelog('ERROR! No nodelist found!'); exit; } unless (open (F, "<$nlist")) { print( "Cannot read nodelist $nlist: $!\n"); writelog("ERROR! Cannot read nodelist $nlist: $!"); exit; } print("Parsing nodelist file $nlist \n"); $start = Time::HiRes::time; $zone = $net = $node = 0; $domzone = $domreg = $domnet = $ird = ""; $domain = 'binkp.net'; $nodes = 0; while (defined($line = )) { if( $line =~ /Nodelist ([a-zA-Z]+ [a-zA-Z]+\, [a-zA-Z]+ \d+\, \d+ \-\- Day number \d+)/i) { $nldate = $1; next; } $line =~ s/\r?\n$//s; next unless $line =~ /^([a-z]*),(\d+),([^,]*),[^,]*,([^,]*),([^,]*),\d+(?:,(.*))?\s*$/i; ($keyword, $node, $name,$sysopn ,$phone, $flags) = ($1, $2, $3, $4, $5, $6); unless( $ignoredown ) { next if $keyword eq 'Down'; next if $keyword eq 'Hold'; } $uflag = ''; %flags = (); %addr = (); @addr = (); # undef $timetocall; if ($keyword eq 'Zone') { $zone = $region = $net = $node; } if ( defined($flags) ) { if ( $flags =~ /\bCM\b/ ) { $timetocall_s = '0000'; $timetocall_e = '2400'; } elsif ( $flags =~ /\bICM\b/ ) { $timetocall_s = '0000'; $timetocall_e = '2400'; } elsif ( $flags =~ /\bT([a-z])([a-z])\b/i ) { $timetocall_s = $letters{$1}; $timetocall_e = $letters{$2}; } else { if ( $flags =~ /(\#\d\d)/ ) { $timetocall_s = $ZMH_s{$1}; $timetocall_e = $ZMH_e{$1}; } else { $timetocall_s = $ZMH_s{$zone}; $timetocall_e = $ZMH_e{$zone}; } } foreach (split(/,/, $flags)) { if (/^U/) { $uflag = 'U'; next if /^U$/; } else { $_ = "$uflag$_"; } if (/:/) { $flags{$`} .= ',' if defined($flags{$`}); $flags{$`} .= $'; } else { $flags{$_} .= ',' if defined($flags{$_}); $flags{$_} .= ''; } } } if ($keyword eq 'Zone') { $zone = $region = $net = $node; $node = 0; $domzone = $domreg = $domnet = ''; foreach $i (qw(M 1 2 3 4)) { $domzone = $domreg = $domnet = "DO$i:" . $flags{"UDO$i"} if $flags{"UDO$i"}; } $ird = $flags{"IRD"}; } elsif ($keyword eq 'Region') { $region = $net = $node; $node = 0; $domreg = $domnet = ''; foreach $i (qw(M 1 2 3 4)) { $domreg = $domnet = "DO$i:" . $flags{"UDO$i"} if $flags{"UDO$i"}; } $ird = $flags{"IRD"}; } elsif ($keyword eq 'Host') { $net = $node; $node = 0; $domnet = ""; foreach $i (qw(M 1 2 3 4)) { $domnet = "DO$i:" . $flags{"UDO$i"} if $flags{"UDO$i"}; } $ird = $flags{"IRD"}; } next unless defined($flags{"IBN"}); $sysopn =~ s/_/ /g; $sysopname{"$zone:$net/$node"} = $sysopn; $calltime{"$zone:$net/$node"}{s} = $timetocall_s; $calltime{"$zone:$net/$node"}{e} = $timetocall_e; if ( defined( $hostsonly ) ) { next unless $node == 0; } if ( defined($fzone) ){ next unless $zone == $fzone; } if ( defined($lreg) ){ next unless $region == $lreg; } if ( defined($lnetw) ){ next unless $net == $lnetw; } $sortednodes{"$zone\:$net\/$node"} = $region; %port = (); foreach (split(/,/, $flags{"IBN"})) { if (/^\d*$/) { $port{/\d/ ? ":$_" : ""} = 1; next; } $lport = ""; ($_, $lport) = ($`, ":$'") if /:/; $_ .= "." unless /^\d+\.\d+\.\d+\.\d+$|\.$/; %lport = ($lport ? ( ":$lport" => 1 ) : %port); $lport{""} = 1 unless %lport; foreach $lport (keys %lport) { next if $addr{"$_$lport"}; $addr{"$_$lport"} = 1; push(@addr, "$_$lport"); } } if (@addr) { $nodelist{"$zone:$net/$node"} = join(';', @addr); $nodes++; next; } $port{""} = 1 unless %port; if ($_ = $flags{"INA"}) { foreach (split(/,/, $flags{"INA"})) { $_ .= "." unless /^\d+\.\d+\.\d+\.\d+$|\.$/; foreach $port (keys %port) { next if $addr{"$_$port"}; $addr{"$_$port"} = 1; push(@addr, "$_$port"); } } $nodelist{"$zone:$net/$node"} = join(';', @addr); $nodes++; next; } if ($phone =~ /000-([1-9]\d*)-(\d+)-(\d+)-(\d+)$/) { $addr{"$1.$2.$3.$4"} = 1; push(@addr, "$1.$2.$3.$4"); } if ($name =~ /^(\d+\.\d+\.\d+\.\d+|[a-z0-9][-a-z0-9.]*\.(net|org|com|biz|info|name|[a-z][a-z]))$/) { $name .= "." if $name =~ /[a-z]/; unless ($addr{$name}) { $addr{$name} = 1; push(@addr, $name); } } unless (@addr) { $domflag = ($domnet || $domreg || $domzone); foreach $i (qw(M 1 2 3 4)) { $domflag = "DO$i:" . $flags{"UDO$i"} if $flags{"UDO$i"}; } if ($domflag =~ /^DO(.):/) { ($i, $dom) = ($1, $'); if ($i eq 'M') { $_ = "f$node.n$net.z$zone.$domain.$dom."; } elsif ($i eq '4') { $_ = "f$node.n$net.z$zone.$dom."; } elsif ($i eq '3') { $_ = "f$node.n$net.$dom."; } elsif ($i eq '2') { $_ = "f$node.$dom."; } elsif ($i eq '1') { $_ = "$dom."; } unless ($addr{$_}) { $addr{$_} = 1; push(@addr, $_); } } if ($ird) { $_ = "f$node.n$net.z$zone.$ird."; unless ($addr{$_}) { $addr{$_} = 1; push(@addr, $_); } } } next unless @addr; %addr = (); foreach $addr (@addr) { foreach $port (keys %port) { $addr{"$addr$port"} = 1; } } if(defined($port)){ $_ .= $port foreach @addr; } $nodelist{"$zone:$net/$node"} = join(';', keys %addr); $nodes++; } close(F); my $lstr = "Nodelist $nldate parsed, $nodes IP-nodes processed (" . sprintf( "%.3f" ,(Time::HiRes::time() - $start) ) . " sec)"; print( $lstr ); writelog( $lstr ); } sub readareas() { print "Reading areafile $config{areafile}\n"; my ( $F, $line, $key, $areapath ); return unless defined $config{areafile}; unless( open( $F, '<', $config{areafile} ) ) { print STDERR "Can't open file $config{areafile} ($!).\n"; exit; } my $lines = 0; while( $line = <$F> ) { $line =~ s/[\r\n]//g; $line =~ s/ / /g; next if $line =~ /^\s*[\#\;]/; next if $line =~ /^\s+$/; next if $line eq ''; next unless $line =~ /^\s*EchoArea\s*(\S+)\s+(\S+).*?\-b\s+JAM/i; $key = uc($1); $areapath = $2; next if $areapath =~ /passthrough/i; $areas{$key} = $areapath; $lines++; } close($F); print "$lines areas read.\n"; } sub writelog($) { my ( $str ) = @_; my ($sec,$min,$hour,$mday,$month,$year) = (localtime)[0...5]; my $timestamp = sprintf("%04d-%02d-%02d %02d:%02d:%02d ", $year+1900, $month+1, $mday, $hour, $min, $sec); $str =~ s/\n/\n$timestamp/g; if ( defined( $logfile ) ) { if ( open( my $FLOG, '>>', $logfile ) ) { print( $FLOG "$timestamp$str\n" ); close( $FLOG ); } else { print( STDERR "Can't open logfile $logfile. ($!)\n" ); } } } sub readlastread($) { my $lrfile = catfile($_[0], 'lastread'); my $lrsize = -s $lrfile; my $usercount = $lrsize/2; #writelog( "usercount: \'$usercount\'" ); my ( $LRF, $lr ); if ( open( $LRF, '<', $lrfile ) ) { binmode( $LRF ); read( $LRF, $lr, $lrsize ); close( $LRF ); return ( $usercount, unpack( "S$usercount", $lr ) ); } else { print( STDERR "Can't open $lrfile. $!\n" ); writelog( "Can't open $lrfile. $!" ); return ( 1, 1 ); } } sub writelastread #( $$ ) { my ( $lastreadDir, $users, @lastreads ) = @_; my ( $FLTD, $lastreadPath ); #writelog( "users: \'$users\', user1 \'$lastreads[0]\', user2 \'$lastreads[1]\'" ); $lastreadPath = catfile( $lastreadDir, 'lastread.' . time() ); if( open( $FLTD, '>', $lastreadPath ) ) { binmode( $FLTD ); print( $FLTD pack( "S$users", @lastreads ) ); close( $FLTD ); move( $lastreadPath, catfile( $lastreadDir, 'lastread' ) ); } else { print(STDERR "Can't open \"$lastreadPath\".($!)\n"); writelog("Can't open \"$lastreadPath\".($!)"); } } sub readmsg($) { my ($msgpath) = @_; my $msgsize = -s $msgpath; my ( $FM, $msg ); if ( open( $FM, '<', $msgpath ) ) { binmode( $FM ); read( $FM, $msg, $msgsize); close( $FM ); return ( unpack("Z36Z36Z72Z20S13Z".($msgsize - 190), $msg) ); } else { print( STDERR "Can't open file \"$msgpath\". \($!\)\n"); writelog("Can't open \"$msgpath\".($!)"); return 0; } } sub sendhelp() { # witelog( "" ); # print "Help message.\n"; } sub read_help() { my $help; unless ( defined( $config{helpfile} ) ){ print STDERR "HELP file nod defined.\n"; writelog( 'HELP file nod defined.' ); return; } if ( open( my $H, '<', $config{helpfile} ) ) { read( $H , $help, -s $H ); close( $H ); $help =~ s/\r?\n/\r/g; } else { print STDERR "Can't open $config{helpfile} ($!)\n"; writelog( "Can't open $config{helpfile} ($!)" ); } return $help; } sub usage() { print <', $tmpmsg ) ) { binmode( $FL ); print( $FL pack( "Z36Z36Z72Z20S13Z".($filesize - 190), $fromUserName,$toUserName,$subject,$DateTime, $timesread,$destnode,$orignode,$cost,$orignet,$destnet, $date_written16,$time_written16,$date_arrived,$time_arrived, $replyto,$attr,$nextmsg,$msgtext ) ); close( $FL ); # writelog("Can't wright \'$msgpath\'.($!)") unless move( $tmpmsg, $msgname ); } else { print(STDERR "Can't open \'$tmpmsg\'.($!)\n"); writelog("Can't open \'$tmpmsg\'.($!)"); } } sub is_area( $$ ) { my ( $ar, $ars ) = @_; # $ars = s/\s{2,}/ /g; foreach my $a ( split( / /, $ars ) ) { return 1 if $ar =~ /$a/i; } return 0; } sub search_area( $$$;$$$$$$$$$$$ ) { my ( $list, $echo_tag, $search_area, $from_date, $to_date, $from_name, $to_name, $search_words, $search_nowords, $exact_str, $search_msgid, $twit_from, $twit_to, $some_words ) = @_; my ( $search_res, %baseheader, $nummsgs, %msgheader, @subfields, $msgtext, $mday, $mon, $year, $msg_date, $msg_chrs, $msg_from, $msg_to, $msg_subj, $msg_from_address, $mb_handle, $found_msg, $msg_msgid, $m_from_addr, $msg_tzutc, $percent ); # print "Search in area \'$search_area\'\n"; writelog( "Search in area \'$echo_tag\'" ); $mb_handle = FTN::JAM::OpenMB( $search_area ); unless ( $mb_handle ) { writelog( "Failed to open \'$search_area\'. ($!)"); return ''; } unless ( FTN::JAM::LockMB( $mb_handle, 30 ) ) { writelog( "Failed to lock messagebase \'$search_area\'. ($!)" ); FTN::JAM::CloseMB( $mb_handle ); return ''; } unless ( FTN::JAM::ReadMBHeader( $mb_handle, \%baseheader ) ) { writelog( "Failed to read messagebase header of \'$search_area\'. ($!)"); FTN::JAM::CloseMB( $mb_handle ); return ''; } unless ( FTN::JAM::GetMBSize( $mb_handle, \$nummsgs ) ) { writelog( "Failed to get size of messagebase \'$search_area\'. ($!)"); FTN::JAM::CloseMB( $mb_handle ); } $found_msg = ''; for ( my $i = $baseheader{BaseMsgNum}; $i < $baseheader{BaseMsgNum}+$nummsgs; $i++) { $percent = 0; unless ( FTN::JAM::ReadMessage( $mb_handle, $i, \%msgheader, \@subfields, \$msgtext ) ) { writelog("Failed to open message ($i)" ); next; } ( $msg_chrs ) = grep( /CHRS\: [^ ]+ \d+/, @subfields ); if ( defined( $msg_chrs ) && $msg_chrs =~ /CHRS\:?\s*(\S+)\s*\d*/i ) { $msg_chrs = lc( $1 ); # if ( $msg_chrs ne $config{defaultchrs} ) { # writelog( "Msg CHRS: \'$msg_chrs\' not equal to local \'$config{defaultchrs}\'." ); # } } else { $msg_chrs = $config{defaultchrs}; # writelog( "Msg CHRS not found. Using default: \'$config{defaultchrs}\'." ); } # ( $msg_msgid ) = grep( /MSGID\: ([^ ]+) \d+/, @subfields ); # ( $msg_from, undef, $msg_to, undef, $msg_subj, undef, $msg_from_address ) = @subfields[1..7]; for (my $i = 0; $i <= $#subfields; $i=$i+2) { $msg_from = $subfields[$i+1] if $subfields[$i] == 2; $msg_to = $subfields[$i+1] if $subfields[$i] == 3; $msg_subj = $subfields[$i+1] if $subfields[$i] == 6; $msg_msgid = $subfields[$i+1] if $subfields[$i] == 4; $msg_tzutc = $subfields[$i+1] if $subfields[$i] == 2004; } ( $mday, $mon, $year ) = ( localtime( $msgheader{DateWritten} ) )[3...5]; $msg_date = sprintf("%04d%02d%02d",$year+1900,$mon+1,$mday); # if ( $msg_from_address =~/(\d+\:\d+\/\d+\.?\d*)/ ) { # $m_from_addr = $1; # } else { # $m_from_addr = $msg_from_address; # } # utf8::encode( $msgtext ); if ( $msgtext =~ /\r \* Origin\: [^\r]*?\((\d+\:\d+\/\d+\.?\d*)[^\r]*?\)\r/ ) { $m_from_addr = $1; } $msgtext =~ s/\r\-\-\- /\r\-\+\- /g; $msgtext =~ s/\r \* Origin\: /\r \+ Origin\: /g; if ( defined( $search_msgid ) ) { if ( $msg_msgid =~ /^$search_msgid$/i ) { writelog( "Found msg From: $msg_from $m_from_addr, To: $msg_to, \@MSGID: $msg_msgid, \@CHRS: $msg_chrs" ); # $msgtext =~ s/\r\-\-\- /\r\-\+\- /g; # $msgtext =~ s/\r \* Origin\: /\r \+ Origin\: /g; $found_msg .= "컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r". " EchoArea: ".uc($echo_tag)." Date: " . sprintf( "%02d.%02d.%04d\r", $mday, $mon+1, $year+1900 ) . " From: ". sprintf( "%-35s", $msg_from ) . " $m_from_addr\r To : $msg_to\r Subj: $msg_subj\r". "컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r". "\@MSGID: $msg_msgid\r". "$msgtext". "컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r\r"; } next; } my $digest = ''; if ( defined( $from_date ) ) { next if $msg_date < $from_date; } if ( defined( $to_date ) ) { next if $msg_date > $to_date; } if ( defined( $from_name ) ) { next unless $msg_from =~ /^$from_name$/i; } if ( defined( $to_name ) ) { next unless $msg_to =~ /^$to_name$/i; } # utf8::encode( $msgtext ); if ( defined( $exact_str ) ) { # utf8::encode( $exact_str ); next unless $msgtext =~ /(.{0,32})($exact_str)(.{0,32})/i; $digest .= "$1 _$2_ $3\r"; } if ( defined( $twit_from ) ){ next if $msgtext =~ /^$twit_from$/i; } if ( defined( $twit_to ) ) { next if $msgtext =~ /^$twit_to$/i; } if ( defined( $some_words ) ) { my ( $sc, $sca ) = ( 0, 0 ); foreach my $sw ( split( / /, $some_words ) ) { $sca++; if( $msgtext =~ /(.{0,32})($sw)(.{0,32})/i ) { $digest .= "$1 _$2_ $3\r"; $sc++; } } next if $sc == 0; next if $sca == 0; $percent = ( $sc/$sca*100 ); next if $percent < 50; $digest .= "\r ======= \r $percent\% of words found."; } if ( defined( $search_words ) ) { # $msgtext = encode( 'utf-8', decode( 'cp866', $msgtext ) ); # utf8::encode( $search_words ); my ( $c, $ca ) = ( 0, 0 ); foreach my $w ( split( / /, $search_words ) ) { $ca++; if( $msgtext =~ /(.{0,32})($w)(.{0,32})/i ) { $digest .= "$1 _$2_ $3\r"; $c++; } } next if $c != $ca; } # $msgtext = encode( 'cp866', decode( 'utf-8', $msgtext ) ); if ( defined( $search_nowords ) ) { # $search_nowords # utf8::encode( $search_nowords ); my $cn = 0; foreach my $nw ( split( / /, $search_nowords ) ) { if ( $msgtext =~ /$nw/i ) { $cn++; # last; } } next if $cn > 0; } writelog( "Found msg From: $msg_from $m_from_addr, To: $msg_to, \@MSGID: $msg_msgid, \@CHRS: $msg_chrs" ); # utf8::decode( $digest ); # utf8::decode( $msgtext ); $msgtext .= "\r ======= \r $percent\% of words found.\r" if $percent > 0; $found_msg .= "컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r". " EchoArea: ".uc($echo_tag)." Date: ". sprintf( "%02d.%02d.%04d\r", $mday, $mon+1, $year+1900 ) . " From: ". sprintf( "%-35s", $msg_from ) . " $m_from_addr\r To : $msg_to\r Subj: $msg_subj\r". "컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r". "\@MSGID: $msg_msgid\r\r"; if ( $list eq 'list' ) { $digest = substr( $msgtext, 0, 320 ) if $digest eq ''; $found_msg .= "$digest\r컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r\r"; } elsif ( $list eq 'search' ) { $found_msg .= "${msgtext}컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r\r"; } else { $found_msg .= "\r컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴\r\r"; } } writelog( "Failed unlock messagebase $search_area. ($!)") unless FTN::JAM::UnlockMB( $mb_handle ); FTN::JAM::CloseMB( $mb_handle ); return $found_msg; } sub search( $$;$$$$$$$$$$$ ) { my ( $list, $search_areas, $from_date, $to_date, $from_name, $to_name, $search_words, $search_nowords, $exact_str, $search_msgid, $twit_from, $twit_to, $some_words ) = @_; if ( !defined( $from_date ) && !defined( $to_date ) && !defined( $from_name ) && !defined( $to_name ) && !defined( $search_words ) && !defined( $search_nowords ) && !defined( $exact_str ) && !defined( $search_msgid ) && !defined( $some_words ) ){ writelog( 'Nothing to search.' ); return "Nothing to search.\r"; # !defined( $twit_from ) && !defined( $twit_to ) && } my $result = ''; foreach my $key ( keys %areas ){ if ( is_area( $key, $search_areas ) ) { # print "$key $areas{$key}\n"; $result .= search_area( $list, $key, $areas{$key}, $from_date, $to_date, $from_name, $to_name, $search_words, $search_nowords, $exact_str, $search_msgid, $twit_from, $twit_to, $some_words ); } } writelog('Search complete.'); return $result; } sub msg_date_time() { my $datetime = localtime(); $datetime =~ /[a-z]+\s+([a-z]+)\s+(\d+)\s+(\d\d\:\d\d\:\d\d)\s+\d\d(\d\d)/i; return sprintf ( "%02d %3s %02d %8s", $2, $1, $4, $3 ); } my ( $sbrief, $brief, $flagdir, $debug, $placed ); my ( $M_NUL, $M_ADR, $M_PWD, $M_OK, $M_FILE, $M_EOB, $M_GOT, $M_ERR, $M_BSY, $M_GET, $M_SKIP ) = ( "\x00", "\x01", "\x02", "\x04", "\x03", "\x05", "\x06", "\x07", "\x08", "\x09", "\x0a"); #my $systemname = "Fidogle at $config{address}"; #my $sysop = $config{myname}; #my $location = $config{address}; my $NDL = '300,MO'; sub readblock($) { my ($sock) = @_; my ( $iscmd, $cmd, $cmdlen, $data, $remoteaddr, $readresult, $starttime ); print "reading first byte\n" if $debug; $sock->timeout(15); $readresult = sysread($sock, $iscmd, 1 ); return ('Error', 'Socket read error.' ) unless $readresult; $iscmd = ord($iscmd); if ( $iscmd < 128 ) { # print "reading second byte\n" if $debug; return ('Error', "Socket read error." ) unless sysread($sock, $cmdlen, 1 ) == 1; $cmdlen = ord($cmdlen); $cmdlen = ( $iscmd * 256 ) + $cmdlen; $readresult = 0; $starttime = time(); while ( $readresult < $cmdlen ) { $readresult += sysread($sock, $data, $cmdlen ); if ( (time()-$starttime) > 30 ) { return ('Error', "Socket read error." ); } } return ('DATA', $data); } else { print "reading second byte\n" if $debug; return ('Error', "Socket read error ($!)." ) unless sysread($sock, $cmdlen, 1 ) == 1; $cmdlen = ( ord($cmdlen) + ( ( $iscmd - 128 ) * 256) ); return ('Error', "Socket read error.($!)" ) unless sysread($sock, $cmd, 1 ) == 1; $readresult = 0; $starttime = time(); while ( $readresult < $cmdlen - 1 ) { $readresult += sysread($sock, $data, $cmdlen - 1 ); if ( (time()-$starttime) > 30 ) { return ('Error', "Socket read error." ); } } # return ('Error', "Socket read error.($!)" ) unless sysread($sock, $data, $cmdlen - 1 ) == $cmdlen - 1; return ($cmd,$data); } } sub connec2binkd($$$$) { my ($host,$portaddress,$fn,$hostname) = @_; my $rc = ''; my ($sock,$s,@bsyflag,@pid,$l,$wait_mgot,$wait_mok); my $isbinkd = "Error! No binkp found"; my $place; my $myaka = "$config{address}.9"; # $place = getplace($host) if $placed; $place = '' unless defined $place; writelog("***Calling $fn ($host:$portaddress)***"); # $rc = "$fn\t$hostname\:$portaddress" if $sbrief; localtime() =~ /([^ ]+) ([^ ]+)[ ]+(\d+) (\d\d\:\d\d:\d\d) (\d\d\d\d)/; my ( @str ) = ( "SYS $config{systemname}", "ZYZ $config{myname}", "LOC $config{location}", "NDL $NDL", "TIME $1 $3 $2 $5 $4 $TZUTC", "VER $programfile/$vers/$^O binkp/1.0" ); print "Calling $fn ($host\:$portaddress)$place\n"; writelog( " ($host\:$portaddress) $place" ); $fn =~ /(\d+)\:(\d+)\/(\d+)/; # @bsyflag = ( File::Spec->catfile( $flagdir, "$1.$2.$3.0.busy" ) ); # while( -e $bsyflag[0] ) { # print "$fn is busy\n"; # sleep 1; # } # $pid[0] = File::Flock::Tiny->write_pid( $bsyflag[0] ) or do { # print "$fn is busy. Sleep 1 sec.\n"; # sleep 1; # }; $sock = IO::Socket::IP->new( PeerAddr => $host, PeerPort => $portaddress, Timeout => 15, Proto => 'tcp') or do { print( "error \($@\)\n" ); # $pid[0]->release if defined $pid[0]; # unlink( @bsyflag ); writelog( " $host - Error: $@" ); return( 'Error' ); }; if( $sock == 0 ) { print( "Error: Can't connect to $host:$portaddress\n" ); # unlink( @bsyflag ); writelog( " $host$place - Error: $!"); return( 'Error' ); } print "$host Sending our info...\n" if $debug; # writelog( "$fn ($host) Sending our info...\n" ) if $debug; foreach $s ( @str ) { unless( syswrite($sock, "\x80" . chr(length($s) + 1) . $M_NUL . $s) ) { # unlink( @bsyflag ); writelog( "Socket write error!" ); close($sock); return 'Error'; } } unless( syswrite($sock, "\x80" . chr(length($myaka) + 2) . "$M_ADR $myaka") ){ # unlink( @bsyflag ); writelog( "Socket write error!" ); close($sock); return 'Error'; } # set password... my $password = '-'; # if ( defined( $ReportTo{addr} ) ) { # $password = $ReportTo{pwd} if defined( $ReportTo{pwd} ) && $fn eq $ReportTo{addr}; # } unless( syswrite($sock, "\x80".chr(length($password)+1)."$M_PWD$password") ) { # unlink( @bsyflag ); writelog( "Socket write error!" ); close($sock); return 'Error'; } # set traff... my ($mtrf,$ftrf) = (0,0); if( defined( $files[0] ) ) { print "$files[0]\n"; $files[0] =~ /[^ ]+ (\d+) \d+ \d+/; $mtrf = $1; } my $alltrf = "TRF $mtrf $ftrf"; unless( syswrite($sock, "\x80" . chr( length( $alltrf ) + 1 ) . "${M_NUL}${alltrf}") ) { # foreach $l ( @pid ) { # $l->release if defined $l; # } # unlink( @bsyflag ); writelog( "Socket write error!" ); return 'Error!'; } print "Waiting M_OK...\n" if $debug; WAITOK: my ($c,$d) = readblock($sock); print localtime()."\n" if $debug; if ( $c eq "DATA" ) { print "DATA not expected now!\n\'$c\', \'$d\'\n"; $s = 'Not expected DATA!'; writelog( " $s\n \'$c\'\, \'$d\'\n$isbinkd" ); goto WAITOK; }elsif( $c eq 'Error') { print "$c $d\n"; close($sock); # unlink @bsyflag; writelog( " $c\: $d" ); # $rc .= "\t$host$place\t$c\: $d\n" if $sbrief; return 'Error'; } else { if ($c eq $M_NUL) { print "$d\n"; # if ( $d =~ /^OPT CRAM\-MD5\-(.*)$/ ) { # print( decode_base64($1) ); # } $rc .= " $d\n" unless $brief; if( $d =~ m@(binkp/1.[01])@i ) { $isbinkd = ''; } goto WAITOK; } elsif ($c eq $M_ADR) { my $is = 0; # $rc .= "M_ADR \'$d\' \n" if $debug; $d =~ s/^ //; $d =~ s/\x00$//; foreach my $ma ( split(' ',$d) ) { print "address: $ma\n"; writelog( " address: $ma" ); $is = 1 if $ma =~ /^$fn(\.0)?(\@[a-zA-z\.0-9\-]+)?$/i; $ma =~ /(\d+)\:(\d+)\/(\d+)/; # @bsyflag = ( @bsyflag, File::Spec->catfile( $flagdir, "$1.$2.$3.0.busy" ) ); # @pid = ( @pid, File::Flock::Tiny->write_pid( $bsyflag[0] ) ) or do { # print( "$host is busy. Sleep 1 sec.\n" ); # sleep 1; # }; } if ($is == 0) { print "No such AKA.\n$isbinkd"; writelog( " No such AKA." ); # $rc .= "\t$host$place\tNo such AKA.\n" if $sbrief; writelog( "Socket write error!" ) unless syswrite($sock, "\x80\x0d${M_ERR}No such AKA."); writelog( "Socket write error!" ) unless syswrite($sock, "\x80\x01${M_EOB}"); close($sock); # unlink @bsyflag; return 'Error'; } goto WAITOK; } elsif ($c eq $M_ERR) { print "Got binkp error: $d.\n"; writelog( " $host$place - Got binkp error: $d." ); writelog( "Socket write error!" ) unless syswrite($sock, "\x80\x01${M_EOB}"); close($sock); # unlink @bsyflag; return 'Error'; } elsif ($c eq $M_BSY) { print "Error: $d.\n"; writelog( " $host$place - Got error: $d." ); writelog( " Socket write error!" ) unless syswrite($sock, "\x80\x01${M_EOB}"); close($sock); # unlink @bsyflag; return 'Error'; } elsif ($c eq $M_FILE) { $d =~ /^([^ ]* \d+ \d+) \d+$/; syswrite($sock, "\x80".chr( length($1)+1 )."${M_SKIP}$1"); print "File $d skipped."; writelog( " $fn have a file $d for us." ); } elsif ($c eq $M_OK) { print " $host - Ok.\n"; writelog( " $host$place - Ok." ); # $rc .= "\t$host$place\tOk.\n" if $sbrief; } } $wait_mok = 0; if( defined( $files[0] ) ) { foreach my $fff ( @files ) { print "Sending file $fff.\n"; writelog("Sending file $fff."); syswrite($sock, "\x80". chr(length( $fff ) + 1) ."${M_FILE}${fff}"); my ( $lll, $ofset, $www ) = ( length($pkt2bnd), 0, 0 ); while( $ofset < $lll ){ $www = substr( $pkt2bnd, $ofset, 4096 ); my $wll = length($www); $ofset += $wll; my $fb = int( $wll/256 ); my $sb = $wll - ( $fb * 256 ); syswrite($sock, chr( $fb ) . chr( $sb ) . $www ); } $wait_mgot = 0; while( $wait_mgot == 0 ) { ($c,$d) = readblock($sock); if ( $c eq $M_GOT ) { $wait_mgot = 1; $d =~ /([^ ]+) (\d+) \d+/; print "file $1 ($2 bytes) sent to $fn.\n"; writelog("file $1 ($2 bytes) sent to $fn."); } elsif ( $c eq $M_EOB ) { $wait_mok = 1; } elsif ($c eq $M_NUL) { print "$d\n"; writelog( "$d" ); } elsif ($c eq $M_FILE) { $d =~ /^([^ ]* \d+ \d+) \d+$/; syswrite($sock, "\x80".chr( length($1)+1 )."${M_SKIP}$1"); print "File $d skipped.\n"; writelog( "File $d skipped." ); } } } } unless( syswrite($sock, "\x80\x01${M_EOB}") ) { # foreach $l ( @pid ) { # $l->release if defined $l; # } # unlink( @bsyflag ); return "Socket write error!"; } print( "Waiting M_EOB\n" ) if $debug; writelog( "Waiting M_EOB" ) if $debug; while( $wait_mok == 0 ) { ($c,$d) = readblock($sock); if ($c eq $M_NUL) { print "$d\n"; writelog( "$d" ); } elsif ($c eq $M_FILE) { $d =~ /^([^ ]* \d+ \d+) \d+$/; syswrite($sock, "\x80".chr( length($1)+1 )."${M_SKIP}$1"); print "File $d skipped.\n"; writelog( "File $d skipped." ); } elsif ($c eq $M_EOB) { print "Session with $fn done.\n"; writelog( "Session with $fn done." ); $wait_mok = 1; } else { print "\'$c\'\n"; writelog( "\'$c\',\'$d\'" ); } } close($sock); # foreach $l ( @pid ) { # $l->release if defined $l; # } # unlink @bsyflag; return 'Ok'; } sub testcall($$$) { my ( $hostname, $portaddress, $fn ) = @_; print "Resolving host name...\n" if $debug; # writelog("Resolving host name...\n") if $debug; my ($err, @res) = getaddrinfo($hostname, "", {socktype => SOCK_RAW}); my $r = ''; if ( $err ) { writelog( " Error: Cannot getaddrinfo - $err\n" ); # $r = "$fn\t$hostname\t-\tError: Cannot getaddrinfo - $err" if $sbrief; return 'Error'; } while( my $ai = shift @res ) { my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV); if ( $err ) { writelog( " Cannot getnameinfo - $err" ); # $r .= "\t$fn\t$hostname\:$portaddress\tCannot getnameinfo - $err" if $sbrief; undef $err; next; } $r = connec2binkd($ipaddr,$portaddress,$fn,$hostname); return 'Ok' if $r eq 'Ok'; } return $r; } sub callnode($) { my ($fn) = @_; my ( $hostname, $portaddress, $r, $bsyflag, $pid, $nowutc ); $nowutc = sprintf( "%02d%02d", (gmtime())[2], (gmtime())[1] ); writelog( "Calling $fn" ); print "Calling \'$fn\'."; print " Call time: \'$calltime{$fn}{s}\-$calltime{$fn}{e}\' UTC.\n"; print " Now is: $nowutc UTC.\n"; unless ( defined( $ignoredown ) ) { unless ( $nowutc gt $calltime{$fn}{s} && $nowutc le $calltime{$fn}{e} ) { print " Nothing to do.\n"; # writelog( "$fn Call Time: $calltime{$fn}{s}\-$calltime{$fn}{e} UTC " ) if $sbrief; writelog( "Now isn't a call time." ); return 'Ok'; } } foreach my $d ( split( ';', $nodelist{$fn} ) ) { undef $portaddress; if ( $d =~ /^(.+?)[\.\]]?\:+(\d+)\.?$/ ) { ( $hostname, $portaddress ) = ($1, $2); } else { $d =~ /(.*?)\.?$/; $hostname = $1; } $portaddress = '24554' unless defined $portaddress; print "$hostname, $portaddress\n"; writelog( " $hostname\:$portaddress" ); # if( defined( $flagdir ) ) { # $bsyflag = File::Spec->catfile($flagdir, "$hostname\-$portaddress\.busy"); # while( -e $bsyflag ) { # print( "$hostname is busy. Sleep 1 sec.\n" ); # sleep 1; # } # $pid = File::Flock::Tiny->write_pid( $bsyflag ) or do { # print( "$hostname is busy. Sleep 1 sec.\n" ); # sleep 1; # } # } $r = testcall($hostname, $portaddress, $fn); return $r if $r eq 'Ok'; # if( defined $bsyflag ) { # $pid->release if defined $pid; # unlink $bsyflag; # } } return $r; } sub prep_str($) { my ( $str ) = @_; $str =~ s/[H\x8D]/\[H\x8D\]/g; # $str =~ s/�/[p�]/g; # $str =~ s/p/[p�]/g; $str =~ s/\%/\\\%]/g; $str =~ s/\$/\\\$]/g; $str =~ s/\#/\\\#]/g; $str =~ s/\@/\\\@]/g; return $str; } sub send_as_msg( $$$$$$$ ) { my ( $reply_txt, $from_name, $orig_node, $dest_node, $dest_net, $orig_net, $rmsgnum ) = @_; $reply_txt = sprintf( "\001MSGID: $config{address} %08x\r", time() ) . $reply_txt; $reply_txt .= "\r\r--- \r\000"; writemsg( find_free_msgname( $config{netmail} ), length($reply_txt)+190, $config{myname}, $from_name, 'Your request reply.', msg_date_time(), 0, $orig_node, $dest_node, 0, $dest_net, $orig_net, 0, 0, 0, 0, $rmsgnum, PVT+LOC, 0, $reply_txt ); sleep 1; } sub reply_ibn( $$$$;$) { my ( $replytxt, $fromname, $fromaddr, $r_addr, $MSGID ) = @_; # my ( $pkt2bnd ); $replytxt = "\001REPLY: $MSGID\r$replytxt" if defined $MSGID; $replytxt = "\001CHRS: $config{defaultchrs}\r". "\001PID: Fidogle v.$vers\r$replytxt"; $pkt2bnd = txt2pkt( "$config{address}\.9", $r_addr, '', $config{myname}, $fromname, $config{address}, $fromaddr, LOC+PVT+0x08, $replytxt, 'Your request reply.', '' ); $files[0] = sprintf( "%08x\.pkt %d %d %d", time(), length( $pkt2bnd ), time(), 0 ); if ( callnode( $r_addr ) ne 'Ok' ) { # writelog( 'Send by binkd failed. Sending by msg.' ); # send_as_msg( "$cluges$replytxt\r\r--- \r\000", # $fromname, $orignode, $destnode, $destnet, # $orignet, $r_msgnum ); return 0; } return 1; } sub get_echotags( $ ) { my ( $m_txt ) = @_; my $echtags = ''; while ( $m_txt =~ /\%(?:EchoArea|Area):?\s*([^\r]+)/i ) { $echtags .= prep_str( $1 ) . ' '; $m_txt =~ s/\%(?:EchoArea|Area):?\s*([^\r]+)//i; } $echtags =~ s/\./\\\./g; $echtags =~ s/\*/\.\*/g; $echtags =~ s/ $//; return $echtags; } sub area_links( $ ) { my ( $msgtxt ) = @_; my %links = (); while ( $msgtxt =~ /\barea\:\/\/([^\r\s]+?)\?msgid\=([^\r^\s]+?)\+([^\r^\s]+)\b/i ) { $links{"$2 $3"} = $1; $msgtxt =~ s/\barea\:\/\/([^\r\s]+?)\?msgid\=([^\r^\s]+?)\+([^\r^\s]+)\b//i; } return %links; } sub scannetmail($) { my ( $netmailarea ) = @_; my @lr = readlastread( $netmailarea ); $lr[0] = $config{fidousernumber} if $lr[0] < $config{fidousernumber}; my ( $fromname, $toname, $subj, $datetime, $timesread, $destnode, $orignode, $cost, $orignet, $destnet, $date_written16, $time_written16, $date_arrived, $time_arrived, $replyto, $attr, $nextmsg, $msgtext, $fromaddr, $toaddr, $searchfromdate, $cluges, $searchtodate, $searchechoarea, $searchnowords, $searchwords, $chrs, $replytxt, $MSGID, $searchmsgid, $searchstring, $DH, $msgfile, $r_msgnum, $w_msgnum, $searchfromname, $searchtoname, $search_msgid, $r_addr, $dom, $searchtwitfrom, $searchtwitto, $partial_search ); my $lastread = $lr[$config{fidousernumber}]; $lastread = 0 unless defined $lastread; $lastread++; unless ( opendir( $DH, $netmailarea ) ){ print STDERR "Can't open dir \'$netmailarea\' ($!).\n"; writelog( "Can't open dir \'$netmailarea\' ($!)." ); return; } while( readdir( $DH ) ){ next unless $_ =~ /^(\d+)\.msg$/i; $r_msgnum = $1; next if $r_msgnum < $lastread; $msgfile = catfile( $netmailarea, $_ ); print "$_\n"; writelog( "Reading $_" ); ( $fromname, $toname, $subj, $datetime, $timesread, $destnode, $orignode, $cost, $orignet, $destnet, $date_written16, $time_written16, $date_arrived, $time_arrived, $replyto, $attr, $nextmsg, $msgtext ) = readmsg( $msgfile ); #writelog( "reading: $r_msgnum, lastread: $lastread" ); @lr[$config{fidousernumber}] = $r_msgnum if $r_msgnum > $lr[$config{fidousernumber}]; writelastread( $netmailarea, @lr ); undef $MSGID; undef $fromaddr; undef $toaddr; if ( $msgtext =~ /\001MSGID\:?[ ]+([^\r]+)\r/ ) { $MSGID = $1; } $fromaddr = "$orignet/$orignode"; $toaddr = "$destnet/$destnode"; if ( $msgtext =~ /\001INTL\:?[ ]+(\d+:\d+\/\d+)[ ]+(\d+:\d+\/\d+)/ ) { $fromaddr = $2; $toaddr = $1; } if ( $msgtext =~ /\001FMPT\:?[ ]+(\d+)/ ) { $fromaddr .= ".$1"; } if ( $msgtext =~ /\001TOPT\:?[ ]+(\d+)/ ) { $toaddr .= ".$1"; } if ( $msgtext =~ /\r \* Origin\: +\((\d+:\d+\/\d+.?\d*)[^\r\)\(]*\)\r/ ) { $fromaddr = $1; } if ( $toaddr =~ /^\d+\/\d+/ ) { $toaddr = "$config{defaultzone}:$toaddr"; } if ( $fromaddr =~ /^\d+\/\d+/ ) { $fromaddr = "$config{defaultzone}:$fromaddr"; } writelog( "Message From $fromname $fromaddr" ); if ( $toaddr eq $config{address} ) { if ( $toname =~ /^$config{myname}$/i ) { writelog( "Message to $toname $toaddr" ); $replytxt = ''; $cluges = ''; undef $reply_as; undef $searchfromdate; undef $searchtodate; undef $searchfromname; undef $searchtoname; undef $searchtwitfrom; undef $searchtwitto; undef $searchmsgid; undef $searchnowords; undef $searchwords; undef $searchstring; my %msglink = (); if ( "$fromaddr $toaddr" =~ /(\d+:\d+\/\d+)\S* (\d+:\d+\/\d+)/ ) { $cluges .= "\001INTL $1 $2\r"; } if( $fromaddr =~ /\d+:\d+\/\d+\.(\d+)/ ) { $cluges .= "\001TOPT $1\r"; } if( $toaddr =~ /\d+:\d+\/\d+\.(\d+)/ ) { $cluges .= "\001FMPT $1\r"; } $cluges .= "\001REPLY: $MSGID\r" if defined $MSGID; $cluges .= "\001CHRS: $config{defaultchrs}\r". "\001PID: Fidogle v.$vers\r". "\001TZUTC: $TZUTC\r"; print "From: $fromname $fromaddr\nTo : $toname $toaddr\nSubj: $subj\n"; # writelog( "Message from $fromname $fromaddr." ); if ( $msgtext =~ /\001CHRS\:[ ]*([^ ]+)[ ]+\d?\r/i ) { $chrs = lc($1); writelog("Message charset \'$chrs\' found."); } else { $chrs = lc( $config{defaultchrs} ); print STDERR "Message charset not found. \'$chrs\' will be used.\n"; writelog("Message charset not found. \'$chrs\' will be used."); } if ( $msgtext =~ /\%Reply\:?\s*([a-z]+)\:?([^\r\s\:]*\:?\d*)/i ) { $reply_as = uc($1); if ( defined( $2 ) && $2 ne '' ) { $dom = $2; } else { undef $dom; } if( $fromaddr =~ /(\d+\:\d+\/\d+)\.\d+/ ){ $r_addr = $1; } else { $r_addr = $fromaddr; } if ( defined( $dom ) ) { if ( defined( $nodelist{$r_addr} ) ) { $nodelist{$r_addr} = "$dom;$nodelist{$r_addr}"; } else { $nodelist{$r_addr} = $dom unless defined $dom; } writelog( "Domain defined as \'$nodelist{$r_addr}\'" ); } } my $need_help = 0; if ( $subj =~ /\%HELP/i || $msgtext =~ /\%HELP/i ) { $need_help = 1; } my $report_type; if ( $subj =~ /\%(Search)[ ]?([^\r]*)/i || $msgtext =~ /\%(Search)[ ]?([^\r]*)/i || $subj =~ /\%(List)[ ]?([^\r]*)/i || $msgtext =~ /\%(List)[ ]?([^\r]*)/i ) { $report_type = lc( $1 ); writelog("$report_type request found..."); $partial_search = prep_str( $2 ) if ( defined $2 ) && ( $2 ne '' ); } if ( $msgtext =~ /\%(?:EchoArea|Area):?\s*([^\r]+)/i ) { $searchechoarea = get_echotags( $msgtext ); writelog( "Search in echoarea \'$searchechoarea\'" ); } else { $searchechoarea = '.*'; writelog( "Search in echoarea \'$searchechoarea\'" ); } if ( $msgtext =~ /\%FromDate\:?\s*(\d\d)[:\/\-\.](\d\d)[:\/\-\.](\d\d\d\d)/i ) { $searchfromdate = "$3$2$1"; writelog( "Search from date: $1:$2:$3." ); } if ( $msgtext =~ /\%TillDate\:?\s*(\d\d)[:\/\-\.](\d\d)[:\/\-\.](\d\d\d\d)/i ) { $searchtodate = "$3$2$1"; writelog( "Search till date: $1:$2:$3." ); } if ( $msgtext =~ /\%FromName\:?\s*([^\r]+)/i ) { $searchfromname = $1; writelog( "Search from name: $1." ); } if ( $msgtext =~ /\%ToName\:?\s*([^\r]+)/i ) { $searchtoname = $1; writelog( "Search to name: $1." ); } if ( $msgtext =~ /\%Words[:]?\s*([^\r]+)/i ) { $searchwords = prep_str( $1 ); writelog( "Search for words: \'$searchwords\'." ); } if ( $msgtext =~ /\%NoWords:?\s*([^\r]+)/i ) { $searchnowords = prep_str( $1 ); writelog( "Search for no words: \'$searchnowords\'." ); } if ( $msgtext =~ /\%TwitFrom\:?\s*([^\r]+)/i ) { $searchtwitfrom = $1; writelog( "Search from name: $1." ); } if ( $msgtext =~ /\%TwitTo\:?\s*([^\r])/i ) { $searchtwitto = $1; writelog( "Search to name: $1." ); } if ( $msgtext =~ /\%String:?\s*([^\r]+)/i ) { $searchstring = prep_str( $1 ); writelog( "Search for exact string: \'$searchstring\'." ); } if ( $msgtext =~ /\%MSGID:?\s*([^\r]+)/i ) { $searchmsgid = $1; writelog( "Search for msgid: \'$searchmsgid\'." ); } %msglink = area_links( $msgtext ); $report_type = 'query' unless defined $report_type; $msgtext =~ s/\001[^\r\n]*\r//g; $msgtext =~ s/\r\-\-\- /\r\-\+\-/g; $msgtext =~ s/\r \* Origin: /\r \+ Origin: /g; $replytxt .= "Hi $fromname!\r\r". "I've got your search request:\r". "===================================================\r". " From: ".sprintf("%-35s",$fromname)." $fromaddr\r". " To : ".sprintf("%-35s",$toname)." $toaddr\r". " Subj: $subj\r". "===================================================\r". "$msgtext\r". "===================================================\r\r". "It recognised as:\r Report type: $report_type\r"; $replytxt .= " You need HELP.\r" if $need_help; $replytxt .= " Reply will be sent as: $reply_as\r" if defined $reply_as; $replytxt .= " EchoArea: \'$searchechoarea\'\r"; $replytxt .= " Search from date: \'$searchfromdate\'\r" if defined $searchfromdate; $replytxt .= " Search to date: \'$searchtodate\'\r" if defined $searchtodate; $replytxt .= " Search for FromName: \'$searchfromname\'\r" if defined $searchfromname; $replytxt .= " Search for ToName: \'$searchtoname\'\r" if defined $searchtoname; $replytxt .= " Search for words: \'$searchwords\'\r" if defined $searchwords; $replytxt .= " Search for no words: \'$searchnowords\'\r" if defined $searchnowords; $replytxt .= " Search for MSGID: \'$searchmsgid\'\r" if defined $searchmsgid; $replytxt .= " Search for twit from name: \'$searchtwitfrom\'\r" if defined $searchtwitfrom; $replytxt .= " Search for twit to name: \'$searchtwitto\'\n" if defined $searchtwitto; $replytxt .= " Search for some of words: \'$partial_search\'\n" if defined $partial_search; if ( defined( $reply_as ) && $reply_as eq 'IBN' ) { writelog( 'Reply as IBN' ); unless ( reply_ibn( $replytxt, $fromname, $fromaddr, $r_addr, $MSGID ) ) { writelog( 'Send by binkd failed. Sending by msg.' ); send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } undef $files[0]; $replytxt = ''; } else { send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } if ( $need_help ) { $replytxt = read_help(); if ( defined( $reply_as ) && $reply_as eq 'IBN' ) { writelog( 'Reply as IBN defined' ); unless ( reply_ibn( $replytxt, $fromname, $fromaddr, $r_addr, $MSGID ) ) { writelog( 'Send by binkd failed. Sending by msg.' ); send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } undef $files[0]; $replytxt = ''; } else { send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); $replytxt = ''; } writelog('Help request found. Help message sent.'); } if ( scalar keys %msglink > 0 ) { $replytxt = ''; foreach my $l ( keys %msglink ) { writelog( "Search for exact message \'$l\' in exact area: \'$msglink{$l}\'." ); $replytxt .= search( 'Search', $msglink{$l}, undef, undef, undef, undef, undef, undef, undef, $l ); } if ( $replytxt eq '' ) { $replytxt = "Hi $fromname!\r\rNothing found\r\rCUL8R\r"; writelog( 'Nothing found.' ); } if ( defined( $reply_as ) && $reply_as eq 'IBN' ) { writelog( 'Reply as IBN defined' ); unless ( reply_ibn( $replytxt, $fromname, $fromaddr, $r_addr, $MSGID ) ) { writelog( 'Send by binkd failed. Sending by msg.' ); send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } undef $files[0]; $replytxt = ''; } else { send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); $replytxt = ''; } writelog( 'Result of exact message search sent.' ); } $replytxt = search( $report_type, $searchechoarea, $searchfromdate, $searchtodate, $searchfromname, $searchtoname, $searchwords, $searchnowords, $searchstring, $searchmsgid, $searchtwitfrom, $searchtwitto, $partial_search ); if ( $replytxt eq '' ) { $replytxt = "Hi $fromname!\r\rNothing found\r\rCUL8R\r"; writelog( 'Nothing found.' ); } if ( defined( $reply_as ) && $reply_as eq 'IBN' ) { writelog( 'Reply by IBN' ); $replytxt = "\001REPLY: $MSGID\r$replytxt" if defined $MSGID; $replytxt = "\001CHRS: $config{defaultchrs}\r". "\001PID: Fidogle v.$vers\r$replytxt"; $pkt2bnd = txt2pkt( "$config{address}\.9", $r_addr, '', $config{myname}, $fromname, $config{address}, $fromaddr, LOC+PVT+0x08, $replytxt, 'Your request reply.', '' ); $files[0] = sprintf( "%08x\.pkt %d %d %d", time(), length( $pkt2bnd ), time(), 0 ); if ( callnode( $r_addr ) ne 'Ok' ) { writelog( 'Send by binkd failed. Sending by msg.' ); send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } } else { send_as_msg( "$cluges$replytxt\r\r--- \r\000", $fromname, $orignode, $destnode, $destnet, $orignet, $r_msgnum ); } } } } } # --- Main ----------------------- my $options = join( ' ', @ARGV ); GetOptions ( "config=s" => \$configfile, "help" => \$needhelp, "log=s" => \$logfile )or die("Error in command line arguments\n"); if ( defined( $needhelp ) || !defined( $configfile ) ) { usage(); } readconf(); $logfile = $config{log} unless defined $logfile; testconf(); writelog( "--- $programfile (v.$vers) $options" ); readndl( findndl( $config{nodelist} ) ); readareas(); scannetmail( $config{netmail} ); writelog( '--- Done.' ); # the end