#!/usr/bin/perl -w

package File::PerlMove;

my $RCS_Id = '$Id: PerlMove.pm,v 1.6 2007/08/15 12:00:26 jv Exp $ ';

# Author          : Johan Vromans
# Created On      : Tue Sep 15 15:59:04 1992
# Last Modified By: Johan Vromans
# Last Modified On: Thu Mar 13 20:23:51 2008
# Update Count    : 155
# Status          : Unknown, Use with caution!

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

our $VERSION = "0.05";

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: 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;
    }

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

    return $op;
}

1;

__END__

=head1 NAME

File::PerlMove - Rename files using Perl expressions

=head1 SYNOPSIS

  use File::PerlMove;
  move(sub { $_ = lc }, \@filelist, { verbose => 1 });

=head1 DESCRIPTION

File::PerlMove provides a single subroutine: B<File::PerlMove::move>.

B<move> takes three arguments: transform, filelist, and options.

I<transform> must be a string or a code reference. If it is not a
string, it is assumed to be a valid Perl expression that will be
turned into a anonymous subroutine that evals the expression. If the
expression is any of C<uc>, C<lc>, of C<ucfirst>, the resultant code
will behave as if these operations would modify C<$_> in-place.
Note, however, that using any of these operations is useless on file
systems that are case insensitive, like MS Windows and Mac.

When I<transform> is invoked it should transform a file name in C<$_>
into a new file name.

I<filelist> must be an array reference containing the list of file
names to be processed.

I<options> is a hash reference containing options to the operation.

Options are enabled when set to a non-zero (or otherwise 'true')
value. Possible options are:

=over 8

=item B<showonly>

Show the changes, but do not rename the files.

=item B<link>

Link instead of rename.

=item B<symlink>

Symlink instead of rename. Note that not all platforms support symlinking,

=item B<reverse>

Process the files in reversed order.

=item B<overwrite>

Overwrite existing files.

=item B<createdirs>

Create target directories if necessary.

=item B<verbose>

More verbose information.

=back

=head1 EXAMPLES

See B<pmv> for examples.

=head1 AUTHOR

Johan Vromans <jvromans@squirrel.nl>

=head1 COPYRIGHT

This programs is Copyright 2004,2007 Squirrel Consultancy.

This program is free software; you can redistribute it and/or modify
it under the terms of the Perl Artistic License or the GNU General
Public License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.

=cut