File Coverage

blib/lib/File/Rename.pm

Criterion	Covered	Total	%
statement	70	81	86.4
branch	32	38	84.2
condition	5	9	55.5
subroutine	8	8	100.0
pod	3	3	100.0
total	118	139	84.8

package File::Rename;

use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( rename );

our $VERSION = '2.00_4';

sub import {
    my $pack = shift;
    my($args, $config) = &_config;  # sees @_
    $pack->export_to_level(1, $pack, @$args);
    require File::Rename::Options;
    File::Rename::Options->import(@$config);
}

sub rename_files {
    my $code = shift;
    my $options = shift;
    _default(\$options);

    my $sub = $code;
    if ( $options->{unicode_strings} ) {
        require File::Rename::Unicode;
        $sub = File::Rename::Unicode::code($code,
                            $options->{encoding});
    }
    my $errors;
    for (@_) {
        my $was = $_;
        if ( $options->{filename_only} ) {
            require File::Spec;
            my($vol, $dir, $file) = File::Spec->splitpath($_);
            $sub->() for ($file);
            $_ = File::Spec->catpath($vol, $dir, $file);
        }
        else {
            $sub->();
        }

        if( $was eq $_ ){ }     # ignore quietly
        elsif( -e $_ and not $options->{over_write} ) {
            if (/\s/ or $was =~ /\s/ ) {
                warn  "'$was' not renamed: '$_' already exists\n";
            }
            else {
                warn  "$was not renamed: $_ already exists\n";
            }
            $errors ++;
        }
        elsif( $options->{no_action} ) {
            print "rename($was, $_)\n";
        }
        elsif( CORE::rename($was,$_)) {
            print "$was renamed as $_\n" if $options->{verbose};
        }
        else {  warn  "Can't rename $was $_: $!\n"; $errors ++; }
    }
    return !$errors;
}

sub rename_list {
    my($code, $options, $fh, $file) = @_;
    _default(\$options);
    print "Reading filenames from ",
      ( defined $file ?                 $file
        : defined *{$fh}{SCALAR} and
          defined ${*{$fh}{SCALAR}} ?   ${*{$fh}{SCALAR}}
        :                               "file handle ($fh)"
      ),
      "\n" if $options->{verbose};
    my @file;
    {
        local $/ = "\0" if $options->{input_null};
        chop(@file = <$fh>);
    }
    rename_files $code, $options,  @file;
}

sub rename {
    my($argv, $code, $verbose) = @_;
    if( ref $code ) {
        if( 'HASH' eq ref $code ) {
            if(defined $verbose ) {
                require Carp;
                Carp::carp(<
File::Rename::rename: third argument ($verbose) ignored
CARP
            }
            $verbose = $code;
            $code = delete $verbose->{_code};
            unless ( $code ) {
                require Carp;
                Carp::carp(<
File::Rename::rename: no _code in $verbose
CARP
            }

        }
    }
    unless( ref $code ) {
        if( my $eval = eval <
sub {
$code
}
CODE
        {
            $code = $eval;
        }
        else {
            my $error = $@;
            $error =~ s/\b(at\s+)\(eval\s+\d+\)\s/$1/g;
            $error =~ s/(\s+line\s+)(\d+)\b/$1 . ($2-1)/eg;
            $error =~ s/\.?\s*\z/, in:\n$code\n/;
            die $error;
        }
    }
    if( @$argv ) { rename_files $code, $verbose, @$argv }
    else { rename_list $code, $verbose, \*STDIN, 'STDIN' }
}

sub _default {
    my $ref = shift;
    return if ref $$ref;
    my $verbose = $$ref;
    $$ref = { verbose => $verbose }
}

sub _config {
    # copied from GetOpt::Long::import
    my @syms = ();              # symbols to import
    my @config = ();            # configuration
    my $dest = \@syms;          # symbols first
    for ( @_ ) {
        if ( $_ eq ':config' ) {
            $dest = \@config;   # config next
            next;
        }
        push(@$dest, $_);       # push
    }
    return (\@syms, \@config);
}

1;

__END__