├── .gitignore ├── .proverc ├── .shipit ├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── README.pod ├── author ├── benchmark.pl └── test.pl ├── lib └── File │ └── Zglob.pm ├── t ├── 00_compile.t ├── 02_glob_prepare_pattern.t ├── 03_zglob.t ├── 04_dotdot.t └── dat │ ├── bug │ └── 0 │ ├── lib │ ├── bar.pl │ └── foo.pm │ └── very │ └── deep │ ├── .dotfile │ └── normalfile └── xt ├── 01_podspell.t ├── 02_perlcritic.t ├── 03_pod.t └── 04_minimum_version.t /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | inc/ 3 | .c 4 | ppport.h 5 | *.sw[po] 6 | *.bak 7 | *.old 8 | Build 9 | _build/ 10 | xshelper.h 11 | tags 12 | pm_to_blib 13 | blib/ 14 | META.yml 15 | MYMETA.* 16 | fileutil.scm 17 | nytprof.out 18 | -------------------------------------------------------------------------------- /.proverc: -------------------------------------------------------------------------------- 1 | -l 2 | -------------------------------------------------------------------------------- /.shipit: -------------------------------------------------------------------------------- 1 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN 2 | git.push_to=origin 3 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension File::Zglob 2 | 3 | 0.11 4 | 5 | - tiny fix, no feature changes. 6 | 7 | 0.10 8 | 9 | - support '..' in path segments 10 | 11 | 0.09 12 | 13 | - Support "." in path segments(cho45) 14 | 15 | 0.08 16 | 17 | - win32 fix(mattn++) 18 | 19 | 0.07 20 | 21 | - refactoring 22 | 23 | 0.06 24 | 25 | - '0' is true value. 26 | - optimization 27 | 28 | 0.05 29 | 30 | - support ~foo/ 31 | - ignore case on osx, win32 32 | 33 | 0.04 34 | 35 | - pod fix 36 | 37 | 0.03 38 | 39 | - doc fix 40 | 41 | 0.02 42 | 43 | - make deep recursion as fatal error 44 | 45 | 0.01 Fri Sep 23 12:21:47 2011 46 | - original version 47 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | .gitignore 2 | .proverc 3 | author/benchmark.pl 4 | author/test.pl 5 | Changes 6 | inc/Module/Install.pm 7 | inc/Module/Install/AuthorTests.pm 8 | inc/Module/Install/Base.pm 9 | inc/Module/Install/Can.pm 10 | inc/Module/Install/Fetch.pm 11 | inc/Module/Install/Makefile.pm 12 | inc/Module/Install/Metadata.pm 13 | inc/Module/Install/Win32.pm 14 | inc/Module/Install/WriteAll.pm 15 | lib/File/Zglob.pm 16 | Makefile.PL 17 | MANIFEST This list of files 18 | META.yml 19 | README 20 | t/00_compile.t 21 | t/02_glob_prepare_pattern.t 22 | t/03_zglob.t 23 | t/04_dotdot.t 24 | t/dat/bug/0 25 | t/dat/lib/bar.pl 26 | t/dat/lib/foo.pm 27 | t/dat/very/deep/.dotfile 28 | t/dat/very/deep/normalfile 29 | xt/01_podspell.t 30 | xt/02_perlcritic.t 31 | xt/03_pod.t 32 | xt/04_minimum_version.t 33 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^\.git/ 2 | \bRCS\b 3 | \bCVS\b 4 | ^MANIFEST\. 5 | ^Makefile$ 6 | ~$ 7 | ^# 8 | \.old$ 9 | ^blib/ 10 | ^pm_to_blib 11 | ^MakeMaker-\d 12 | \.gz$ 13 | \.cvsignore 14 | ^t/perlcritic 15 | ^tools/ 16 | \.svn/ 17 | ^[^/]+\.yaml$ 18 | ^[^/]+\.pl$ 19 | ^\.shipit$ 20 | \.sw[po]$ 21 | ^Build$ 22 | ^ppport.h$ 23 | ^xshelper.h$ 24 | cover_db 25 | nytprof 26 | perltidy.ERR$ 27 | ^README.pod$ 28 | ^tags$ 29 | ^MYMETA.(.+)$ 30 | ^File-Zglob- 31 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | use Module::Install::AuthorTests; 3 | 4 | name 'File-Zglob'; 5 | all_from 'lib/File/Zglob.pm'; 6 | 7 | tests 't/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t'; 8 | test_requires 'Test::More' => 0.96; # done_testing, subtest 9 | author_tests('xt'); 10 | WriteAll; 11 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is Perl module File::Zglob. 2 | 3 | INSTALLATION 4 | 5 | File::Zglob installation is straightforward. If your CPAN shell is set up, 6 | you should just be able to do 7 | 8 | % cpan File::Zglob 9 | 10 | Download it, unpack it, then build it as per the usual: 11 | 12 | % perl Makefile.PL 13 | % make && make test 14 | 15 | Then install it: 16 | 17 | % make install 18 | 19 | DOCUMENTATION 20 | 21 | File::Zglob documentation is available as in POD. So you can do: 22 | 23 | % perldoc File::Zglob 24 | -------------------------------------------------------------------------------- /README.pod: -------------------------------------------------------------------------------- 1 | lib/File/Zglob.pm -------------------------------------------------------------------------------- /author/benchmark.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use 5.010000; 6 | 7 | use Benchmark qw(:all); 8 | use lib 'lib'; 9 | use File::Zglob; 10 | use File::Glob qw(bsd_glob); 11 | use File::Find::Rule; 12 | 13 | my $t = timethese(-1, { 14 | glob => sub { 15 | glob('*/*.t') 16 | }, 17 | zglob => sub { 18 | zglob('*/*.t') 19 | }, 20 | bsd_glob => sub { 21 | bsd_glob('*/*.t') 22 | }, 23 | rule => sub { 24 | File::Find::Rule->file->name('*.t')->in('.') 25 | }, 26 | }); 27 | cmpthese($t); 28 | 29 | -------------------------------------------------------------------------------- /author/test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use 5.010000; 6 | use autodie; 7 | 8 | use File::Zglob; 9 | 10 | my $pattern = shift or die "Usage: $0 'pattern'"; 11 | say $_ for zglob($pattern); 12 | -------------------------------------------------------------------------------- /lib/File/Zglob.pm: -------------------------------------------------------------------------------- 1 | package File::Zglob; 2 | use strict; 3 | use warnings 'all', FATAL => 'recursion'; 4 | use 5.008008; 5 | our $VERSION = '0.11'; 6 | use base qw(Exporter); 7 | 8 | our @EXPORT = qw(zglob); 9 | 10 | use File::Basename; 11 | 12 | our $SEPCHAR = '/'; 13 | our $NOCASE = $^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS|darwin)$/ ? 1 : 0; 14 | our $DIRFLAG = \"DIR?"; 15 | our $DEEPFLAG = \"**"; 16 | our $PARENTFLAG = \".."; 17 | our $DEBUG = 0; 18 | our $STRICT_LEADING_DOT = 1; 19 | our $STRICT_WILDCARD_SLASH = 1; 20 | 21 | sub zglob { 22 | my ($pattern) = @_; 23 | #dbg("FOLDING: $pattern"); 24 | # support ~tokuhirom/ 25 | if ($^O eq 'MSWin32') { 26 | require Win32; 27 | $pattern =~ s!^(\~[^$SEPCHAR]*)!Win32::GetLongPathName([glob($1)]->[0])!e; 28 | } else { 29 | $pattern =~ s!^(\~[^$SEPCHAR]*)![glob($1)]->[0]!e; 30 | } 31 | my ($node, $matcher) = glob_prepare_pattern($pattern); 32 | # $node : \0 if absolute path, \1 if relative. 33 | 34 | #dbg("pattern: ", $node, $matcher); 35 | return _rec($node, $matcher, []); 36 | } 37 | 38 | sub dbg(@) { 39 | return unless $DEBUG; 40 | my ($pkg, $filename, $line, $sub) = caller(1); 41 | my $i = 0; 42 | while (caller($i++)) { 1 } 43 | my $msg; 44 | $msg .= ('-' x ($i-5)); 45 | $msg .= " [$sub] "; 46 | for (@_) { 47 | $msg .= ' '; 48 | if (not defined $_) { 49 | $msg .= '<>'; 50 | } elsif (ref $_) { 51 | require Data::Dumper; 52 | local $Data::Dumper::Terse = 1; 53 | local $Data::Dumper::Indent = 0; 54 | $msg .= Data::Dumper::Dumper($_); 55 | } else { 56 | $msg .= $_; 57 | } 58 | } 59 | $msg .= " at $filename line $line\n"; 60 | print($msg); 61 | } 62 | 63 | sub _recstar { 64 | my ($node, $matcher) = @_; 65 | #dbg("recstar: ", $node, $matcher, $seed); 66 | return ( 67 | _rec( $node, $matcher ), 68 | ( 69 | map { _recstar( $_, $matcher ) } 70 | glob_fs_fold( $node, qr{^[^.].*$}, 1 ) 71 | ) 72 | ); 73 | } 74 | 75 | sub _rec { 76 | my ($node, $matcher) = @_; 77 | # $matcher: ArrayRef[Any] 78 | 79 | my ($current, @rest) = @{$matcher}; 80 | if (!defined $current) { 81 | #dbg("FINISHED"); 82 | return (); 83 | } elsif (ref($current) eq 'SCALAR' && $current == $DEEPFLAG) { 84 | #dbg("** mode"); 85 | return _recstar($node, \@rest); 86 | } elsif (ref($current) eq 'SCALAR' && $current == $PARENTFLAG) { 87 | if (ref($node) eq 'SCALAR' && $$node eq 1) { #t 88 | die "You cannot get a parent directory of root dir."; 89 | } elsif (ref($node) eq 'SCALAR' && $$node eq 0) { #f 90 | return _rec("..", \@rest); 91 | } else { 92 | return _rec("$node$SEPCHAR..", \@rest); 93 | } 94 | } elsif (@rest == 0) { 95 | #dbg("file name"); 96 | # (folder proc seed node (car matcher) #f) 97 | return glob_fs_fold($node, $current, 0); 98 | } else { 99 | return glob_fs_fold($node, $current, 1, \@rest); 100 | } 101 | } 102 | 103 | 104 | # /^home$/ のような固定の文字列の場合に高速化をはかるための最適化予定地なので、とりあえず undef をかえしておいても問題がない 105 | sub fixed_regexp_p { 106 | return undef; 107 | die "TBI" 108 | } 109 | 110 | # returns arrayref of seeds. 111 | sub glob_fs_fold { 112 | my ($node, $regexp, $non_leaf_p, $rest) = @_; 113 | 114 | my $prefix = do { 115 | if (ref $node eq 'SCALAR') { 116 | if ($$node eq 1) { #t 117 | $SEPCHAR 118 | } elsif ($$node eq '0') { #f 119 | ''; 120 | } else { 121 | die "FATAL"; 122 | } 123 | } elsif ($node !~ m{/$}) { 124 | $node . '/'; 125 | } else { 126 | $node; 127 | } 128 | }; 129 | dbg("prefix: $prefix"); 130 | dbg("regxp: ", $regexp); 131 | if ($^O eq 'MSWin32' && ref $regexp eq 'SCALAR' && $$regexp =~ /^[a-zA-Z]\:$/) { 132 | return _rec($$regexp . '/', $rest); 133 | } 134 | if (ref $regexp eq 'SCALAR' && $regexp == $DIRFLAG) { 135 | if ($rest) { 136 | return _rec($prefix, $rest); 137 | } else { 138 | return ($prefix); 139 | } 140 | # } elsif (my $string_portion = fixed_regexp_p($regexp)) { # /^path$/ 141 | # die "TBI"; 142 | # my $full = $prefix . $string_portion; 143 | # if (-e $full && (!$non_leaf_p || -d $full)) { 144 | # $proc->($full, $seed); 145 | # } else { 146 | # $proc; 147 | # } 148 | } else { # normal regexp 149 | #dbg("normal regexp"); 150 | my $dir = do { 151 | if (ref($node) eq 'SCALAR' && $$node eq 1) { 152 | $SEPCHAR 153 | } elsif (ref($node) eq 'SCALAR' && $$node eq 0) { 154 | '.'; 155 | } else { 156 | $node; 157 | } 158 | }; 159 | #dbg("dir: $dir"); 160 | opendir my $dirh, $dir or do { 161 | #dbg("cannot open dir: $dir: $!"); 162 | return (); 163 | }; 164 | my @ret; 165 | while (defined(my $child = readdir($dirh))) { 166 | next if $child eq '.' or $child eq '..'; 167 | my $full; 168 | #dbg("non-leaf: ", $non_leaf_p); 169 | if (($child =~ $regexp) && ($full = $prefix . $child) && (!$non_leaf_p || -d $full)) { 170 | #dbg("matched: ", $regexp, $child, $full); 171 | if ($rest) { 172 | push @ret, _rec($full, $rest); 173 | } else { 174 | push @ret, $full; 175 | } 176 | # } else { 177 | #dbg("Don't match: $child"); 178 | } 179 | } 180 | return @ret; 181 | } 182 | } 183 | 184 | sub glob_prepare_pattern { 185 | my ($pattern) = @_; 186 | my @path = split $SEPCHAR, $pattern; 187 | 188 | my $is_absolute = $path[0] eq '' ? 1 : 0; 189 | if ($is_absolute) { 190 | shift @path; 191 | } 192 | if ($^O eq 'MSWin32' && $path[0] =~ /^[a-zA-Z]\:$/) { 193 | $is_absolute = 1; 194 | } 195 | 196 | @path = map { 197 | if ($_ eq '**') { 198 | $DEEPFLAG 199 | } elsif ($_ eq '') { 200 | $DIRFLAG 201 | } elsif ($_ eq '.') { 202 | () 203 | } elsif ($_ eq '..') { 204 | $PARENTFLAG 205 | } elsif ($^O eq 'MSWin32' && $_ =~ '^[a-zA-Z]\:$') { 206 | \$_ 207 | } else { 208 | glob_to_regex($_) # TODO: replace with original implementation? 209 | } 210 | } @path; 211 | 212 | return ( \$is_absolute, \@path ); 213 | } 214 | 215 | # this is not a private function. '**' was handled at glob_prepare_pattern() function. 216 | sub glob_to_regex { 217 | my $glob = shift; 218 | my $regex = glob_to_regex_string($glob); 219 | return $NOCASE ? qr/^$regex$/i : qr/^$regex$/; 220 | } 221 | 222 | sub glob_to_regex_string { 223 | my $glob = shift; 224 | my ($regex, $in_curlies, $escaping); 225 | local $_; 226 | my $first_byte = 1; 227 | for ($glob =~ m/(.)/gs) { 228 | if ($first_byte) { 229 | if ($STRICT_LEADING_DOT) { 230 | $regex .= '(?=[^\.])' unless $_ eq '.'; 231 | } 232 | $first_byte = 0; 233 | } 234 | if ($_ eq '/') { 235 | $first_byte = 1; 236 | } 237 | if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || 238 | $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { 239 | $regex .= "\\$_"; 240 | } 241 | elsif ($_ eq '*') { 242 | $regex .= $escaping ? "\\*" : 243 | $STRICT_WILDCARD_SLASH ? "[^/]*" : ".*"; 244 | } 245 | elsif ($_ eq '?') { 246 | $regex .= $escaping ? "\\?" : 247 | $STRICT_WILDCARD_SLASH ? "[^/]" : "."; 248 | } 249 | elsif ($_ eq '{') { 250 | $regex .= $escaping ? "\\{" : "("; 251 | ++$in_curlies unless $escaping; 252 | } 253 | elsif ($_ eq '}' && $in_curlies) { 254 | $regex .= $escaping ? "}" : ")"; 255 | --$in_curlies unless $escaping; 256 | } 257 | elsif ($_ eq ',' && $in_curlies) { 258 | $regex .= $escaping ? "," : "|"; 259 | } 260 | elsif ($_ eq "\\") { 261 | if ($escaping) { 262 | $regex .= "\\\\"; 263 | $escaping = 0; 264 | } 265 | else { 266 | $escaping = 1; 267 | } 268 | next; 269 | } 270 | else { 271 | $regex .= $_; 272 | $escaping = 0; 273 | } 274 | $escaping = 0; 275 | } 276 | 277 | return $regex; 278 | } 279 | 280 | 1; 281 | __END__ 282 | 283 | =encoding utf8 284 | 285 | =head1 NAME 286 | 287 | File::Zglob - Extended globs. 288 | 289 | =head1 SYNOPSIS 290 | 291 | use File::Zglob; 292 | 293 | my @files = zglob('**/*.{pm,pl}'); 294 | 295 | =head1 DESCRIPTION 296 | 297 | B 298 | 299 | Provides a traditional Unix glob(3) functionality; returns a list of pathnames that matches the given pattern. 300 | 301 | File::Zglob provides extended glob. It supports C<< **/*.pm >> form. 302 | 303 | =head1 FUNCTIONS 304 | 305 | =over 4 306 | 307 | =item zglob($pattern) # => list of matched files 308 | 309 | my @files = zglob('**/*.[ch]'); 310 | 311 | Unlike shell's glob, if there's no matching pathnames, () is returned. 312 | 313 | =back 314 | 315 | =head1 Special chars 316 | 317 | A glob pattern also consists of components and separator characters. In a component, following characters/syntax have special meanings. 318 | 319 | =over 4 320 | 321 | =item C<< * >> 322 | 323 | When it appears at the beginning of a component, it matches zero or more characters except a period (.). And it won't match if the component of the input string begins with a period. 324 | 325 | Otherwise, it matches zero or more sequence of any characters. 326 | 327 | =item C<< ** >> 328 | 329 | If a component is just **, it matches zero or more number of components that match *. For example, src/**/*.h matches all of the following patterns. 330 | 331 | src/*.h 332 | src/*/*.h 333 | src/*/*/*.h 334 | src/*/*/*/*.h 335 | ... 336 | 337 | =item C<< ? >> 338 | 339 | When it appears at the beginning of a component, it matches a character except a period (.). Otherwise, it matches any single character. 340 | 341 | =item C<< [chars] >> 342 | 343 | Specifies a character set. Matches any one of the set. The syntax of chars is the same as perl's character set syntax. 344 | 345 | =item C<< {pm,pl} >> 346 | 347 | There is alternation. 348 | 349 | "example.{foo,bar,baz}" matches "example.foo", "example.bar", and "example.baz" 350 | 351 | =back 352 | 353 | =head1 zglob and deep recursion 354 | 355 | C<< **/* >> form makes deep recursion by soft link. zglob throw exception if it's deep recursion. 356 | 357 | =head1 PORTABILITY 358 | 359 | =over 4 360 | 361 | =item Win32 362 | 363 | Zglob supports Win32. zglob() only uses '/' as a path separator. Since zglob() accepts non-utf8 strings. CP932 contains '\' character as a second byte of multibyte chars. 364 | 365 | =back 366 | 367 | =head1 LIMITATIONS 368 | 369 | =over 4 370 | 371 | =item File order is not compatible with shells. 372 | 373 | =back 374 | 375 | =head1 AUTHOR 376 | 377 | Tokuhiro Matsuno Etokuhirom AAJKLFJEF GMAIL COME 378 | 379 | =head1 THANKS TO 380 | 381 | Most code was translated from gauche's fileutil.scm. 382 | 383 | glob_to_regex function is taken from L. 384 | 385 | =head1 SEE ALSO 386 | 387 | L, L, gauche's fileutil.scm 388 | 389 | =head1 LICENSE 390 | 391 | Copyright (C) Tokuhiro Matsuno 392 | 393 | This library is free software; you can redistribute it and/or modify 394 | it under the same terms as Perl itself. 395 | 396 | =cut 397 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 1; 3 | 4 | BEGIN { use_ok 'File::Zglob' } 5 | -------------------------------------------------------------------------------- /t/02_glob_prepare_pattern.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use File::Zglob; 6 | 7 | *gpp = *File::Zglob::glob_prepare_pattern; 8 | 9 | local $File::Zglob::NOCASE = 0; # case sensitive to pass tests. 10 | 11 | subtest 'normal' => sub { 12 | my @patterns = ( 13 | '**/*' => [ \0, [ \"**", qr{^(?=[^\.])[^/]*$} ] ], 14 | ".*" => [ \0, [qr{^\.[^/]*$}] ], 15 | '/home' => [ \1, [qr{^(?=[^\.])home$}] ], 16 | ); 17 | for (my $i=0; $i<@patterns; $i+=2) { 18 | is_deeply([gpp($patterns[$i])], $patterns[$i+1], $patterns[$i]); 19 | } 20 | }; 21 | 22 | done_testing; 23 | 24 | -------------------------------------------------------------------------------- /t/03_zglob.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use File::Zglob; 6 | use Data::Dumper; 7 | use Cwd; 8 | 9 | { 10 | package Cwd::Guard; 11 | sub new { 12 | my ($class, $path) = @_; 13 | my $cwd = Cwd::getcwd(); 14 | chdir($path); 15 | bless \$cwd, $class; 16 | } 17 | sub DESTROY { 18 | my $self = shift; 19 | chdir($$self); 20 | } 21 | } 22 | 23 | $File::Zglob::DEBUG = $ENV{DEBUG} ? 1 : 0; 24 | 25 | { 26 | my $guard = Cwd::Guard->new('t/dat/'); 27 | is_deeply2('**/normalfile', ['very/deep/normalfile']); 28 | is_deeply2('very/**/*', [qw(very/deep very/deep/normalfile)]); 29 | is_deeply2('very/deep/*', ['very/deep/normalfile']); 30 | is_deeply2('very/deep/.*', ['very/deep/.dotfile']); 31 | is_deeply2('**/*.{pm,pl}', [qw(lib/bar.pl lib/foo.pm)]); 32 | is_deeply2('bug/0', ['bug/0']); 33 | is_deeply2('./very/**/*', [qw(very/deep very/deep/normalfile)]); 34 | is_deeply2('./very/deep/*', ['very/deep/normalfile']); 35 | is_deeply2('./very/deep/.*', ['very/deep/.dotfile']); 36 | is_deeply2('very/./**/*', [qw(very/deep very/deep/normalfile)]); 37 | } 38 | is_deeply2('*/*.t', [qw(t/00_compile.t t/02_glob_prepare_pattern.t t/03_zglob.t t/04_dotdot.t xt/01_podspell.t xt/02_perlcritic.t xt/03_pod.t xt/04_minimum_version.t)]); 39 | is_deeply2('lib/File/Zglob.pm', ['lib/File/Zglob.pm']); 40 | is_deeply2('lib/*/Zglob.pm', ['lib/File/Zglob.pm']); 41 | is_deeply2('lib/File/*.pm', ['lib/File/Zglob.pm']); 42 | is_deeply2('l*/*/*.pm', ['lib/File/Zglob.pm']); 43 | is_samepath('~', [glob('~')]); 44 | if (-f glob('~/.bashrc')) { 45 | is_samepath('~/.bashrc', [glob('~/.bashrc')]); 46 | } 47 | if (-f '/etc/passwd') { 48 | is_samepath('/etc/passwd', ['/etc/passwd']); 49 | } 50 | if ($ENV{USER} && $ENV{HOME} eq "/home/$ENV{USER}" && -d "/home/$ENV{USER}/") { 51 | is_deeply2("~", ["/home/$ENV{USER}"]); 52 | is_deeply2("~$ENV{USER}", ["/home/$ENV{USER}"]); 53 | } 54 | 55 | done_testing; 56 | 57 | sub is_deeply2 { 58 | local $Data::Dumper::Purity = 1; 59 | local $Data::Dumper::Sortkeys = 1; 60 | local $Data::Dumper::Indent = 0; 61 | 62 | local $Test::Builder::Level = $Test::Builder::Level + 1; 63 | my ($pattern, $expected, $reason) = @_; 64 | is(Dumper([sort { $a cmp $b } zglob($pattern)]), Dumper([sort @$expected]), $reason || $pattern) or do { 65 | die "ABORT" if $File::Zglob::DEBUG; 66 | }; 67 | } 68 | 69 | sub normalize { 70 | my $path = shift; 71 | if ($^O eq 'MSWin32') { 72 | require Win32; 73 | Win32::GetLongPathName(Cwd::abs_path($path)) 74 | } else { 75 | Cwd::abs_path($path) 76 | } 77 | 78 | } 79 | sub is_samepath { 80 | my ($p, $b) = @_; 81 | 82 | my $a = [zglob($p)]; 83 | return 0 if !defined($a) || !defined($b) || @$a != @$b; 84 | for (0..$#$a) { 85 | is(normalize($a->[$_]), normalize($b->[$_])); 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /t/04_dotdot.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use File::Zglob qw(zglob); 6 | use Fatal qw(chdir); 7 | use File::Basename qw(dirname basename); 8 | 9 | local $File::Zglob::NOCASE = 0; # case sensitive to pass tests. 10 | 11 | 12 | { 13 | chdir 't/'; 14 | my @abs = map { basename($_) } zglob("../lib/**/*.pm"); 15 | is_deeply \@abs, [qw(Zglob.pm)]; 16 | chdir '..'; 17 | } 18 | 19 | { 20 | my @abs = map { basename($_) } zglob("lib/../lib/**/*.pm"); 21 | is_deeply \@abs, [qw(Zglob.pm)]; 22 | } 23 | 24 | done_testing; 25 | 26 | -------------------------------------------------------------------------------- /t/dat/bug/0: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/File-Zglob/05c904c77a9a3ce62953c7be481ca1f97c3b02a0/t/dat/bug/0 -------------------------------------------------------------------------------- /t/dat/lib/bar.pl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/File-Zglob/05c904c77a9a3ce62953c7be481ca1f97c3b02a0/t/dat/lib/bar.pl -------------------------------------------------------------------------------- /t/dat/lib/foo.pm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/File-Zglob/05c904c77a9a3ce62953c7be481ca1f97c3b02a0/t/dat/lib/foo.pm -------------------------------------------------------------------------------- /t/dat/very/deep/.dotfile: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/File-Zglob/05c904c77a9a3ce62953c7be481ca1f97c3b02a0/t/dat/very/deep/.dotfile -------------------------------------------------------------------------------- /t/dat/very/deep/normalfile: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/File-Zglob/05c904c77a9a3ce62953c7be481ca1f97c3b02a0/t/dat/very/deep/normalfile -------------------------------------------------------------------------------- /xt/01_podspell.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval q{ use Test::Spelling }; 4 | plan skip_all => "Test::Spelling is not installed." if $@; 5 | add_stopwords(map { split /[\s\:\-]/ } ); 6 | $ENV{LANG} = 'C'; 7 | my $spell_cmd; 8 | foreach my $path (split(/:/, $ENV{PATH})) { 9 | -x "$path/spell" and $spell_cmd="spell", last; 10 | -x "$path/ispell" and $spell_cmd="ispell -l", last; 11 | -x "$path/aspell" and $spell_cmd="aspell list", last; 12 | } 13 | plan skip_all => "no spell/ispell/aspell" unless $spell_cmd; 14 | 15 | set_spell_cmd($spell_cmd); 16 | all_pod_files_spelling_ok('lib'); 17 | __DATA__ 18 | Tokuhiro Matsuno 19 | File::Zglob 20 | tokuhirom 21 | AAJKLFJEF 22 | GMAIL 23 | COM 24 | Tatsuhiko 25 | Miyagawa 26 | Kazuhiro 27 | Osawa 28 | lestrrat 29 | typester 30 | cho45 31 | charsbar 32 | coji 33 | clouder 34 | gunyarakun 35 | hio_d 36 | hirose31 37 | ikebe 38 | kan 39 | kazeburo 40 | daisuke 41 | maki 42 | TODO 43 | API 44 | URL 45 | URI 46 | db 47 | TTerse 48 | irc 49 | org 50 | CSS 51 | Amon 52 | UNIX-ish 53 | fileutil.scm 54 | gauche's 55 | scm 56 | baz 57 | foo 58 | bar 59 | pull-req 60 | github 61 | zglob 62 | CP932 63 | utf-8 64 | -------------------------------------------------------------------------------- /xt/02_perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval q{ 4 | use Test::Perl::Critic 1.02 -exclude => [ 5 | 'Subroutines::ProhibitSubroutinePrototypes', 6 | 'Subroutines::ProhibitExplicitReturnUndef', 7 | 'TestingAndDebugging::ProhibitNoStrict', 8 | 'ControlStructures::ProhibitMutatingListFunctions', 9 | 'InputOutput::RequireEncodingWithUTF8Layer', 10 | ] 11 | }; 12 | plan skip_all => "Test::Perl::Critic 1.02+ is not installed." if $@; 13 | all_critic_ok('lib'); 14 | -------------------------------------------------------------------------------- /xt/03_pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Pod 1.00"; 3 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 4 | all_pod_files_ok(); 5 | -------------------------------------------------------------------------------- /xt/04_minimum_version.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::MinimumVersion 0.101080"; 3 | plan skip_all => "Test::Minimumversion required for testing perl minimum version" if $@; 4 | all_minimum_version_from_metayml_ok(); 5 | --------------------------------------------------------------------------------