#!/usr/bin/perl

use strict;
use warnings;

use Parallel::ForkManager;

use Getopt::Long;
use IO::Socket::IP;
use Socket qw(:addrinfo SOCK_RAW);
use LWP::Simple;
use Time::TZOffset qw/tzoffset/;
use Time::HiRes;
use Cwd 'abs_path';
use File::Spec;

our $myaka = '2:9999/9999.9999';
my $vers = 'v.0.9.2.1';
our $TZUTC = sprintf( "%04d", tzoffset( localtime() ) );

our ( $lreg,$lnetw,$logfile, $fnode, $fzone, $ndlfile, $needhelp,
	$check_updates,$configfile,$export,$flagdir, $debug, $threads );

my ( $sysop, $systemname, $location, $NDL ) = ('Evil Robot',
					    $^O, 'Sinferopol, Crimea',
					    '-Unpublushed-,300,MO' );
$flagdir = './';
$threads = 8;

GetOptions ("region=s"   => \$lreg,
            "net=s"      => \$lnetw,
            "fnode=s"    => \$fnode,
            "zone=s"     => \$fzone,
            "config=s"   => \$configfile,
            "aka=s"      => \$myaka,
            "help"       => \$needhelp,
            "export"     => \$export,
            "update=s"   => \$check_updates,
            "debug"      => \$debug,
            "log=s"      => \$logfile)  # string
or die("Error in command line arguments\n");

$ndlfile = shift @ARGV;

our (%nodelist,%sortednodes,$nldate);

sub help
{
    print "\nCalls the specified nodes by the binkp protocol, using connect information\n".
	  "from the nodelist.\n\n".
	  "Usage: $0 [options] nodelist_file_name\n".
	  "~~~~~\n".
	  "         -f,--fnode address     - address of node to call. Optional.\n".
	  "         -z,--zone number       - number of zone to test all nodes. Optional.\n".
	  "         -r,--region number     - number of region to test all nodes. Optional.\n".
	  "         -n,--net network       - number of network to test all nodes,\n".
	  "                                  i.e. 460. Optional.\n".
	  "                                  If you do not specify anything, then the\n".
	  "                                  check will pass through the entire nodelist.\n".
	  "         -l,--log log_file_name - file name of log file\n".
	  "         -a,--aka address       - the fido address from which to make calls.\n".
	  "                                  Optional. default is \'$myaka\'.\n".
	  "                                  It is strongly recommended do not to specify\n".
	  "                                  your known AKA in the script settings, but\n".
	  "                                  to use something like 2:460/58.1, i.e. an\n".
	  "                                  address with which you are completely sure\n".
	  "                                  that definitely cannot be the other session\n".
	  "                                  in any way. \n".
	  "         -c,--config            - Configuration file name. Command line options\n".
	  "                                  owerrides it. Optional. Not needed by default.\n".
	  "                                  Use command \'callip.pl -e > callip.conf\' to\n".
	  "                                  create a new one.\n".
	  "         -e,--export            - export configuration end exit.\n".
	  "         -u,--update            - How to update programm. Optional.\n".
	  "                                  =a - auto. Check for a new version, download\n".
	  "                                       and update.\n".
	  "                                  =d - download. Checks for a new version and\n".
	  "                                       download the update to a new file.\n".
	  "                                  =f - Force download callip.pl end exit even\n".
	  "                                       if no new version is found.\n".
	  "                                  =w - warn. Checks for a new version and warn\n".
	  "                                       the sysop. Default.\n".
	  "                                  =n - no. Do nothing.\n";
    exit;
}

#my ( $sysop,$systemname,$location, $NDL );

