view release on metacpan or  search on metacpan

lib/IO/Prompter.pm  view on Meta::CPAN

                             . ($opt_ref->{-timeout} == 1 ? q{} : q{s});
                    },
                 };
}


# Simulate a command line expansion for the -argv option...
sub _shell_expand {
    my ($text) = @_;

    # Single-quoted text is literal...
    if ($text =~ m{\A ' (.*) ' \z}xms) {
        return $1;
    }

    # Everything else has shell variables expanded...
    my $ENV_PAT = join '|', reverse sort keys %ENV;
    $text =~ s{\$ ($ENV_PAT)}{$ENV{$1}}gxms;

    # Double-quoted text isn't globbed...
    if ($text =~ m{\A " (.*) " \z}xms) {
        return $1;
    }

    # Everything else is...
    return glob($text);
}

# No completion is the default...
my $DEFAULT_COMPLETER = sub { q{} };

# Translate std constraints...
my %STD_CONSTRAINT = (
    positive  => sub { $_ > 0      },
    negative  => sub { $_ < 0      },
    zero      => sub { $_ == 0     },
    even      => sub { $_ % 2 == 0 },
    odd       => sub { $_ % 2 != 0 },
);

# Create abbreviations...
$STD_CONSTRAINT{pos} = $STD_CONSTRAINT{positive};
$STD_CONSTRAINT{neg} = $STD_CONSTRAINT{negative};

# Create antitheses...
for my $constraint (keys %STD_CONSTRAINT) {
    my $implementation = $STD_CONSTRAINT{$constraint};
    $STD_CONSTRAINT{"non$constraint"}
        = sub { ! $implementation->(@_) };
}

# Special style specifications require decoding...

sub _decode_echo {
    my $style = shift;

    # Not a special style...
    return $style if ref $style || $style !~ m{/};

    # A slash means yes/no echoes...
    my ($yes, $no) = split m{/}, $style;
    return sub{ /y/i ? $yes : $no };
}

sub _decode_echostyle {
    my $style = shift;

    # Not a special style...
    return $style if ref $style || $style !~ m{/};

    # A slash means yes/no styles...
    my ($yes, $no) = split m{/}, $style;
    return sub{ /y/i ? $yes : $no };
}

sub _decode_style {
    # No special prompt styles (yet)...
    return shift;
}

# Generate safe closure around active sub...
sub _gen_wrapper_for {
    my ($arg) = @_;
    return ref $arg ne 'CODE'
           ? sub { $arg }
           : sub { eval { for (shift) { no warnings; return $arg->($_) // $_ } } };
}

# Create recognizer...
my $STD_CONSTRAINT
    = '^(?:' . join('|', reverse sort keys %STD_CONSTRAINT) . ')';

# Translate name constraints to implementations...
sub _standardize_constraint {
    my ($option_type, $constraint_spec) = @_;

    return ("be an acceptable $option_type", $constraint_spec)
        if ref $constraint_spec;

    my @constraint_names = split /\s+/, $constraint_spec;
    my @constraints =
        map { $STD_CONSTRAINT{$_}
              // _opt_err('invalid',-$option_type,'"pos", "neg", "even", etc.', qq{"$_"})
            } @constraint_names;

    return (
        'be ' . join(' and ', @constraint_names),
        sub {
            my ($compare_val) = @_;
            for my $constraint (@constraints) {
                return 0 if !$constraint->($compare_val);
            }
            return 1;
        }
    );
}


# Convert args to prompt + options hash...
sub _decode_args {
    my %option = (
        -prompt    => undef,
        -complete  => $DEFAULT_COMPLETER,
        -must      => {},
        -history   => 'DEFAULT',
        -style     => sub{ q{} },
        -nostyle   => sub{ q{} },
        -echostyle => sub{ q{} },
        -echo      => sub { my $char = shift; $char eq "\t" ? q{ } : $char },
        -return    => sub { "\n" },
        -indent    => q{},
    );