The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

# Created on: 2008-01-16 08:05:58
# Create by:  ivanw
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use strict;
use warnings;
use version;
use Scalar::Util;
use List::Util qw/max min/;
use Getopt::Long;
use Pod::Usage;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use FindBin qw/$Bin/;
use VCS::Which;
use IO::Prompt qw/prompt/;
use Path::Class;

our $VERSION = version->new('0.4.1');
my ($name)   = $PROGRAM_NAME =~ m{^.*/(.*?)$}mxs;

my %option = (
    revision => '',
    diff     => 'vimdiff',
    verbose  => 0,
    man      => 0,
    help     => 0,
    VERSION  => 0,
);

if ( !@ARGV ) {
    pod2usage( -verbose => 1 );
}

main();
exit 0;

sub main {

    Getopt::Long::Configure('bundling');
    GetOptions(
        \%option,
        'file|f=s',
        'revision|r=s',
        'change|c=i',
        'replay|R',
        'max|m=i',
        'prev|previous|p',
        'three|3',
        'diff|d=s',
        'test|t!',
        'verbose|v+',
        'man',
        'help',
        'VERSION!',
    ) or pod2usage(2);
    $option{'file'} ||= shift @ARGV;

    if ( $option{'VERSION'} ) {
        print "$name Version = $VERSION\n";
        exit 1;
    }
    elsif ( $option{'man'} ) {
        pod2usage( -verbose => 2 );
    }
    elsif ( $option{'help'} || !-e $option{'file'} ) {
        pod2usage( -verbose => 1 );
    }

    # sort out the revision names
    my ( $rev_old, $rev_new ) = ('', '');
    if ( $option{'revision'} ) {
        ( $rev_old, $rev_new )
            = $option{'revision'} =~ /:/xms ? ( split /:/xms, $option{'revision'} )
            :                                 ( $option{'revision'} );
    }

    if ( $option{'change'} ) {
        ( $rev_old, $rev_new ) =
            $option{'change'} > 0 ? ( $option{'change'} - 1, $option{'change'} )
            :                       ( $option{'change'}, $option{'change'} - 1 );
        $option{'revision'} = "$rev_old\:$rev_new";
    }

    # create the temporary file object name
    my $tmp = "/tmp/$$.$name." . file($option{'file'})->basename;

    # create a new VCS::Which object for the file of interest
    my $vcs = VCS::Which->new(dir => $option{file});

    if ($option{replay}) {
        my $warned   = 0;
        my $versions = $vcs->log( $option{file} );
        if ( $option{verbose} > 2 ) {
            my $i = 0;
            my $j = -2;
            print map {$i++ . "\t" . $j-- . "\t$versions->{$_}{rev}\n"} sort keys %$versions;
        }
        my $last;
        die "Could not find any versions for $option{file}!\n" if !%$versions;

        while ( %$versions ) {
            if ( ( $option{prev} || $option{three} ) && $rev_old ) {
                unlink $last if $last && -e $last;
                $last = "$tmp.$rev_old";
            }
            else {
                unlink "$tmp.$rev_old" if -e "$tmp.$rev_old";
            }

            my $rev_no = max keys %$versions;
            my $rev    = delete $versions->{$rev_no};
            $rev_old = $rev->{rev};

            my @files
                = $option{three} && $last ? ( $option{'file'}, $last, "$tmp.$rev_old" )
                : $option{prev} && $last  ? ( $last, "$tmp.$rev_old" )
                :                           ( $option{'file'}, "$tmp.$rev_old" );

            my $diff = "$option{diff} " . join ' ', @files;

            # write the revisioned file to disk
            write_file( "$tmp.$rev_old", scalar $vcs->cat($option{file}, $rev_old) );

            if ($option{test} || $option{verbose}) {
                print "$diff\n" if $option{verbose} > 1;
                my $other = { %$rev };

                if ( @files == 2 ) {
                    my $diff = "diff -wuN " . join ' ', @files;
                    my @diff = `$diff`;
                    $other->{'Lines added'}   = grep {/^([+] [^+] )/gxms} @diff;
                    $other->{'Lines removed'} = grep {/^([-] [^-] )/gxms} @diff;
                }

                local $Data::Dumper::Indent = 1;
                local $Data::Dumper::Sortkeys = 1;
                print Data::Dumper->Dump([$other], ["*$rev_no"]);

                next if @files == 2 && $other->{'Lines added'} == 0 && $other->{'Lines removed'} == 0;
            }

            print "y = yes continue (Default), n = not stop processing, s = skip this revision\n" if !$warned++;
            my $ans = prompt(
                "Next revision $rev_old: Continue? [yns] ",
                '-tty',
                '-1',
                -d => 'y',
            );
            print "\n\n";
            $ans = lc $ans;
            last if $ans eq 'n' || $ans eq 'q';
            next if $ans eq 's';

            # run the diff if not testing
            system $diff if !$option{test};
        }
        unlink "$tmp.$rev_old" if -e "$tmp.$rev_old";
        unlink $last           if $last && -e $last;
    }
    elsif ($rev_new) {
        write_file( "$tmp.$rev_new", scalar $vcs->cat($option{file}, $rev_new) );
        write_file( "$tmp.$rev_old", scalar $vcs->cat($option{file}, $rev_old) );
        if ($option{test} || $option{verbose}) {
            print "$option{diff} $tmp.$rev_new $tmp.$rev_old\n";
        }
        if (!$option{test}) {
            exec "$option{diff} $tmp.$rev_new $tmp.$rev_old";
        }
    }
    elsif ($rev_old) {
        write_file( "$tmp.$rev_old", scalar $vcs->cat($option{file}, $rev_old) );
        if ($option{test} || $option{verbose}) {
            print "$option{diff} $option{'file'} $tmp.$rev_old\n";
        }
        if (!$option{test}) {
            exec "$option{diff} $option{'file'} $tmp.$rev_old";
        }
    }
    else {
        my $log = $vcs->log($option{file});
        my ($ver) = max keys %$log;
        my $rev = $log->{$ver}{rev} ? ".$log->{$ver}{rev}" : '';

        my $content;
        my $i = -1;
        while ( !$content && $i++ < 10 ) {
            $content = $vcs->cat($option{file}, $i ? ":$i" : '');
        }
        write_file( "$tmp$rev", $content );

        if ($option{test} || $option{verbose}) {
            print "$option{diff} $option{'file'} $tmp$rev\n";
        }
        if (!$option{test}) {
            exec "$option{diff} $option{'file'} $tmp$rev";
        }
    }

    return;
}

