File Coverage

blib/lib/File/Rename/Options.pm

Criterion	Covered	Total	%
statement	33	37	89.1
branch	10	16	62.5
condition	3	6	50.0
subroutine	8	8	100.0
pod	2	2	100.0
total	56	69	81.1

package File::Rename::Options;
use strict;
use warnings;

use Getopt::Long 2.24 ();

our $VERSION = 2.00;
our $IMPORTED;

sub import {
    my $pack = shift;
    if( $IMPORTED++ ) {
        require Carp;
        Carp::cluck("$pack->import() called twice");
    }
    my @config = qw(
      posix_default
      no_ignore_case
    );
    push @config, @_;
    Getopt::Long::Configure(@config);
}

sub GetOptions {
    my ($no_code) = @_;
    my @expression;
    my $fullpath = 1;
    Getopt::Long::GetOptions(
        '-v|verbose'    => \my $verbose,
        '-0|null'       => \my $null,
        '-n|nono'       => \my $nono,
        '-f|force'      => \my $force,
        '-h|?|help'     => \my $help,
        '-m|man'        => \my $man,
        '-V|version'    => \my $version,
        '-d|filename'   => sub { undef $fullpath },
        '-path|fullpath!' => \$fullpath,
        '-e=s'          => \@expression,
        '-E=s' =>
            sub {
                my(undef, $e) = @_;
                $e .= ';';
                push @expression, $e;
            },
        '-u|unicode:s'  => \my $unicode,
      ) or return;

    my $options = {
        verbose         => $verbose,
        input_null      => $null,
        no_action       => $nono,
        over_write      => $force,
        filename_only   => !$fullpath,
        show_help       => $help,
        show_manual     => $man,
        show_version    => $version,
        unicode_strings => defined $unicode,
        encoding        => $unicode,
    };
    return $options if $no_code;
    return $options if $help or $man or $version;

    if( @expression ) {
        $options->{_code} = join "\n", @expression;
    }
    else {
        return unless @ARGV;
        $options->{_code} = shift @ARGV;
    }
    return $options;
}

sub bad_encoding {
    my $options = shift;
    my $encoding = $options->{encoding};
    return unless $encoding;
    return unless $encoding =~ /[^\s\w.-]/;
    return 1
}

1;
__END__