#!/usr/bin/perl
#
# written by Stas Mishchenkov 2:460/58
#
#@CHRS: CP866

use strict;
use warnings;

use Getopt::Long;
use File::Spec::Functions;
use Cwd 'abs_path';
use Time::Local;

my ( $needhelp, $logfile, %globals,  $nodelist, $czone, $cregion, $cnet );

abs_path($0) =~ /^(.*?)[\\\/]([^\\\/]+)$/;
my ( $curpath, $programfile ) = ( $1, $2 );

my %modemflags = ( V22B => 'V22', V22 => '', V29 => '', V32 => 'V22', V32B => 'V32,V22',
                   V32T => 'V32B,V32,V22', V34 => 'V22,V32,V32B', V42 => 'MNP',
                   V42B => 'V42,MNP', MNP => '', H96 => '', HST => 'MNP',
                   H14 => 'HST,MNP', H16 => 'H14,HST,MNP,V42,V42B', MAX => '',
                   PEP => '', CSP => '', VFC => 'V32B,V32,V22',
                   ZYX => 'V22,V32B,V32,V42B,V42,MNP',
                   V90C => 'V34,V22,V32,V32B', V90S => 'V34,V22,V32,V32B',
                   X2C => 'V22,V32,V32B,V34', X2S => 'V22,V32,V32B,V34',
                   Z19 => 'ZYX,V32B,V32,V42B,V42,MNP,V22'
                 );
my @nomeaningflags = ( 'CM', 'ICM', 'MO', 'LO', 'MN' );
my @ipflags = ( 'IBN', 'IFC', 'IFT', 'ITN', 'IVM' );

my %baudrate = ( '300' => 1, '1200' => 1, '2400' => 1, '4800' => 1,
				'9600' => 1, '14400' => 1, '16800' => 1, '19200' => 1,
				'28800' => 1, '33600' =>1, '38400' => 1 );

sub usage()
{
	printf <<USAGE;

   A nodelist checking tool, based on FTS-5000 rev.5 and  FTS-5001 rev.6.
                                         Written by Stas Mishchenkov 2:460/58.

Usage: $programfile <nodelist> [options]
~~~~~~
   nodelist                    Nodelist file name. Wild cards allowed.

   Options:

   --help,-h                   This text.
   --zone,-z[=]Zonenumber      Zone number.
   --region,-r[=]Regionnumber  Region number.
   --net,-n[=]Netnumber        Net number.
   --log,-l[=]filename         The name of log file. No logging if not defined.

USAGE
	exit;
}

sub knownflag( $ )
{
	my ( $flag ) = @_;
	my %knownflags = ( 'CM' => '', 'ICM' => '', 'MO' => '', 'LO' => '',
						'MN' => '', 'IBN' => '', 'IFC' => '', 'IFT' => '',
						'ITN' => '', 'IVM' => '', 'GUUCP' => '', 'XA' => '',
						'XB' => '', 'XC' => '', 'XP' => '', 'XR' => '',
						'XW' => '', 'XX' => '', 'INO4' => '', 'ITX' => '',
						'IUC' => '', 'IMI' => '', 'ISE' => '', 'EVY' => '',
						'EMA' => '', 'IEM' => '', 'U' => '', 'V110L' => '',
						'V110H' => '', 'V120L' => '', 'V120H' => '',
						'X75' => '', 'ISDN' => '', 'PING' => '', 'TRACE' => '',
						'ZEC' => '', 'REC' => '', 'NEC' => '', 'NC' => '',
						'SDS' => '', , 'SMH' => '', 'RPK' => '', 'NPK' => '',
						'ENC' => '', 'CDP' => '', 'INA' => '', 'BEER' => '',
						'IP' => ''
					 );
	my ( $f );

	return 1 if defined $modemflags{$flag};
	return 1 if $flag =~ /^T[a-x][a-x]$/i;

	if ( $flag =~ /([\#\!])\d\d/ ) {
		foreach $f ( split( /$1/, $flag ) ) {
			if ( $f eq '02' || $f eq '08' || $f eq '09' || $f eq '17' ) {
				return 1;
			} else {
				return 0 if defined$f && $f ne '';
			}
		}
		return 1;
	}
	if ( $flag =~ /^(I[BFTVN][NCTMA])\:.*/i ) {
		$flag =~ s/^(I[BFTVN][NCTMA])\:.*/$1/i;
	} 
	if ( $flag =~ /[IE][TUMSVE][XCIEYAM]\:.*/ ) {
		$flag =~ s/([IE][TUMSVE][XCIEYAM])\:.*/$1/;
	}
	if ( $flag =~ /BEER\:.*/ ) {
		$flag =~ s/(BEER)\:.*/$1/;
	}
	return 1 if defined $knownflags{$flag};
	return 0;
}

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


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 FidoNet 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();
    
    writelog("Finding last nodelist file from $filemask.");
    $filemask =~ /(.*?)([^\\\/]+)$/;
    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 = 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() - $start ) ) . ' seconds.' );
    return catfile( $ndlpath, $lastnl );
}

