libfile-copy-link-perl 0.113-1 / usr / share / perl5 / File / Spec / Link.pm

package File::Spec::Link;

use strict;
use warnings;

use File::Spec ();
use base q(File::Spec); 

our $VERSION = 0.072;

# over-ridden class method - just a debugging wrapper
# 
sub canonpath { 
    my($spec, $path) = @_;
    return $spec->SUPER::canonpath($path) if $path;
    require Carp;
    Carp::cluck( "canonpath: ", 
		defined $path ? "empty path" : "path undefined"  
    );
    return $path;
}
sub catdir { my $spec = shift; return @_ ? $spec->SUPER::catdir(@_) : $spec->curdir }

# new class methods - implemented via objects
# 
sub linked { 
    my $self = shift -> new(@_); 
    return unless $self -> follow; 
    return $self -> path; 
}
sub resolve { 
    my $self = shift -> new(@_); 
    return unless $self -> resolved; 
    return $self -> path; 
}
sub resolve_all { 
    my $self = shift -> new(@_); 
    return unless $self -> resolvedir; 
    return $self -> path; 
}
sub relative_to_file { 
    my($spec, $path) = splice @_, 0, 2;
    my $self = $spec -> new(@_); 
    return unless $self -> relative($path);
    return $self -> path;
}
sub chopfile {
    my $self = shift -> new(@_);
    return $self -> path if length($self -> chop); 
    return
}

# other new class methods - implemented via Cwd
# 
sub full_resolve {
    my($spec, $file) = @_;
    my $path = $spec->resolve_path($file);
    return defined $path ? $path : $spec->resolve_all($file);
}

sub resolve_path {
    my($spec, $file) = @_;
    my $path = do {
	local $SIG{__WARN__} = sub { 
	    if ($_[0] =~ /^opendir\b/			and
		$_[0] =~ /\bNot\s+a\s+directory\b/	and
	    	$Cwd::VERSION < 2.18		 	and
		not -d $file)
	    {
		warn <<WARN;
Cwd::abs_path() only works on directories, not: $file
Use Cwd v2.18 or later
WARN
	    }
	    else {
		warn $_[0]
	    }
	};
	eval { require Cwd } && Cwd::abs_path($file) 
    };
    return unless $path; 
    return $spec->file_name_is_absolute($file)
	    ? $path : $spec->abs2rel($path);
} 

# old class method - not needed
# 
sub splitlast { 
    my $self = shift -> new(@_);
    my $last_path = $self -> chop;
    return ($self -> path, $last_path);
}

# object methods: 
# 	constructor methods	new
# 	access methods		path, canonical, vol, dir 
# 	updating methods	add, pop, push, split, chop
# 				relative, follow, resolved, resolvedir  

sub new { 
    my $self = bless { }, shift; 
    $self -> split(shift) if @_; 
    return $self; 
}
sub path { 
    my $self = shift; 
    return $self -> catpath( $self->vol, $self->dir, q{} ); 
}
sub canonical { my $self = shift; return $self -> canonpath( $self -> path ); }
sub vol { my $vol = shift->{vol}; return defined $vol ? $vol : q{} } 
sub dir { my $self = shift; return $self -> catdir( $self -> dirs ); }
sub dirs { my $dirs = shift->{dirs}; return $dirs ? @{$dirs} : () }
	
sub add {
    my($self, $file) = @_;
    if( $file eq $self -> curdir ) { }
    elsif( $file eq $self -> updir ) { $self -> pop }
    else { $self -> push($file); }
    return;
}
sub pop {
    my $self = shift;
    my @dirs = $self -> dirs;
    if( not @dirs or $dirs[-1] eq $self -> updir ) {
	push @{$self->{dirs}}, $self -> updir;
    }
    elsif( length $dirs[-1] and $dirs[-1] ne $self -> curdir) {
	CORE::pop @{$self->{dirs}}
    }	
    else {
	require Carp;
	Carp::cluck( "Can't go up from ", 
			length $dirs[-1] ? $dirs[-1]: "empty dir"
	);
    }
    return;
}

sub push {
    my $self = shift;
    my $file = shift;
    CORE::push @{$self->{dirs}}, $file if length $file;
    return;
}
sub split {
    my($self, $path) = @_;
    my($vol, $dir, $file) = $self->splitpath($path, 1);
    $self->{vol} = $vol;
    $self->{dirs} = [ $self->splitdir($dir) ];
    $self->push($file);
    return;
}
sub chop {
    my $self = shift;
    my $dirs = $self->{dirs};
    my $file = '';
    while( @$dirs ) {
	last if @$dirs == 1 and not length $dirs->[0];	# path = '/'
	last if length($file = CORE::pop @$dirs);
    }
    return $file;    
}    
    
sub follow {
    my $self = shift;
    my $path = $self -> path;
    my $link = readlink $self->path;
    return $self->relative($link) if defined $link;
    require Carp;
    Carp::confess(
	"Can't readlink ", $self->path, 
    	" : ", 
	(-l $self->path ? "but it is" : "not"), 
	" a link"
    );
}
 
