#!/usr/bin/perl

use strict;
use warnings;

use Getopt::Long;
use File::Spec::Functions;
use File::Copy;
use Cwd 'abs_path';
use FTN::JAM;
use FTN::JAM::Attr;
use FTN::JAM::Subfields;
use FTN::JAM::Errnum;
use LWP::Simple;

my $vers = 'v.0.0.0.7';
my $url = 'http://brorabbit.g0x.ru/files/perl/';

my ( $logfile, %config, %areas, $needhelp, %lastall, $maxlastread, $maxread,
	$whatsnew, $prinver, $check_updates, %dw, %mattr, $purge, $basedir );

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

sub usage()
{
    if ( 'MSWin32' eq $^O ) {
    print <<USW;
    
    $programfile sorts, links and optionally purges JAM echo base.
                             Written by Stas Mishchenkov 2:460/58.
    
    Usage: $programfile [options] <echotag>
    ~~~~~~
    echotag - echo area tag to sort messages. Wild cards allowed.
    Options:
        -h,--help                  this text.
        -l,--log[=]filename        log file name. Optional.
        -a,--areas[=]filename      file name of husky areas file.
        -b,--base[=]dirname        base dir for JAM echo base.
        
        -a,--areas and -b,--base are mutually exclusive options.
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        -p,--purge      while sorting, purge messages marked as DELETED,
                        or according to -d and -m options in area
                        configuration.
        -u,--update     How to update the program. Optional.
                           =d - download. Check for a new version and
                                download the update to a new file.
                           =f - Force download callip.pl end exit even
                                if no new version is found.
                           =w - warn. Check for a new version and warn
                                the sysop. Default.
                           =n - no. Do nothing.
        -V,--ver        show version and exit.
        -w,--whatsnew   show whatsnew.
USW
    } else {
    print <<US;
    
    \x1b[36m$programfile sorts, links and optionally purges JAM echo base.
                             Written by Stas Mishchenkov 2:460/58.
    
   \x1b[32;1m Usage: $programfile [options] <echotag>
    ~~~~~~
   \x1b[37;1m echotag \x1b[37;0m - echo area tag to sort messages. Wild cards allowed.
    Options:
       \x1b[37;1m -h,--help\x1b[37;0m                  this text.
        \x1b[37;1m-l,--log[=]filename\x1b[37;0m        log file name. Optional.
        \x1b[37;1m-a,--areas[=]filename\x1b[37;0m      file name of husky areas file.
        \x1b[37;1m-b,--base[=]dirname\x1b[37;0m        base dir for JAM echo base.
        
        \x1b[33;1m-a,--areas and -b,--base are mutually exclusive options.
        
        \x1b[37;1m-p,--purge\x1b[37;0m      while sorting, purge messages marked as DELETED,
                        or according to -d and -m options in area
                        configuration.
        \x1b[37;1m-u,--update\x1b[37;0m     How to update the program. Optional.
                          \x1b[37;1m =d\x1b[37;0m - download. Check for a new version and
                                download the update to a new file.
                          \x1b[37;1m =f\x1b[37;0m - Force download callip.pl end exit even
                                if no new version is found.
                          \x1b[37;1m =w\x1b[37;0m - warn. Check for a new version and warn
                                the sysop. Default.
                          \x1b[37;1m =n\x1b[37;0m - no. Do nothing.
        \x1b[37;1m-V,--ver\x1b[37;0m        show version and exit.
        \x1b[37;1m-w,--whatsnew\x1b[37;0m   show whatsnew.\x1b[0m
US
}
exit;
}


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*\w+Area\s*(\S+)\s+(\S+).*?\-b\s+JAM/i;
		$key = uc($1);
		$areapath = $2;
		next if $areapath =~ /^passthrough$/i;
		$areas{$key}{areapath} = $areapath;
		if ( $line =~ /\s\-p\s+(\d+)/i ) {
			$areas{$key}{purgedays} = ( $1 * 86400 );
		}
		if ( $line =~ /\s\-m\s+(\d+)/i ) {
			$areas{$key}{maxmsgs} = $1;
		}
		$lines++;
    }
    close($F);
    print "$lines areas read.\n";
}

sub writelog($)
{
    my ( $str ) = @_;
    if ( defined( $logfile ) ) {
		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 ( open( my $FLOG, '>>', $logfile ) ) {
            print( $FLOG "$timestamp$str\n" );
            close( $FLOG );
        } else {
            print( STDERR "Can't open logfile $logfile. ($!)\n" );
        }
    }
}

sub readlastreads($)
{
	my ( $mbfile ) = @_;
	my ( $FH, $u, $buf );

	$mbfile .= '.jlr';
	writelog( "Reading users lastreads $mbfile." );
	unless ( open( $FH, '<', $mbfile ) ) {
		print STDERR "Can't open $mbfile ($!).\n";
		writelog( "Can't open $mbfile ($!)." );
		return 0;
	}

	$u = 0;
	while( read( $FH, $buf, 16 ) == 16 ) {
		( undef, undef, $lastall{$u}{LastReadHold},
			$lastall{$u}{HighReadHold} ) = ( $lastall{$u}{UserCRC},
			$lastall{$u}{UserID}, $lastall{$u}{LastReadMsg},
			$lastall{$u}{HighReadMsg} ) = unpack( "LLLL", $buf );
		$u++;
	}
	print "$u users read.\n";
	writelog( "$u users read." );
	return 1;
}


sub ReadMessageHeader
{
    my ( $handleref, $msgnum, $BaseMsgNum ) = @_;

    my ( $buf, @data, @m_header, $SubfieldLen, $tzutc );

#	print "Reading message header \#$msgnum\n";
#	writelog( "Reading message header \#$msgnum" );

    if ( !seek( $$handleref{jdx}, ( $msgnum - $BaseMsgNum ) * 8, 0 ) )
    {
        writelog( "IO_ERROR" );
        return 0;
    }

    if ( read( $$handleref{jdx}, $buf, 8 ) != 8 ) {
        writelog( "IO_ERROR" );
        return 0;
    }

    @data = unpack( "LL", $buf );

    if ( !seek( $$handleref{jhr}, $data[1], 0 ) ) {
        writelog( "IO_ERROR" );
        return 0;
    }

    if ( read( $$handleref{jhr}, $buf, 76 ) != 76 ) {
        writelog( "IO_ERROR" );
        return 0;
    }

    @m_header = unpack( "Z[4]SSLLLLLLLLLLLLLLLLL", $buf );

    if ( $m_header[0] ne "JAM" ) {
        writelog( "MSGHEADER_CORRUPT" );
        return 0;
    }

    if ( $m_header[1] != 1 ) {
        writelog( "MSGHEADER_UNKNOWN" );
        return 0;
    }
#	my ( $DateWritten, $DateProcessed, $Attributes ) = 
#				( $m_header[10], $m_header[12], $m_header[14] );
	my ( $sign, $mm, $hh, $msgid, $replyto );
	$tzutc = $replyto = $msgid = 0;
	$SubfieldLen = $m_header[3];
        if ( read( $$handleref{jhr}, $buf, $SubfieldLen ) != $SubfieldLen ) {
            writelog( "IO_ERROR" );
            return 0;
        }

        while ($buf) {
            @data = unpack( "LL", $buf );
			if ( $data[0] == 2004 ) {
				$tzutc = substr( $buf, 8, $data[1] );
				if ( $tzutc =~ /(\-?)(\d\d)(\d\d)/) {
					( $sign, $hh, $mm ) = ( $1, $2, $3 );
					$tzutc = ( $hh * 3600 ) + ( $mm * 60 );
					$tzutc = "$sign$tzutc" if defined $sign;
				} else { $tzutc = 0; }
			}
			if ( $data[0] == 4 ) {
				$msgid = substr( $buf, 8, $data[1] );
			}
			if ( $data[0] == 5 ) {
				$replyto = substr( $buf, 8, $data[1] );
			}
            $buf = substr( $buf, 8 + $data[1] );
        }

	return ( ($m_header[10] - $tzutc), $m_header[12], $m_header[14],
			$msgid, $replyto, @m_header );
}


sub setlastreads($$)
{
	my ( $oldmsgnum, $newmsgnum ) = @_;
	my $user = 0;
		while ( defined( $lastall{$user}{LastReadMsg} ) ) {
			if ( $lastall{$user}{LastReadHold} == $oldmsgnum ) {
				$lastall{$user}{LastReadMsg} = $newmsgnum;
			}
			$lastall{$user}{HighReadMsg} = $newmsgnum if $lastall{$user}{HighReadHold} == $oldmsgnum;
			$user++;
		}
}

sub setMessageHeader
{
    my ( $headerref, @data ) = @_;

    %$headerref = ();

    $$headerref{Signature}     = $data[0];
    $$headerref{Revision}      = $data[1];
    $$headerref{ReservedWord}  = $data[2];
    $$headerref{SubfieldLen}   = $data[3];
    $$headerref{TimesRead}     = $data[4];
    $$headerref{MsgIdCRC}      = $data[5];
    $$headerref{ReplyCRC}      = $data[6];
    $$headerref{ReplyTo}       = $data[7];
    $$headerref{Reply1st}      = $data[8];
    $$headerref{ReplyNext}     = $data[9];
    $$headerref{DateWritten}   = $data[10];
    $$headerref{DateReceived}  = $data[11];
    $$headerref{DateProcessed} = $data[12];
    $$headerref{MsgNum}        = $data[13];
    $$headerref{Attributes}    = $data[14];
    $$headerref{Attributes2}   = $data[15];
    $$headerref{TxtOffset}     = $data[16];
    $$headerref{TxtLen}        = $data[17];
    $$headerref{PasswordCRC}   = $data[18];
    $$headerref{Cost}          = $data[19];

    writelog "$$headerref{Signature}\n";
}

sub sortJAMbase($$)
{
	my ( $areaname, $search_area ) = @_;
	my ( $mb_handle, %baseheader, $nummsgs, %mb, %msgheader, @subfields,
		$msgtext, $i, $key, $user, $m_msgid, $m_replyto, @message_header,
		%msgids, %replytos, %headers, %newMsgBase, %oldMsgBase );

    $mb_handle = FTN::JAM::OpenMB( $search_area );
	writelog( "Reading mesage base $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 );
    }
	writelog( "Reading headers of mesages." );
    for ( $i = $baseheader{BaseMsgNum}; $i < $baseheader{BaseMsgNum}+$nummsgs; $i++)
    {

		( $mb{$i}, $dw{$i}, $mattr{$i}, $m_msgid, $m_replyto, @message_header )
		 = ReadMessageHeader($mb_handle, $i, $baseheader{BaseMsgNum} );
		if ( $mb{$i} == 0 ) {
			writelog( "IO ERROR OR BAD MSG HEADER" );
			die "IO ERROR OR BAD MSG HEADER\n";
		}
		$message_header[7] = $message_header[8] = $message_header[9] = 0;
		$msgids{$m_msgid} = $i;
		$replytos{$i} = $m_replyto;
		$headers{$i} = [@message_header];
#		setMessageHeader( \$headers{$i}, @message_header );
	}
	writelog( ( $i - $baseheader{BaseMsgNum} ) . ' messages read.' );
	return if $nummsgs == 0;

	writelog( 'Sorting messages.' );
	$i = 2;
	foreach $key ( sort { $mb{$a} <=> $mb{$b} || $a <=> $b } keys %mb ) {
		if ( $purge ) {
			if ( $mattr{$key} >= 0x80000000 ){
				setlastreads( $key, $i );
				writelog( "Deleted message \#$key purged." );
				next;
			}
			if ( defined($areas{$areaname}{purgedays}) &&
				 defined( $dw{$key} &&
				 $areas{$areaname}{purgedays} > 0 ) ) {
				if ( $dw{$key} <= ( time() - $areas{$areaname}{purgedays} ) ) {
					# date recived
					setlastreads( $key, $i );
					writelog( int( (time() - $dw{$key})/86400 ) . 
								" days old message \#$key purged." );
					next;
				}
			}
			if ( defined( $areas{$areaname}{maxmsgs} ) && 
				 $areas{$areaname}{maxmsgs} > 0 ) {
				if ( ( $nummsgs - $i ) > $areas{$areaname}{maxmsgs} ) {
					setlastreads( $key, $i );
					writelog( "MaxMsgs ($areas{$areaname}{maxmsgs}) exceeded. " .
								"Message \#$key purged." );
					next;
				}
			}
		}
		# --- purge end -----------------

		$newMsgBase{$i} = $key;
		$oldMsgBase{$key} = $i;
		setlastreads( $key, $i );
		$i++;
	} # -- sort end ---------------------

	writelog( 'Sorting done.' );
	writelog( 'Linking messages.' );
	
# --- link-----------
	$i = 2;
	my ( $pre_prev_msg_replyto, $prev_msg_replyto, $prev_msg_num );
	while( defined($newMsgBase{$i}) ) {
		$key = $newMsgBase{$i};
		if ( $replytos{$key} ne '0' ) {
			$m_msgid = $replytos{$key};
			if ( defined $msgids{$m_msgid} ) {
#				$m_replyto = $oldMsgBase{$msgids{$m_msgid}};
#				$headers{$key}[7] = $m_replyto;
				$headers{$key}[7] = $oldMsgBase{$msgids{$m_msgid}};
				if ( $headers{$msgids{$m_msgid}}[8] == 0 ) {
					$headers{$msgids{$m_msgid}}[8] = $i;
				}
				$prev_msg_num = $msgids{$m_msgid};
				if ( defined($replytos{$prev_msg_num}) ) {
					$prev_msg_replyto = $replytos{$prev_msg_num};
					if ( defined($msgids{$prev_msg_replyto}) ) {
						$pre_prev_msg_replyto = $msgids{$prev_msg_replyto};
						if ( $headers{$pre_prev_msg_replyto}[9] == 0 ) {
							$headers{$pre_prev_msg_replyto}[9] = $i;
						}
					}
				}
			}
		}
		$i++;
	}
	writelog( 'Linking done.' );
# --- link end -------

	my $tmp_area = "$search_area\.tmp-".time();
	my $tmp_handle = FTN::JAM::CreateMB( $tmp_area, 2 );

	unless ( $tmp_handle ) {
		writelog("Failed to create $tmp_area");
		die "Failed to create $tmp_area\n";
	}
	unless ( FTN::JAM::LockMB( $tmp_handle, 0 ) ) {
		writelog( "Failed to lock messagebase $tmp_area." );
		die "Failed to lock messagebase $tmp_area.\n";
	}

	writelog( 'Writing new message base.' );
	$i = 2;
	while( defined($newMsgBase{$i}) ) {
#	foreach $i ( sort keys %newMsgBase ){
		unless ( FTN::JAM::ReadMessage( $mb_handle, $newMsgBase{$i},
							\%msgheader, \@subfields, \$msgtext ) ) {
			writelog( "Failed to read message ($newMsgBase{$i})" );
			print STDERR "Failed to read message ($newMsgBase{$i})\n";
			exit;
		}

#----->

#		setMessageHeader( \%msgheader, [$headers{$key}] );
#$headers{$m_replyto}[8]

		$key = $newMsgBase{$i};
		$msgheader{ReplyTo}       = $headers{$key}[7];
		$msgheader{Reply1st}      = $headers{$key}[8];
		$msgheader{ReplyNext}     = $headers{$key}[9];


		my $j = FTN::JAM::AddMessage( $tmp_handle, \%msgheader, \@subfields, \$msgtext );
#		writelog( "Index: $i, MSGnum: $j." );
		unless ( $j ) {
#		unless ( FTN::JAM::AddMessage( $tmp_handle, \%msgheader, \@subfields,
#																\$msgtext ) ) {
			writelog( "MSG \#$key, AddMessage filed. " );
			print STDERR "MSG \#$key, AddMessage filed.\n";
			exit;
		}
#----->
		$i++;
	}	
	writelog( 'Writing done. '.($i-2).' messages written.' );

	FTN::JAM::UnlockMB($tmp_handle);
	my $tmp_lr = "$tmp_area\.jlr";
	if ( open( my $tmp_h, '>', $tmp_lr ) ) {
		binmode( $tmp_h );
		$user = 0;
		while ( defined( $lastall{$user}{LastReadMsg} ) ) {
			print( $tmp_h pack( "LLLL", $lastall{$user}{UserCRC},
										$lastall{$user}{UserID},
										$lastall{$user}{LastReadMsg},
										$lastall{$user}{HighReadMsg}
			) );
			$user++;
		}
		close( $tmp_h );
	} else {
		print STDERR "Can't open $tmp_lr ($!).\n";
		writelog( "Can't open $tmp_lr ($!)." );
	}

#	writelog( 'Sorting done.' );
#	writelog( ( $i - 1 ) . ' messages written' );
	
    writelog( "Failed unlock messagebase $search_area. ($!)")
	    unless FTN::JAM::UnlockMB( $mb_handle );
    FTN::JAM::CloseMB( $mb_handle );
#	writelog( ( $i - $baseheader{BaseMsgNum} ) . ' messages read.' );
	FTN::JAM::CloseMB( $tmp_handle );

	move( "$tmp_area.jdt", "$search_area.jdt" );
	move( "$tmp_area.jhr", "$search_area.jhr" );
	move( "$tmp_area.jdx", "$search_area.jdx" );
	move( "$tmp_area.jlr", "$search_area.jlr" );

}

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

    my ( $ver_s, $upd, $of, $HANDLE );

  $ver_s = get( $url . "$pfile.v" );
  if (defined ($ver_s) ) {
	$ver_s =~ s/[\r\n]//g; 
	if ( $check_updates eq 'f' ) {
		if ( $curpath =~ /^(.*?)\.pl$/ ) {
		    $of = "$1_$ver_s\.pl";
		} elsif ( $curpath =~ /^(.*?[\/\\])[^\/\\]+$/ ) {
		    $of = "$1${pfile}_${ver_s}\.pl";
		} else {
		    $of = "${curpath}_${ver_s}\.pl";
		}
		print "Latest version is $ver_s\!\n";
		writelog("Latest version is $ver_s\! Downloaded 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 'd' ) {
			if ( $curpath =~ /^(.*?)\.pl$/ ) {
			$of = "$1_$ver_s\.pl";
		} elsif ( $curpath =~ /^(.*?[\/\\])[^\/\\]+$/ ) {
		    $of = "$1${pfile}_${ver_s}\.pl";
		} else {
		    $of = "${curpath}_${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}$pfile.pl" );
	unless( defined $upd ) {
	    print STDERR "Can't get update. ${url}$pfile.pl\n";
	    writelog("Can't get update. ${url}$pfile.pl\n");
		exit if $check_updates eq 'f';
	    return;
	}
	my $tmp_of = $of . time();
	if ( open ( $HANDLE, '>', $tmp_of ) ) {
	    binmode($HANDLE);
	    print( $HANDLE $upd );
	    close($HANDLE);
	    print "Can't create $of ($!)." unless move( $tmp_of, $of );
	    chmod 0755, $of if $^O eq 'linux';
	    print "$of saved.\n\n";
	} else {
	    print STDERR "Can't open $of ($!).\n";
	    writelog( "Can't open $tmp_of ($!)." );
	}
  } else {
	print STDERR "Can't connect to $url\n";
	writelog("Can't connect to $url\n");
  }
    exit if $check_updates eq 'f';
}


# ----- main --------

$check_updates = 'w';

my $options = join( ' ', @ARGV );

  GetOptions (
            "areas=s"     => \$config{areafile},
            "base=s"      => \$basedir,
            "help"        => \$needhelp,
            "log=s"       => \$logfile,
            "purge"       => \$purge,
            "ver"         => \$prinver,
            "whatsnew"    => \$whatsnew,
            "update=s"    => \$check_updates
           )or die("Error in command line arguments\n");

my $area = shift( @ARGV );
  
if ( $whatsnew ) {
    my $wn = get( "${url}${pfile}.w");
	if( defined( $wn) ) {
		if ( $wn =~ /^$vers/i ) {
	    	print $wn;
		} elsif ( $wn =~ /$vers/i ) {
			print $`;
		} else { print $wn; }
    } else {
		print "Can't get what's new. (${url}${pfile}\.w)\n";
    }
    exit;
}

if ( $prinver ) {
	print "\n    $programfile $vers\n";
	exit;
}

  if ( defined( $needhelp ) || !defined( $area ) ) {
	usage() if $check_updates ne 'f';
  }
  if ( !defined( $config{areafile} ) && !defined( $basedir ) ) {
	usage() if $check_updates ne 'f';
  }
  if ( defined( $config{areafile} ) && defined( $basedir ) ) {
	if( 'MSWin32' eq $^O ) {
	    print "   Error: -a,--areas and -b,--base are mutually exclusive options.\n";
	} else {
	    print "   \x1b[31;1m Error: -a,--areas and -b,--base are mutually exclusive options.\x1b[0m\n";
	}
	exit;
  }

  update();

  $area = uc( $area );
  $area =~ s/\*/\.\*/g;

  writelog( "$programfile ($vers) $options." );

  my ( $DH, $ebfname );
  if ( defined( $basedir ) ) {
    if ( opendir( $DH, $basedir ) ) {
	while ( readdir( $DH ) ) {
	    next if $_ =~ /^\./;
	    $ebfname = $_;
	    if ( $ebfname =~ /^(.*?)\.jdt$/i ) {
		$ebfname = $1;
	    } else { next; }
	    if ( $ebfname =~ /$area/i ) {
		print "\nArea: $ebfname\n";
		writelog("Area: $ebfname");
		my $areapath = catfile( $basedir, $ebfname );
		next if readlastreads( $areapath ) == 0;
		sortJAMbase( $ebfname, $areapath );
	    }
	}
	close( $DH );
    } else {
	print "Can't open $basedir ($!).\n";
	writelog("Can't open $basedir ($!)." );
    }
  } else {

   readareas();

   foreach my $a ( sort keys %areas ) {
	if ( $a =~ /$area/ ) {
		print "\nArea: $a\n";
		writelog("Area: $a");
		next if readlastreads( $areas{$a}{areapath} ) == 0;
		sortJAMbase( $a, $areas{$a}{areapath} );
    }
   }
  }