#!/usr/bin/perl -w
################################################################################
#
# $Project: /VCS-SnapshotCM $
# $Author: mhx $
# $Date: 2005/04/09 13:13:21 +0200 $
# $Revision: 16 $
# $Snapshot: /VCS-SnapshotCM/0.02 $
# $Source: /bin/whistory $
#
################################################################################
#
# Copyright (c) 2004 Marcus Holland-Moritz. All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
################################################################################

use strict;
use VCS::SnapshotCM::Tools;
use Data::Dumper;
use Getopt::Long;
use Pod::Usage;
use Term::ANSIColor qw(:constants);
use Text::Wrap;
use POSIX qw(strftime);

my($NAME) = $0 =~ /([\w\.]+)$/;
my $VERSION = ('$Snapshot: /VCS-SnapshotCM/0.02 $' =~ /([^\/\s]+)\s*\$$/)[0];

my %OPT = (
  'debug'          => 0,
  'changelog'      => 0,
  'reverse'        => 0,
  'warnings'       => 0,
  'color'          => (exists $ENV{TERM} && $ENV{TERM} =~ /^(dt|x)term$/),
  'exclude'        => [],
  'exclude-regexp' => [],
);

Getopt::Long::Configure('bundling');

GetOptions(\%OPT, qw(
  exclude|x=s@
  exclude-regexp|X=s@
  server|host|h=s
  changelog|C
  reverse|r
  help|?
  man
  version
  debug+
  warnings+
  color!
)) or pod2usage(2);

if ($OPT{version}) {
  print <<VERSION;

This is $NAME, v$VERSION ($0).

Copyright (c) 2004 Marcus Holland-Moritz. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

VERSION
  exit 0;
}

pod2usage(-exitstatus => 0, -verbose => 0) if exists $OPT{help};
pod2usage(-exitstatus => 0, -verbose => 2) if exists $OPT{man};

if (@ARGV > 2) {
  print "Too many arguments.\n\n";
  pod2usage(2);
}

my $vcs = new VCS::SnapshotCM::Tools debug => $OPT{debug};
my $mapping = $vcs->get_current_mapping;

unless (@ARGV) {
  # No arguments?
  # If we're inside a mapped directory, present the user a list of
  # available snapshots to compare against, plus some help.
  if ($mapping) {
    my @snapshots = $vcs->get_snapshots(server  => $mapping->{server},
                                        project => $mapping->{project});

    print "Available snapshots for project $mapping->{project}:\n\n",
          wrap('', '', join(', ', sort @snapshots)), "\n", <<ENDHELP;

Use '$NAME --help' for more options.

ENDHELP

    exit 0;
  }
  else {
    pod2usage(2);
  }
}

if (@ARGV < 2 and not defined $mapping) {
  die <<END;
*** You are not inside a mapped directory.
Either go to a mapped directory, or specify two snapshots.
END
}

my @snapshots = map { $vcs->guess_local(snapshot => $_) || $_ } @ARGV;

if ($OPT{debug}) {
  print Data::Dumper->Dump([\@snapshots], ['*snapshots']);
}

for my $ss1 (@snapshots) {
  if (not ref $ss1) {
    for my $ss2 (@snapshots) {
      if (ref $ss2) {
        my $ss = $ss1;
        $ss1 = { %$ss2 };
        $ss1->{snapshot} = $ss;
        $ss1->{path}     = "$ss1->{project}/$ss";
        last;
      }
    }
  }
}

$OPT{server} ||= $snapshots[0]{server};

my(%source, %target);
($source{path}, $target{path}) = map { $_->{path} } @snapshots == 2
                               ? @snapshots : (@snapshots, { path => $mapping->{snapshot} });

@$_{qw( project snapshot )} = $vcs->split_snapshot_path($_->{path})
    for \%source, \%target;

if ($source{project} and $target{project} and
    $source{project} ne  $target{project}) {
  die <<END;
*** Cannot compare snapshots from different projects.
END
}

unless ($source{project}) {
  if ($target{project}) {
    $source{project} = $target{project};
  }
  elsif ($mapping) {
    $source{project} = $mapping->{project};
  }
  else {
    die <<END;
*** No project specified.
Specify the full snapshot path for one snapshot.
END
  }
}

if ($OPT{debug}) {
  print Data::Dumper->Dump([\%OPT, \%source, \%target],
                           [qw( *OPT *source *target )]);
}

$vcs->configure(server => $OPT{server}, project => $source{project});

if ($target{snapshot} eq '.') {
  die <<END;
*** Target snapshot cannot be '.'.
END
}

