view release on metacpan or  search on metacpan

Prima/sys/FS.pm  view on Meta::CPAN

package Prima::sys::FS;

use strict;
use warnings;
require Exporter;
use Symbol ();
use Scalar::Util qw(readonly);
use Encode;
use Fcntl qw(O_RDONLY O_WRONLY O_RDWR O_CREAT O_TRUNC O_APPEND);
use Prima;
use Prima::Utils qw(
	chdir chmod closedir getcwd link mkdir open_dir open_file
	read_dir rename rmdir unlink utime
	getenv setenv stat access getdir
	seekdir telldir rewinddir
);

use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
	chdir chmod getcwd link mkdir open opendir readdir closedir 
	rename rmdir unlink utime
	getenv setenv abs_path stat lstat access getdir
	seekdir telldir rewinddir glob
	_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
);
@EXPORT = @EXPORT_OK;

sub open(*;$*)
{
	my ( $handle, @p ) = @_;
	goto NATIVE unless @p;
	$p[0] =~ m/^([\<\>\|\-\+\=\&]*])(.*)/ if 1 == @p;
	my ( $mode, $what, @rest) = @p;
	goto NATIVE if !defined($what) || ref($what);
	goto NATIVE if $what =~ /[\-\|\=\&]/;

	my $flags;
	my @layers;

	if ( $mode =~ /^([^:\s]+)(.+)$/ ) {
		$mode = $1;
		my $binmode = $2;
		$binmode =~ s/^\s+//;
		$binmode =~ s/\s+$//;
		@layers = grep { length } split /[:\s]/, $binmode if length $binmode;
	}

	if ( $mode eq '>') {
		$flags = O_CREAT | O_WRONLY | O_TRUNC;
	} elsif ( $mode eq '>>') {
		$flags = O_CREAT | O_APPEND;
	} elsif ( $mode eq '<' ) {
		$flags = O_RDONLY;
	} elsif ( $mode eq '>+' ) {
		$flags = O_CREAT | O_RDWR;
	} elsif ( $mode eq '>>+' ) {
		$flags = O_CREAT | O_RDWR | O_APPEND;
	} elsif ( $mode eq '<+' ) {
		$flags = O_CREAT | O_RDWR;
	} elsif ( $mode eq '+>' ) {
		$flags = O_CREAT | O_RDWR | O_TRUNC;
	} elsif ( $mode eq '+>>' ) {
		$flags = O_CREAT | O_RDWR | O_APPEND | O_TRUNC;
	} elsif ( $mode eq '+<' ) {
		$flags = O_CREAT | O_RDWR | O_TRUNC;
	} else {
		goto NATIVE;
	}

	my $fd = open_file( $what, $flags );
	return if $fd < 0;

        $_[0] = Symbol::geniosym unless defined $_[0];
        $handle = Symbol::qualify_to_ref($_[0], scalar caller);

	my $ok = open $handle, "$mode&=", $fd;
	return unless $ok;
	binmode($handle, ":$_") for @layers;
	return $ok;

NATIVE:
	goto &CORE::open;

Prima/sys/FS.pm  view on Meta::CPAN

	}

	unless (_d $path) {
		# Make sure we can be invoked on plain files, not just directories.
		require File::Spec;
		my ($vol, $dir, $file) = File::Spec->splitpath($path);
		return File::Spec->catfile($cwd, $path) unless length $dir;

		return $dir eq File::Spec->rootdir
			? File::Spec->catpath($vol, $dir, $file)
			: abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
	}

	return undef unless Prima::Utils::chdir($path);
	my $realpath = Prima::Utils::getcwd();
	if (! ((_d $cwd) && (Prima::Utils::chdir($cwd)))) {
		croak("Cannot chdir back to $cwd: $!");
	}

	return $realpath;
}

1;

=pod

=head1 NAME

Prima::sys::FS - unicode-aware core file functions

=head1 DESCRIPTION

Since perl win32 unicode support for files is unexistent, Prima has its own
parallel set of functions mimicking native functions, ie open, chdir etc. This
means that files with names that cannot be converted to ANSI (ie
user-preferred) codepage are not visible in perl, but the functions below
mitigate that problem.

This module exports the unicode-aware functions from C<Prima::Utils> to override
the core functions. Read more in L<Prima::Utils/"Unicode-aware file system functions">.

=head2 SYNOPSIS

  use Prima::sys::FS;

  my $fn = "\x{dead}\x{beef};
  if ( _f $fn ) {
     open F, ">", $fn or die $!;
     close F;
  }
  print "ls: ", getdir, "\n";
  print "pwd: ", getcwd, "\n";

=head1 API

The module exports by default three groups of functions:

These are described in L<Prima::Utils/API>:

  chdir chmod getcwd link mkdir open rename rmdir unlink utime
  getenv setenv stat access getdir
  opendir closedir rewinddir seekdir readdir telldir

The underscore-prefixed functions are same as the ones in L<perlfunc/-X> (all are present except -T and -B ).

  _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

The functions that are implemented in the module itself:

=over

=item abs_path

Same as C<Cwd::abs_path>.

=item glob PATTERN

More or less same as C<CORE::glob> or C<File::Glob::glob>.

=item lstat PATH

Same as C<CORE::lstat>

=back

=head1 AUTHOR

Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.

=head1 SEE ALSO

L<Prima::Utils>, L<Win32::Unicode>.