sub relative {
    my($self, $path) = @_;
    unless( $self->file_name_is_absolute($path) ) {
	return unless length($self->chop);
	$path = $self->catdir($self->path, $path);
    }
    # what we want to do here is just set $self->{path}
    # to be read by $self->path; but would need to 
    # unset $self->{path} whenever it becomes invalid
    $self->split($path);
    return 1;
}

sub resolved {
    my $self = shift;
    my $seen = @_ ? shift : {};
    while( -l $self->path ) {
	return if $seen->{$self->canonical}++;
	return unless $self->follow;
    }
    return 1;
}

sub resolvedir {
    my $self = shift;
    my $seen = @_ ? shift : {};
    my @path;
    while( 1 ) {
	return unless $self->resolved($seen);
	my $last = $self->chop;
	last unless length $last;
	unshift @path, $last;
    }
    $self->add($_) for @path;    
    return 1;
}

1;

__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

File::Spec::Link - Perl extension for reading and resolving symbolic links

=head1 SYNOPSIS

    use File::Spec::Link;
    my $file = File::Spec::Link->linked($link); 
    my $file = File::Spec::Link->resolve($link); 
    my $dirname = File::Spec::Link->chopfile($file);
    my $newname = File::Spec::Link->relative_to_file($path, $link);
  
    my $realname = File::Spec::Link->full_resolve($file);
    my $realname = File::Spec::Link->resolve_path($file);
    my $realname = File::Spec::Link->resolve_all($file);

=head1 DESCRIPTION

C<File::Spec::Link> is an extension to C<File::Spec>, adding methods for
resolving symbolic links; it was created to implement C<File::Copy::Link>.

=over

=item C<< linked($link) >>

Returns the filename linked to by C<$link>: by C<readlink>ing C<$link>,
and resolving that path relative to the directory of C<$link>. 

=item C<< resolve($link) >>

Returns the non-link ultimately linked to by C<$link>, by repeatedly
calling C<linked>.  Returns C<undef> if the link can not be resolved.

=item C<< chopfile($file) >>

Returns the directory of C<$file>, by splitting the path of C<$file>
and returning (the volumne and) directory parts.

=item C<< relative_to_file($path, $file) >>

Returns the path of C<$path> relative to the directory of file
C<$file>.  If C<$path> is absolute, just returns C<$path>.

=item C<< resolve_all($file) >>

Returns the filename of C<$file> with all links in the path resolved,
wihout using C<Cwd>.

=item C<< full_resolve($file) >>

Returns the filename of C<$file> with all links in the path resolved.

This sub tries to use C<Cwd::abs_path> via C<< ->resolve_path >>.

=item C<< resolve_path($file) >>

Returns the filename of C<$file> with all links in the path resolved.

This sub uses C<Cwd::abs_path> and is independent of the rest of
C<File::Spec::Link>. 

=back
 
=head2 Object methods 

=over 4

=item C<< new([$path]) >>

create new path object: stores path as a list

=item C<< path >>

returns path as a string, using catpath

=item C<< canonical >>

returns canonical path, using canonpath

=item C<< vol >>

returns volume element of path, see File::Spec->splitpath

=item C<< dir >>

returns directory element of path, as a string, see File::Spec->splitpath

=item C<< dirs >>

return list of directory components in path, see File::Spec->splitdir
	
=item C<< pop >>

remove last component of the path 

=item C<< push($file) >>

add a file component to the path, ignoring empty strings

=item C<< add($file) >>

add a component to the path:
treating C<updir> as C<pop>,
and ignoring C<curdir> and empty strings

=item C<< split($path) >>

populate a path object, using splitpath

=item C<< chop >>

remove and return a file component from path, 
an empty string returns means this was root dir.
    
=item C<< relative($path) >>

replace the path object with the supplied path,
where the new path is relative to the path object

=item C<< follow >>

follow the link, where the path object is a link 

=item C<< resolved >>

resolve the path object, by repeatedly following links
 
=item C<< resolvedir >>

resolve the links at all component levels  within the path object

=back

=head2 Other class methods

=over 4

=item C<< canonpath($path) >>

Wrapper round File::Spec::canonpath, fatal if empty input

=item C<< catdir(@dirs) >>

Wrapper round File::Spec::catdir, returns C<curdir> from empty list

=item C<< splitlast($path) >>

Get component from C<$path> (using C<chop>)
and returns remaining path and compenent, as strings.
[Not used]

=back

=head2 EXPORT

None - all subs are methods for C<File::Spec::Link>.

=head1 SEE ALSO

File::Spec(3) File::Copy::Link(3)

=head1 AUTHOR

Robin Barker, E<lt>Robin.Barker@npl.co.ukE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003, 2005, 2006, 2007 by Robin Barker

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut

$Id: Link.pm 221 2008-06-12 12:32:23Z rmb1 $