for ($source{snapshot}, $target{snapshot}) {
  $_ eq '.' || $vcs->exists_snapshot(snapshot => $_) or die <<END;
*** No snapshot '$_' in project '$source{project}'.
END
}

# prepare regular expressions
for (@{$OPT{'exclude-regexp'}}) {
  my $re = m! ^/(.*)/(\w*)$ !x ? "qr/$1/$2" : "qr/$_/";
  $re = eval $re;
  if ($@) {
    my $error = $@;
    $error =~ s/\s+at\s+\(eval\s+\d+\).*//s;
    die <<END;
*** Invalid regular expression '$_':
$error
END
  }
  $_ = $re;
}

### all error checking is done, we should be safe now

# get file list from both snapshots
$_->{files} = $_->{snapshot} eq '.' ? {} : $vcs->get_files(snapshot => $_->{snapshot})
    for \%source, \%target;

my %files;

EXCLUDE: for (keys %{$source{files}}, keys %{$target{files}}) {
  my($base) = m! ([^/\\]+)$ !x;
  for my $x (@{$OPT{exclude}}) {
    $base eq $x and next EXCLUDE;
  }
  for my $x (@{$OPT{'exclude-regexp'}}) {
    $_ =~ $x and next EXCLUDE;
  }

  my($s, $t) = ($source{files}{$_}, $target{files}{$_});
  if (defined $s and defined $t) {
    if ($s->{revision} != $t->{revision}) {
      $files{changed}{$_} = { source => $s, target => $t };
    }
  }
  elsif (defined $s) { $files{deleted}{$_} = $s }
  elsif (defined $t) { $files{added}{$_}   = $t }
  else { die "Huh?" }
}

if ($OPT{debug}) {
  print Data::Dumper->Dump([\%source, \%target, \%files],
                           [qw( *source *target *files )]);
}

my @changelog;
my $indent = ' 'x8;

for my $file (sort (keys %{$files{added}}, keys %{$files{deleted}}, keys %{$files{changed}})) {
  my($ss, $r1, $r2, $action, $fref, $type);

  if ($files{added}{$file}) {
    $type = 'added';
    $fref = $files{added}{$file};
    $ss = $target{snapshot};
    $r1 = '';
    $r2 = $fref->{revision};
    $action = colored('[NEW ITEM]', BOLD, GREEN);
  }
  elsif ($files{deleted}{$file}) {
    $type = 'deleted';
    $fref = $files{deleted}{$file};
    $ss = $source{snapshot};
    $r1 = $fref->{revision};
    $r2 = '';
    $action = colored('[DELETED ITEM]', BOLD, RED);
  }
  elsif ($files{changed}{$file}) {
    $type = 'changed';
    $fref = $files{changed}{$file};
    $ss = $target{snapshot};
    $r1 = $fref->{source}{revision};
    $r2 = $fref->{target}{revision};
    $action = '[change]';
  }
  else { die "Huh?" }

  my $history = $vcs->get_history(snapshot => $ss, file => $file,
                                  rev1 => $r1, rev2 => $r2, ancestors => 1);

  my @revs = sort { $a <=> $b } keys %{$history->{revisions}};

  $fref->{history} = $history;
  $fref->{revisions} = \@revs;

  $r1 ||= '0';
  $r2 ||= $revs[-1];

  my $derivation = "$file($r1)";
  $derivation .= " --> $file($r2)" if defined $r2;

  unless ($OPT{changelog}) {
    print '-' x 72, "\n", colored($derivation, BOLD, BLUE), " $action\n\n";
  }

  @revs = reverse @revs if $OPT{reverse};

  for my $r (@revs) {
    my $rev = $history->{revisions}{$r};
    my $comment = $rev->{comment};
    my @functions;

    if ($r > 1 and $type ne 'deleted' and $file =~ / \. (?: [cC] | cc | cpp ) $ /x) {
      @functions = get_changed_function_names($vcs, $ss, $file, $r-1, $r);
    }

    if ($OPT{changelog}) {
      $rev->{changed_functions} = \@functions;
      push @changelog, [ $type, $file, $r, $rev->{time} ];
    }
    else {
      $comment =~ s/^/$indent/gm;  # indent
      print colored(sprintf("%d --> %d%s on %s by %s\n", $r-1, $r,
                    (exists $rev->{change} ? " ($rev->{change})" : ''),
                    $rev->{date}, $rev->{author}), BLUE);

      if (@functions) {
        print $indent, colored("Functions: ", BOLD),
              wrap('', $indent . ' 'x11, join(', ', @functions), "\n");
      }

      print "$comment\n\n";
    }
  }
}

