461 lines
11 KiB
Perl
461 lines
11 KiB
Perl
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
|