File Coverage

lib/LEOCHARRE/Basename.pm

Criterion	Covered	Total	%
statement	61	67	91.0
branch	32	54	59.2
condition	0	12	0.0
subroutine	15	17	88.2
pod	12	12	100.0
total	120	162	74.0

package LEOCHARRE::Basename;
use strict;
use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA $VERSION);
use Exporter;
use Carp;
$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)/g;
@ISA = qw/Exporter/;
@EXPORT_OK = qw(basename basename_ext abs_dir abs_loc_or_die abs_path_or_die abs_dir_or_die abs_file abs_file_or_die abs_loc abs_path dirname filename filename_ext filename_only);
%EXPORT_TAGS = ( all => \@EXPORT_OK ); # this was missing \@ a slash, causing errors

sub dirname { my $loc = abs_loc($_[0]); filename($loc); }

*basename_only = \&filename_only;
*basename_ext = \&filename_ext;
*basename = \&filename;

sub filename {
   $_[0] or return;
   $_[0]=~/([^\/]+)\/*$/ or return;
   $1;
}

sub filename_ext {
   my $f = filename(+shift) or return;
   $f=~/\.([a-z0-9]{1,7})$/i or return;
   my $ext = $1;
   @_ ? _matches_one_of($ext,@_) : $ext;
}
sub filename_only {
   my $f = filename($_[0]) or return;
   $f=~s/\.([a-z0-9]{1,7})$//i;
   $f;
}

sub abs_loc {
   $_[0] or return; # if left out, returns as if cwd were arg
   my $a = abs_path($_[0]) or return;
   $a=~s/\/[^\/]+\/*$//;
   $a;
}
sub abs_loc_or_die { abs_loc($_[0]) or die }

sub abs_file {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::cluck("Can't Cwd::abs_path($_[0])") and return;
   -f $abs or Carp::cluck("Not file on disk: '$abs'") and return;
   $abs;
}
sub abs_dir {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::cluck("Can't Cwd::abs_path($_[0])") and return;
   -d $abs or Carp::cluck("Not dir on disk: '$abs'") and return;
   $abs;
}
sub abs_path {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::cluck("Can't Cwd::abs_path($_[0])") and return;
   -e $abs or Carp::cluck("Not on disk: '$abs'") and return;
   $abs;
}

sub abs_path_or_die {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::croak("Can't Cwd::abs_path('$_[0]')");
   -e $abs or Carp::croak("Not on disk: '$abs'");
   $abs;
}
sub abs_file_or_die {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::croak("Can't Cwd::abs_path('$_[0]')");
   -f $abs or Carp::croak("Not file on disk: '$abs'");
   $abs;
}
sub abs_dir_or_die {
   require Cwd;
   require Carp;
   my $abs = Cwd::abs_path($_[0]) or Carp::croak("Can't Cwd::abs_path('$_[0]')");
   -d $abs or Carp::croak("Not dir on disk: '$abs'");
   $abs;
}

sub _matches_one_of {
   my $string = shift;

   for my $arg ( @_ ){
      ref $arg or (($string eq $arg) ? return 1 : next);

      if (ref $arg eq 'ARRAY'){
            map { ( $string eq $_ ) and return $string } @$arg;
      }

      elsif ( ref $arg eq 'Regexp' ){
            $string=~$arg and return $string;
      }
   }
   return;
}

1;


__END__