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 c
+leartool(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 op
+tion '$_'");

    } 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 wi
+th -version.\n";
    }
}

@allcomps = sort map { chomp; tr/\r//d; $_ } `cleartool lscomp -s -inv
+ob "$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 multi
+ple components)
                push @{$subbaselines{$tbl}}, "$rbl $comp";
                $titlebls{$tbl} = 1;
                $rbl2tbl{$rbl} = $tbl;
                $rbl2comp{$rbl} = $comp;
                warn "$argv0(" . __LINE__ . "): rbl:'$ts $rbl' tbl:'$t
+bl'\n" if ($debug);
            }
        }
        close LSBL;

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

foreach (keys %titlebls) {
    warn "$argv0(" . __LINE__ . "): RBL2TS $_ -> $rbl2ts{$_} @{$subbas
+elines{$_}}\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 base
+lines to diff', @blchoices));
warn "$argv0(" . __LINE__ . "): Found " . scalar(@blchoices) . " basel
+ines 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 ($debu
+g);
        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\@$p
+vob");
            } 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 ($debu
+g);
        $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 co
+mpared to it's previous baseline.\nIf you select more than one baseli
+ne, 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 => 'b
+oth');

        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->destro
+y; })->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] . "): Can
+not create($tmpfo): $!\n";

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

    my @cpargv = ('clearprompt', 'list', '-prompt', qqq($prompt), '-df
+ile', 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( @ARG
+V ) = "$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/t
+mp', '/usr/tmp', '/tmp')) {
        if (defined($_) && -d && (($^O eq 'cygwin') or -w)) {    # cyg
+win has a bug with -w on dirs
            return cygpath_w($_);
        }
    }

    return '.';
} # GetTmpDir
[download]

20100817 Janitored by Corion: Added formatting, code tags, as per Writeup Formatting Tips