File Coverage

lib/File/Filename/Convention.pm

Criterion	Covered	Total	%
statement	37	37	100.0
branch	12	14	85.7
condition			n/a
subroutine	4	4	100.0
pod	0	1	0.0
total	53	56	94.6

package File::Filename::Convention;
use strict;
use File::Filename 'get_filename_segments';
require Exporter;
use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = (qw(get_filename_hash));
$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)/g;

sub get_filename_hash {
	my $filename = shift;
	my $filenamingconvention_fields = shift;
	my $filenamingconvention_matchsubs = shift;

	my $segments =get_filename_segments($filename);

	my $try=0;

	CONVENTION :
	for my $convention (@{$filenamingconvention_fields}){

      ++$try;
		### CONVENTION MATCH try: $try

		(scalar @$convention == scalar @$segments) or next;

		my $x=0;
		my $segment_hash={};

		for my $segmentlabel (@$convention) {
			my $segmentcontent = @$segments[$x++];

			### $segmentlabel
         ### $segmentcontent

			defined $segmentlabel or next CONVENTION;

			### was def

			my $mustbe;
			if (ref $segmentlabel eq 'ARRAY'){

				### was array: $segmentlabel
				($segmentlabel,$mustbe) = @$segmentlabel;
				### split into: $segmentlabel
            ### must be: $mustbe
			}


			if (defined $filenamingconvention_matchsubs->{$segmentlabel}){

				### has sub?

				&{$filenamingconvention_matchsubs->{$segmentlabel}}($segmentcontent) or do {
					### returns no for: $segmentcontent
					next CONVENTION;
				};

				### had sub yes

				if(defined $mustbe){
					### $mustbe
					$segmentcontent=~/^$mustbe$/i or next CONVENTION;
					### is
				}

				$segment_hash->{$segmentlabel} = $segmentcontent;
				next;
			}

			$segment_hash->{$segmentlabel} = $segmentcontent;
		}



		return $segment_hash;
	}

	### $filename
   ### matches no conventions
   ### tries: $try
	return;

}

1;

__END__