sub readconf
{
    my ( $line );
    unless( open( CFG, "<$configfile" ) ){
	print "Can't open $configfile. ($!)\n";
    }
    while( $line = <CFG> ) {
	$line =~ s/	/ /g;
	$line =~ s/^\s+//g;
	$line =~ s/[ ]{2,}/ /g while $line =~ /[ ]{2,}/;
	$line =~ s/[\r\n]//g;
	next if $line =~ /^[\#\:\;]/;
	if( $line =~ /^sysop (.*?)$/i ){
	    $sysop = $1;
	} elsif ( $line =~ /^sysname (.+)$/i ){
	    $systemname = $1;
	} elsif ( $line =~ /^address (.+)$/i ){
	    $myaka = $1;
	} elsif ( $line =~ /^location (.+)$/i ){
	    $location = $1;
	} elsif ( $line =~ /^nodeinfo (.+)$/i ){
	    $NDL = $1;
	} elsif ( $line =~ /^nodelist ([^ ]+)$/i ){
	    $ndlfile = $1 unless defined $ndlfile;
	} elsif ( $line =~ /^log ([^ ]+)$/i ){
	    $logfile = $1 unless defined $logfile;
	} elsif ( $line =~ /^flags ([^ ]+)$/i ){
	    $flagdir = $1;
	    mkdir $flagdir unless -e $flagdir;
	} elsif ( $line =~ /^update ([^ ]+)$/i ){
	    $check_updates = $1 unless defined $check_updates;
	    $check_updates =~ s/^([a-z]{1}).*$/$1/i;
	    $check_updates = lc($check_updates);
#	    print "\$check_updates = $check_updates\n";
	} elsif ( $line =~ /^threads (\d+)/i ){
	    $threads = $1;
	}
    }
}

sub exportcfg
{
	print "\# callip\.pl configuration\.\n#\n".
	"# SyOp Name\n".
	"SysOp $sysop\n#\n".
	"# System Name\n".
	"SysName $systemname\n#\n".
	"# 4D or 5D fido address\n".
	"# It is strongly recommended do not to specify your known AKA in the script\n".
	"# settings, but to use something like 2:460/58.1, i.e. an address with which\n".
	"# you are completely sure that definitely cannot be the other session anyway.\n".
	"Address $myaka\n#\n".
	"# Where are you from\n".
	"location $location\n#\n".
	"# Phone number, modem speed, nodelist flags\n".
	"nodeinfo $NDL\n#\n".
	"# Nodelist file name. * and ? may be used.\n".
	"#nodelist /home/fido/nodelist/*list.???\n".
	"#nodelist /home/fido/nodelist/nodelist.367\n#\n".
	"# log file name\n".
	"#log /home/fido/logs/callip.log\n#\n".
	"# busy flags dir name.\n".
	"#flags /home/fido/flags\n#\n".
	"# How to update programm.\n".
	"# auto = Check for a new version, download and update.\n".
	"# download = Checks for a new version and download the update to a new file.\n".
	"# force = Force download callip.pl end exit even if no new version is found.\n".
	"# warn = Checks for a new version and warn the sysop. Default.\n".
	"# no = Do nothing.\n".
	"update warn\n#\n".
	"# How many threads use to call nodes. Default 8.\n".
	"threads 8\n#\n";
	exit;
}

sub oldbsy()
{
 my $bsyf;
    if ( opendir( DH, $flagdir ) ) {
	while( readdir( DH ) ) {
	    if( $_ =~ /'.bsy'$/i) {
		$bsyf = File::Spec->catfile( $flagdir, $_ );
		if ( unlink( $bsyf ) ) {
		    print "found $_ and deleted.\n";
		    writelog("found $_ and deleted.\n");
		} else {
		    print STDERR "Can't delete $bsyf ($!).\n";
		    writelog( "ERROR: Can't delete $bsyf ($!).\n" );
		}
	    }
	}
    } else {
	print STDERR "Can't open $flagdir ($!).\n";
	writelog("ERROR: Can't open $flagdir ($!).\n");
    }
}

sub findndl()
{
    $ndlfile =~ /(.*?)([^\\\/]+)$/;
    my ( $ndlpath, $ndlfn ) = ($1,$2);
    my ( $nldate, $lastdate, $lastnl );
    $ndlpath = './' if !defined( $ndlpath ) || $ndlpath eq '';
#    print abs_path($ndlpath) . "\n";
    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 = ( stat( $ndlpath . $_ ) )[9];
#		$nldate = -A $ndlpath . $_;
		if ( $nldate > $lastdate ) {
		    $lastdate = $nldate;
		    $lastnl = $_;
		}
	    }
        }
    } else {
	print STDERR "Can't open $ndlpath. ($!)\n";
	exit;
    }
    return $ndlpath . $lastnl;
}