if ($OPT{changelog}) {
  @changelog = sort { $a->[3] <=> $b->[3] } @changelog;

  my %current = (
    title   => '',
    comment => '',
    files   => [],
  );

  @changelog = reverse @changelog if $OPT{reverse};

  for my $change (@changelog) {
    my($type, $file, $rev, $time) = @$change;
    my $c = $files{$type}{$file}{history}{revisions}{$rev};
    my $date = strftime("%Y-%m-%d", localtime $time);
    my $comment = $c->{comment};
    my($login, $author) = $c->{author} =~ /^\s*(.*?)\s+\(([^)]+)\)/;
    my $title = "$date  $author  <$login>";
    if ($title   ne $current{title} or
        $comment ne $current{comment}) {
      write_changelog_entry(\%current);
      if ($title ne $current{title}) {
        write_changelog_title($title);
      }
      $current{files} = [];
    }
    $current{title}   = $title;
    $current{comment} = $comment;
    my $filespec = "$file\@$rev";
    $filespec .= ' (' . join(', ', @{$c->{changed_functions}}) . ')'
        if @{$c->{changed_functions}};
    push @{$current{files}}, $filespec;
  }
  write_changelog_entry(\%current);
}

sub write_changelog_title
{
  my $title = shift;
  print "$title\n\n";
}

sub write_changelog_entry
{
  my $log = shift;
  return unless @{$log->{files}};
  my $comment = $log->{comment};
  $comment =~ s/^/\t  /mg;
  print wrap("\t", "\t  ", "* " . join(", ", @{$log->{files}}) . ":\n"), $comment, "\n\n";
}

sub colored
{
  my($text, @spec) = @_;
  $OPT{color} or return $text;
  $OPT{changelog} and return $text;
  return join '', @spec, $text, RESET;
}

sub get_changed_function_names
{
  my($vcs, $ss, $file, $r1, $r2) = @_;
  local $_;

  my $fh = $vcs->open_file(snapshot => $ss, file => $file, rev => $r2);
  my @ranges = get_function_line_ranges($file, $fh);
  @ranges or return ();

  my @change_ranges;
  $fh = $vcs->open_diff(snapshot => $ss, file => $file, rev1 => $r1, rev2 => $r2);
  while (<$fh>) {
    push @change_ranges, [ $1, $2 || $1 ]
        if /^\d+(?:,\d+)?[acd](\d+)(?:,(\d+))?/;
  }
  if ($OPT{warnings} or $OPT{debug}) {
    warn "$file: warning: no changes found\n" unless @change_ranges;
  }

  my @functions;
  my @change_range = (0, 0);
  push @change_ranges, [];

  FUNCTION: for my $range (@ranges) {
    # Advance to successive change ranges.
    for (;; @change_range = @{shift @change_ranges}) {
      last FUNCTION unless @change_range;

      # If past this function, move on to the next one.
      next FUNCTION if $change_range[0] > $range->[1];
      
      # If an overlap with this function range, record the function name.
      if ($change_range[1] >= $range->[0]
          and $change_range[0] <= $range->[1])
        {
          push @functions, $range->[2];
          next FUNCTION;
        }
    }
  }

  return @functions;
}

