Initial Commit
This commit is contained in:
Riley Schneider
460
database/perl/vendor/lib/File/chdir.pm
vendored
Normal file
460
database/perl/vendor/lib/File/chdir.pm
vendored
Normal file
@@ -0,0 +1,460 @@
|
||||
package File::chdir;
|
||||
use 5.004;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT $CWD @CWD);
|
||||
# ABSTRACT: a more sensible way to change directories
|
||||
|
||||
our $VERSION = '0.1010';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(*CWD);
|
||||
|
||||
use Carp;
|
||||
use Cwd 3.16;
|
||||
use File::Spec::Functions 3.27 qw/canonpath splitpath catpath splitdir catdir/;
|
||||
|
||||
tie $CWD, 'File::chdir::SCALAR' or die "Can't tie \$CWD";
|
||||
tie @CWD, 'File::chdir::ARRAY' or die "Can't tie \@CWD";
|
||||
|
||||
sub _abs_path {
|
||||
# Otherwise we'll never work under taint mode.
|
||||
my($cwd) = Cwd::getcwd =~ /(.*)/s;
|
||||
# Run through File::Spec, since everything else uses it
|
||||
return canonpath($cwd);
|
||||
}
|
||||
|
||||
# splitpath but also split directory
|
||||
sub _split_cwd {
|
||||
my ($vol, $dir) = splitpath(_abs_path, 1);
|
||||
my @dirs = splitdir( $dir );
|
||||
shift @dirs; # get rid of leading empty "root" directory
|
||||
return ($vol, @dirs);
|
||||
}
|
||||
|
||||
# catpath, but take list of directories
|
||||
# restore the empty root dir and provide an empty file to avoid warnings
|
||||
sub _catpath {
|
||||
my ($vol, @dirs) = @_;
|
||||
return catpath($vol, catdir(q{}, @dirs), q{});
|
||||
}
|
||||
|
||||
sub _chdir {
|
||||
# Untaint target directory
|
||||
my ($new_dir) = $_[0] =~ /(.*)/s;
|
||||
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
if ( ! CORE::chdir($new_dir) ) {
|
||||
croak "Failed to change directory to '$new_dir': $!";
|
||||
};
|
||||
return 1;
|
||||
}
|
||||
|
||||
{
|
||||
package File::chdir::SCALAR;
|
||||
use Carp;
|
||||
|
||||
BEGIN {
|
||||
*_abs_path = \&File::chdir::_abs_path;
|
||||
*_chdir = \&File::chdir::_chdir;
|
||||
*_split_cwd = \&File::chdir::_split_cwd;
|
||||
*_catpath = \&File::chdir::_catpath;
|
||||
}
|
||||
|
||||
sub TIESCALAR {
|
||||
bless [], $_[0];
|
||||
}
|
||||
|
||||
# To be safe, in case someone chdir'd out from under us, we always
|
||||
# check the Cwd explicitly.
|
||||
sub FETCH {
|
||||
return _abs_path;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
return unless defined $_[1];
|
||||
_chdir($_[1]);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
package File::chdir::ARRAY;
|
||||
use Carp;
|
||||
|
||||
BEGIN {
|
||||
*_abs_path = \&File::chdir::_abs_path;
|
||||
*_chdir = \&File::chdir::_chdir;
|
||||
*_split_cwd = \&File::chdir::_split_cwd;
|
||||
*_catpath = \&File::chdir::_catpath;
|
||||
}
|
||||
|
||||
sub TIEARRAY {
|
||||
bless {}, $_[0];
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my($self, $idx) = @_;
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
return $cwd[$idx];
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my($self, $idx, $val) = @_;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
if( $self->{Cleared} ) {
|
||||
@cwd = ();
|
||||
$self->{Cleared} = 0;
|
||||
}
|
||||
|
||||
$cwd[$idx] = $val;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
|
||||
_chdir($dir);
|
||||
return $cwd[$idx];
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
return scalar @cwd;
|
||||
}
|
||||
sub STORESIZE {}
|
||||
|
||||
sub PUSH {
|
||||
my($self) = shift;
|
||||
|
||||
my $dir = _catpath(_split_cwd, @_);
|
||||
_chdir($dir);
|
||||
return $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub POP {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $popped = pop @cwd;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
_chdir($dir);
|
||||
return $popped;
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $shifted = shift @cwd;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
_chdir($dir);
|
||||
return $shifted;
|
||||
}
|
||||
|
||||
sub UNSHIFT {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $dir = _catpath($vol, @_, @cwd);
|
||||
_chdir($dir);
|
||||
return $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my($self) = shift;
|
||||
$self->{Cleared} = 1;
|
||||
}
|
||||
|
||||
sub SPLICE {
|
||||
my $self = shift;
|
||||
my $offset = shift || 0;
|
||||
my $len = shift || $self->FETCHSIZE - $offset;
|
||||
my @new_dirs = @_;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my @orig_dirs = splice @cwd, $offset, $len, @new_dirs;
|
||||
my $dir = _catpath($vol, @cwd);
|
||||
_chdir($dir);
|
||||
return @orig_dirs;
|
||||
}
|
||||
|
||||
sub EXTEND { }
|
||||
sub EXISTS {
|
||||
my($self, $idx) = @_;
|
||||
return $self->FETCHSIZE >= $idx ? 1 : 0;
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my($self, $idx) = @_;
|
||||
croak "Can't delete except at the end of \@CWD"
|
||||
if $idx < $self->FETCHSIZE - 1;
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
$self->POP;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::chdir - a more sensible way to change directories
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.1010
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::chdir;
|
||||
|
||||
$CWD = "/foo/bar"; # now in /foo/bar
|
||||
{
|
||||
local $CWD = "/moo/baz"; # now in /moo/baz
|
||||
...
|
||||
}
|
||||
|
||||
# still in /foo/bar!
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl's C<chdir()> has the unfortunate problem of being very, very, very
|
||||
global. If any part of your program calls C<chdir()> or if any library
|
||||
you use calls C<chdir()>, it changes the current working directory for
|
||||
the *whole* program.
|
||||
|
||||
This sucks.
|
||||
|
||||
File::chdir gives you an alternative, C<$CWD> and C<@CWD>. These two
|
||||
variables combine all the power of C<chdir()>, L<File::Spec> and L<Cwd>.
|
||||
|
||||
=head1 $CWD
|
||||
|
||||
Use the C<$CWD> variable instead of C<chdir()> and Cwd.
|
||||
|
||||
use File::chdir;
|
||||
$CWD = $dir; # just like chdir($dir)!
|
||||
print $CWD; # prints the current working directory
|
||||
|
||||
It can be localized, and it does the right thing.
|
||||
|
||||
$CWD = "/foo"; # it's /foo out here.
|
||||
{
|
||||
local $CWD = "/bar"; # /bar in here
|
||||
}
|
||||
# still /foo out here!
|
||||
|
||||
C<$CWD> always returns the absolute path in the native form for the
|
||||
operating system.
|
||||
|
||||
C<$CWD> and normal C<chdir()> work together just fine.
|
||||
|
||||
=head1 @CWD
|
||||
|
||||
C<@CWD> represents the current working directory as an array, each
|
||||
directory in the path is an element of the array. This can often make
|
||||
the directory easier to manipulate, and you don't have to fumble with
|
||||
C<File::Spec->splitpath> and C<File::Spec->catdir> to make portable code.
|
||||
|
||||
# Similar to chdir("/usr/local/src/perl")
|
||||
@CWD = qw(usr local src perl);
|
||||
|
||||
pop, push, shift, unshift and splice all work. pop and push are
|
||||
probably the most useful.
|
||||
|
||||
pop @CWD; # same as chdir(File::Spec->updir)
|
||||
push @CWD, 'some_dir' # same as chdir('some_dir')
|
||||
|
||||
C<@CWD> and C<$CWD> both work fine together.
|
||||
|
||||
*NOTE* Due to a perl bug you can't localize C<@CWD>. See L</CAVEATS> for a work around.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
(We omit the C<use File::chdir> from these examples for terseness)
|
||||
|
||||
Here's C<$CWD> instead of C<chdir()>:
|
||||
|
||||
$CWD = 'foo'; # chdir('foo')
|
||||
|
||||
and now instead of Cwd.
|
||||
|
||||
print $CWD; # use Cwd; print Cwd::abs_path
|
||||
|
||||
you can even do zsh style C<cd foo bar>
|
||||
|
||||
$CWD = '/usr/local/foo';
|
||||
$CWD =~ s/usr/var/;
|
||||
|
||||
if you want to localize that, make sure you get the parens right
|
||||
|
||||
{
|
||||
(local $CWD) =~ s/usr/var/;
|
||||
...
|
||||
}
|
||||
|
||||
It's most useful for writing polite subroutines which don't leave the
|
||||
program in some strange directory:
|
||||
|
||||
sub foo {
|
||||
local $CWD = 'some/other/dir';
|
||||
...do your work...
|
||||
}
|
||||
|
||||
which is much simpler than the equivalent:
|
||||
|
||||
sub foo {
|
||||
use Cwd;
|
||||
my $orig_dir = Cwd::getcwd;
|
||||
chdir('some/other/dir');
|
||||
|
||||
...do your work...
|
||||
|
||||
chdir($orig_dir);
|
||||
}
|
||||
|
||||
C<@CWD> comes in handy when you want to start moving up and down the
|
||||
directory hierarchy in a cross-platform manner without having to use
|
||||
File::Spec.
|
||||
|
||||
pop @CWD; # chdir(File::Spec->updir);
|
||||
push @CWD, 'some', 'dir' # chdir(File::Spec->catdir(qw(some dir)));
|
||||
|
||||
You can easily change your parent directory:
|
||||
|
||||
# chdir from /some/dir/bar/moo to /some/dir/foo/moo
|
||||
$CWD[-2] = 'foo';
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
=head2 C<local @CWD> does not work.
|
||||
|
||||
C<local @CWD> will not localize C<@CWD>. This is a bug in Perl, you
|
||||
can't localize tied arrays. As a work around localizing $CWD will
|
||||
effectively localize @CWD.
|
||||
|
||||
{
|
||||
local $CWD;
|
||||
pop @CWD;
|
||||
...
|
||||
}
|
||||
|
||||
=head2 Assigning to C<@CWD> calls C<chdir()> for each element
|
||||
|
||||
@CWD = qw/a b c d/;
|
||||
|
||||
Internally, Perl clears C<@CWD> and assigns each element in turn. Thus, this
|
||||
code above will do this:
|
||||
|
||||
chdir 'a';
|
||||
chdir 'a/b';
|
||||
chdir 'a/b/c';
|
||||
chdir 'a/b/c/d';
|
||||
|
||||
Generally, avoid assigning to C<@CWD> and just use push and pop instead.
|
||||
|
||||
=head2 Volumes not handled
|
||||
|
||||
There is currently no way to change the current volume via File::chdir.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
C<$CWD> returns the current directory using native path separators, i.e. \
|
||||
on Win32. This ensures that C<$CWD> will compare correctly with directories
|
||||
created using File::Spec. For example:
|
||||
|
||||
my $working_dir = File::Spec->catdir( $CWD, "foo" );
|
||||
$CWD = $working_dir;
|
||||
doing_stuff_might_chdir();
|
||||
is( $CWD, $working_dir, "back to original working_dir?" );
|
||||
|
||||
Deleting the last item of C<@CWD> will act like a pop. Deleting from the
|
||||
middle will throw an exception.
|
||||
|
||||
delete @CWD[-1]; # OK
|
||||
delete @CWD[-2]; # Dies
|
||||
|
||||
What should %CWD do? Something with volumes?
|
||||
|
||||
# chdir to C:\Program Files\Sierra\Half Life ?
|
||||
$CWD{C} = '\\Program Files\\Sierra\\Half Life';
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If an error is encountered when changing C<$CWD> or C<@CWD>, one of
|
||||
the following exceptions will be thrown:
|
||||
|
||||
* ~Can't delete except at the end of @CWD~
|
||||
* ~Failed to change directory to '$dir'~
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Michael wanted C<local chdir> to work. p5p didn't. But it wasn't over!
|
||||
Was it over when the Germans bombed Pearl Harbor? Hell, no!
|
||||
|
||||
Abigail and/or Bryan Warnock suggested the C<$CWD> thing (Michael forgets
|
||||
which). They were right.
|
||||
|
||||
The C<chdir()> override was eliminated in 0.04.
|
||||
|
||||
David became co-maintainer with 0.06_01 to fix some chronic
|
||||
Win32 path bugs.
|
||||
|
||||
As of 0.08, if changing C<$CWD> or C<@CWD> fails to change the directory, an
|
||||
error will be thrown.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::pushd>, L<File::Spec>, L<Cwd>, L<perlfunc/chdir>,
|
||||
"Animal House" L<http://www.imdb.com/title/tt0077975/quotes>
|
||||
|
||||
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests through the issue tracker
|
||||
at L<https://github.com/dagolden/File-chdir/issues>.
|
||||
You will be notified automatically of any progress on your issue.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
This is open source software. The code repository is available for
|
||||
public review and contribution under the terms of the license.
|
||||
|
||||
L<https://github.com/dagolden/File-chdir>
|
||||
|
||||
git clone https://github.com/dagolden/File-chdir.git
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Michael G. Schwern <schwern@pobox.com>
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONTRIBUTOR
|
||||
|
||||
=for stopwords Joel Berger
|
||||
|
||||
Joel Berger <joel.a.berger@gmail.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2015 by Michael G. Schwern and David Golden.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user