sub readndl($)
{
    my ($nlist) = @_;
    my ($zone, $net, $node, $region, $dom, $ird, $domain, $start);
    my ($line, $keyword, $name, $phone, $flags, $port, $lport, %port,
            %lport, $nodes, $i, $addr);
    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();
    $start = Time::HiRes::time;
    $zone = $net = $node = 0;
    $domzone = $domreg = $domnet = $ird = "";
    $domain = 'binkp.net';
    $nodes = 0;
    while (defined($line = <F>)) {
	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, $phone, $flags) = ($1, $2, $3, $4, $5);
	next if $keyword eq "Down";
	next if $keyword eq "Hold";
	next if $keyword eq "Pvt";
	next unless defined $flags;
	$uflag = "";
	%flags = ();
	%addr = ();
	@addr = ();
	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"});
	    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++;
#	    print( "Fetch addr for $zone:$net/$node: " . $nodelist{"$zone:$net/$node"} . " (IBN flag)\n");
	    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++;
#	    print("Fetch addr for $zone:$net/$node: " . $nodelist{"$zone:$net/$node"} . " (INA flag)\n");
	    next;
	}
	if ($phone =~ /000-([1-9]\d*)-(\d+)-(\d+)-(\d+)$/) {
	    $addr{"$1.$2.$3.$4"} = 1;
	    push(@addr, "$1.$2.$3.$4");
#	    print( "Fetch addr for $zone:$net/$node: $1.$2.$3.$4 (phone)\n");
	}
	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);
#		print( "Fetch addr for $zone:$net/$node: $name (system name)\n");
	    }
	}
	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, $_);
#		    Log(8, "Fetch addr for $zone:$net/$node: $_ (IRD flag)");
		}
	    }
	}
	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)\n";
    print( $lstr );
    writelog( $lstr );
}

