BEGIN {
	eval { require Tk; };
	if ($@) {
		$useclearprompt = 1;

	} else {
		import Tk;
	}
}

# Use $_ instead of $0 directly, because ccperl in CC5 is broken.
$_ = $0;
s:\.bat$::io;
s:.*[\\/]::o;
$argv0 = $_;

my $MSWIN = (($^O eq 'cygwin') or !(-c '/dev/null'));
my $nulldev = $MSWIN ? 'NUL' : '/dev/null';
$ENV{'PATH'} .= '';	# This enables /usr/atria/bin/Perl to pipe to cleartool(1).
$^O = 'MSWin32' if ($MSWIN && !$^O);

$ENV{'ATRIA_FORCE_GUI'} = '1';
$ENV{'CCASE_ISO_DATE_FMT'} = '0';

$pvob = "\\MIL_PVOB";

if ($#ARGV == -1) {
	usage();
}

while (defined($_ = shift(@ARGV))) {
	if (/^-d/) {
		$debug = 1;

	} elsif (/^-cp/i) {
		$useclearprompt = 1;

	} elsif (/^-(invob|pvob)/i) {
		($_ = shift(@ARGV)) or usage("Need pvob name with option '$_'");
		if ($MSWIN) {
			$_ = "\\$_" unless(m:^[\\\*]:);

		} else {
			$_ = "*/$_" unless(m:^[/\*]:);
		}
		$pvob = $_;

	} elsif (/^-(lev|gtl|ltl)/) {
		($level = shift(@ARGV)) or usage("Need promotion level with option '$_'");

	} elsif (/^-ver/) {
		$version = '-ver';

	} elsif (/^-view/) {
		($view = shift(@ARGV)) or usage("Need view name with option '$_'");
		$version = '-ver';

	} elsif (/^-c/) {
		($comps = shift(@ARGV)) or usage("Need components with option '$_'");
		push(@comps, split(/[\s,;:]+/, $comps));

	} elsif (/^-[h?q]/i) {
		usage();

	} elsif (/^INITIAL/) {
		$bom = 1;

	} elsif (/^$/) {

	} elsif (/^-/) {
		usage("Unknown option '$_'");

	} else {
		unshift @ARGV, $_;
		last;
	}
}

if ($version ne '') {
	$_ = `cleartool pwv -short`;
	chomp;
	s/\r//g;
	if (/^\*\* NONE \*\*/ || /^\s*$/) {
		die "$argv0(" . __LINE__ . "): You must have a view context with -version.\n";
	}
}

