Skip to content

Commit 53e3682

Browse files
briandfoybriandfoy
committed
re-imagining the glob, as a first pass
1 parent 7f4eb9c commit 53e3682

File tree

2 files changed

+236
-28
lines changed

2 files changed

+236
-28
lines changed

‎bin/glob‎

Lines changed: 118 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -12,50 +12,140 @@ License: perl
1212
1313
=cut
1414

15+
package PerlPowerTools::glob;
16+
17+
use strict;
18+
use warnings;
19+
1520
our $VERSION = '2.1';
1621

1722
use constant EX_SUCCESS => 0;
1823
use constant EX_FAILURE => 1;
24+
use constant EX_ERROR => 2;
1925

20-
use File::Glob qw(csh_glob);
26+
use File::Basename;
27+
use File::Glob qw(csh_glob GLOB_CSH);
2128

22-
my $separator = "\n";
23-
if( $ARGV[0] eq '-0' ) {
24-
shift @ARGV;
25-
$separator = "\0";
26-
}
29+
__PACKAGE__->run(@ARGV) unless caller();
30+
31+
my %Unknown_users;
32+
my $wildcards = qr/[*?\[]/;
33+
34+
sub run {
35+
my( $class, @args ) = @_;
2736

28-
my $pattern = "@ARGV";
37+
my( $code, $message ) = do {
38+
if( @args == 0 ) {
39+
( EX_ERROR, undef );
40+
}
41+
else {
42+
my $separator = "\n";
43+
if( $args[0] eq '-0' ) {
44+
shift @args;
45+
$separator = "\0";
46+
}
47+
48+
my @ARGV_expanded = @args;
49+
if( $^O =~ /\A MSWin32 \z/x ) {
50+
@ARGV_expanded = map { expand_tilde($_) } @ARGV_expanded;
51+
}
52+
53+
my @matches = csh_glob( "@ARGV_expanded", GLOB_CSH );
54+
55+
if( @matches ) {
56+
$class->output_list( \@matches, $separator );
57+
( EX_SUCCESS );
58+
}
59+
elsif( () = keys %Unknown_users ) {
60+
( EX_FAILURE, $class->no_match_message );
61+
}
62+
else {
63+
my $message = do {
64+
my $pattern = "@args";
65+
my $unknown = () = keys %Unknown_users;
66+
67+
if( $^O ne 'MSWin32' && $pattern =~ /(?:\A|\s)~([\w-]+?)\b/ ) {
68+
getpwnam($u) ? undef : "Unknown user $1.";
69+
}
70+
elsif( $pattern =~ $wildcards ) {
71+
( EX_FAILURE, $class->no_match_message );
72+
}
73+
else { undef }
74+
};
75+
76+
( EX_FAILURE, $message );
77+
}
78+
}
79+
};
2980

30-
my @matches = csh_glob( $pattern );
81+
$class->exit( $code, $message );
82+
}
3183

32-
if( @matches ) {
33-
print join $separator, @matches;
34-
exit EX_SUCCESS;
84+
sub exit {
85+
my( $class, $code, $message ) = @_;
86+
87+
print STDERR $message if defined $message;
88+
exit( $code // 0 );
3589
}
3690

37-
my $message = do {
38-
if( $pattern =~ /(?:\A|\s)~([\w-]+?)\b/ ) {
39-
my $u = $1;
40-
my $m = "Unknown user $u.";
91+
sub expand_tilde {
92+
return $_[0] unless $^O eq 'MSWin32';
93+
return $_[0] unless $_[0] =~ $wildcards;
94+
local $_ = $_[0];
4195

42-
if( $^O =~ /\A MSWin32 \z/x ) {
43-
local $_ = `net user $u`;
44-
/could not be found|The syntax of this command/ ? $m : ();
45-
}
46-
elsif( ! getpwnam($u) ) {
47-
$m
96+
my $home = my_home();
97+
my $dir = dirname($home) // '/Users';
98+
99+
return unless m/ \A ~ (\w+)? /x;
100+
my $user = $1;
101+
102+
if( $user && ! $Unknown_users{$user} ) {
103+
my $net_user = `net user "$user" 2>&1`;
104+
if( $net_user =~ /could not be found|The syntax of this command/ ) {
105+
print STDERR "Unknown user $user.\n";
106+
$Unknown_users{$user}++;
107+
return;
48108
}
49-
else { undef }
109+
s/ \A ~ (\w+) /$dir\\$1/x
50110
}
51-
elsif( $pattern =~ /[*?\[]/ ) {
52-
"No Match";
111+
else {
112+
s/ \A ~ /$home/x;
53113
}
54-
else { undef }
55-
};
56114

57-
print STDERR $message if defined $message;
58-
exit EX_FAILURE;
115+
return $_;
116+
}
117+
118+
# Stolen from File::HomeDir::Windows;
119+
sub my_home {
120+
# A lot of unix people and unix-derived tools rely on
121+
# the ability to overload HOME. We will support it too
122+
# so that they can replace raw HOME calls with File::HomeDir.
123+
if (exists $ENV{HOME} and defined $ENV{HOME} and length $ENV{HOME}) {
124+
return $ENV{HOME};
125+
}
126+
127+
# Do we have a user profile?
128+
if (exists $ENV{USERPROFILE} and $ENV{USERPROFILE}) {
129+
return $ENV{USERPROFILE};
130+
}
131+
132+
# Some Windows use something like $ENV{HOME}
133+
if (exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH}) {
134+
return File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '',);
135+
}
136+
137+
return;
138+
}
139+
140+
sub output_list {
141+
my( $class, $array, $separator ) = @_;
142+
$separator = "\n" unless defined $separator;
143+
144+
print STDOUT join $separator, @$array;
145+
print "\n";
146+
}
147+
148+
=encoding utf8
59149
60150
=head1 NAME
61151

‎t/glob/glob.t‎

Lines changed: 118 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
use 5.006;
2+
use strict;
3+
4+
BEGIN {
5+
*CORE::GLOBAL::exit = sub { 1 }
6+
}
7+
8+
use Test::More 1;
9+
10+
package Local::Glob {
11+
our @ISA = qw(PerlPowerTools::glob);
12+
13+
sub exit {
14+
( my $class, $Local::Glob::code, $Local::Glob::message ) = @_;
15+
}
16+
17+
sub output_list {
18+
( my $class, $Local::Glob::array, $Local::Glob::separator ) = @_;
19+
$Local::Glob::separator = "\n" unless defined $Local::Glob::separator;
20+
}
21+
}
22+
23+
my $class = 'Local::Glob';
24+
25+
26+
my $NO_MATCH_MESSAGE = 'glob: No match.';
27+
28+
subtest setup => sub {
29+
use lib qw(.);
30+
require_ok( 'bin/glob' );
31+
can_ok( $class, 'run' );
32+
};
33+
34+
subtest 'no args' => sub {
35+
$class->run();
36+
37+
is $Local::Glob::code, 2, 'exit code is error';
38+
is "$Local::Glob::message", '', 'there is no output message';
39+
};
40+
41+
subtest 'no wildcards' => sub {
42+
my @args = qw(foo bar);
43+
44+
$class->run(@args);
45+
46+
is $Local::Glob::code, 0, 'exit code is successful';
47+
is "$Local::Glob::message", '', 'there is no output message';
48+
is_deeply $Local::Glob::array, [@args], 'list as expected';
49+
};
50+
51+
subtest 'one arg, some matches' => sub {
52+
my @args = qw(t/lib/*);
53+
54+
$class->run(@args);
55+
56+
is $Local::Glob::code, 0, 'exit code is successful';
57+
is "$Local::Glob::message", '', 'there is no output message';
58+
is_deeply
59+
[ sort @$Local::Glob::array ],
60+
[map { "t/lib/$_" } qw(common.pl utils.pm)],
61+
'list as expected';
62+
};
63+
64+
subtest 'one arg, no matches' => sub {
65+
my @args = qw(t/not_there/*);
66+
67+
$class->run(@args);
68+
69+
is $Local::Glob::code, 1, 'exit code is no matches';
70+
is "$Local::Glob::message", $NO_MATCH_MESSAGE, 'there is no output message';
71+
is_deeply
72+
[ sort @$Local::Glob::array ],
73+
[map { "t/lib/$_" } qw(common.pl utils.pm)],
74+
'list as expected';
75+
};
76+
77+
subtest 'two arg, some matches' => sub {
78+
my @args = qw(t/lib/* t/glob/*);
79+
80+
$class->run(@args);
81+
82+
is $Local::Glob::code, 0, 'exit code is successful';
83+
is "$Local::Glob::message", '', 'there is no output message';
84+
is_deeply
85+
[ sort @$Local::Glob::array ],
86+
[ 't/glob/glob.t', map { "t/lib/$_" } qw(common.pl utils.pm)],
87+
'list as expected';
88+
};
89+
90+
subtest 'one tidle, no wildcard' => sub {
91+
my @args = qw(~nouserxyz456);
92+
93+
$class->run(@args);
94+
95+
is $Local::Glob::code, 0, 'exit code is successful';
96+
is "$Local::Glob::message", '', 'there is no output message';
97+
is_deeply
98+
[ sort @$Local::Glob::array ],
99+
[ @args ],
100+
'list as expected';
101+
};
102+
103+
subtest 'two tidle, no wildcard' => sub {
104+
my @args = qw(~nouserxyz456 ~nousersafgadfg);
105+
106+
$class->run(@args);
107+
108+
is $Local::Glob::code, 0, 'exit code is successful';
109+
is "$Local::Glob::message", '', 'there is no output message';
110+
is_deeply
111+
[ sort @$Local::Glob::array ],
112+
[ sort @args ],
113+
'list as expected';
114+
};
115+
116+
done_testing();
117+
118+
__END__

0 commit comments

Comments
 (0)