File Coverage

blib/lib/Getopt/Euclid.pm

Criterion	Covered	Total	%
statement	614	652	94.1
branch	231	274	84.3
condition	61	80	76.2
subroutine	59	61	96.7
pod	7	7	100.0
total	972	1074	90.5

package Getopt::Euclid;

use version; our $VERSION = version->declare('0.4.5');

use warnings;
use strict;
use 5.005000; # perl 5.5.0
use Carp;
use Symbol ();
use re 'eval'; # for matcher regex
use Pod::Select;
use Pod::PlainText;
use File::Basename;
use File::Spec::Functions qw(splitpath catpath catfile);
use List::Util qw( first );
use Text::Balanced qw(extract_multiple extract_bracketed extract_variable extract_delimited);


# Set some module variables
my $skip_keyword = 'Getopt::Euclid'; # Ignore files with a first line containing this keyword.
my $pod_file_msg = "# This file was generated dynamically by $skip_keyword. Do not edit it.";

my $has_run = 0;
my $has_processed_pod = 0;
my $export_lvl = 1;
my @pod_names;
my $minimal_keys;
my $vars_prefix;
my $defer = 0;
my $matcher;
my %requireds;
my %options;
my %longnames;
our $man;    # --man     message
my $help;    # --help    message
my $usage;   # --usage   message
my $version; # --version message

