File Coverage

blib/lib/File/PerlMove.pm

Criterion	Covered	Total	%
statement	70	91	76.9
branch	32	58	55.1
condition	9	19	47.3
subroutine	10	12	83.3
pod	0	3	0.0
total	121	183	66.1

#!/usr/bin/perl -w

package File::PerlMove;

# Author          : Johan Vromans
# Created On      : Tue Sep 15 15:59:04 1992
# Last Modified By: Johan Vromans
# Last Modified On: Tue Dec 15 14:59:21 2020
# Update Count    : 223
# Status          : Unknown, Use with caution!

################ Common stuff ################

our $VERSION = "2.01";

use strict;
use warnings;
use Carp;
use File::Basename;
use File::Path;
use parent qw(Exporter);

our @EXPORT = qw( pmv );

sub move {
    my $transform = shift;
    my $filelist  = shift;
    my $options   = shift || {};
    pmv( $transform, $filelist, { %$options, legacy => 1 } );
}

sub pmv {
    my $transform = shift;
    my $filelist  = shift;
    my $options   = shift || {};
    my $result    = 0;

    croak("Usage: ", __PACKAGE__, "::move(" .
	  "operation, [ file names ], { options })")
      unless defined $transform && defined $filelist;

    # For those who misunderstood the docs.
    $options->{showonly}   ||= delete $options->{'dry-run'};
    $options->{createdirs} ||= delete $options->{'create-dirs'};

    # Create transformer.
    $transform = build_sub( $transform, $options )
      unless ref($transform) eq 'CODE';

    # Process arguments.
    @$filelist = reverse(@$filelist) if $options->{reverse};
    foreach ( @$filelist ) {
	# Save the name.
	my $old = $_;

	# Perform the transformation.
	my $new;
	if ( $options->{legacy}) {
	    # Legacy operates on $_.
	    $transform->();
	    $new = $_;
	}
	else {
	    $new = $transform->($_);
	}

	# Anything changed?
	unless ( $old eq $new ) {

	    # Create directories.
	    if ( $options->{createdirs} ) {
		my $dir = dirname($new);
		unless ( -d $dir ) {
		    if ( $options->{showonly} ) {
			warn("[Would create: $dir]\n");
		    }
		    else {
			mkpath($dir, $options->{verbose}, 0777);
		    }
		}
	    }

	    # Dry run.
	    if ( $options->{verbose} || $options->{showonly} ) {
		warn("$old => $new\n");
		next if $options->{showonly};
	    }

	    # Check for overwriting target.
	    if ( ! $options->{overwrite} && -e $new ) {
		warn("$new: exists\n");
		next;
	    }

	    # Perform.
	    my $res = -1;
	    if ( $options->{symlink} ) {
		$res = symlink($old, $new);
	    }
	    elsif ( $options->{link} ) {
		$res = link($old, $new);
	    }
	    else {
		$res = rename($old, $new);
	    }
	    if ( $res == 1 ) {
		$result++;
	    }
	    else {
		# Force error numbers (for locale independency).
		warn($options->{errno}
		     ? "$old: ".(0+$!)."\n"
		     : "$old: $!\n");
	    }
	}
    }

    $result;
}

sub build_sub {
    my ( $cmd, $options ) = @_;

    # If it is a verb, try extensions and builtins.
    # foo           File::PerlMove::foo => &File::PerlMove::foo::foo
    # foo=bar       File::PerlMove::foo => &File::PerlMove::foo::bar
    # xx::foo       xx::foo => &xx::foo::foo
    # xx::foo=bar   xx::foo => &xx::foo::bar
    if ( $cmd =~ /^((?:\w|::)+)(?:=(\w+))?$/ ) {
	my $pkg = $1;
	my $sub = $2;
	if ( !defined($sub) ) {
	    if ( $pkg =~ /^(.*)::(\w+)$/ ) {
		$sub = $2;
	    }
	    else {
		$sub = $pkg;
	    }
	}
	$pkg = __PACKAGE__."::".$pkg unless $pkg =~ /::/;
	warn("OP: $pkg => $sub\n") if $options->{trace};

	# Extensions.
	if ( eval "require $pkg" ) {
	    if ( my $op = $pkg->can($sub) ) {
		return "$pkg => $sub" if $options->{testing};
		return $op;
	    }
	    else {
		croak("$pkg does not provide a subroutine $sub");
	    }
	}
	# Builtins.
	elsif ( my $op = (__PACKAGE__."::BuiltIn")->can($cmd) ) {
	    return __PACKAGE__."::BuiltIn => $cmd" if $options->{testing};
	    return $op;
	}
	croak("No such operation: $cmd");
    }

    # Recode.
    if ( $cmd =~ /^:(.+):(.+):$/ ) {
	return 'Encode::from_to($_,"'.$1.'","'.$2.'")' if $options->{testing};
	require Encode;
	$cmd = 'Encode::from_to($_,"'.$1.'","'.$2.'")';
    }

    # Hopefully a regex. Build subroutine.
    return "sub { \$_ = \$_[0]; $cmd; \$_ }" if $options->{testing};
    my $op = eval "sub { \$_ = \$_[0]; $cmd; \$_ }";
    if ( $@ ) {
	$@ =~ s/ at \(eval.*/./;
	croak($@);
    }

    return $op;
}

package File::PerlMove::BuiltIn;

sub lc { CORE::lc($_[0]) }
sub uc { CORE::uc($_[0]) }
sub ucfirst { CORE::ucfirst($_[0]) }

1;

__END__