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