File Coverage

blib/lib/File/Glob/Windows.pm

Criterion	Covered	Total	%
statement	38	115	33.0
branch	5	86	5.8
condition	1	15	6.6
subroutine	12	13	92.3
pod	5	5	100.0
total	61	234	26.0

#!perl
package File::Glob::Windows;
use strict;
use warnings;
use utf8;
use Encode;
use DirHandle;
use Exporter;
use Carp;
use 5.005;

our $VERSION="0.1.5";

our @ISA = qw(Exporter);
our @EXPORT = qw( glob );
our @EXPORT_OK = qw( glob getCodePage getCodePage_A getCodePage_B getCodePage_POSIX);

##############################################
# find native encoding

sub getCodePage_A{
	eval "require Win32::TieRegistry"; $@ and return;
	my $key = Win32::TieRegistry->new('HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Nls/CodePage',{Delimiter=>"/"}) or return;
	for('Default','ACP','OEMCP'){
		my $v = $key->GetValue($_);
		return "cp$v" if defined($v) and $v=~/(\d+)/;
	}
	return;
}
sub getCodePage_B{
	eval "require Win32::API"; $@ and return;
	my $f=Win32::API->new("Kernel32", "GetACP", '', 'N') or return;
	my $v= $f->Call; $v and return "cp$v";
	return;
}

sub getCodePage_POSIX {
        require POSIX;
        my $v = POSIX::setlocale( &POSIX::LC_CTYPE );
    #~ LC_TYPE returns
    #~    English_United States.1252
    #~ which matches ...Control/Nls/CodePage
    #~    (default)=(value  not set)
    #~     ACP=1252
    #~     OEMCP=437
        return "cp$1" if defined($v) and $v=~/(\d+)$/;
        return;
}


sub getCodePage{
	for( \&getCodePage_B,\&getCodePage_A,\&getCodePage_POSIX ){
		my $cp = eval{ &$_ };
		next if $@;
		$cp and return $cp;
	}
	return;
}

##############################################

# public options
our $encoding = getCodePage();
our $sorttype = 0;
our $nocase   = 1;


our %alpha;
our %glob_sortfunc=(
	1=>sub{                       $a->[2] cmp $b->[2] }, # name order
	2=>sub{$b->[0] <=> $a->[0] or $a->[2] cmp $b->[2] }, # directory and name
	3=>sub{$a->[0] <=> $b->[0] or $a->[2] cmp $b->[2] }, # fine and name
	4=>sub{                       $b->[2] cmp $a->[2] }, # name desc
);

sub glob{
	my($path)=@_;
	# check input
	(not defined $path or $path eq '') and croak "path is not specified";
	# check encoding
	my $enc = Encode::find_encoding($encoding);
	ref($enc) or croak "encoding is not specified";

	my $sortfunc = $glob_sortfunc{$sorttype};

	# read volume and root
	utf8::is_utf8($path) or $path = Encode::decode($enc,$path);
	my $top='';
	$path =~s!^([^:]+:|\\\\[^\\]+)!! and $top .=$1;
	$path =~s!^([\\/]+)!! and $top .='\\';
	$top= Encode::encode($enc,$top);
	($path eq '') and return ($top);

	# split path and convert wildcard to regex
	my @node;
	my $re1 = Encode::encode($enc,'.*?');
	my $re2 = Encode::encode($enc,'.');
	if($nocase and not %alpha){ $alpha{$_}=1 for 'A'..'Z','a'..'z';}
	for my $t (split m![\\/]+!,$path){
		next if $t eq '';
		if( not $t =~ /[*?]/ ){ push @node,Encode::encode($enc,$t); next; }
		my $r='';
		if($nocase){
			for(split /([*?A-Za-z])/,$t){
				next if $_ eq '';
				   if($_ eq '*'  ){ $r.=$re1 }
				elsif($_ eq '?'  ){ $r.=$re2 }
				elsif($alpha{$_} ){ $r.=Encode::encode($enc,'['.uc($_).lc($_).']') }
				else{ $r .= quotemeta(Encode::encode($enc,$_)) }
			}
		}else{
			for(split /([*?])/,$t){
				next if $_ eq '';
				   if($_ eq '*'  ){ $r.=$re1 }
				elsif($_ eq '?'  ){ $r.=$re2 }
				else{ $r .= quotemeta(Encode::encode($enc,$_)) }
			}
		}
		utf8::is_utf8($r) and die "bad implement. pattern is_utf8 !!\n";
		push @node,qr/^$r$/;
	}

	# directory search
	my @result;
	my @stack=([0,'']);
	while(@stack){
		my($level,$prefix)=@{shift @stack};
		if($level==-1){ push @result,$prefix; next; }
		my($replace,$separator,$parent,$spec) = (0,'\\',$top.$prefix,$node[$level++]);
		if($parent eq '' ){ ($parent,$replace)=('.',1); }
		elsif(length($top) and not length($prefix) ){ $separator =''; }

		my @list;
		if(ref $spec){
			my $d = new DirHandle($parent) or next;
			while(defined( $_=$d->read )){
				next if not $_ =~ $spec;
				my $path = ($replace?$_:"$parent$separator$_");
				   if($level==@node){ push @list,[-1,$path,$_]; }
				elsif(-d $path){ push @list,[$level,($replace?$_:"$prefix$separator$_"),$_]; }
			}
			$sortfunc and @list = sort $sortfunc @list;
			pop @$_ for @list;
			splice @stack,0,0,@list;
		}else{
			my $path = ($replace?$spec:"$parent$separator$spec");
			next if not -e $path;
			   if($level==@node){ push @result,$path; }
			elsif(-d _){ unshift @stack,[$level,($replace?$spec:"$prefix$separator$spec")]; }
		}
	}
	return @result;
}

1;

__END__