The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package cmt::dirdiff; 

=head1 NAME

dirdiff - Perl_simple_module_template

=cut
use strict; 
use vars qw($LOGNAME $LOGLEVEL);
use cmt::lang('_def'); 
use cmt::log(2);
    $LOGNAME    = __PACKAGE__; 
    $LOGLEVEL   = 1;
use cmt::path('path_join', 'path_split');
use cmt::util('readfile', 'writefile', 'listdir');
use cmt::vcs('parse_id'); 
    my %RCSID   = parse_id('$Id$'); 
    our $VER    = "0.$RCSID{rev}"; 
use Exporter; 
use File::Path('mkpath');
use Digest::SHA1; 

our @ISA    = qw(Exporter); 
our @EXPORT = qw(dirdiff
                 dump_plain
                 ); 

our $opt_digest_cache   = '.digest';

sub dirdiff;
sub dump_plain;

sub gname;
sub sha1_hex_f;
sub new_diglist;
sub load_diglist;
sub save_diglist;
sub calc_diglist;
sub flatten_diglist;
sub get_digest;

sub shortdig    { my $t = shift; $t =~ s/:.+$/:/; $t }

# INITIALIZORS

=head1 SYNOPSIS

    use dirdiff;
    mysub(arguments...)

=head1 DESCRIPTION

B<dirdiff> is a WHAT used for WHAT. It HOW-WORKS. 

BACKGROUND-PROBLEM. 

HOW-dirdiff-RESOLVES. 

=head1 FUNCTIONS

=cut

=head2 dirdiff LIST

=cut
sub dirdiff {
    _sig1 '1', $_[0]; 
    # assert @_ > 1
    my @digest = map { get_digest $_ } @_; 
    my %digest;
        for (0..$#_) {
            my $dig = $digest[$_];
            next unless defined $dig;
            push @{$digest{$dig}}, $_[$_];
        }
    my @detail;
    for (keys %digest) {
        next unless defined $_; # unexisted items are not contained in detail.
        my $group = $digest{$_};
        if (@$group == 1) {
            # single => digest
            push @detail, (@$group, $_); 
        } else {
            if ($_ eq '/') {
                my %union;
                my @subdiff;
                for my $g (@$group) {
                    for my $f (listdir $g, undef, qr/^\.\.?$/) {
                        next if $f eq $opt_digest_cache;
                        next if exists $union{$f};
                        $union{$f} = 1;
                        my $fdet = dirdiff map { path_join($_, $f) } @$group;
                        push @subdiff, ($f, $fdet);
                    }
                }
                $_ = \@subdiff;
            }
            return $_ if @$group == @_;
            # [group] => digest
            push @detail, ($group, $_);
        }
    }
    return \@detail;
}

sub dump_plain {
    my ($det, $lev) = @_;
    my $lead = '    'x$lev;
    my $glead = sub { sprintf '%'.(8 + length $lead).'s', 
                        @_ ? gname(shift).'> ' : '' };
    my $i = 0; 
    while ($i < @$det) {
        my $file = $det->[$i++];
        my $dig = $det->[$i++];
        if (ref $dig) {
            my $j = 0; 
            while ($j < @$dig) {
                my $g = $dig->[$j++];
                my $sub = $dig->[$j++];
                if (ref $sub) {
                    print $glead->($g).$file.'/'."\n";
                    dump_plain($sub, $lev + 1);
                } else {
                    $sub = ' ('.shortdig($sub).')' if $sub ne '/';
                    if (ref $g or $g =~ /[\/\\]/) {
                        # the same in group or single-group
                        # (partial same or distinct different??)
                        _P0 $glead->($g).$file.$sub;
                    } else {
                        # the same in whole
                        _P0 '    '.$glead->().$g.$sub;
                    }
                }
            }
        } else { # the same in whole
            $dig = ' ('.shortdig($dig).')' if $dig ne '/';
            _P0 $glead->().$file.$dig;
        }
    }
}

=head1 DIAGNOSTICS

(No Information)

=cut
# (HELPER FUNCTIONS)

# group-name: concat of the outmost dirname of members
sub gname {
    my $g = shift; 
    if (ref $g) {
        my @d = map { /^([^\/\\]+)/; $1} @$g;
        join(', ', @d);
    } else {
        $g =~ /^([^\/\\]+)/; $1
    }
}

sub sha1_hex_f {
    my $f = shift; 
    open(FH, '<', $f) or die "error open $f for read"; 
    my $sd = new Digest::SHA1; 
    $sd->addfile(*FH); 
    my $sha1 = $sd->hexdigest; 
    close FH; 
    $sha1
}

sub new_diglist {
    my $f = shift; 
    [ -s $f, sub { sha1_hex_f($f) } ]
}

sub load_diglist {
    my $digfile = shift; 
    my $digs = readfile $digfile;
    my @list = split(/\n/, $digs);
    \@list
}

sub save_diglist {
    my $digfile = shift; 
    my $list = shift; 
    calc_diglist $list;
    writefile $digfile, join("\n", @$list); 
}

sub calc_diglist {
    my $list = shift; 
    my $i = 0;
    while ($i <= $#$list) {
        my $v = $list->[$i]; 
        if (ref $v eq 'CODE') {
            splice @$list, $i, 1, $v->(); 
        } else {
            $i++; 
        }
    }
}

sub flatten_diglist {
    my $list = shift; 
    calc_diglist $list;
    join(':', @$list)
}

sub get_digest {
    my $path = shift; 
    return undef unless -e $path;
    return '/' if -d $path;
    my $digdir; 
    my $digfile;
    my $diglist;
    if (defined $opt_digest_cache) {
        my ($dir, $base) = path_split $path;
        $digdir = path_join($dir, $opt_digest_cache);
        $digfile = path_join($digdir, $base);
        $diglist = load_diglist($digfile) if -f $digfile and -M $digfile > -M $path;
    }
    unless (defined $diglist) {
        $diglist = new_diglist($path);
        if (defined $opt_digest_cache) {
            mkpath $digdir;
            save_diglist $digfile, $diglist;
        }
    }
    return flatten_diglist($diglist);
}

=head1 HISTORY

=over

=item 0.x

The initial version. 

=back

=head1 SEE ALSO

The L<cmt/"Perl_simple_module_template">

=head1 AUTHOR

Xima Lenik <lenik@bodz.net>

=cut
1