sub write_file {
    my ($file, @contents) = @_;
    my $fh = file($file)->openw;
    print {$fh} @contents;
    close $fh;
}

__DATA__

=head1 NAME

vcsvimdiff - Uses vimdiff to compare a file with it unmodified version or
historic versions from subversion or bazaar.

=head1 VERSION

This documentation refers to vcsvimdiff version 0.4.1.

=head1 SYNOPSIS

   vcsvimdiff [option] file

 OPTIONS:
  -r --revision=rev1[:rev2]
                Specify revisions to use for full details see vcs help diff
  -c --change=int
                Specify changes from a specific revision (see vcs help diff)
  -f --file=str Explisitly specify the file name
  -R --replay   Replay each change vs the current file
  -m --max=int  Maximum number of revisions to replay
  -3 --three    Three way diff for --replay, showing the file on disk, the
                revision one newer than the current revision and the current
                revision.
  -p --previous
                If set diff are between the revision currently being used and
                the either the last looked revision or the file on disk
  -t --test     Turn on testing (vimdiff wont actually be run)
     --no-test  Trurn off testing
  -d --diff=str Allows you to specify a diffing program (Default vimdiff)

  -v --verbose  Show more detailed option
     --version  Prints the version information
     --help     Prints this help information
     --man      Prints the full documentation for vcsvimdiff

=head1 DESCRIPTION

=head1 SUBROUTINES/METHODS

=head1 DIAGNOSTICS

=head1 CONFIGURATION AND ENVIRONMENT

=head1 DEPENDENCIES

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to Ivan Wills (ivan.wills@gmail.com).

Patches are welcome.

=head1 AUTHOR

Ivan Wills - (ivan.wills@gmail.com)

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW, 2077)
All rights reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.

=cut