my $optional_re;
$optional_re = qr{ \[ [^[]* (?: (??{$optional_re}) [^[]* )* \] }xms;


# Global variables
our $SCRIPT_NAME;
our $SCRIPT_VERSION; # for ticket # 55259


# Convert arg specification syntax to Perl regex syntax

my %std_matcher_for = (
    integer => '[+-]?\\d+(?:[eE][+]?\d+)?',
    number  => '[+-]?(?:\\d+\\.?\\d*|\\.\\d+)(?:[eE][+-]?\d+)?',
    input   => '\S+',
    output  => '\S+',
    string  => '\S+',
    q{}     => '\S+',
);

_make_equivalent(
    \%std_matcher_for,
    integer => [qw( int i +int +i 0+int 0+i +integer 0+integer )],
    number  => [qw( num n +num +n 0+num 0+n +number 0+number   )],
    input   => [qw( readable in )],
    output  => [qw( writable writeable out )],
    string  => [qw( str s )],
);

my %std_constraint_for = (
    'string'    => sub { 1 },            # Always okay (matcher ensures this)
    'integer'   => sub { 1 },            # Always okay (matcher ensures this)
    '+integer'  => sub { $_[0] > 0 },
    '0+integer' => sub { $_[0] >= 0 },
    'number'    => sub { 1 },            # Always okay (matcher ensures this)
    '+number'   => sub { $_[0] > 0 },
    '0+number'  => sub { $_[0] >= 0 },
    'input'     => sub { $_[0] eq '-' || -r $_[0] },
    'output'    => sub {
        my ( $vol, $dir ) = splitpath( $_[0] );
        $dir = ($vol && $dir) ? catpath($vol, $dir) : '.';
        $_[0] eq '-' ? 1 : -e $_[0] ? -w $_[0] : -w $dir;
    },
);

_make_equivalent(
    \%std_constraint_for,
    'integer'   => [qw(   int   i )],
    '+integer'  => [qw(  +int  +i )],
    '0+integer' => [qw( 0+int 0+i )],
    'number'    => [qw(   num   n )],
    '+number'   => [qw(  +num  +n )],
    '0+number'  => [qw( 0+num 0+n )],
    'string'    => [qw( str s )],
    'input'     => [qw( in readable )],
    'output'    => [qw( out writable writeable )],
);


sub Getopt::Euclid::Importer::DESTROY {
    return if $has_run || $^C;    # No errors when only compiling
    croak '.pm file cannot define an explicit import() when using Getopt::Euclid';
}


sub import {
    shift @_;
    @_ = grep { !( /:minimal_keys/     and $minimal_keys = 1             ) } @_;
    @_ = grep { !( /:vars(?:<(\w+)>)?/ and $vars_prefix  = $1 || 'ARGV_' ) } @_;
    @_ = grep { !( /:defer/            and $defer        = 1             ) } @_;
    croak "Unknown mode ('$_')" for @_;
    $export_lvl++ if not $defer;

    # No POD parsing and argument processing in Perl compile mode (ticket 34195)
    return if $^C;

    # Get name of caller program and its modules in @pod_names
    return unless _get_pod_names();

    # Extract POD of given files
    __PACKAGE__->process_pods( [reverse @pod_names] );
    undef @pod_names;
    $has_run = 1;

    # Parse POD + parse and export arguments

    ######
    #use Data::Dumper; print "ARGV: ".Dumper(\@ARGV);
    ######

    __PACKAGE__->process_args( \@ARGV ) unless $defer;

    return 1;
}


sub process_pods {
    # Extract POD content from list of Perl scripts (.pl) and modules (.pm) and
    # their corresponding .pod file if available. When given the argument
    # {-strict => 1}, do not look for .pod files.
    my ($self, $perl_files, $args) = @_;

    my $pod_string = '';
    open my $pod_fh, '>', \$pod_string
      or croak "Could not open filehandle to variable because $!";
    for my $perl_file (@$perl_files) {

        my $got_pod_file = 0;

        if ( not $args->{-strict} ) {

            # Find corresponding .pod file
            my ($name_re, $path, $suffix) = fileparse($perl_file, qr/\.[^.]*/);
            my $pod_file = catfile( $path, $name_re.'.pod' );

            # Get POD either from .pod file (preferably) or from Perl file
            if ( -e $pod_file ) {
                # Get .pod file content
                open my $in, '<', $pod_file
                  or croak "Could not open file $pod_file because $!";
                my $first_line = <$in>;
                chomp $first_line;
                if ( not ($first_line =~ m/$skip_keyword/) ) {
                    # Skip G::E auto-generated files since they lack important data
                    print $pod_fh "$first_line\n";
                    print $pod_fh $_ while <$in>;
                    $got_pod_file = 1;
                }
                close $in;
            }
        }

        if (not $got_pod_file) {
            # Parse POD content of Perl file
            podselect( {-output => $pod_fh}, $perl_file );
        }
        print $pod_fh "\n" if $pod_string;

    }
    close $pod_fh;
    $man = $pod_string;
    return 1;
}


sub process_args {
    # First, parse the POD specifications. Then, parse the given array of
    # arguments (\@ARGV or other) and populate %ARGV (or export specific
    # variable names).
    my ($self, $args, $options) = @_;

    # Parse POD
    if (not $has_processed_pod) {
        _parse_pod();
        $has_processed_pod = 1;
    }

    # Set options for argument parsing
    if (defined $options) {
       if (exists $options->{-minimal_keys}) {
          $minimal_keys = 1;
       }
       if (exists $options->{-vars}) {
          $vars_prefix = $options->{-vars};
       }
    }

    %ARGV = ();

    # Handle standard args...
    if ( first { $_ eq '--man' } @$args ) {
        _print_pod( __PACKAGE__->man(), 'paged' );
        exit;
    } elsif ( first { $_ eq '--usage' } @$args ) {
        print __PACKAGE__->usage();
        exit;
    } elsif ( first { $_ eq '--help' } @$args ) {
        _print_pod( __PACKAGE__->help(), 'paged' );
        exit;
    } elsif ( first { $_ eq '--version' } @$args ) {
        print __PACKAGE__->version();
        exit;
    } elsif ( first { $_ eq '--podfile' } @$args ) {
        # Option meant for authors
        my $podfile = podfile( );
        print "Wrote POD manual in file $podfile\n";
        exit;
    }

    # Subroutine to report problems during parsing...
    *_bad_arglist = sub {
        my (@msg) = @_;
        my $msg = join q{}, @msg;
        $msg = _rectify_arg($msg);
        $msg =~ s/\n?\z/\n/xms;
        warn "$msg\nTry this for usage help: $SCRIPT_NAME --help\n".
                   "Or this for full manual: $SCRIPT_NAME --man\n\n";
        exit 2;    # Traditional "bad arg list" value
    };

    # Run matcher...
    my $argv = join( q{ }, map { $_ = _escape_arg($_) } @$args );
    my $all_args_ref = { %options, %requireds };
    if ( my $error = _doesnt_match( $matcher, $argv, $all_args_ref ) ) {
        _bad_arglist($error);
    }

    # Check that all requireds have been found...
    my @missing;
    while ( my ($req) = each %requireds ) {
        push @missing, "\t$req\n" if !exists $ARGV{$req};
    }
    _bad_arglist(
        'Missing required argument',
        ( @missing == 1 ? q{} : q{s} ),
        ":\n", @missing
    ) if @missing;

    # Back-translate \0-quoted spaces and \1-quoted tabs...
    _rectify_all_args();

    # Check exclusive variables, variable constraints and fill in defaults...
    _verify_args($all_args_ref);

    # Clean up @$args since everything must have been parsed
    @$args = ();

    # Clean up %ARGV
    for my $arg_name ( keys %ARGV ) {

        # Flatten non-repeatables...
        my $vals = delete $ARGV{$arg_name};
        my $repeatable = $all_args_ref->{$arg_name}{is_repeatable};
        if ($repeatable) {
            pop @{$vals};
        }

        for my $val ( @{$vals} ) {
            my $var_count = keys %{$val};
            $val = $var_count == 0
              ? 1    # Boolean -> true
              : $var_count == 1
              ? ( values %{$val} )[0]    # Single var -> var's val
              : $val                     # Otherwise keep hash
              ;
            my $false_vals = $all_args_ref->{$arg_name}{false_vals};
            my %vars_opt_vals;

            for my $arg_flag ( _get_variants($arg_name) ) {
                my $variant_val = $val;
                if ( $false_vals && $arg_flag =~ m{\A $false_vals \z}xms ) {
                    $variant_val = $variant_val ? 0 : 1;
                }

                if ($repeatable) {
                    push @{ $ARGV{$arg_flag} }, $variant_val;
                } else {
                    $ARGV{$arg_flag} = $variant_val;
                }
                $vars_opt_vals{$arg_flag} = $ARGV{$arg_flag} if $vars_prefix;
            }

            if ($vars_prefix) {
                _minimize_entries_of( \%vars_opt_vals );
                my $maximal = _longestname( keys %vars_opt_vals );
                _export_var( $vars_prefix, $maximal, $vars_opt_vals{$maximal} );
                delete $longnames{$maximal};
            }
        }
    }

    if ($vars_prefix) {

        # Export any unspecified options to keep use strict happy
        while ( my ($opt_name, $arg_name) = each %longnames ) {
            my $arg_info = $all_args_ref->{$arg_name};
            my $val;
            if ( $arg_info->{is_repeatable} or $arg_name =~ />\.\.\./ ) {
               # Empty arrayref for repeatable options
               $val = [];
            } else {
               if (keys %{ $arg_info->{var} } > 1) {
                   # Empty hashref for non-repeatable options with multiple placeholders
                   $val = {};
               }
            }
            _export_var( $vars_prefix, $opt_name, $val );
        }
    }


    if ($minimal_keys) {
        _minimize_entries_of( \%ARGV );
    }

    return 1;
}


sub podfile {
    # Write the given POD doc into a .pod file, overwriting any existing .pod file
    return if not -e $0;
    my ($name_re, $path, $suffix) = fileparse($0, qr/\.[^.]*/);
    my $pod_file = catfile( $path, $name_re.'.pod' );
    open my $out_fh, '>', $pod_file or croak "Could not write file $pod_file because $!";
    print $out_fh $pod_file_msg."\n\n".__PACKAGE__->man();
    close $out_fh;
    return $pod_file;
}


sub man {
    return $man;
}


sub usage {
    return $usage;
}


sub help {
    return $help;
}


sub version {
    return $version;
}


# # # # # # # # Utility subs # # # # # # # #

# Recursively remove decorations on %ARGV keys

sub AUTOLOAD {
    our $AUTOLOAD;
    $AUTOLOAD =~ s{.*::}{main::}xms;
    no strict 'refs';
    goto &$AUTOLOAD;
}


sub _parse_pod {
    # Set up parsing rules...
    my $space_re      = qr{ [^\S\n]*               }xms;
    my $head_start_re = qr{ ^=head1                }xms;
    my $head_end_re   = qr{ (?= $head_start_re | \z)  }xms;
    my $pod_cmd_re    = qr{            = [^\W\d]\w+ [^\n]* (?= \n\n )}xms;
    my $pod_cut_re    = qr{ (?! \n\n ) = cut $space_re        (?= \n\n )}xms;

    my $name_re  = qr{ $space_re NAME    $space_re \n }xms;
    my $vers_re  = qr{ $space_re VERSION $space_re \n }xms;
    my $usage_re = qr{ $space_re USAGE   $space_re \n }xms;

    my $std_re = qr{ STANDARD | STD | PROGRAM | SCRIPT | CLI  | COMMAND(?:-|\s)?LINE }xms;
    my $arg_re = qr{ $space_re (?:PARAM(?:ETER)?|ARG(?:UMENT)?)S? }xms;

    my $options_re  = qr{ $space_re $std_re? $space_re OPTION(?:AL|S)?        $arg_re? $space_re \n }xms;
    my $required_re = qr{ $space_re $std_re? $space_re (?:REQUIRED|MANDATORY) $arg_re? $space_re \n }xms;

    my $euclid_arg = qr{ ^=item \s* ([^\n]*?) \s* \n\s*\n
                        (
                        .*?
                        (?:
                            ^=for \s* (?i: Euclid) .*? \n\s*\n
                            | (?= ^=[^\W\d]\w* | \z)
                        )
                        )
                    }xms;

    # Clean up line delimiters
    $man =~ s{ [\n\r] }{\n}gx;

    # Clean up significant entities...
    $man =~ s{ E }{<}gxms;
    $man =~ s{ E }{>}gxms;

    # Put program name in man
    $SCRIPT_NAME = (-e $0) ? (splitpath $0)[-1] : 'one-liner';
    $man =~ s{ ($head_start_re $name_re \s*) .*? (- .*)? $head_end_re }
              {$1.$SCRIPT_NAME.($2 ? " $2" : "\n\n")}xems;

    # Put version number in man
    ($SCRIPT_VERSION) =
        $man =~ m/$head_start_re $vers_re .*? (\d+(?:[._]\d+)+) .*? $head_end_re /xms;
    if ( !defined $SCRIPT_VERSION ) {
        $SCRIPT_VERSION = $main::VERSION;
    }
    if ( !defined $SCRIPT_VERSION ) {
        $SCRIPT_VERSION = (-e $0) ? localtime((stat $0)[9]) : 'one-liner';
    }
    $man =~ s{ ($head_start_re $vers_re    \s*) .*? (\s*) $head_end_re }
             {$1This document refers to $SCRIPT_NAME version $SCRIPT_VERSION $2}xms;

    # Extra info from PODs
    my ($options, $opt_name, $required, $req_name, $licence);
    while ($man =~ m/$head_start_re ($required_re) (.*?) $head_end_re /gxms) {
        # Required arguments
        my ( $more_req_name, $more_required ) = ($1, $2);
        $req_name = $more_req_name if not defined $req_name;
        $required = ( $more_required || q{} ) . ( $required || q{} );
    }
    while ($man =~ m/$head_start_re ($options_re)  (.*?) $head_end_re /gxms) {
        # Optional arguments
        my ( $more_opt_name, $more_options ) = ($1, $2);
        $opt_name = $more_opt_name if not defined $opt_name;
        $options = ( $more_options || q{} ) . ( $options || q{} );
    }
    while ($man =~ m/$head_start_re [^\n]+ (?i: licen[sc]e | copyright ) .*? \n \s* (.*?) \s* $head_end_re /gxms) {
        # License information
        my ($more_licence) = ($1, $2);
        $licence = ( $more_licence || q{} ) . ( $licence || q{} );
    }

    # Clean up interface titles...
    for my $name_re ( $opt_name, $req_name ) {
        next if !defined $name_re;
        $name_re =~ s{\A \s+ | \s+ \z}{}gxms;
    }

    # Extract the actual interface and store each arg entry into a hash of specifications...
    my $seq  = 0;
    my $seen = {};
    while ( ( $required || q{} ) =~ m{ $euclid_arg }gxms ) {
        $seen = _register_specs( $1, $2, $seq, \%requireds, \%longnames, $seen );
        $seq++;
    }
    while ( ( $options  || q{} ) =~ m{ $euclid_arg }gxms ) {
        $seen = _register_specs( $1, $2, $seq, \%options, \%longnames, $seen );
        $seq++;
    }
    undef $seen;
    _minimize_entries_of( \%longnames );

    # Extract Euclid information...
    my $all_specs = {%requireds, %options};
    _process_euclid_specs( $all_specs );

    # Insert default values (if any) in the program's documentation
    $required = _insert_default_values(\%requireds);
    $options  = _insert_default_values(\%options  );

    # One-line representation of interface...
    my $arg_summary = join ' ', (sort
       { $requireds{$a}{'seq'} <=> $requireds{$b}{'seq'} }
       (keys %requireds));

    1 while $arg_summary =~ s/\[ [^][]* \]//gxms;

    if ($opt_name) {
      $arg_summary .= ' ' if $arg_summary;
      $arg_summary .= lc "[$opt_name]";
    }
    $arg_summary =~ s/\s+/ /gxms;

    # Manual message
    $man =~ s{ ($head_start_re $usage_re    \s*) .*? (\s*) $head_end_re } {$1$SCRIPT_NAME $arg_summary$2}xms;
    $man =~ s{ ($head_start_re $required_re \s*) .*? (\s*) $head_end_re } {$1$required$2}xms;
    $man =~ s{ ($head_start_re $options_re  \s*) .*? (\s*) $head_end_re } {$1$options$2}xms;

    # Usage message
    $usage  = "       $SCRIPT_NAME $arg_summary\n";
    $usage .= "       $SCRIPT_NAME --help\n";
    $usage .= "       $SCRIPT_NAME --man\n";
    $usage .= "       $SCRIPT_NAME --usage\n";
    $usage .= "       $SCRIPT_NAME --version\n";

    # Help message
    $help  = "=head1 \L\uUsage:\E\n\n$usage\n";
    $help .= "=head1 \L\u$req_name:\E\n\n$required\n\n"
      if ( $req_name || q{} ) =~ /\S/;
    $help .= "=head1 \L\u$opt_name:\E\n\n$options\n\n"
      if ( $opt_name || q{} ) =~ /\S/;

    $usage  = "Usage:\n".$usage;

    # Version message
    $version  = "This is $SCRIPT_NAME version $SCRIPT_VERSION\n";
    $version .= "\n$licence\n" if $licence;

    # Convert arg specifications to regexes...
    _convert_to_regex( $all_specs );

    # Build matcher...
    my @arg_list = ( values(%requireds), values(%options) );
    $matcher = join '|', map { $_->{matcher} }
      sort( { $b->{name} cmp $a->{name} } grep { $_->{name} =~ /^[^<]/ } @arg_list ),
      sort( { $a->{seq}  <=> $b->{seq}  } grep { $_->{name} =~ /^[<]/  } @arg_list );
    $matcher .= '|(?> (.+)) (?{ push @errors, $^N }) (?!)';
    $matcher = '(?:' . $matcher . ')';

    return 1;
}


sub _register_specs {
    my ($name_re, $spec, $seq, $storage, $longnames, $seen) = @_;
    my @variants = _get_variants($name_re);
    $storage->{$name_re} = {
        seq      => $seq,
        src      => $spec,
        name     => $name_re,
        variants => \@variants,
    };
    if ($minimal_keys) {
        my $minimal = _minimize_name($name_re);
        croak "Internal error: minimalist mode caused arguments ".
           "'$name_re' and '".$seen->{$minimal}."' to clash"
           if $seen->{$minimal};
        $seen->{$minimal} = $name_re;
    }
    $longnames->{ _longestname(@variants) } = $name_re;
    return $seen;
}


sub _process_euclid_specs {
    my ($args) = @_;
    my %all_var_list;
    my %excluded_by_def;

  ARG:
    while ( (undef, my $arg) = each %$args ) {

        # Validate and record variable names seen here...
        my $var_list = _validate_name( $arg->{name} );
        while (my ($var_name, undef) = each %$var_list) {
            $all_var_list{$var_name} = undef;
        }

        # Process arguments with a Euclid specification further
        $arg->{src} =~ s{^ =for \s+ Euclid\b [^\n]* \s* (.*) \z}{}ixms
            or next ARG;
        my $info = $1;

        $arg->{is_repeatable} = $info =~ s{^ \s* repeatable \s*? $}{}xms;

        my @false_vals;
        while ( $info =~ s{^ \s* false \s*[:=] \s* ([^\n]*)}{}xms ) {
            my $regex = $1;
            1 while $regex =~ s/ \[ ([^]]*) \] /(?:$1)?/gxms;
            $regex =~ s/ (\s+) /$1.'[\\s\\0\\1]*'/egxms;
            push @false_vals, $regex;
        }
        if (@false_vals) {
            $arg->{false_vals} = '(?:' . join( '|', @false_vals ) . ')';
        }

        while (
            $info =~ m{\G \s* (([^.]+)\.([^:=\s]+) \s*[:=]\s* ([^\n]*)) }gcxms )
        {
            my ( $spec, $var, $field, $val ) = ( $1, $2, $3, $4 );

            # Check for misplaced fields...
            if ( $arg->{name} !~ m{\Q<$var>}xms ) {
                _fail( "Invalid constraint: $spec\n(No <$var> placeholder in ".
                    "argument: $arg->{name})" );
            }

            # Decode...
            if ( $field eq 'type.error' ) {
                $arg->{var}{$var}{type_error} = $val;
            } elsif ( $field eq 'type' ) {
                $val = _qualify_variables_fully( $val );
                my ( $matchtype, $comma, $constraint ) =
                  $val =~ m{(/(?:\.|.)+/ | [^,\s]+)\s*(?:(,))?\s*(.*)}xms;
                $arg->{var}{$var}{type} = $matchtype;
                if ( $comma && length $constraint ) {
                    ( $arg->{var}{$var}{constraint_desc} = $constraint ) =~
                      s/\s*\b\Q$var\E\b\s*//g;
                    $constraint =~ s/\b\Q$var\E\b/\$_[0]/g;
                    $arg->{var}{$var}{constraint} = eval "sub{ $constraint }"
                      or _fail("Invalid .type constraint: $spec\n($@)");
                } elsif ( length $constraint ) {
                    $arg->{var}{$var}{constraint_desc} = $constraint;
                    $arg->{var}{$var}{constraint} =
                      eval "sub{ \$_[0] $constraint }"
                      or _fail("Invalid .type constraint: $spec\n($@)");
                } else {
                    $arg->{var}{$var}{constraint_desc} = $matchtype;
                    $arg->{var}{$var}{constraint} =
                      $matchtype =~ m{\A\s*/.*/\s*\z}xms
                      ? sub { 1 }
                      : $std_constraint_for{$matchtype}
                      or _fail("Unknown .type constraint: $spec");
                }

            } elsif ( ($field eq 'default') || ($field eq 'opt_default') ) {
                $val = _qualify_variables_fully( $val );
                eval "\$val = $val; 1"
                  or _fail("Invalid .$field value: $spec\n($@)");
                $arg->{var}{$var}{$field} = $val;
                my $has_field = 'has_'.$field;
                $arg->{$has_field} = exists $arg->{$has_field} ?
                                      $arg->{$has_field}++ :
                                      1;

                if ($field eq 'opt_default') {
                    # Check that placeholders with optional defaults have a flagged argument
                    if ( $arg->{name} =~ m{^<}xms ) {
                       _fail( "Invalid .$field constraint: $spec\nParameter ".
                           "$arg->{name} must have a flag" );
                    }
                    # Check that placeholders with optional defaults is optional
                    if ( $arg->{name} !~ m{\Q[<$var>]}xms ) {
                       _fail( "Invalid .$field constraint: $spec\nPlaceholder".
                           " <$var> must be optional, i.e. [<$var>], to have ".
                           "an optional default in argument: $arg->{name}" );
                    }
                }

            } elsif ( $field eq 'excludes.error' ) {
                $arg->{var}{$var}{excludes_error} = $val;
            } elsif ( $field eq 'excludes' ) {
                $arg->{var}{$var}{excludes} = [ split '\s*,\s*', $val ];
                for my $excl_var (@{$arg->{var}{$var}{excludes}}) {
                    if ($var eq $excl_var) {
                        _fail( "Invalid .excludes value for variable <$var>: ".
                            "<$excl_var> cannot exclude itself." );
                    }
                }
            } else {
                _fail("Unknown specification: $spec");
            }
        }
        # Record variables excluded by another that has a default
        while (my ($var_name, $var_data) = each %{$arg->{var}}) {
            for my $excl_var (@{$arg->{var}{$var_name}{excludes}}) {
                $excluded_by_def{$excl_var}{default}{$var_name}     = 1 if $arg->{has_default};
                $excluded_by_def{$excl_var}{opt_default}{$var_name} = 1 if $arg->{has_opt_default};
            }
        }
        if ( $info =~ m{\G \s* ([^\s\0\1] [^\n]*) }gcxms ) {
            _fail("Unknown specification: $1");
        }
    }

    # Validate and complete .excludes specs

    while ( (undef, my $arg) = each %$args ) {
        while ( my ($var, $var_specs) = each %{$arg->{var}} ) {
            # Check for invalid placeholder name in .excludes specifications
            for my $excl_var (@{$var_specs->{excludes}}) {
                if (not exists $all_var_list{$excl_var}) {
                    _fail( "Invalid .excludes value for variable <$var>: ".
                        "<$excl_var> does not exist\n" );
                }
            }
            # Remove default for placeholders excluded by others that have a default
            for my $type ( 'default', 'opt_default' ) {
                if ( (exists $arg->{var}->{$var}->{$type}) && (exists $excluded_by_def{$var}{$type}) ) {
                    delete $arg->{var}->{$var}->{$type};
                    $arg->{"has_$type"}--;
                    if ($arg->{"has_$type"} == 0) {
                        delete $arg->{"has_$type"};
                    }
                }
            }
        }
    }

    return 1;
}


sub _qualify_variables_fully {
    # Restore fully-qualified name to variables:
    #    $x          becomes  $main::x
    #    $::x        becomes  $main::x
    #    $Package::x stays as $Package::x
    #    /^asdf$/    stays as /^asdf$/
    #    '$10'       stays as '$10'
    # Note: perlvar indicates that ' can also be used instead of ::
    my ($val) = @_;
    if ($val =~ m/[\$\@\%]/) { # Avoid expensive Text::Balanced operations when there are no variables
        my $new_val;
        for my $s (extract_multiple($val,[{Quoted=>sub{extract_delimited($_[0])}}],undef,0)) {
            if (not ref $s) {
                # A non-quoted section... may contain variables to fix
                for my $var_name ( @{_get_variable_names($s)} ) {
                    # Skip fully qualified names, such as '$Package::x'
                    next if $var_name =~ m/main(?:'|::)/;
                    # Remove sigils from beginning of variable name: $ @ % {
                    $var_name =~ s/^[\$\@\%\{]+//;
                    # Substitute non-fully qualified vars, e.g. '$x' or '$::x', by '$main::x'
                    my $new_name = Symbol::qualify($var_name, 'main');
                    next if $new_name eq $var_name;
                    $var_name = quotemeta( $var_name );
                    $s =~ s/$var_name/$new_name/;
                }
                $new_val .= $s;
            } else {
                # A quoted section, to keep as-is
                $new_val .= $$s;
            }
        }
        return $new_val;
    } else {
        return $val;
    }
}


sub _get_variable_names {
    # Get an arrayref of the variables names found in the provided string.
    # This function is a hack, needed only because of Text::Balanced ticket #78855:
    #    https://rt.cpan.org/Public/Bug/Display.html?id=78855
    my ($str) = @_;
    my $vars = [];
    for my $var (extract_multiple($str,[sub{extract_variable($_[0],'')}],undef,1)) {
        # Name must start with underscore or a letter, e.g. $t $$h{a} ${$h}{a} $h->{a} @_
        # Skip special or invalid names, e.g. $/ $1
        my $tmp = $var;
        $tmp =~ s/(?:{|})//g;
        next if not $tmp =~ m/^[\$\@\%]+[_a-z]/i;
        push @$vars, $var;
    }
    return $vars;
}


sub _minimize_name {
    my ($name_re) = @_;
    $name_re =~ s{[][]}{}gxms;                      # remove all square brackets
    $name_re =~ s{\A \W+ ([\w-]*) .* \z}{$1}gxms;
    $name_re =~ s{-}{_}gxms;
    return $name_re;
}


sub _minimize_entries_of {
    my ($arg_ref) = @_;
    return if ref $arg_ref ne 'HASH';

    for my $old_key (keys %$arg_ref) {
        my $new_key = _minimize_name($old_key);
        $arg_ref->{$new_key} = delete $arg_ref->{$old_key};
    }

    return 1;
}


# Do match, recursively trying to expand cuddles...
sub _doesnt_match {
    my ( $matcher, $argv, $arg_specs_ref ) = @_;

    our @errors; # 'our' instead of 'my' because it is needed for the re pragma
    local @errors = ();
    %ARGV = ();

    # Match arguments, populate %ARGV and @errors
    # Note that the matcher needs the pragma: use re 'eval';
    $argv =~ m{\A (?: \s* $matcher )* \s* \z}xms;

    # Report errors in passed arguments
    for my $error (@errors) {
        if ( $error =~ m/\A ((\W) (\w) (\w+))/xms ) {
            my ( $bundle, $marker, $firstchar, $chars ) = ( $1, $2, $3, $4 );
            $argv =~ s{\Q$bundle\E}{$marker$firstchar $marker$chars}xms;
            return if !_doesnt_match( $matcher, $argv, $arg_specs_ref );
        }
      ARG:
        for my $arg_spec_ref ( values %{$arg_specs_ref} ) {
            our $bad_type;
            local $bad_type;
            next ARG
              if $error !~ m/\A [\s\0\1]* ($arg_spec_ref->{generic_matcher})/xms
                  || !$bad_type;

            my $msg = _type_error( $bad_type->{arg}, $bad_type->{var},
                $bad_type->{val}, $bad_type->{type}, $bad_type->{type_error} );
            return $msg;
        }
        return "Unknown argument: $error";
    }

    return 0;    # No error
}


sub _escape_arg {
    my $arg = shift;
    my ($num_replaced) = ($arg =~ tr/ \t/\0\1/);
    return $arg;
}


sub _rectify_arg {
    my $arg = shift;
    my ($num_replaced) = ($arg =~ tr/\0\1/ \t/);
    return $arg;
}


sub _rectify_all_args {
    while ( my (undef, $arg_list) = each %ARGV ) {
        for my $arg ( @{$arg_list} ) {
            if ( ref $arg eq 'HASH' ) {
                for my $var ( values %{$arg} ) {
                    if ( ref $var eq 'ARRAY' ) {
                        $var = [ map { _rectify_arg($_) } @{$var} ];
                    } else {
                        $var = _rectify_arg($var);
                    }
                }
            } else {
                if ( ref $arg eq 'ARRAY' ) {
                    $arg = [ map { _rectify_arg($_) } @{$arg} ];
                } else {
                    $arg = _rectify_arg($arg);
                }
            }
        }
    }
    return 1;
}


sub _verify_args {
    my ($arg_specs_ref) = @_;
    # Check exclusive variables, variable constraints and fill in defaults...
    # Handle mutually exclusive arguments
    my %seen_vars;
    while ( my ($arg_name, $arg_elems) = each %ARGV ) {
        for my $elem (@{$arg_elems}) {
            while ( my ($var_name) = each (%{$elem}) ) {
                $seen_vars{$var_name} = $arg_name if $var_name;
            }
        }
    }

    while ( my ($arg_name, $arg) = each %{$arg_specs_ref} ) {
        while ( my ($var_name, $var) = each %{$arg->{var}} ) {
            # Enforce placeholders that cannot be specified with others
            for my $excluded_var ( @{$var->{excludes}} ) {
                if (exists $seen_vars{$var_name} &&
                    exists $seen_vars{$excluded_var}) {
                    my $excl_arg = $seen_vars{$excluded_var};
                    my $msg;
                    if (exists $var->{excludes_error}) {
                        $msg = $var->{excludes_error};
                    } else {
                        $msg =
                            qq{Invalid "$excl_arg" argument.\n<$excluded_var> }.
                            qq{cannot be specified with <$var_name> because }.
                            qq{argument "$arg_name" excludes <$excluded_var>};
                    }
                    _bad_arglist($msg);
                }
            }
        }
    }

    # Enforce constraints and fill in defaults...
  ARG:
    while (my ($arg_name, $arg_specs) = each %{$arg_specs_ref} ) {

        # Skip non-existent/non-defaulting/non-optional-defaulting arguments
        next ARG
          if !exists $ARGV{$arg_name}
              && !(   $arg_specs->{has_default}
                   || $arg_specs->{has_opt_default} );

        # Ensure all vars exist within arg...
        my @vars = keys %{$arg_specs->{placeholders}};
        for my $index ( 0 .. $#{ $ARGV{$arg_name} } ) {
            my $entry = $ARGV{$arg_name}[$index];
            @{$entry}{@vars} = @{$entry}{@vars};

            # Get arg specs...
          VAR:
            for my $var (@vars) {

                my $arg_vars = $arg_specs->{var}->{$var};

                # Check constraints on vars...
                if ( exists $ARGV{$arg_name} ) {

                    if ( ref $entry eq 'HASH' && defined $entry->{$var} ) {
                        # Named vars...
                        for my $val (
                            ref $entry->{$var} eq 'ARRAY'
                            ? @{ $entry->{$var} }
                            : $entry->{$var}
                          )
                        {
                            if ( $arg_vars->{constraint} &&
                                !$arg_vars->{constraint}->($val) ) {
                                _bad_arglist( _type_error($arg_name, $var, $val,
                                    $arg_vars->{constraint_desc},
                                    $arg_vars->{type_error}) );
                            }
                        }
                        next VAR;
                    } elsif ( ref $entry ne 'HASH' && defined $entry ) {
                        # Unnamed vars...
                        for my $val (
                            ref $entry eq 'ARRAY'
                            ? @{$entry}
                            : $entry
                          )
                        {
                            if ( $arg_vars->{constraint} &&
                                !$arg_vars->{constraint}->($val) ) {
                                _bad_arglist( _type_error( $arg_name, $var, $val,
                                    $arg_vars->{constraint_desc},
                                    $arg_vars->{type_error}) );
                            }
                            $entry->{$var} = ''
                              unless defined( $ARGV{$arg_name} );
                        }
                        next VAR;
                    }
                }

                # Assign placeholder defaults (if necessary)...
                next ARG
                  if   !exists $arg_vars->{default}
                    && !exists $arg_vars->{opt_default};

                $entry->{$var} = exists $arg_vars->{opt_default} ?
                                 $arg_vars->{opt_default} :
                                 $arg_vars->{default};
            }
        }

        # Handle defaults for missing args...
        if ( !@{ $ARGV{$arg_name} } ) {
            for my $var (@vars) {
                # Assign defaults (if necessary)...
                my $arg_vars = $arg_specs->{var}->{$var};
                next ARG
                  if !exists $arg_vars->{default}; # no default specified

                # Omit default if it conflicts with a specified parameter
                for my $excl_var ( @{$arg_specs->{var}->{$var}->{excludes}} ) {
                    if (exists $seen_vars{$excl_var}) {
                        next ARG;
                    }
                }

                $ARGV{$arg_name}[0]{$var} = $arg_vars->{default};
            }
        }
    }
    return 1;
}


sub _type_error {
    my ($arg_name, $var_name, $var_val, $var_constraint, $var_error) = @_;
    my $msg = qq{Invalid "$arg_name" argument.\n};
    $var_name =~ s{\W+}{}gxms;
    if ( $var_error ) {
        $msg = $var_error;
        $msg =~ s{(?)}{$var_val}gxms;
    } else {
        $msg = qq{<$var_name> must be $var_constraint but the supplied value }.
               qq{("$var_val") is not.};
    }
    return $msg;
}


sub _convert_to_regex {
    my ($args_ref) = @_;

    # Regexp to capture the start of a new argument
    my $no_esc_ws = '(?!\0)'; # no escaped whitespaces

    my @arg_variants;
    while ( my ($arg_name, $arg_specs) = each %{$args_ref} ) {
        push @arg_variants, @{$arg_specs->{variants}};
    }

    my $no_match = join('|',@arg_variants);
    $no_match = _escape_specials($no_match);
    $no_match = '(?!(?:'.$no_match.')'.$no_esc_ws.')';

    while ( my ($arg_name, $arg) = each %{$args_ref} ) {
        my $regex = $arg_name;

        # Quotemeta specials...
        $regex = _escape_specials($regex);
        $regex = "(?:$regex)";

        # Convert optionals...
        1 while $regex =~ s/ \[ ([^]]*) \] /(?:$1)?/gxms;
        $regex =~ s/ (\s+) /$1.'\s*'.$no_esc_ws/egxms;
        my $generic = $regex;

        # Set the matcher
        $regex =~
            s{ < (.*?) >(\.\.\.|) }
             { my ($var_name, $var_rep) = ($1, $2);
               $var_name =~ s/(\s+)\[\\s\\0\\1]\*/$1/gxms;
               my $type = $arg->{var}{$var_name}{type} || q{};
               $arg->{placeholders}->{$var_name} = undef;
               my $matcher =
                   $type =~ m{\A\s*/.*/\s*\z}xms
                   ? eval "qr$type"
                   : $std_matcher_for{ $type }
                   or _fail("Unknown type ($type) in specification: $arg_name");
               $var_rep ?
                 "(?:[\\s\\0\\1]*$no_match($matcher)(?{push \@{(\$ARGV{q{$arg_name}}||=[{}])->[-1]{q{$var_name}}}, \$^N}))+"
                 :
                 "(?:$no_match($matcher)(?{(\$ARGV{q{$arg_name}}||=[{}])->[-1]{q{$var_name}} = \$^N}))";
             }gexms
             or do {
                 $regex .= "(?{(\$ARGV{q{$arg_name}}||=[{}])->[-1]{q{}} = 1})";
             };

        if ( $arg->{is_repeatable} ) {
            $arg->{matcher} = "$regex (?:(?
        } else {
            $arg->{matcher} = "(??{exists\$ARGV{q{$arg_name}}?'(?!)':''}) "
              . (
                $arg->{false_vals}
                ? "(?:$arg->{false_vals} (?:(? 0 }] }) | $regex (?:(? 1}] }))"
                : "$regex (?:(?
              );
        }

        # Set the generic matcher
        $generic =~
            s{ < (.*?) > }
             { my $var_name = $1;
               $var_name =~ s/(\s+)\[\\s\\0\\1]\*/$1/gxms;
               my $type = $arg->{var}{$var_name}{type} || q{};
               my $type_error = $arg->{var}{$var_name}{type_error} || q{};
               my $matcher = $type =~ m{\A\s*/.*/\s*\z}xms
                                ? eval "qr$type"
                                : $std_matcher_for{ $type };
               "(?:($matcher|([^\\s\\0\\1]+)"
               . "(?{\$bad_type ||= "
               . "{arg=>q{$arg_name},type=>q{$type},type_error=>q{$type_error}, var=>q{<$var_name>},val=>\$^N};})))"
             }gexms;
        $arg->{generic_matcher} = $generic;
    }
    return 1;
}


sub _escape_specials {
    # Escape quotemeta special characters
    my $arg = shift;
    $arg =~ s{([@#\$^*()+{}?])}{\\$1}gxms;
    return $arg;
}


sub _print_pod {
    my ( $pod, $paged ) = @_;

    if ($paged) {
        # Page output
        eval { require IO::Pager::Page } or eval { require IO::Page };
    }

    # Convert POD to plaintext, wrapping the lines at 76 chars and print to STDOUT
    open my $parser_in, '<', \$pod or croak "Could not read from variable because $!";
    Pod::PlainText->new()->parse_from_filehandle($parser_in);
    close $parser_in;

    return 1;
}


sub _validate_name {
    # Check that the argument name only has pairs of < > brackets (ticket 34199)
    # Return the name of the variables that this argument specifies
    my ($name) = @_;
    if ($name =~ m/[<>]/) { # skip expensive Text::Balance functions if possible
        my %var_names;
        my $pos = 0;
        for my $s (extract_multiple($name,[sub{extract_bracketed($_[0],'<>')}],undef,0)) {
            next if not $s =~ m/[<>]/;
            $s =~ s/^<(.*)>$/$1/;
            if ( $s =~ m/[<>]/ ) {
                _fail( 'Invalid argument specification: '.$name );
            }
            $pos++;
            $var_names{$s} = $pos if not exists $var_names{$s};
        }
        return \%var_names;
    } else {
        return {};
    }
}


sub _get_variants {
    my @arg_desc = shift =~ m{ [^[|]+ (?: $optional_re [^[|]* )* }gmxs;

    for (@arg_desc) {
        s{^ \s+ | \s+ $}{}gxms;
    }

    # Only consider first "word"...
    return $1 if $arg_desc[0] =~ m/\A (< [^>]+ >)/xms;

    $arg_desc[0] =~ s/\A ([^\s<]+) \s* (?: < .*)? \z/$1/xms;

    # Variants are all those with and without each optional component...
    my %variants;
    while (@arg_desc) {
        my $arg_desc_with    = shift @arg_desc;
        my $arg_desc_without = $arg_desc_with;

        if ( $arg_desc_without =~ s/ \[ [^][]* \] //xms ) {
            push @arg_desc, $arg_desc_without;
        }
        if ( $arg_desc_with =~ m/ [[(] ([^][()]*) [])] /xms ) {
            my $option = $1;
            for my $alternative ( split /\|/, $option ) {
                my $arg_desc = $arg_desc_with;
                $arg_desc =~ s{[[(] [^][()]* [])]}{$alternative}xms;
                push @arg_desc, $arg_desc;
            }
        }

        $arg_desc_with =~ s/[][]//gxms;
        $arg_desc_with =~ s/\b[^-\w] .* \z//xms;
        $variants{$arg_desc_with} = 1;
    }

    return keys %variants;
}


sub _longestname {
    return ( sort { length $a <=> length $b || $a cmp $b } @_ )[-1];
}


sub _export_var {
    my ( $prefix, $key, $value ) = @_;
    my $export_as = $prefix . $key;
    $export_as =~ s{\W}{_}gxms;    # mainly for '-'
    my $callpkg = caller( $export_lvl + ($Exporter::ExportLevel || 0) );
    no strict 'refs';
    *{"$callpkg\::$export_as"} = ( ref $value ) ? $value : \$value;
    return 1;
}


# Utility sub to factor out hash key aliasing...
sub _make_equivalent {
    my ( $hash_ref, %alias_hash ) = @_;

    while ( my ( $name_re, $aliases ) = each %alias_hash ) {
        for my $alias (@$aliases) {
            $hash_ref->{$alias} = $hash_ref->{$name_re};
        }
    }

    return 1;
}


# Report problems in specification and die
sub _fail {
    my (@msg) = @_;
    croak "Getopt::Euclid: @msg";
}


sub _get_pod_names {
    # Parse the POD of the caller program and its modules.
    my @caller = caller(1);

    # Sanity check
    if ($has_run) {
        carp 'Getopt::Euclid loaded a second time';
        warn "Second attempt to parse command-line was ignored\n";
        return 0;
    }

    # Handle calls from .pm files
    if ( $caller[1] =~ m/[.]pm \z/xms ) {
        my @caller = caller(1); # at import()'s level
        push @pod_names, $caller[1];
        # Install this import() sub as module's import sub...
        no strict 'refs';
        croak '.pm file cannot define an explicit import() when using Getopt::Euclid'
          if *{"$caller[0]::import"}{CODE};
        my $lambda;    # Needed so the anon sub is generated at run-time
        *{"$caller[0]::import"}
          = bless sub { $lambda = 1; goto &Getopt::Euclid::import },
          'Getopt::Euclid::Importer';

        return 0;
    }

    # Add name of caller program
    push @pod_names, $0 if (-e $0); # When calling perl -e '...', $0 is '-e', i.e. not a actual file

    return 1;
}


sub _insert_default_values {
    my ($args) = @_;
    my $pod_string = '';
    # Retrieve item names in sequential order
    for my $item_name ( sort { $args->{$a}->{'seq'} <=> $args->{$b}->{'seq'} } (keys %$args) ) {
        my $item_spec = $args->{$item_name}->{'src'};
        $item_spec =~ s/=for(.*)//ms;
        $pod_string .= "=item $item_name\n\n";
        # Get list of variable for this argument
        while ( my ($var_name, $var) = each %{$args->{$item_name}->{var}} ) {
            # Get default for this variable
            for my $default_type ( 'default', 'opt_default' ) {
                my $var_default;
                if (exists $var->{$default_type}) {
                    if (ref($var->{$default_type}) eq 'ARRAY') {
                        $var_default = join(' ', @{$var->{$default_type}});
                    } elsif (ref($var->{$default_type}) eq '') {
                        $var_default = $var->{$default_type};
                    } else {
                        carp 'Getopt::Euclid found an unexpected default value type';
                    }
                } else {
                    $var_default = 'none';
                }
                $item_spec =~ s/$var_name\.$default_type/$var_default/g;
            }
        }
        if ($item_spec =~ m/(\S+(\.(?:opt_)?default))/) {
            my ($reference, $default_type) = ($1, $2);
            _fail( "Invalid reference to field $reference in argument ".
                   "description:\n$item_spec" );
        }
        $pod_string .= $item_spec;
    }
    $pod_string = "=over\n\n".$pod_string."=back\n\n";
    return $pod_string;
}


1;                                 # Magic true value required at end of module


=head1 NAME

Getopt::Euclid - Executable Uniform Command-Line Interface Descriptions

=head1 VERSION

This document describes Getopt::Euclid version 0.4.5

=head1 SYNOPSIS

    use Getopt::Euclid;

    if ($ARGV{-i}) {
        print "Interactive mode...\n";
    }

    for my $x (0..$ARGV{-size}{h}-1) {
        for my $y (0..$ARGV{-size}{w}-1) {
            do_something_with($x, $y);
        }
    }

    __END__

    =head1 NAME

    yourprog - Your program here

    =head1 VERSION

    This documentation refers to yourprog version 1.9.4

    =head1 USAGE

        yourprog [options]  -s[ize]=x  -o[ut][file]

    =head1 REQUIRED ARGUMENTS

    =over

    =item  -s[ize]=x

    Specify size of simulation

    =for Euclid:
        h.type:    int > 0
        h.default: 24
        w.type:    int >= 10
        w.default: 80

    =item  -o[ut][file]

    Specify output file

    =for Euclid:
        file.type:    writable
        file.default: '-'

    =back

    =head1 OPTIONS

    =over

    =item  -i

    Specify interactive simulation

    =item  -l[[en][gth]]

    Length of simulation. The default is l.default

    =for Euclid:
        l.type:    int > 0
        l.default: 99

    =item --debug []

    Set the log level. Default is log_level.default but if you provide --debug,
    then it is log_level.opt_default.

    =for Euclid:
        log_level.type:        int
        log_level.default:     0
        log_level.opt_default: 1

    =item --version

    =item --usage

    =item --help

    =item --man

    Print the usual program information

    =back

    Remainder of documentation starts here...

    =head1 AUTHOR

    Damian Conway ([e-mail])

    =head1 BUGS

    There are undoubtedly serious bugs lurking somewhere in this code.
    Bug reports and other feedback are most welcome.

    =head1 COPYRIGHT

    Copyright (c) 2005, Damian Conway. All Rights Reserved.
    This module is free software. It may be used, redistributed
    and/or modified under the terms of the Perl Artistic License
    (see http://www.perl.com/perl/misc/Artistic.html)


=head1 DESCRIPTION

Getopt::Euclid uses your program's own POD documentation to create a powerful
command-line argument parser. This ensures that your program's documented interface
and its actual interface always agree.

The created command-line argument parser includes many features such as argument
type checking, required arguments, exclusive arguments, optional arguments with
default values, automatic usage message, ...

To use the module, simply write the following at the top of your program:

    use Getopt::Euclid;

This will cause Getopt::Euclid to be require'd and its import method will be
called. It is important that the import method be allowed to run, so do not
invoke Getopt::Euclid in the following manner:

    # Will not work
    use Getopt::Euclid ();

When the module is loaded within a regular Perl program, it will:

=over

=item 1.

locate any POD in the same *.pl file or its associated *.pod file.

=item 2.

extract information from that POD, most especially from
the C<=head1 REQUIRED ARGUMENTS> and C<=head1 OPTIONS> sections,

=item 3.

build a parser that parses the arguments and options the POD specifies,

=item 4.

remove the command-line arguments from C<@ARGV> and parse them, and

=item 5.

put the results in the global C<%ARGV> variable (or into specifically named
optional variables, if you request that -- see L).

=back

As a special case, if the module is loaded within some other module
(i.e. from within a C<.pm> file), it still locates and extracts POD
information, but instead of parsing C<@ARGV> immediately, it caches that
information and installs an C subroutine in the caller module.
This new C acts just like Getopt::Euclid's own import, except
that it adds the POD from the caller module to the POD of the callee.

All of which just means you can put some or all of your CLI specification
in a module, rather than in the application's source file.
See L for more details.

=head1 INTERFACE

=head2 Program interface

You write:

    use Getopt::Euclid;

and your command-line is parsed automagically.

=head2 Module interface

=over

=item import()

You write:

    use Getopt::Euclid;

and your module will then act just like Getopt::Euclid (i.e. you can use
your module I of Getopt::Euclid>, except that your module's POD
will also be prepended to the POD of any module that loads yours. In
other words, you can use Getopt::Euclid in a module to create a standard
set of CLI arguments, which can then be added to any application simply
by loading your module.

To accomplish this trick Getopt::Euclid installs an C
subroutine in your module. If your module already has an C
subroutine defined, terrible things happen. So do not do that.

You may also short-circuit the import method within your calling program to
have the POD from several modules included for argument parsing.

    use Module1::Getopt (); # No argument parsing
    use Module2::Getopt (); # No argument parsing
    use Getopt::Euclid;     # Arguments parsed

=item process_args()

Alternatively, to parse arguments from a source different from C<@ARGV>, use the
C subroutine.

    use Getopt::Euclid qw(:defer);
    my @args = ( '-in', 'file.txt', '-out', 'results.txt' );
    Getopt::Euclid->process_args(\@args);

If you want to use the :minimal or :vars mode in this type of scenario, you can
pass extra options to C:

    use Getopt::Euclid qw(:defer);
    my @args = ( '-in', 'file.txt', '-out', 'results.txt' );
    Getopt::Euclid->process_args(\@args, {-minimal => 1, -vars => 'prefix_'});

This is particularly when you plan on processing POD manually.

=item process_pods()

Similarly, to parse argument specifications from a source different than the
current script (and its dependencies), use the C subroutine.

    use Getopt::Euclid ();
    my @pods = ( 'script.pl', 'Module.pm' );
    $Getopt::Euclid::MAN = Getopt::Euclid->process_pods(\@pods, {-strict => 1});
    my @args = ( '-in', 'file.txt', '-out', 'results.txt' );
    Getopt::Euclid->process_args(\@args);

By default, this method will look for .pod files associated with the given .pl
and .pm files and use these .pod files preferentially when available. Set
-strict to 1 to only use the given files.

=back

=head2 POD interface

This is where all the action is. POD markup can be placed in a .pod file that
has the same prefix as the corresponding Perl file. Alternatively, POD can be
inserted anywhere in the Perl code, but is typically added either after an
__END__ statement (like in the L), or interspersed in the code: