split m results from the CPAN

Getopt-Auto

view release on metacpan or search on metacpan

    }

    return;
}

sub _set_option {
    my ( $arg, $caller_local ) = @_;

    my ( $opt, $pkg );

    # This is sort of backwards.
    # If the arg is known to be a registered option,
    # then we don't need the caller.
    # Otherwise, $caller_local is used to determine options and package.

    if ( defined $caller_local ) {
        $opt = qq{$caller_local->[1]};
    }
    else {
        $opt = $options{$arg}{'options'};
    }
    # At this point $opt is the hash defined by "our %options" (or main::options)
    # in the _user's_ code. That's a different entity form %options in this code
    # which saves the registration info we collected by parsing the POD

    # This is true for our --help and --version
    if ( not defined $opt ) { return 0; }

    # Warning -- if opption_type is BARE, this should only be called if the
    # op -- arg is registered.
    _trace("Bumping $opt for $arg");
    no strict 'refs';    ## no critic (ProhibitNoStrict)
    # And here we bump the use count for the option
    ${$opt}{$arg}++;

    return 1;
}

sub _split_arg {
    my ( $arg, $args ) = @_;

    if ( defined $config{'nobundle'} ) {
        $args->{$arg} = 1;
        return $arg;
    }

    # This applies only to SHORT options
    if ( _option_type($arg) != $SHORT ) { return $arg; }
    if ( length $arg == 2 )             { return $arg; }

    # Builtin help/version meets this criteria
    if (    ( exists $options{$arg} )
        and ( exists $options{$arg}{'registered'} ) )
    {
        return $arg;
    }

    _trace("Splitting $arg into its components");

    my @args;
    foreach my $char ( split m{}smx, substr $arg, 1 ) {
        $char = "-$char";
        push @args, $char;
        $args->{$char}++;
        $args->{$arg}++;
    }
    return @args;
}

sub _is_registered {
    my $arg = shift;

    return ( ( exists $options{$arg} )
        and ( exists $options{$arg}{'registered'} ) );
}

sub _notreg {
    my $text = shift;
    if ( defined $config{'oknotreg'} ) { return; }
    _error(qq{$text is not a registered option});

    if ( defined $config{'nohelp'} ) { return; }
    
    # Make an attempt to add useful info
    # If user has not provided help, this will be the builtin version
    if ( exists $options{'--help'}{'code'} ) {
        _do_option_action('--help');
        return;
    }

    # If user has not provided help, this will be the builtin version
    if ( exists $options{'-h'}{'code'} ) {
        _do_option_action('-h');
        return;
    }

    # Well get here iff the user has provided non-fatal help
    # Or, 'test' is configured
    return;
}

sub _do_option_action {
    my ( $arg, $arg_eq ) = @_;

    if ( defined $options{$arg} ) {

        # Registered option
        # Check for sub to execute
        if ( exists $options{$arg}{'code'} ) {
            _trace("Running code $options{$arg}{'code'}");
            no strict 'refs';    ## no critic (ProhibitNoStrict)
            $options{$arg}{'code'}->();
            return 1;
        }

        # No sub, registered option, so assign %options
        # unless it's an assignment-type option, which must have a sub
        if ( defined $arg_eq ) { return 0; }

        _set_option($arg);
        return 1;

lib/Getopt/Auto.pm view on Meta::CPAN


my @not_option;

sub _not_option {
    my ( $arg, $eq ) = @_;

    # The param $eq indicates that we're undoing an arg of the
    # form -foo=22. The 22 is in @ARGV, but there was no sub
    # to consume it, so we move it off.
    if ( defined $eq ) { $arg .= qq{=$eq}; shift @ARGV; }
    push @not_option, $arg;
    return;
}

sub _parse_args {    ## no critic (ProhibitExcessComplexity)
    @not_option = ();

    _trace_argv();

    # Check that builtin help is defined according to the option type
    _check_help();

    # Check each script/module for an init sub to execute
    # If the user has defined one, its in the @callers array at [2].
    foreach my $caller_local (@callers) {
        my $init_sub = $caller_local->[2]{'init'};
        if ( defined $init_sub ) {
            _trace("Executing code for init_sub");
            no strict 'refs';    ## no critic (ProhibitNoStrict)
            $init_sub->();
        }
    }

    while ( my $argv = shift @ARGV ) {

        my $op_type = _option_type($argv);

        _trace("Considering $argv, option type is $TYPES[$op_type]");
        _trace_argv();

        # Check cease and desist
        if ( $argv =~ m{\A-{1,2}\z}smx ) {
            _trace("Option end $argv, scanning ends");

            # Marker is not replaced
            last;
        }

        # Check restricted option
        if ( _is_restricted($argv) ) {
            _trace("Option $argv is restricted, skipping");
            _not_option($argv);
            next;
        }

        # Check --foo=bar syntax use
        my $arg_eq;
        if ( $argv =~ m{=}smx ) {

            # Assign-type option: --foo=bar
            ( $argv, $arg_eq ) = split m{=}smx, $argv;
            unshift @ARGV, $arg_eq;
            _trace("Option $argv has assignment");
            _trace_argv();
        }

        # Process $argv as directed by %options, or push it back onto @ARGV

        if ( _is_registered($argv) ) {

            # Registered option, the simple case
            if ( _do_option_action( $argv, $arg_eq ) ) { next; }

            # _do_option_action returns 0 iff $arg_eq and no sub
            _error(qq{To use $argv with "=", a subroutine must be provided});
            _not_option( $argv, $arg_eq );
            next;
        }

        _trace("$argv is not registered");

        # Well, what we have in $argv is not registered

        if ( defined $config{'findsub'} ) {
            my $sub = _check_all_sub($argv);
            if ( defined $sub ) {
                _trace("Running code $sub");
                no strict 'refs';    ## no critic (ProhibitNoStrict)
                $sub->();
                next;
            }
            if ( _do_option_action( $argv, $arg_eq ) ) { next; }
        }

        # $argv is not registered.
        # Perhaps its a concatiation of single-letter SHORTs?
        if ( ( $op_type == $SHORT ) && ( length $argv > 2 ) ) {
            my %args;
            my @args = _split_arg( $argv, \%args );

            foreach my $arg (@args) {
                if ( _is_registered($arg) ) {
                    _do_option_action($arg);
                    $args{$arg}--;
                    $args{$argv}--;
                }
                else {
                    _trace("$arg is not registered");
                }
            }

        # Generate error messages for unregistered arg(s)
        # $argv is not registered iff _none_ of its components are registered
        # We know this because none of the components caused a decrement above
            if ( $args{$argv} == @args ) {
                _notreg($argv);
                _trace("$argv is not an option");
                _not_option( $argv, $arg_eq );
                next;
            }

lib/Getopt/Auto.pm view on Meta::CPAN

        if ($and_there_s_more) {
            print STDERR <<"EOF";

More help is available on the topics marked with [*]
Try $callers[0][0][1] $PREFIXES[$help_p]help $PREFIXES[$help_p]foo
EOF
        }
    }
    print STDERR qq{This is the built-in help, exiting\n};
    if ( not defined $config{'test'} ) { exit 0; }
    return;
}

1;

# This package exists to provide replacement for the default subs (of the same name)
# provided by Pod::Parser
# The way it works is that they are called at appropriate times to extract the
# information we need to support the options.
# The sub names are determined by Pod::Parser, so don't meddle.

## no critic (ProhibitMultiplePackages)
package Getopt::Auto::PodExtract;
use base 'Pod::Parser';

## no critic (ProtectPrivateSubs)

# Called when Pod::Parser finds '^=...'
sub command {
    my ( $self, $command, $text, $line_num ) = @_;

    # Cancel text grabs; whatever we've got, we've got.
    $self->{'copying'} = 0;

    # Process only "=item" and "=head2, =head3 and =head4"
    if ( $command eq 'item' || $command =~ m{^head(?:2|3|4)}smx ) {

        # Sometimes more han one newline, which I don't understand
        while ( chomp $text ) { }

        Getopt::Auto::_trace("Parsing =$command $text");

        my $shorthelp;
        $text =~ s{\s+-+\s+(.*)}{}smx;
        if ( defined $1 ) {
            $shorthelp = $1;
        }

        # No qualifying dash, or no space after dash
        # The RE fails, leaving $t unchanged
        if ( not defined $shorthelp ) {
            Getopt::Auto::_trace('No shorthelp, not an option');
            return;
        }

        Getopt::Auto::_trace("Shorthelp is: $shorthelp");

        # This suports options of the form "-f, --foo"
        my $sub;
        my @nosub;
        my @opts = split m{,\s*}smx, $text;
        foreach my $name (@opts) {
            $name =~ s{\A(\w<)?([\w_-]+)>?}{$2}smx;
            if ( $name =~ m{\s}smx ) {
                Getopt::Auto::_trace("$name dropped, has spaces");
                next;
            }

            Getopt::Auto::_trace("Option is $name");
            $self->{'funcs'}{$name} = { 'shorthelp' => $shorthelp, };
            $self->{'copying'}      = 1;
            $self->{'latest'}       = $name;
            my $sub_found = Getopt::Auto::_check_func($name);
            if ( defined $sub_found ) {
                $self->{'funcs'}{$name}{'code'} = $sub_found;
                $sub = $sub_found;
            }
            else {
                push @nosub, $name;
            }
        }

        # Options that had no defined sub get the last-defined sub
        foreach my $name (@nosub) {
            $self->{'funcs'}{$name}{'code'} = $sub;
        }
    }
    return;
}

# Called when text that begins with spaces (or tabs) is discovered inside POD text.
# As implied by the name, verbatum text is taken 'as is'.
# We save it only if we're inside of =item or =head ($self->{copying})

sub verbatim {
    my ( $self, $paragraph, $line_num ) = @_;
    if ( $self->{'copying'} ) {
        $self->{'funcs'}{ $self->{'latest'} }{'longhelp'} .= $paragraph;
        Getopt::Auto::_trace("verbatim - longhelp is: $paragraph");
    }
    return;
}

# Called when text that does not begin with spaces (or tabs) is discovered inside POD text.
# The semantics of text blocks require that 'interior sequences' (e.g.: B<foo>) be expanded.
# That's what the Pod::Parser sub interpolate() does.
# We save it only if we're inside of =item or =head ($self->{copying})

sub textblock {
    my ( $self, $paragraph, $line_num ) = @_;
    if ( $self->{'copying'} ) {
        $self->{'funcs'}{ $self->{'latest'} }{'longhelp'}
            .= $self->interpolate( $paragraph, $line_num );
        Getopt::Auto::_trace("textblock - longhelp is: $paragraph");
    }
    return;
}

sub preprocess_line {
    my ( $self, $text, $line_num ) = @_;

( run in 0.977 second using v1.01-cache-2.11-cpan-71847e10f99 )