File Coverage

blib/lib/File/Version.pm

Criterion	Covered	Total	%
statement	15	95	15.7
branch	0	46	0.0
condition	0	28	0.0
subroutine	5	12	41.6
pod	0	7	0.0
total	20	188	10.6

package File::Version;

use 5.006;
use strict;
use warnings;
use integer;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(); # nothing to export, this is OO
our $VERSION = '0.02';
use Carp;

# file-private functions

my $recursive_find = sub {
    my $self = shift;
    my $regex = shift;
    my($loc_recursive, $rec_depth, @matches);
    $loc_recursive = sub {
        my $path = shift;
        return if $self->{RECURSION_DEPTH} && (scalar @$path > $rec_depth);
        my $str_path = join('/', @$path);
        substr($str_path, 0, 0) = '/' unless $str_path =~ /^\.+\/?/;
        opendir(PH, $str_path);
        my @files = grep(!/^\.\.?$/, readdir(PH));
#weed out symbolic links unless FOLLOW_SYMBOLIC is true
        @files = grep( !( -l $_ ), @files) unless $self->{FOLLOW_SYMBOLIC};
        closedir(PH);
        for(@files) {
            my @temp = @$path;
            push(@temp, $_);
            my $string_loc = join('/', @temp);
            substr($string_loc, 0, 0) = '/' unless $string_loc =~ /^\.+\/?/;
            next unless (-r $string_loc);
            if( -f $string_loc && /$regex/ ) {
                push(@matches, $string_loc);
            }
            if( -d $string_loc ) {
               &$loc_recursive(\@temp);
            }
        }
    };

    for(@ { $self->{SEARCH_PATHS} }) {

        my @dir_parts = grep(/./, split '/');
        $rec_depth = ($self->{RECURSION_DEPTH} + scalar @dir_parts);
        &$loc_recursive([ @dir_parts ]);
    }
    @matches ? return \@matches : return;
};

# constructor

sub new {
    my $invocant = shift;
    my $class = ref($invocant) || $invocant;
    my $self = { SEARCH_PATHS     => [ qw(.) ], # search current directory
                 RECURSION_DEPTH => 0,
                 FOLLOW_SYMBOLIC => 0, # default: don't follow symlinks
    };
# validate user supplied arguments
    my %args = @_;
    croak( "Invalid file" ) unless( $args{FILE} && -f $args{FILE} && -r _);
    if($args{FILE} =~ /^(.*\/)?((?:\d+_)+?)(?:0_)*_(.+)$/) {
        $self->{FILE} = $3 or croak( "Invalid file.\n" );
        $self->{VERSION} = $2 || '';
    }
    elsif($args{FILE} =~ /^(.*\/)?(.+)$/) {
        $self->{FILE} = $2 or croak( "Invalid file.\n" );
        $self->{VERSION} = '';
    }
    else { croak( "Invalid file" ) };
    $self->{FILE_PATH} = $1 if $1;
    $self->{WHOLE} = $& or croak( "Invalid file.\n" );

    if ( $args{SEARCH_PATHS} && @{ $args{SEARCH_PATHS} }) {
        for(@{ $args{SEARCH_PATHS} }) {
            if( -d && -r) {
                push @{ $self->{SEARCH_PATHS} }, $_;
            }
            else {
                carp ( "Directory does not exist: $_\n");
            }
        }
    }
    if ($args{RECURSION_DEPTH}) {
        croak ( "Invalid RECURSION_DEPTH: $args{RECURSION_DEPTH}\n")
          unless $args{RECURSION_DEPTH} =~ /^[+]?\d+$/;
        $self->{RECURSION_DEPTH} = $args{RECURSION_DEPTH};
    }
    $self->{FOLLOW_SYMBOLIC} = $args{FOLLOW_SYMBOLIC} ? 1 : 0;
    bless $self, $class;
    return $self;
}

# OO functions

sub recursion_depth {
    my $self = shift;
    if(@_) { $self->{RECURSION_DEPTH} = shift }
    return $self->{RECURSION_DEPTH};
}

sub follow_symbolic {
    my $self = shift;
    my %args = @_;
    $self->{FOLLOW_SYMBOLIC} = $args{FOLLOW_SYMBOLIC} ? 1 : 0;
    return $self->{FOLLOW_SYMBOLIC};
}

sub search_paths {
    my $self = shift;
    my %args = @_;
    if (@{ $args{SEARCH_PATHS} }) {
        for(@{ $args{SEARCH_PATHS} }) {
            if( -d && -r) {
                push @{ $self->{SEARCH_PATHS} }, $_;
            }
            else {
                carp ( "SEARCH_PATHS not set: $_\n");
            }
        }
    }
    else { carp ( "SEARCH_PATHS not set.\n"); }
    return $self->{SEARCH_PATHS};
}

sub locate_ancestors {
    my $self = shift;
    my @gens;
        @gens = split('_', $self->{VERSION});
        my $gen_count = 0;
        while(@gens) {
            my $match;
            my $regex = join('_', @gens) . "_(?:0_)*_$self->{FILE}";
            $regex = eval { qr/$regex/ } || croak "Invalid pattern.\n";
            ($match = &$recursive_find($self, $regex)) && do {
                for(@$match) { $self->{ANCESTORS}{$gen_count}{$_}++; }
            };
            $gen_count++;
            pop(@gens);
        };
    return $self->{ANCESTORS};
}

sub locate_descendants {
    my $self = shift;
    my $match;
    my $regex = eval { qr/^$self->{VERSION}(?:\d+_)+?(?:0_)*_$self->{FILE}/ }
      || croak "Invalid pattern.\n";
    ($match = &$recursive_find($self, $regex)) && do {
        for(@$match) {
            if( my($gen) = /$self->{VERSION}((\d+_)+?)(?:0_)*_/) {
                my $count = ($gen =~ tr/\_//);
                (my $last = $+) =~ s/\D//g if $+;
                $self->{DESCENDANTS}{$count}{$_} = $last || 0;
            }
        }
    };
    return $self->{DESCENDANTS};
};

sub next_version {
    my $self = shift;
    my $high = 0;
    &locate_descendants($self) unless $self->{DESCENDANTS};
    $self->{DESCENDANTS} && do {
        for(keys(% { $self->{DESCENDANTS}{1} } )) {
            $high = $self->{DESCENDANTS}{1}{$_} if $high < $self->{DESCENDANTS}{1}{$_};
        }
    };
    $self->{NEXT_VERSION} = $self->{VERSION} . ++$high . "__$self->{FILE}";
    return $self->{NEXT_VERSION};
}

1;
__END__