File Coverage

blib/lib/File/PerlMove.pm

Criterion	Covered	Total	%
statement	53	60	88.3
branch	23	34	67.6
condition	9	17	52.9
subroutine	7	7	100.0
pod	0	2	0.0
total	92	120	76.6

#!/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: Mon Apr 24 10:04:57 2017
# Update Count    : 177
# Status          : Unknown, Use with caution!

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

our $VERSION = "1.01";

use strict;
use warnings;
use Carp;
use File::Basename;
use File::Path;

sub move {
    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)
      unless ref($transform) eq 'CODE';

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

	# 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 = shift;
    # Special treatment for some.
    if ( $cmd =~ /^(uc|lc|ucfirst)$/ ) {
	$cmd = '$_ = ' . $cmd;
    }
    elsif ( $cmd =~ /^:(.+):(.+):$/ ) {
	require Encode;
	$cmd = 'Encode::from_to($_,"'.$1.'","'.$2.'")';
    }

    # Build subroutine.
    my $op = eval "sub { $cmd }";
    if ( $@ ) {
	$@ =~ s/ at \(eval.*/./;
	croak($@);
    }

    return $op;
}

1;

__END__