# This function is adapted from a ChangeLog script by Darin Adler
sub get_function_line_ranges
{
  my($file, $fh) = @_;
  my @ranges;
  my $in_parentheses = 0;
  my $in_braces = 0;
  my $word = "";
  my $potential_start = 0;
  my $potential_name = "";
  my $start = 0;
  my $name = "";
  local $_;

  my $content = do { local $/; <$fh> };

  # get rid of preprocessor statements
  $content =~ s{
    ^ ( \s* \# (?: [^\r\n\\]* (?: \\[^\r\n] | \\(?:\r\n|[\r\n]) ) ) *
                   [^\r\n]* )
  }{
    my $r = $1;
    $r =~ s/.*//mg;
    $r;
  }egsmx;

  # get rid of comments and strings
  $content =~ s{
    ([^"'/]+)
    |
    (
      "[^"\\]*(?:\\.[^"\\]*)*"
      |
      '[^'\\]*(?:\\.[^'\\]*)*'
      |
      / (?:
         \*[^*]*\*+(?:[^/*][^*]*\*+)* /
         |
         /[^\r\n]*
        )
    )
  }{
    my $r = $2;
    $r =~ s/.*//mg if defined $r;
    defined $1 ? $1 : $r;
  }egsx;

  my @lines = $content =~ /\G^(.*(?:\r\n|[\r\n]|\z))/mg;

  for my $lineno (1 .. @lines) {
    $_ = $lines[$lineno-1];

    # Find function names.
    while (m!(\w+|[(){};])!g) {
      # Open parenthesis.
      if ($1 eq "(") {
        $potential_name = $word unless $in_parentheses;
        $in_parentheses++;
        next;
      }

      # Close parenthesis.
      if ($1 eq ")") {
        $in_parentheses--;
        next;
      }

      # Open brace.
      if ($1 eq "{") {
        # Promote potiential name to real function name at the
        # start of the outer level set of braces (function body?).
        if (!$in_braces and $potential_start) {
          $start = $potential_start;
          $name = $potential_name;
        }

        $in_braces++;
        next;
      }

      # Close brace.
      if ($1 eq "}") {
        $in_braces--;

        # End of an outer level set of braces.
        # This could be a function body.
        if (!$in_braces and $name) {
          push @ranges, [ $start, $lineno, $name ];
          $name = "";
        }

        $potential_start = 0;
        $potential_name = "";
        next;
      }

      # Semicolon.
      if ($1 eq ";") {
        $potential_start = 0;
        $potential_name = "";
        next;
      }

      # Word.
      $word = $1;
      unless ($in_parentheses) {
        $potential_start = 0;
        $potential_name = "";
      }
      unless ($potential_start) {
        $potential_start = $lineno;
        $potential_name = "";
      }
    }
  }

  if ($OPT{warnings} or $OPT{debug}) {
    warn "$file: warning: mismatched braces\n"      if $in_braces;
    warn "$file: warning: mismatched parentheses\n" if $in_parentheses;
  }

  if ($OPT{debug} && @ranges) {
    print STDERR "--- functions for $file ---\n";
    print STDERR "  $_->[2] ($_->[0]-$_->[1])\n" for @ranges;
  }

  if ($in_braces or $in_parentheses) {
    # we better don't risk returning crap...
    return ();
  }

  return @ranges;
}

__END__

=head1 NAME

whistory - Show history between snapshots

=head1 SYNOPSIS

whistory {I<options>} I<source-snapshot> [I<target-snapshot>]

I<options>:

  -h, --host, --server=SERVER     server hostname
  -x, --exclude=FILE              exclude files named FILE
  -X, --exclude-regexp=PATTERN    exclude files matching PATTERN
  -C, --changelog                 write history in changelog format
  -r, --reverse                   reverse history output

  --(no)color                     (don't) use colored output
  --warnings                      print additional warnings

  -?, --help                      show this help
  --man                           show manpage
  --version                       print version information

Inside a mapped directory I<target-snapshot> is optional.
Use '.' for I<source-snapshot> if there's no source snapshot.

=head1 DESCRIPTION

The C<whistory> tool can be used to display the history between
different snapshots of a SnapshotCM project. 

=head1 OPTIONS

=head2 C<-h>, C<--host>, C<--server> hostname

Specify the hostname of the SnapshotCM server. C<whistory> uses
various heuristics to figure out which hostname to use, so you'll
rarely have to specify this option.

=head2 C<-x>, C<--exclude> file

Exclude all files named I<file>. Can be given multiple times.

=head2 C<-X>, C<--exclude-regexp> pattern

Exclude all files matchin I<pattern>. Can be given multiple times.
Patterns are Perl regular expressions (see L<perlre>).

=head2 C<-C>, C<--changelog>

Write output in changelog format. This output is never colored.

=head2 C<-r>, C<--reverse>

Write history output in reverse order, i.e. newest changes first.

=head2 C<--(no)color>

Use or don't use color in the output. The default is chosen
depending on your terminal. When piping the colored output
into C<less>, you may need to use C<less -R> to display the
colors correctly.

=head2 C<--warnings>

Enable printing of additional warnings.

=head1 EXAMPLES

Display all changes that since snapshot 0.54 while being in a
mapped directory:

  whistory 0.54

Display all changes between snapshots 0.40 and 0.42 of project
I<foobar>, excluding all files named F<Makefile>:

  whistory -x Makefile /foobar/0.40 0.42

Display all changes since snapshot 0.50, excluding all I<*.h> files
and all files matching I<readme> (case insensitive). Use changelog
format:

  whistory -X '\.h$' -X '/readme/i' --changelog 0.50

Display all changes made between creating the project and snapshot
0.01:

  whistory - 0.01

=head1 COPYRIGHT

Copyright (c) 2004 Marcus Holland-Moritz. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

SnapshotCM is copyright (c) 2000-2003 True Blue Software Company.

=head1 SEE ALSO

See L<whist>, L<wannotate>, L<VCS::SnapshotCM::Tools>.

=cut