1package Prima::sys::FS;
2
3use strict;
4use warnings;
5require Exporter;
6use Symbol ();
7use Scalar::Util qw(readonly);
8use Encode;
9use Fcntl qw(O_RDONLY O_WRONLY O_RDWR O_CREAT O_TRUNC O_APPEND);
10use Prima;
11use Prima::Utils qw(
12	chdir chmod closedir getcwd link mkdir open_dir open_file
13	read_dir rename rmdir unlink utime
14	getenv setenv stat access getdir
15	seekdir telldir rewinddir
16);
17
18use vars qw(@ISA @EXPORT @EXPORT_OK);
19@ISA = qw(Exporter);
20@EXPORT_OK = qw(
21	chdir chmod getcwd link mkdir open opendir readdir closedir
22	rename rmdir unlink utime
23	getenv setenv abs_path stat lstat access getdir
24	seekdir telldir rewinddir glob
25	_r _w _x _o _R _W _X _O _e _z _s _f _d _l _p _S _b _c _t _u _g _k _M _A _C
26);
27@EXPORT = @EXPORT_OK;
28
29sub open(*;$*)
30{
31	my ( $handle, @p ) = @_;
32	goto NATIVE unless @p;
33	$p[0] =~ m/^([\<\>\|\-\+\=\&]*])(.*)/ if 1 == @p;
34	my ( $mode, $what, @rest) = @p;
35	goto NATIVE if !defined($what) || ref($what);
36	goto NATIVE if $what =~ /[\-\|\=\&]/;
37
38	my $flags;
39	my @layers;
40
41	if ( $mode =~ /^([^:\s]+)(.+)$/ ) {
42		$mode = $1;
43		my $binmode = $2;
44		$binmode =~ s/^\s+//;
45		$binmode =~ s/\s+$//;
46		@layers = grep { length } split /[:\s]/, $binmode if length $binmode;
47	}
48
49	if ( $mode eq '>') {
50		$flags = O_CREAT | O_WRONLY | O_TRUNC;
51	} elsif ( $mode eq '>>') {
52		$flags = O_CREAT | O_APPEND;
53	} elsif ( $mode eq '<' ) {
54		$flags = O_RDONLY;
55	} elsif ( $mode eq '>+' ) {
56		$flags = O_CREAT | O_RDWR;
57	} elsif ( $mode eq '>>+' ) {
58		$flags = O_CREAT | O_RDWR | O_APPEND;
59	} elsif ( $mode eq '<+' ) {
60		$flags = O_CREAT | O_RDWR;
61	} elsif ( $mode eq '+>' ) {
62		$flags = O_CREAT | O_RDWR | O_TRUNC;
63	} elsif ( $mode eq '+>>' ) {
64		$flags = O_CREAT | O_RDWR | O_APPEND | O_TRUNC;
65	} elsif ( $mode eq '+<' ) {
66		$flags = O_CREAT | O_RDWR | O_TRUNC;
67	} else {
68		goto NATIVE;
69	}
70
71	my $fd = open_file( $what, $flags );
72	return if $fd < 0;
73
74        $_[0] = Symbol::geniosym unless defined $_[0];
75        $handle = Symbol::qualify_to_ref($_[0], scalar caller);
76
77	my $ok = open $handle, "$mode&=", $fd;
78	return unless $ok;
79	binmode($handle, ":$_") for @layers;
80	return $ok;
81
82NATIVE:
83	if ( 0 == @p ) {
84		return CORE::open($handle);
85	} elsif ( 1 == @p ) {
86		return CORE::open($handle, $p[0]);
87	} elsif ( 2 == @p ) {
88		return CORE::open($handle, $p[0], $p[1]);
89	} else {
90		my ( $x, $y ) = (shift @p, shift @p);
91		return CORE::open($handle, $x, $y, @p);
92	}
93}
94
95sub opendir(*$)
96{
97	if ( readonly($_[0])) {
98		warn "Prima::sys::FS::opendir: cannot be use on filehandles, variables only\n";
99		return;
100	}
101	$_[0] = open_dir( $_[1] );
102	return defined $_[0];
103}
104
105sub readdir($)
106{
107	my $dh = shift;
108
109	if ( wantarray ) {
110		my @ret;
111		while ( defined( my $f = read_dir($dh)) ) {
112			push @ret, $f;
113		}
114		return @ret;
115	} else {
116		return read_dir($dh);
117	}
118}
119
120sub glob
121{
122	my $pat = shift;
123	my @pats;
124	while ( 1 ) {
125		$pat =~ m/\G"((?:[^"]|\\")*)(?<!\\)"/gcs and push @pats, $1 and next;
126		$pat =~ m/\G'((?:[^']|\\')*)(?<!\\)'/gcs and push @pats, $1 and next;
127		$pat =~ m/\G((?:\S|\\\s)+)/gcs and push @pats, $1 and next;
128		$pat =~ m/\G\s+/gcs and next;
129		$pat =~ m/\G$/gcs and last;
130	}
131	my @matches = @pats;
132	@pats = ();
133	my $win32 = $^O =~ /win32/i;
134	MATCH: while ( my $q = shift @matches ) {
135		if ( $q =~ m/^(.*)\{([^}]*)\}(.*)$/ ) {
136			my ( $pre, $subpat, $post ) = ( $1, $2, $3 );
137			push @matches, map { "$pre$_$post" } split /,/, $subpat;
138		} elsif ( $q =~ m/^(.*)\[([^\]]*)\](.*)$/ ) {
139			my ( $pre, $subpat, $post ) = ( $1, $2, $3 );
140			push @matches, map { "$pre$_$post" } split //, $subpat;
141		} elsif ( $q =~ m/^~(\w*)(.*)/ ) {
142			my @pwent;
143			unless ( length $1 ) {
144				push @matches, ($ENV{HOME} // ($win32 ? $ENV{USERPROFILE} : undef) // '/' ) . $2;
145			} elsif (!$win32 && (@pwent = getpwnam($1)) && defined($pwent[7])) {
146				push @matches, $pwent[7] .  $2;
147			}
148		} elsif ( $q =~ m/(?<!\\)\*|\?/ ) {
149			my @paths = ('');
150			my $expanded;
151			for my $subpath ( split m{(/)}, $q ) {
152				if ( !$expanded && $subpath =~ m/(?<!\\)\*|\?/ ) {
153					$subpath =~ s/(?<!\\)\*/.*/g;
154					$subpath =~ s/(?<!\\)\?/./g;
155					$subpath = qr/$subpath/;
156					next MATCH unless Prima::sys::FS::opendir( my $dh, length($paths[0]) ? $paths[0] : '.' );
157					my $opath = pop @paths;
158					for my $e ( Prima::sys::FS::readdir $dh ) {
159						next unless $e =~ /^$subpath$/;
160						push @paths, $opath . $e;
161					}
162					Prima::Utils::closedir $dh;
163					$expanded++;
164				} else {
165					$_ .= $subpath for @paths;
166				}
167			}
168			push @matches, @paths;
169		} elsif (_e($q)) {
170			push @pats, $q;
171		}
172	}
173
174	return @pats;
175}
176
177sub lstat { Prima::Utils::stat($_[0], 1) }
178
179sub __x(&$) {
180	my @p = Prima::Utils::stat($_[1]);
181	return undef unless scalar @p;
182	$_[0]->(@p);
183}
184
185sub __f($$) {
186	no strict 'refs';
187	my @p = Prima::Utils::stat($_[1]);
188	return undef unless scalar @p;
189	return undef unless ${'Fcntl::'}{$_[0]};
190	my $c = Fcntl->can($_[0])->();
191	return (($c & $p[2]) == $c) ? 1 : 0;
192}
193
194sub _l ($) {
195	no strict 'refs';
196	my @p = Prima::Utils::stat($_[1], 1);
197	return undef unless scalar @p;
198	return undef unless ${'Fcntl::'}{S_IFLNK};
199	my $c = Fcntl->can('S_IFLNK')->();
200	return (($c & $p[2]) == $c) ? 1 : 0;
201}
202
203sub _r ($) { access($_[0], 4, 1) >= 0 }
204sub _w ($) { access($_[0], 2, 1) >= 0 }
205sub _x ($) { access($_[0], 1, 1) >= 0 }
206sub _o ($) { __x sub { $> == $_[4] }, $_[0] }
207sub _R ($) { access($_[0], 4, 0) >= 0 }
208sub _W ($) { access($_[0], 2, 0) >= 0 }
209sub _X ($) { access($_[0], 1, 0) >= 0 }
210sub _O ($) { __x sub { $< == $_[4] }, $_[0] }
211sub _e ($) { __x sub { 1 }, $_[0] }
212sub _z ($) { __x sub { 0  == $_[7] }, $_[0] }
213sub _s ($) { __x sub { $_[7] }, $_[0] }
214sub _f ($) { __f S_IFREG  => $_[0] }
215sub _d ($) { __f S_IFDIR  => $_[0] }
216sub _p ($) { __f S_IFFIFO => $_[0] }
217sub _S ($) { __f S_IFSOCK => $_[0] }
218sub _b ($) { __f S_IFBLK  => $_[0] }
219sub _c ($) { __f S_IFCHR  => $_[0] }
220sub _t ($) { -t $_[0] }
221sub _u ($) { __f S_ISUID  => $_[0] }
222sub _g ($) { __f S_ISGID  => $_[0] }
223sub _k ($) { __f S_ISVTX  => $_[0] }
224sub _A ($) { __x sub { ( time - $_[8]  ) / 86400 }, $_[0] }
225sub _M ($) { __x sub { ( time - $_[9]  ) / 86400 }, $_[0] }
226sub _C ($) { __x sub { ( time - $_[10] ) / 86400 }, $_[0] }
227
228# adapted from Cwd.pm
229sub abs_path
230{
231	unless ( $^O =~ /win32|cygwin/i ) {
232		require Cwd;
233		my $p = $_[0];
234		my $was_utf8 = Encode::is_utf8($p);
235		$p = Cwd::abs_path($p);
236		$p = Encode::decode('utf-8', $p) if $was_utf8;
237		return $p;
238	}
239
240	my $cwd = Prima::Utils::getcwd();
241	defined $cwd or return undef;
242
243	my $path = @_ ? shift : '.';
244	unless (_e $path) {
245		require Errno;
246		$! = Errno::ENOENT();
247		return undef;
248	}
249
250	unless (_d $path) {
251		# Make sure we can be invoked on plain files, not just directories.
252		require File::Spec;
253		my ($vol, $dir, $file) = File::Spec->splitpath($path);
254		return File::Spec->catfile($cwd, $path) unless length $dir;
255
256		return $dir eq File::Spec->rootdir
257			? File::Spec->catpath($vol, $dir, $file)
258			: abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
259	}
260
261	return undef unless Prima::Utils::chdir($path);
262	my $realpath = Prima::Utils::getcwd();
263	if (! ((_d $cwd) && (Prima::Utils::chdir($cwd)))) {
264		_croak("Cannot chdir back to $cwd: $!");
265	}
266
267	return $realpath;
268}
269
2701;
271
272=pod
273
274=head1 NAME
275
276Prima::sys::FS - unicode-aware core file functions
277
278=head1 DESCRIPTION
279
280Since perl win32 unicode support for files is unexistent, Prima has its own
281parallel set of functions mimicking native functions, ie open, chdir etc. This
282means that files with names that cannot be converted to ANSI (ie
283user-preferred) codepage are not visible in perl, but the functions below
284mitigate that problem.
285
286This module exports the unicode-aware functions from C<Prima::Utils> to override
287the core functions. Read more in L<Prima::Utils/"Unicode-aware filesystem functions">.
288
289=head2 SYNOPSIS
290
291  use Prima::sys::FS;
292
293  my $fn = "\x{dead}\x{beef};
294  if ( _f $fn ) {
295     open F, ">", $fn or die $!;
296     close F;
297  }
298  print "ls: ", getdir, "\n";
299  print "pwd: ", getcwd, "\n";
300
301=head1 API
302
303The module exports by default three groups of functions:
304
305These are described in L<Prima::Utils/API>:
306
307  chdir chmod getcwd link mkdir open rename rmdir unlink utime
308  getenv setenv stat access getdir
309  opendir closedir rewinddir seekdir readdir telldir
310
311The underscore-prefixed functions are same as the ones in L<perlfunc/-X> (all are present except -T and -B ).
312
313  _r _w _x _o _R _W _X _O _e _z _s _f _d _l _p _S _b _c _t _u _g _k _M _A _C
314
315The functions that are implemented in the module itself:
316
317=over
318
319=item abs_path
320
321Same as C<Cwd::abs_path>.
322
323=item glob PATTERN
324
325More or less same as C<CORE::glob> or C<File::Glob::glob>.
326
327=item lstat PATH
328
329Same as C<CORE::lstat>
330
331=back
332
333=head1 AUTHOR
334
335Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.
336
337=head1 SEE ALSO
338
339L<Prima::Utils>, L<Win32::Unicode>.
340
341