our ( $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");

sub readblock($)
{
  my ($sock) = @_;

  my ($iscmd,$cmd,$cmdlen, $data,$remoteaddr);

    return ('Error', "Socket read error.\n" ) unless sysread($sock, $iscmd, 1 ) == 1;
    $iscmd = ord($iscmd);
    if ( $iscmd < 128 ) {
	return ('Error', "Socket read error.\n" ) unless sysread($sock, $cmdlen, 1 ) == 1;
	$cmdlen = ord($cmdlen);
	$cmdlen = ( $iscmd * 256 ) + $cmdlen;
	return ('Error', "Socket read error.\n" ) unless sysread($sock, $data, $cmdlen ) == $cmdlen;
	return ('DATA', $data);
    } else {
	return ('Error', "Socket read error.\n" ) unless sysread($sock, $cmdlen, 1 ) == 1;
	$cmdlen = ( ord($cmdlen) + ( ( $iscmd - 128 ) * 256) );
	return ('Error', "Socket read error.($!)" ) unless sysread($sock, $cmd, 1 ) == 1;
	return ('Error', "Socket read error.($!)" ) unless sysread($sock, $data, $cmdlen - 1 ) == $cmdlen - 1;
	return ($cmd,$data);
    }


}
sub connec2binkd($$$)
{
  my ($host,$portaddress,$fn) = @_;
  my $rc = '';
  my ($s,@bsyflag);
  my $isbinkd = "Error! No binkp found\n";
  
  writelog("***Calling $fn ($host:$portaddress)***") if $debug;
  
  localtime() =~ /([^ ]+) ([^ ]+)[ ]+(\d+) (\d\d\:\d\d:\d\d) (\d\d\d\d)/;
  my ( @str ) = ( 
	"SYS $systemname",
	"ZYZ $sysop",
	"LOC $location",
	"NDL $NDL",
	"TIME $1 $3 $2 $5 $4 $TZUTC",
	"VER Call_Robot/$vers/$^O binkp/1.0"
	);

  print "Calling $fn ($host\:$portaddress)\n";
  $rc .= "     ($host\:$portaddress)\n";
  $fn =~ /(\d+)\:(\d+)\/(\d+)/;
  @bsyflag = ( File::Spec->catfile( $flagdir, "$1.$2.$3.0.bsy" ) );
  print( "$fn is busy\n" ) && sleep 1 while -e $bsyflag[0];
  if ( open( BF, ">$bsyflag[0]" ) ){
    close(BF);
  } else {
    print STDERR "Can't create $bsyflag[0]. ($!)\n";
    $rc .= "Can't create $bsyflag[0]. ($!)\n";
  }
  my $sock = IO::Socket::IP->new(PeerAddr => $host,
    PeerPort => $portaddress,
    Timeout  => 15,
    Proto    => 'tcp') || print( "error $!\n") &&
		unlink( @bsyflag ) &&
		return( "  $host - Error $!\n" );
    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 );
	    $rc .= "Socket write error!\n";
	    close($sock);
	    return $rc;
	}
    }
    unless( syswrite($sock, "\x80" . chr(length($myaka) + 2) . "$M_ADR $myaka") ){
	unlink( @bsyflag );
	$rc .= "Socket write error!\n";
	close($sock);
	return $rc;
    }
    unless( syswrite($sock, "\x80\x02$M_PWD\-") ) {
	unlink( @bsyflag ); 
	$rc .= "Socket write error!\n";
	close($sock);
	return $rc;
    }

    print "Waiting M_OK...\n" if $debug;
    writelog( "$fn ($host) Waiting M_OK...\n") if $debug;

    WAITOK:
    my ($c,$d) = readblock($sock);
    if ( $c eq "DATA" ) {
	print "DATA not expected now!\n\'$c\', \'$d\'\n";
	$s = 'Not expected DATA!';
	$rc .= " $s\n \'$c\'\, \'$d\'\n$isbinkd";
#	syswrite($sock, "\x80".(length($s)+1)."$M_ERR$s");
#	close($sock);
#	return $rc;
	goto WAITOK;
    }elsif( $c eq 'Error') {
	print "$c $d";
	close($sock);
	unlink @bsyflag;
	return "$rc$c. $d";
    } else {
	if ($c eq $M_NUL) {
	    print "$d\n";
#	    writelog(" $d");
	    $rc .= " $d\n";
#	    $rc .= " binkp - Ok.\n" if $d =~ m@binkp/1.[01]|TIME @i;
	    if( $d =~ m@(binkp/1.[01])@i ) {
		$isbinkd = '';
	    }
	    goto WAITOK;
	} elsif ($c eq $M_ADR) {
	    my $is = 0;
#			print "$d\n";
	    $rc .= "M_ADR \'$d\' \n" if $debug;
	    $d =~ s/^ //;
	    $d =~ s/\x00$//;
#	    $rc .= "M_ADR \'$d\' \n";
	    foreach my $ma ( split(' ',$d) ) {
		print "address: $ma\n";
		$rc .= " address: $ma\n";
		$is = 1 if $ma =~ /^$fn(\.0)?(\@[a-zA-z]+)?$/i;
		$ma =~ /(\d+)\:(\d+)\/(\d+)/;
		@bsyflag = ( @bsyflag, File::Spec->catfile( $flagdir, "$1.$2.$3.0.bsy" ) );
#  print( "$fn is busy\n" ) && sleep 1 while -e @bsyflag[0];
		if ( open( BF, '>'.File::Spec->catfile( $flagdir, "$1.$2.$3.0.bsy" ) ) ){
		    close(BF);
		} else {
		    print STDERR "Can't create bsyflag. ($!)\n";
		    $rc .= "Can't create busyflag. ($!)\n";
		}
	    }
	    if ($is == 0) {
		print "No such AKA.\n$isbinkd";
		$rc .= " No such AKA.\n $isbinkd";
		$rc .= "Socket write error!\n" unless syswrite($sock, "\x80\x0d${M_ERR}No such AKA.");
		$rc .= "Socket write error!\n" unless syswrite($sock, "\x80\x01${M_EOB}");
		close($sock);
		unlink @bsyflag;
		return $rc;
	    }
	    goto WAITOK;
	} elsif ($c eq $M_ERR) {
	    print "Got error: $d.\n";
	    $rc .= " $host - Got error: $d.\n";
	    $rc .= "Socket write error!\n" unless syswrite($sock, "\x80\x01${M_EOB}");
	    close($sock);
	    unlink @bsyflag;
	    return $rc;
	} elsif ($c eq $M_BSY) {
	    print "Error: $d.\n";
	    $rc .= " $host - Got error: $d.\n";
	    $rc .= " Socket write error!\n" unless syswrite($sock, "\x80\x01${M_EOB}");
	    close($sock);
	    unlink @bsyflag;
	    return $rc;
	} elsif ($c eq $M_FILE) {
	    $d =~ /^([^ ]* \d+ \d+) \d+$/;
#	    unlink( @bsyflag ) && return "Socket write error!\n" unless 
	    syswrite($sock, "\x80".chr( length($1)+1 )."${M_SKIP}$1");
#			syswrite($sock, "\x80\x01${M_EOB}");
	    print "File $d skipped.";
	    $rc .= " $fn have a file $d for us.\n";
#	    goto WAITOK;
	} elsif ($c eq $M_OK) {
	    print " $host - Ok.\n";
	    $rc .= " $host - Ok.\n";
	}
    }
    
    unlink( @bsyflag ) && return "Socket write error!\n" unless syswrite($sock, "\x80\x08${M_NUL}TRF 0 0");
    unlink( @bsyflag ) && return "Socket write error!\n" unless syswrite($sock, "\x80\x01${M_EOB}");
    WAITEOB:
    ($c,$d) = readblock($sock);
    if ($c eq $M_NUL) {
	print "$d\n";
	$rc .= "$d\n";
#	writelog(" $d");
	goto WAITEOB;
    } elsif ($c eq $M_FILE) {
	$d =~ /^([^ ]* \d+ \d+) \d+$/;
#	unlink( @bsyflag ) && return "Socket write error!\n" unless 
	syswrite($sock, "\x80".chr( length($1)+1 )."${M_SKIP}$1");
#		syswrite($sock, "\x80\x01${M_EOB}");
	print "File $d skipped.\n";
	$rc .= "File $d skipped.\n";
#	writelog('File $d skipped.');
	goto WAITEOB;
    } elsif ($c eq $M_EOB) {
	print "Session with $fn done.\n";
	$rc .= "Session with $fn done.\n";
#	writelog('Session with $fn done.');
    } else {
	print "\'$c\'\n";
	$rc .= "\'$c\',\'$d\'\n";
	goto WAITEOB;
    }

  close($sock);
  unlink @bsyflag;
  return $rc;
}