sub ipconnectioninfo( $$ )
{
	my ( $sysname, $flags ) = @_;
	
	if ( $sysname =~ /^[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]$/i ) {
		return 1;
	}
	if ( $flags =~ /\,INA\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}
	if ( $flags =~ /\,IBN\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}
	if ( $flags =~ /\,ITN\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}
	if ( $flags =~ /\,IFC\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}
	if ( $flags =~ /\,IFT\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}
	if ( $flags =~ /\,IVM\:[a-z0-9][a-z0-9\-\.]+?\.[a-z0-9\-]+[a-z0-9]/i ) {
		return 1;
	}

	if ( $flags =~ /\,(IMI|ISE|ITX|IUC|IEM|EVY|EMA)\:[a-z0-9][a-z0-9\-\.\@\_]+/i ){
		return 1;
	}

	return 0;
}

sub readndl($)
{
    my ($nlist) = @_;
    my ($zone, $net, $node, $region, $dom, $ird, $domain, $start, $nldate );
    my ($line, $keyword, $sysop, $phone, $system, $location, $baud, $flags,
		$port, $lport, %port, $F, %lport, $nodes, $i, $addr);
    my (%flags, $uflag, %addr, @addr, $domzone, $domreg, $domnet, $domflag );
	my ( $errstr, $errors, $fl );

    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();
    $zone = $net = $node = 0;
#    $domzone = $domreg = $domnet = $ird = "";
#    $domain = 'binkp.net';
    $nodes = 0;
    $errstr = '';
    while (defined($line = <$F>)) {
	if( $line =~ /Nodelist ([a-zA-Z]+ [a-zA-Z]+\, [a-zA-Z]+ \d+\, \d+ \-\- Day number \d+)/i) {
	    $nldate = $1;
		$globals{nodelistldate} = $nldate;
	    next;
	}
	$line =~ s/\r?\n$//s;
	next unless $line =~ /^([a-z]*),(\d+),([^,]*),([^,]*),([^,]*),([^,]*),(\d+)(,.*)$/i;
	($keyword, $node, $system, $location, $sysop, $phone, $baud, $flags) = ($1, $2, $3, $4, $5, $6, $7, $8);
	next if $keyword eq "Down";
	next if $keyword eq "Hold";
#	next if $keyword eq "Pvt";
#	next unless defined $flags;
	$uflag = "";
	%flags = ();
#	%addr = ();
	@addr = ();
	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"};
#	    }
	} elsif ($keyword eq "Region") {
	    $region = $net = $node;
	    $node = 0;
#		$regions{$region} = '' if defined( $config{zone} ) && $zone == $config{zone};
#		$nets{$net} = '--- not listed ---' if defined( $config{region} ) && $region == $config{region};
	} elsif ($keyword eq "Host") {
	    $net = $node;
	    $node = 0;
	    $domnet = '';
#		$nets{$net} = '--- not listed ---' if defined( $config{region} ) && $region == $config{region};
	}
	if ( defined( $czone ) ) {
		next unless $zone == $czone;
	}
	if ( defined( $cregion ) ) {
		next unless $region == $cregion;
	}
	if ( defined( $cnet ) ) {
		next unless $net == $cnet;
	}
	if ( $node > 32767 ) {
		if ( $line ne $errstr ) {
			$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
			$errstr = $line;
		}
		$errors .= "Node number must be in the range of 1 to 32767.\n";
	}
	my %textstr = ( 'System name' => $system, 'Location' => $location,
							'Sysop name' => $sysop);
	foreach my $key ( keys  %textstr ) {
		if ( $textstr{$key} =~ /[^\x20-\x7E]/ ) {
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
		    $errors .= "Not permitted letters in $key.\n";
		}
	}
	if ( $sysop !~ /(UUCP)|(_)/i ) {
		if ( $line ne $errstr ) {
			$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
			$errstr = $line;
		}
		$errors .= "Starting \#037/09 one word sysop names are no longer permitted except the keyword \'UUCP\'.\n";
	}
	if ( length($sysop) > 36 ) {
		if ( $line ne $errstr ) {
			$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
			$errstr = $line;
		}
		$errors .= "SysOp name can not be longer then 36 letters include space.\n";
	}

	if ( $phone =~ /\-Unpublished\-/i ) {
		if ( $baud ne '300' ) {
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
		    $errors .= "Baud must be 300 if phone is -Unpublished-.\n";
	    }
		if ( defined $flags ) {
			foreach  $fl ( keys %modemflags ) {
				if ( $flags =~ /\,($fl)\b/i ) {
					if ( $line ne $errstr ) {
						$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
						$errstr = $line;
					}
					$errors .= "Flag \'$1\' has no meaning  if phone is -Unpublished-.\n";
				}
			}
			if ( ipconnectioninfo( $system, $flags )  != 1 ) {
				if ( $flags !~ /\,[IE][TUMSVE][XCIEYAM]\:.*/ ) {
					if ( $keyword ne 'Pvt' ) {
						if ( $line ne $errstr ) {
							$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
							$errstr = $line;
						}
						$errors .= "Non Pvt node has no connection info.\n";
					}
					next;
				}
				if ( $flags =~ /(X[ABCPRWX])/i ) {
					if ( $line ne $errstr ) {
						$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
						$errstr = $line;
					}
					$errors .= "Flag \'$1\' has no meaning if no connection info.\n";
				}
				foreach $fl ( @nomeaningflags ){
					if ( $flags =~ /($fl)/i ) {
						if ( $line ne $errstr ) {
							$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
							$errstr = $line;
						}
						$errors .= "Flag \'$1\' has no meaning if no connection info.\n";
					}
				}
				if ( $flags =~ /\,(T[a-x][a-x])\b/i ) {
						if ( $line ne $errstr ) {
							$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
							$errstr = $line;
						}
						$errors .= "Flag \'$1\' has no meaning if no connection info.\n";
				}
				if ( $flags =~ /\,([\!\#]\d\d)\b/ ) {
					if ( $line ne $errstr ) {
						$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
						$errstr = $line;
					}
					$errors .= "Mail Period Flags has no meaning if no connection info.\n";
				}
			# end of no INA,IBN,IFC...
			} else {
				if ( $flags =~ /\,ICM/ ) {
#					$flags =~ s/\,ICM/\,CM/;
					if ( $line ne $errstr ) {
						$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
						$errstr = $line;
					}
					$errors .= "Flag \'ICM\' not for IP only systems. It must be \'CM\' flag instead.\n";
				}
			}
		 # if ( defined $flags )
		}
	 # if ( $phone =~ /\-Unpublished\-/i )
	} else {
		unless ( defined( $baudrate{$baud} ) ) {
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "Illegal baud rate \'$baud\'.\r";
		}
		if ( defined $flags ) {
			foreach my $key ( keys %modemflags ) {
				if ( $flags =~ /\,$key\b/i && $modemflags{$key} ne '' ) {
					foreach my $impl ( split( /,/, $modemflags{$key} ) ) {
						if ( $flags =~ /($impl)\b/i  ) {
#							$flags =~ s/\,($impl)\b//i;
							if ( $line ne $errstr ) {
								$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
								$errstr = $line;
							}
							$errors .= "Flag \'$key\' implies \'$1\'.\n";
						}
					}
				}
			} # modem flags end
			if ( $phone !~ /[\d\-]{3,29}/ ) {
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "The phone number must be from 3 up to 29 digits and dashes, or the exact string \"-Unpublished-\".\n";
			}
		 # if ( defined $flags )
		}
	}
	if ( defined $flags ) {
		if ( $flags =~ /\,CM\b/i ) {
			if ( $flags =~ /\,(T[a-x][a-x])\b/i ) {
#				$flags =~ /(T[a-x][a-x])\b/;
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "Flag \'CM\' implies \'$1\'.\n";
			}
			if ( $flags =~ /\,([\!\#]\d\d)\b/ ) {
#				$flags =~ /\b([\!\#]\d\d)\b/;
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "Flag \'CM\' implies Mail Period Flags.\n";
			}
			if ( $flags =~ /\,(ICM)\b/ ) {
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "Flag \'CM\' implies \'ICM\'.\n";
			}
		}
		if ( ipconnectioninfo( $system, $flags )  != 1 ) {
			foreach my $ipfl ( @ipflags ) {
				if ( $flags =~ /($ipfl\:?\d*)/i ) {
					if ( $line ne $errstr ) {
						$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
						$errstr = $line;
					}
					$errors .= "Flag \'$1\' has no meaning if no IP connection info.\n";
				}
			}
		}
		if ( $flags =~ /\,TCP\b/ ) {
#			$flags =~ s/\,TCP\b/\,TCo/;
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "Starting #169/21 the irregular use of a TCP flag Starting #169/21 the use of a TCP flag is prohibited.\n";
		}
		if ( $flags =~ /(.*?)\,U(\,.*)$/ ) {
			my ( $regflags, $uflags ) = ( $1, $2 );
			if ( $uflags =~ /\,(T[a-x][a-x])\b/i ){
#				$regflags .= $1;
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "Starting \#251/12 the System open hours flag Txy moves from userflag to a regular flag.\n";
#				$uflags =~ s/$1//;
			}
#			$flags = "$regflags\,U$uflags";
		}
		if ( $flags =~  /\,IP\b/ ) {
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "\'IP\' flag denotes an unspecified protocol. Deprecated.\n";
#			$flags =~  s/\,IP\b//;
		}
		foreach my $flg ( split( /,/, $flags ) ) {
			next if $flg eq '';
			unless ( knownflag( uc( $flg ) ) ) {
#				$flags =~ s/\,$flg//;
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "Unknown flag \'$flg\'.\n";
			}
		}
		if ( $flags =~ /\,V90C/ && $flags =~ /\,V90S/ ) {
#			$flags =~ s/\,V90C//;
#			$flags =~ s/\,V90S//;
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "The V90C and V90S flags are mutually exclusive.\n";
		}
		if ( $flags =~ /\,X2C/ && $flags =~ /\,X2S/ ) {
#			$flags =~ s/\,X2C//;
#			$flags =~ s/\,X2S//;
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "The X2C and X2S flags are mutually exclusive.\n";
		}
		if ( $flags =~ /\,HST/ || $flags =~ /\,H14/ ||
				$flags =~ /\,H16/ || $flags =~ /\,X2S/ ||
				$flags =~ /\,X2C/ ) {
			if ( $flags =~ /\,ZYX/ || $flags =~ /\,Z19/ ) {
#				$flags =~ s/\,Z[Y1][X9]//;
#				$flags =~ s/\,H[S1][T46]//;
#				$flags =~ s/\,X2[CS]//;
				if ( $line ne $errstr ) {
					$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
					$errstr = $line;
				}
				$errors .= "No modem has at the same time the US Robotics proprietary protocols and the ZyXEL ones.\n";
			}
		}
		if ( $flags =~ /\,X[ABCPRWX].*?\,X[ABCPRWX]/i ) {
#			$flags =~ s/\,X[ABCPRWX]//gi;
			if ( $line ne $errstr ) {
				$errors .= sprintf("%-22s \n$line\n", "$zone\:$net\/$node" );
				$errstr = $line;
			}
			$errors .= "File/Update Request Flags are mutually exclusive.\n";
		}
	} # if defined $flags

		$nodes++;
#		$name =~ s/_/ /g;
#		$nodelist{"$zone\:$net\/$node"} = $name;
   }
    close($F);
    my $lstr = "Nodelist $nldate parsed, $nodes nodes processed (" . ( time() - $start) . " sec)";
    print( "$lstr\n" );
    writelog( $lstr );
	print "$errors\n" unless defined $logfile;
	writelog( $errors );
}

# ------- MAIN -----------
   GetOptions (
               "zone=s"         => \$czone,
               "region=s"       => \$cregion, 
               "net=s"          => \$cnet,
               "help"           => \$needhelp,
               "log=s"          => \$logfile)  # string
   or die("Error in command line arguments\n");
   $nodelist = shift @ARGV;


   $needhelp = 1 unless defined ( $nodelist );
   usage() if $needhelp;
   readndl( findndl( $nodelist ) );