@allcomps = sort map { chomp; tr/\r//d; $_ } `cleartool lscomp -s -invob "$pvob"`;

$compfmt = "\n%s(%d): %d/%d COMP: '%s'\n";
$compind = 0;
$numcomps = scalar(@allcomps);
foreach (@allcomps) {
	$comp = $_;

	$lsblcmd = qq(cleartool lsbl -fmt "%Nd %n\\n" -comp "$comp\@$pvob");
	if (open(LSBL, "$lsblcmd |")) {
		local $_;
		warn(sprintf($compfmt, $argv0, __LINE__, ++$compind, $numcomps, $comp)) if ($debug);
		while (defined($_ = <LSBL>)) {
			chomp;
			tr/\r//d;
			if (/^([12]\d\d\d[01]\d[0-3]\d\.\d\d\d\d\d\d)\s+(.+)$/) {
				warn "$argv0(" . __LINE__ . "): rbl2ts{$2} == '$rbl2ts{$2}' \$1==$1\n" if ($debug);
				$rbl2ts{$2} = $1 if (!defined($rbl2ts{$2}) or ($1 le $rbl2ts{$2}));
				warn "$argv0(" . __LINE__ . "): rbl2ts{$2} == '$rbl2ts{$2}' \$1==$1\n\n" if ($debug);
			}
		}
		close LSBL;

	} else {
		warn "$argv0(" . __LINE__ . "): Cannot run $lsblcmd: $!\n";
	}
}

@comps = @allcomps unless(@comps);

$compind = 0;
$numcomps = scalar(@comps);
foreach (@comps) {
	$comp = $_;

	$lsblcmd = qq(cleartool lsbl -comp "$comp\@$pvob");
	if (open(LSBL, "$lsblcmd |")) {
		warn(sprintf($compfmt, $argv0, __LINE__, ++$compind, $numcomps, $comp)) if ($debug);
		while (defined($_ = <LSBL>)) {
			chomp;
			tr/\r//d;
			if (m/^([0-3]\d-[a-z][a-z][a-z]-\d\d\.\d\d:\d\d:\d\d)\s+(\S+)\s+\S+\s+"(\S+)"/oi) {
				$ts  = $1;
				$rbl = $2;	# Real baseline name	(uniq)
				$tbl = $3;	# Title of baseline	(appears on multiple components)
				push @{$subbaselines{$tbl}}, "$rbl $comp";
				$titlebls{$tbl} = 1;
				$rbl2tbl{$rbl} = $tbl;
				$rbl2comp{$rbl} = $comp;
				warn "$argv0(" . __LINE__ . "): rbl:'$ts $rbl' tbl:'$tbl'\n" if ($debug);
			}
		}
		close LSBL;

	} else {
		warn "$argv0(" . __LINE__ . "): Cannot run $lsblcmd: $!\n";
	}
}

foreach (keys %titlebls) {
	warn "$argv0(" . __LINE__ . "): RBL2TS $_ -> $rbl2ts{$_} @{$subbaselines{$_}}\n" if ($debug);
	push @ts_tbl, "$rbl2ts{$_} $_" if ($rbl2ts{$_} ne '');
}

@ts_tbl = sort @ts_tbl;
foreach (@ts_tbl) {
	warn "$argv0(" . __LINE__ . "): SORTED $_\n" if ($debug);
	m/^..(.............) (.*)$/;
	push @blchoices, "$2 $1";
}

@blchoices = (@ARGV ? @ARGV : promptforlist('Choose any number of baselines to diff', @blchoices));
warn "$argv0(" . __LINE__ . "): Found " . scalar(@blchoices) . " baselines to diff.\n" if ($debug);
if (scalar(@blchoices) >= 1) {
	if (scalar(@blchoices) == 1) {
		unshift @blchoices, '-pred';
	}
	$oldtbl = shift @blchoices;
	foreach (@blchoices) {
		tr/\r//d;
		warn "$argv0(" . __LINE__ . "): DIFFBL $oldtbl $_\n" if ($debug);
		difftbl($oldtbl, $_);
		$oldtbl = $_;
	}
}

sub difftbl { # tbl1 tbl2
	local $_;
	my ($tbl1, $tbl2) = @_;

	$tbl1 =~ s/\s.*$//;	# Remove timestamp
	$tbl2 =~ s/\s.*$//;	# Remove timestamp

	foreach (@{$subbaselines{$tbl2}}) {
		($rbl2, $comp) = split;
		if ('-pred' eq $tbl1) {
			if ($bom) {
				diffrbl($comp, "$comp" . "_INITIAL\@$pvob", "$rbl2\@$pvob");
			} else {
				diffrbl($comp, '-pred', "$rbl2\@$pvob");
			}
		} else {
			foreach (@{$subbaselines{$tbl1}}) {
				m/^(.+)\s+(.+)$/;
				if ($comp eq $2) {
					diffrbl($comp, "$1\@$pvob", "$rbl2\@$pvob");
					last;
				}
			}
		}
	}
} # difftbl

sub diffrbl { # comp rbl1 rbl2
	my ($comp, $rbl1, $rbl2) = @_;

	print "\nDIFFBL $rbl1 $rbl2 (COMPONENT $comp)\n";

	my @diffblargv = ( 'cleartool', 'diffbl', '-act', '-bas' );
	push(@diffblargv, $version) if ($version ne '');
	push(@diffblargv, "$rbl1", "$rbl2");
	system(@diffblargv);
} # sub diffrbl

sub promptforlist { # prompt, items
	local $_;
	my $prompt = shift;
	my @ret;

	if ($useclearprompt) {
		@ret = clearpromptlist($prompt, '-choices', @_);

	} else {
		my $maxlen = 0;
		foreach (@_) {
			$maxlen = max($maxlen, length($_));
		}

		warn "$argv0(" . __LINE__ . "): MAXLEN:$maxlen\n" if ($debug);

		warn "$argv0(" . __LINE__ . "): BEFORE MainWindow\n" if ($debug);
		$mw = MainWindow->new(-title => "Baseline diff in PVOB $pvob");

		warn "$argv0(" . __LINE__ . "): BEFORE Label\n" if ($debug);
		$mw->Label(-text => "If you select one baseline, it will be compared to it's previous baseline.\nIf you select more than one baseline, they will be compared in pairs.", -font => 'Courier')->pack;

		warn "$argv0(" . __LINE__ . "): BEFORE Scrolled\n" if ($debug);
		$lb = $mw->Scrolled('Listbox', -scrollbars => 'e',
			-font => ['Courier', ($MSWIN ? '8' : '11')],
			-width => $maxlen, -height => min(50, scalar(@_)),
			-selectmode => 'extended')->pack(-expand => 1, -fill => 'both');

		warn "$argv0(" . __LINE__ . "): BEFORE insert\n" if ($debug);
		$lb->insert('end', @_);
		$lb->bind('<Button-1>', sub { });	# NOTHING

		warn "$argv0(" . __LINE__ . "): BEFORE Button\n" if ($debug);
		$mw->Button(-text => 'Run baseline diff', -font => 'Courier',
			-command => sub { @sel = $lb->curselection() ; $mw->destroy; })->pack;

		warn "$argv0(" . __LINE__ . "): BEFORE MainLoop\n" if ($debug);
		MainLoop;

		warn "$argv0(" . __LINE__ . "): AFTER MainLoop\n" if ($debug);

		foreach (@sel) {
			push @ret, $_[$_];
		}

	}

	return wantarray ? @ret : "@ret";
} # promptforlist

sub min { # inta, intb
	return(($_[0] <= $_[1]) ? $_[0] : $_[1]);
} # min

sub max { # inta, intb
	return(($_[0] >= $_[1]) ? $_[0] : $_[1]);
} # max

sub clearpromptlist { # prompt, choices, items
	my $tmpdir = GetTmpDir();
	my $tmpfbn = sprintf('%0x%d', time, $$);
	my $tmpfi = "$tmpdir/$tmpfbn-i.txt";
	my $tmpfo = "$tmpdir/$tmpfbn-o.txt";
	my @ret;

	my $prompt = shift;
	my $choices = shift;
	my $items = join(',', @_);

	unlink($tmpfi, $tmpfo);
	open(TMPFI, ">$tmpfi") or die "$argv0(" . (caller(0))[2] . "): Cannot create($tmpfo): $!\n";

	print TMPFI "$items\n";
	close TMPFI;

	my @cpargv = ('clearprompt', 'list', '-prompt', qqq($prompt), '-dfile', qqq($tmpfi));
	push(@cpargv, $choices) if ($choices ne '');	# Make it portable to ccperl5 and ccperl6
	push(@cpargv, '-outfile', qqq($tmpfo), '-prefer_gui');
	system(@cpargv);
	
	if ($? == 0) {
		@ret = grep /^./, map { chomp; tr/\r//d; $_ } do { local( @ARGV ) = "$tmpfo" ; <> } ;
		unlink($tmpfi, $tmpfo);
	}
	exit($?) if ($?);

	return wantarray ? @ret : "@ret";
} # clearpromptlist

sub qqq {
	local $_;
	my @qqq = @_;

	if (($^O eq 'cygwin') or !$MSWIN) {
		qq(@qqq);

	} else {
		@qqq = map { s/"/\\"/g; $_} @qqq;
		qq("@qqq");
	}
} # qqq

sub cygpath_w { # UNIX-pname
	my $pname = shift;

	if ($^O eq 'cygwin') {
		chomp($pname = `cygpath -w "$pname"`);
		$pname =~ s/\r//g;
	}
	return $pname;
} # cygpath_w

sub GetTmpDir {
	foreach ($ENV{'TMPDIR'}, $ENV{'TEMP'}, $ENV{'TMP'}, $ENV{'TEMPDIR'}, $MSWIN ? ("C:\\temp", "C:\\tmp", "D:\\temp", "D:\\tmp") : ('/var/tmp', '/usr/tmp', '/tmp')) {
		if (defined($_) && -d && (($^O eq 'cygwin') or -w)) {	# cygwin has a bug with -w on dirs
			return cygpath_w($_);
		}
	}

	return '.';
} # GetTmpDir