sub update()
{
    return if $check_updates eq 'n';
    return unless $check_updates =~ /^[nwdaf]$/;

    my ( $ver_s, $upd, $of );
    my $url = 'http://brorabbit.g0x.ru/files/perl/';

    my $curpath = abs_path($0);
    $curpath = '' unless defined $curpath;

    $ver_s = get( $url . 'callip.v');
    if (defined ($ver_s) ) {
	if ( $check_updates eq 'f' ) {
		$curpath =~ /^(.*?)\.pl$/;
		$of = "$1_$ver_s\.pl";
		print "You should update to $ver_s\!\n";
		writelog(" \*\*\* You should update to $ver_s\! Update filename is \'$of\'.\n");
	} elsif ( $vers lt $ver_s ) {
	    if ( $check_updates eq 'w' ) {
		print " \*\*\* You should update to $ver_s\! \*\*\* \n";
		writelog(" \*\*\* You should update to $ver_s\! \*\*\* \n");
		return;
	    } elsif ( $check_updates eq 'a' ) {
		$of = $curpath;
		print "callip.pl will be updated to $ver_s\!\n";
		writelog(" \*\*\* Updating callip.pl to $ver_s\!\n");
	    } elsif ( $check_updates eq 'd' ) {
		$curpath =~ /^(.*?)\.pl$/;
		$of = "$1_$ver_s\.pl";
		print "You should update to $ver_s\!\n";
		writelog(" \*\*\* You should update to $ver_s\! Update filename is \'$of\'.\n");
	    }

	} else {
	    print "You have actual version.\n";
	    return;
	}
	$upd = get( $url . 'callip.pl' );
	unless( defined $upd ) {
	    print STDERR "Can't get update.\n";
	    writelog("Can't get update. ${url}callip.pl\n");
	    return;
	}
	if ( open ( OF, ">$of") ) {
	    binmode(OF);
	    print( OF $upd );
	    close(OF);
	    chmod 0755, $of if $^O eq 'linux';
	    print "$of saved.\n\n";
	} else {
	    print STDERR "Can't open $of ($!).\n";
	}
    } else {
	print STDERR "Can't connect to $url\n";
	writelog("Can't connect to $url\n");
    }
}

