File Coverage

blib/lib/File/Name/Check.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	10	10	100.0
condition	5	6	100.0
subroutine	14	14	100.0
pod	6	6	100.0
total	94	95	100.0

package File::Name::Check;

use strict;
use warnings;

use 5.008_005;
our $VERSION = '0.09';

use File::Spec;
use Encode::Locale;
use Encode;

sub new {
  my $class = shift;
  # uncoverable condition false
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
}

# paranoic = caseunique + safechars
sub paranoic {
    my $self = shift;
    my $path = shift;

    return ($self->safechars($path) && $self->caseunique($path,@_) ) ;
}

# matches qr/^[0-9a-zA-Z_.-]+$/
# these chars are also URI-safe
sub safechars {
    my $self = shift;
    my $path = shift;
    my ( $volume, $directories, $file ) = File::Spec->splitpath($path);
    return ( $file =~ m/^[0-9a-zA-Z_.-]+$/ );
}

# can use locale encoding
sub locale {
    my $self = shift;
    my $path = shift;

    my $encoding = $Encode::Locale::ENCODING_LOCALE_FS;
    return $self->encoded( $path, $encoding );
}

sub encoded {
    my $self = shift;
    my $path = shift;
    my $encoding = shift;
    my ( $volume, $directories, $file ) = File::Spec->splitpath($path);
    return $self->_reencode( $file, $encoding );
}

# unique under case-insensitive
sub caseunique {
    my $self = shift;
    my $path = shift;
    my @names = @_;

    my ( $volume, $directories, $file ) = File::Spec->splitpath($path);
    my $dir = File::Spec->catpath( $volume, $directories );

    my @files;
    if  (@names) {
       @files = grep{ m/^${file}$/i } @names;
    }
    else {
      opendir(my $dir_handle, $dir);
      @files = grep{ m/^${file}$/i } readdir($dir_handle);
      closedir($dir_handle);
    }

    return 1 if ( scalar @files == 1 );
}

sub _reencode {
    my $self = shift;
    my ( $bytes, $encoding) = @_;
    no warnings 'utf8';
    if ( $bytes ne encode( $encoding, decode( $encoding, $bytes ) ) ) {
        # say '*** decoded: ', decode( $encoding, $bytes );
        # say '     quoted: ', decode( $encoding, $bytes, Encode::FB_PERLQQ );
        return 0;
    }
    else { return 1; }
}

1;

__END__