sub writelog
{
    my ( $str ) = @_;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    sprintf("%.3f",Time::HiRes::time) =~ /([\.\,]\d+)$/;
    my $startstr = ($year+1900)."-". sprintf("%02d",$mon+1)."-". 
	sprintf("%02d",$mday)." ". sprintf("%02d",$hour).":".
	sprintf("%02d",$min).":". sprintf("%02d",$sec)."$1 ";
    $str =~ s/([\r\n]+)/$1$startstr/g;
#    $str =~ s/  / /g;
    if ( defined($logfile) )
    {
	
        if ( open( FLOG, ">>$logfile") )
        {
        print( FLOG "${startstr}$str\n" );
        close( FLOG );
        }
        else
        {
            printf( STDERR "Can't open $logfile. ($!)\n" );
        }
    }
}

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 ) {
	return " Cannot getaddrinfo - $err\n";
    }

    while( my $ai = shift @res ) {
	my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV);
	if ( $err ) {
	    $r .= " Cannot getnameinfo - $err\n";
	    undef $err;
	    next;
	}
	$r .= connec2binkd($ipaddr,$portaddress,$fn);
    }
    return $r;
}

sub callnode($)
{
    my ($fn) = @_;
    writelog("xxx Calling node $fn xxx") if $debug;
    my ( $hostname, $portaddress, $r, $bsyflag );
    $r = "Calling $fn\n";
    foreach my $d ( split( ';', $nodelist{$fn} ) ) {
	undef $portaddress;
#	print "\'$d\'\n";
        if ( $d =~ /^(.+?)[\.\]]?\:+(\d+)\.?$/ ) {
	    ( $hostname, $portaddress ) = ($1, $2);
	} else {
	    $d =~ /(.*?)\.?$/;
	    $hostname = $1;
	}
	$portaddress = '24554' unless defined $portaddress;
	print "$hostname, $portaddress\n";
	$r .= " $hostname\:$portaddress\n";
	if( defined( $flagdir ) ) {
	    $bsyflag = File::Spec->catfile($flagdir, "$hostname\-$portaddress\.bsy");
	    print( "$hostname is busy. Sleep 1 sec.\n" ) && sleep 1 while -e $bsyflag;
	    open( BF, ">$bsyflag" ) && close(BF);
	}

	$r .= testcall($hostname, $portaddress, $fn);
	unlink $bsyflag if defined $bsyflag;
    }
    return $r;
}

exportcfg() if defined $export;
help() if defined $needhelp;
if( defined( $check_updates ) && $check_updates eq 'f' ) {
    update();
    exit();
}
readconf() if defined $configfile;
oldbsy();
$check_updates = 'w' unless defined( $check_updates );
update();
help() unless defined( $ndlfile ) || defined( $configfile );

readndl( findndl() );

my ( @th, @joinable, $jo, $the );
unless ( defined $fnode ) {
    my $pm = Parallel::ForkManager->new(16);
    CALLALL:
	foreach my $nn (sort keys %nodelist) {
	    $pm->start and next CALLALL;
	    writelog(callnode($nn));
	    $pm->finish;
	}
	$pm->wait_all_children;
    } else {
	if( defined( $nodelist{$fnode} ) ) {
	    writelog( callnode($fnode) );
	} else {
	    print "Node $fnode not found.\n";
	    writelog("Node $fnode not found.");
	}
    }
exit;