#!perl

# BEGIN DATAPACK CODE
{
    my $toc;
    my $data_linepos = 1;
    unshift @INC, sub {
        $toc ||= do {

            # calculate the line number of data section
            my $data_pos = tell(DATA);
            seek DATA, 0, 0;
            my $pos = 0;
            while (1) {
                my $line = <DATA>;
                $pos += length($line);
                $data_linepos++;
                last if $pos >= $data_pos;
            }
            seek DATA, $data_pos, 0;

            my $fh = \*DATA;
my $header_line = <$fh>;
        defined($header_line)
            or die "Unexpected end of data section while reading header line";
        chomp($header_line);
        $header_line eq 'Data::Section::Seekable v1'
            or die "Invalid header, must be 'Data::Section::Seekable v1' (got: $header_line)";

        my %toc;
        my $i = 0;
        while (1) {
            $i++;
            my $toc_line = <$fh>;
            defined($toc_line)
                or die "Unexpected end of data section while reading TOC line #$i";
            chomp($toc_line);
            $toc_line =~ /\S/ or last;
            $toc_line =~ /^([^,]+),(\d+),(\d+)(?:,(.*))?$/
                or die "Invalid TOC line #$i in data section: $toc_line";
            $toc{$1} = [$2, $3, $4];
        }
        my $pos = tell $fh;
        $toc{$_}[0] += $pos for keys %toc;

            \%toc;
        };
        if ($toc->{$_[1]}) {
            seek DATA, $toc->{$_[1]}[0], 0;
            read DATA, my($content), $toc->{$_[1]}[1];
            my ($order, $lineoffset) = split(';', $toc->{$_[1]}[2]);
            $content =~ s/^ //gm;
            $content = "# line ".($data_linepos + 1 + keys(%$toc) + 1 + $order+1 + $lineoffset)." \"".__FILE__."\"\n" . $content;
            open my $fh, '<', \$content
                or die "DataPacker error loading $_[1]: $!";
            return $fh;
        }
        return;
    };
}
# END DATAPACK CODE

# Note: This completer script is generated by App::GenPericmdCompleterScript version 0.03
# on Wed Aug 19 20:46:55 2015. You probably should not manually edit this file.

# NO_PERINCI_CMDLINE_SCRIPT
# PERINCI_CMDLINE_COMPLETER_SCRIPT: {load_module=>undef,program_name=>"check-module-version",read_config=>0,read_env=>0,skip_format=>undef,subcommands=>undef,url=>"/Module/CheckVersion/check_module_version"}
# FRAGMENT id=shcompgen-hint completer=1 for=check-module-version
our $DATE = '2015-08-19'; # DATE
our $VERSION = '0.04'; # VERSION
# PODNAME: _check-module-version
# ABSTRACT: Completer script for check-module-version

use 5.010;
use strict;
use warnings;

die "Please run this script under shell completion\n" unless $ENV{COMP_LINE} || $ENV{COMMAND_LINE};

my $args = {
  'read_config' => 0,
  'program_name' => 'check-module-version',
  'load_module' => undef,
  'skip_format' => undef,
  'url' => '/Module/CheckVersion/check_module_version',
  'read_env' => 0,
  'subcommands' => undef
};

my $meta = {
  'entity_v' => undef,
  'description' => '
Designed to be more general and able to provide more information in the future
in addition to mere checking of latest version, but checking latest version is
currently the only implemented feature.

Can handle non-CPAN modules, as long as you put the appropriate `$AUTHORITY` in
your modules and create the `Module::CheckVersion::<scheme>` to handle your
authority scheme.

',
  'summary' => 'Check module (e.g. check latest version) with CPAN (or equivalent repo)',
  'args' => {
              'check_latest_version' => {
                                          'default' => 1,
                                          'schema' => [
                                                        'bool',
                                                        {},
                                                        {}
                                                      ]
                                        },
              'module' => {
                            'pos' => 0,
                            'schema' => [
                                          'str',
                                          {
                                            'req' => 1,
                                            'match' => qr/\A\w+(::\w+)*\z/
                                          },
                                          {}
                                        ],
                            'req' => 1,
                            'description' => '
This routine will try to load the module, and retrieve its `$VERSION`. If
loading fails will assume module\'s installed version is undef.

'
                          },
              'default_authority_scheme' => {
                                              'schema' => [
                                                            'str',
                                                            {},
                                                            {}
                                                          ],
                                              'description' => '
If a module does not set `$AUTHORITY` (which contains string like
`<scheme>:<extra>` like `cpan:PERLANCAR`), the default authority scheme will be
determined from this setting. The module `Module::CheckVersion::<scheme>` module
is used to implement actual checking.

Can also be set to undef, in which case when module\'s `$AUTHORITY` is not
available, will return 412 status.

',
                                              'default' => 'cpan'
                                            }
            },
  'v' => '1.1',
  'entity_date' => undef
};

my $sc_metas = {};

my $copts = {
  'format' => {
                'tags' => [
                            'category:output'
                          ],
                'handler' => sub {
                                 package Perinci::CmdLine::Base;
                                 use warnings;
                                 use strict;
                                 no feature ':all';
                                 use feature ':5.10';
                                 my($go, $val, $r) = @_;
                                 $r->{'format'} = $val;
                             },
                'default' => undef,
                'is_settable_via_config' => 1,
                'getopt' => 'format=s',
                'schema' => [
                              'str*',
                              'in',
                              [
                                'text',
                                'text-simple',
                                'text-pretty',
                                'json',
                                'json-pretty'
                              ]
                            ],
                'summary' => 'Choose output format, e.g. json, text'
              },
  'naked_res' => {
                   'tags' => [
                               'category:output'
                             ],
                   'default' => 0,
                   'is_settable_via_config' => 1,
                   'getopt' => 'naked-res!',
                   'summary' => 'When outputing as JSON, strip result envelope',
                   'summary.alt.bool.not' => 'When outputing as JSON, add result envelope',
                   'handler' => sub {
                                    package Perinci::CmdLine::Base;
                                    use warnings;
                                    use strict;
                                    no feature ':all';
                                    use feature ':5.10';
                                    my($go, $val, $r) = @_;
                                    $r->{'naked_res'} = $val ? 1 : 0;
                                },
                   'description' => '
By default, when outputing as JSON, the full enveloped result is returned, e.g.:

    [200,"OK",[1,2,3],{"func.extra"=>4}]

The reason is so you can get the status (1st element), status message (2nd
element) as well as result metadata/extra result (4th element) instead of just
the result (3rd element). However, sometimes you want just the result, e.g. when
you want to pipe the result for more post-processing. In this case you can use
`--naked-res` so you just get:

    [1,2,3]

'
                 },
  'version' => {
                 'summary' => 'Display program\'s version and exit',
                 'getopt' => 'version|v',
                 'usage' => '--version (or -v)',
                 'handler' => sub {
                                  package Perinci::CmdLine::Base;
                                  use warnings;
                                  use strict;
                                  no feature ':all';
                                  use feature ':5.10';
                                  my($go, $val, $r) = @_;
                                  $r->{'action'} = 'version';
                                  $r->{'skip_parse_subcommand_argv'} = 1;
                              }
               },
  'json' => {
              'handler' => sub {
                               package Perinci::CmdLine::Base;
                               use warnings;
                               use strict;
                               no feature ':all';
                               use feature ':5.10';
                               my($go, $val, $r) = @_;
                               $r->{'format'} = -t STDOUT ? 'json-pretty' : 'json';
                           },
              'tags' => [
                          'category:output'
                        ],
              'getopt' => 'json',
              'summary' => 'Set output format to json'
            },
  'help' => {
              'handler' => sub {
                               package Perinci::CmdLine::Base;
                               use warnings;
                               use strict;
                               no feature ':all';
                               use feature ':5.10';
                               my($go, $val, $r) = @_;
                               $r->{'action'} = 'help';
                               $r->{'skip_parse_subcommand_argv'} = 1;
                           },
              'usage' => '--help (or -h, -?)',
              'getopt' => 'help|h|?',
              'summary' => 'Display help message and exit',
              'order' => 0
            }
};

my $r = {};

# get words
my $shell;
my ($words, $cword);
if ($ENV{COMP_LINE}) { $shell = "bash"; require Complete::Bash; ($words,$cword) = @{ Complete::Bash::parse_cmdline() }; }
elsif ($ENV{COMMAND_LINE}) { $shell = "tcsh"; require Complete::Tcsh; ($words,$cword) = @{ Complete::Tcsh::parse_cmdline() }; }
@ARGV = @$words;

# strip program name
shift @$words; $cword--;

# parse common_opts which potentially sets subcommand
{
    require Getopt::Long;
    my $old_go_conf = Getopt::Long::Configure('pass_through', 'no_ignore_case', 'bundling', 'no_auto_abbrev');
    my @go_spec;
    for my $k (keys %$copts) { push @go_spec, $copts->{$k}{getopt} => sub { my ($go, $val) = @_; $copts->{$k}{handler}->($go, $val, $r); } }
    Getopt::Long::GetOptions(@go_spec);
    Getopt::Long::Configure($old_go_conf);
}

# select subcommand
my $scn = $r->{subcommand_name};
my $scn_from = $r->{subcommand_name_from};
if (!defined($scn) && defined($args->{default_subcommand})) {
    # get from default_subcommand
    if ($args->{get_subcommand_from_arg} == 1) {
        $scn = $args->{default_subcommand};
        $scn_from = "default_subcommand";
    } elsif ($args->{get_subcommand_from_arg} == 2 && !@ARGV) {
        $scn = $args->{default_subcommand};
        $scn_from = "default_subcommand";
    }
}
if (!defined($scn) && $args->{subcommands} && @ARGV) {
    # get from first command-line arg
    $scn = shift @ARGV;
    $scn_from = "arg";
}

if (defined($scn) && !$sc_metas->{$scn}) { undef $scn } # unknown subcommand name
# XXX read_env

# complete with periscomp
my $compres;
{
    require Perinci::Sub::Complete;
    $compres = Perinci::Sub::Complete::complete_cli_arg(
        meta => defined($scn) ? $sc_metas->{$scn} : $meta,
        words => $words,
        cword => $cword,
        common_opts => $copts,
        riap_server_url => undef,
        riap_uri => undef,
        extras => {r=>$r, cmdline=>undef},
        func_arg_starts_at => (($scn_from//"") eq "arg" ? 1:0),
        completion => sub {
            my %args = @_;
            my $type = $args{type};

            # user specifies custom completion routine, so use that first
            if ($args->{completion}) {
                my $res = $args->{completion}->(%args);
                return $res if $res;
            }
            # if subcommand name has not been supplied and we're at arg#0,
            # complete subcommand name
            if ($args->{subcommands} &&
                $scn_from ne "--cmd" &&
                     $type eq "arg" && $args{argpos}==0) {
                require Complete::Util;
                return Complete::Util::complete_array_elem(
                    array => [keys %{ $args->{subcommands} }],
                    word  => $words->[$cword]);
            }

            # otherwise let periscomp do its thing
            return undef;
        },
    );
}

# display result
if    ($shell eq "bash") { print Complete::Bash::format_completion($compres, {word=>$words->[$cword]}) }
elsif ($shell eq "tcsh") { print Complete::Tcsh::format_completion($compres) }

=pod

=encoding UTF-8

=head1 NAME

_check-module-version - Completer script for check-module-version

=head1 VERSION

This document describes version 0.04 of Perinci::CmdLine::Base (from Perl distribution Module-CheckVersion), released on 2015-08-19.

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Module-CheckVersion>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Module-CheckVersion>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-CheckVersion>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by perlancar@cpan.org.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

__DATA__
Data::Section::Seekable v1
Clone/PP.pm,20,6331,0;0
Complete.pm,6371,10411,1;193
Complete/Bash.pm,16807,29095,2;510
Complete/Getopt/Long.pm,45934,27919,3;1340
Complete/Path.pm,73878,14827,4;2116
Complete/Tcsh.pm,88730,6696,5;2576
Complete/Util.pm,95451,22354,6;2825
Data/Clean/Base.pm,117832,12371,7;3665
Data/Clean/JSON.pm,130230,6576,8;4077
Data/Sah/Normalize.pm,136836,9045,9;4286
DefHash.pm,145900,1195,10;4560
Exporter/Shiny.pm,147121,2336,11;4609
Exporter/Tiny.pm,149482,26222,12;4720
Function/Fallback/CoreOrPP.pm,175742,4609,13;5553
Getopt/Long/Negate/EN.pm,180384,3167,14;5731
Getopt/Long/Util.pm,183579,11978,15;5835
JSON/PP.pm,195576,84628,16;6266
Lingua/EN/PluralToSingular.pm,280242,7003,17;9061
List/MoreUtils.pm,287271,29682,18;9398
List/MoreUtils/PP.pm,316982,10801,19;10358
List/MoreUtils/XS.pm,327812,2126,20;10945
Log/Any.pm,329957,12741,21;11026
Log/Any/Adapter.pm,342725,5999,22;11455
Log/Any/Adapter/Base.pm,348756,948,23;11693
Log/Any/Adapter/File.pm,349736,3153,24;11733
Log/Any/Adapter/Null.pm,352921,1288,25;11863
Log/Any/Adapter/Stderr.pm,354243,2335,26;11935
Log/Any/Adapter/Stdout.pm,356612,2335,27;12044
Log/Any/Adapter/Test.pm,358979,4661,28;12153
Log/Any/Adapter/Util.pm,363672,8116,29;12337
Log/Any/IfLOG.pm,371813,4516,30;12677
Log/Any/Manager.pm,376356,5580,31;12856
Log/Any/Proxy.pm,381961,7419,32;13052
Log/Any/Proxy/Test.pm,389410,475,33;13369
Log/Any/Test.pm,389909,3513,34;13399
Module/Path/More.pm,393450,10918,35;13545
Perinci/Sub/ArgEntity.pm,404401,3338,36;13943
Perinci/Sub/Complete.pm,407771,49957,37;14066
Perinci/Sub/GetArgs/Argv.pm,457764,49807,38;15474
Perinci/Sub/GetArgs/Array.pm,507608,7040,39;16836
Perinci/Sub/Normalize.pm,514681,7317,40;17082
Perinci/Sub/Util.pm,522026,17452,41;17318
Perinci/Sub/Util/ResObj.pm,539513,1568,42;17938
Perinci/Sub/Util/Sort.pm,541114,1980,43;17999
Rinci.pm,543111,1149,44;18090
Sah.pm,544275,1107,45;18139
Sah/Schema/DefHash.pm,545412,3962,46;18188
Sah/Schema/Rinci.pm,549402,5705,47;18362
Sah/Schema/Sah.pm,555133,5086,48;18594
String/LineNumber.pm,560248,2534,49;18787
String/PerlQuote.pm,562810,3410,50;18905
String/Wildcard/Bash.pm,566252,4240,51;19030

### Clone/PP.pm ###
 package Clone::PP;
 
 use 5.006;
 use strict;
 use warnings;
 use vars qw($VERSION @EXPORT_OK);
 use Exporter;
 
 $VERSION = 1.06;
 
 @EXPORT_OK = qw( clone );
 sub import { goto &Exporter::import } # lazy Exporter
 
 # These methods can be temporarily overridden to work with a given class.
 use vars qw( $CloneSelfMethod $CloneInitMethod );
 $CloneSelfMethod ||= 'clone_self';
 $CloneInitMethod ||= 'clone_init';
 
 # Used to detect looped networks and avoid infinite recursion. 
 use vars qw( %CloneCache );
 
 # Generic cloning function
 sub clone {
   my $source = shift;
 
   return undef if not defined($source);
   
   # Optional depth limit: after a given number of levels, do shallow copy.
   my $depth = shift;
   return $source if ( defined $depth and $depth -- < 1 );
   
   # Maintain a shared cache during recursive calls, then clear it at the end.
   local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
   
   return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
   
   # Non-reference values are copied shallowly
   my $ref_type = ref $source or return $source;
   
   # Extract both the structure type and the class name of referent
   my $class_name;
   if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
     $class_name = $ref_type;
     $ref_type = $1;
     # Some objects would prefer to clone themselves; check for clone_self().
     return $CloneCache{ $source } = $source->$CloneSelfMethod() 
 				  if $source->can($CloneSelfMethod);
   }
   
   # To make a copy:
   # - Prepare a reference to the same type of structure;
   # - Store it in the cache, to avoid looping if it refers to itself;
   # - Tie in to the same class as the original, if it was tied;
   # - Assign a value to the reference by cloning each item in the original;
   
   my $copy;
   if ($ref_type eq 'HASH') {
     $CloneCache{ $source } = $copy = {};
     if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied }
     %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source;
   } elsif ($ref_type eq 'ARRAY') {
     $CloneCache{ $source } = $copy = [];
     if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied }
     @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source;
   } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
     $CloneCache{ $source } = $copy = \( my $var = "" );
     if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied }
     $$copy = clone($$source, $depth);
   } else {
     # Shallow copy anything else; this handles a reference to code, glob, regex
     $CloneCache{ $source } = $copy = $source;
   }
   
   # - Bless it into the same class as the original, if it was blessed;
   # - If it has a post-cloning initialization method, call it.
   if ( $class_name ) {
     bless $copy, $class_name;
     $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
   }
   
   return $copy;
 }
 
 1;
 
 __END__
 
 =head1 NAME
 
 Clone::PP - Recursively copy Perl datatypes
 
 =head1 SYNOPSIS
 
   use Clone::PP qw(clone);
   
   $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ]  };
   $copy = clone( $item );
 
   $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ];
   $copy = clone( $item );
 
   $item = Foo->new();
   $copy = clone( $item );
 
 Or as an object method:
 
   require Clone::PP;
   push @Foo::ISA, 'Clone::PP';
   
   $item = Foo->new();
   $copy = $item->clone();
 
 =head1 DESCRIPTION
 
 This module provides a general-purpose clone function to make deep
 copies of Perl data structures. It calls itself recursively to copy
 nested hash, array, scalar and reference types, including tied
 variables and objects.
 
 The clone() function takes a scalar argument to copy. To duplicate
 arrays or hashes, pass them in by reference:
 
   my $copy = clone(\@array);    my @copy = @{ clone(\@array) };
   my $copy = clone(\%hash);     my %copy = %{ clone(\%hash) };
 
 The clone() function also accepts an optional second parameter that
 can be used to limit the depth of the copy. If you pass a limit of
 0, clone will return the same value you supplied; for a limit of
 1, a shallow copy is constructed; for a limit of 2, two layers of
 copying are done, and so on.
 
   my $shallow_copy = clone( $item, 1 );
 
 To allow objects to intervene in the way they are copied, the
 clone() function checks for a couple of optional methods. If an
 object provides a method named C<clone_self>, it is called and the
 result returned without further processing. Alternately, if an
 object provides a method named C<clone_init>, it is called on the
 copied object before it is returned.
 
 =head1 BUGS
 
 Some data types, such as globs, regexes, and code refs, are always copied shallowly.
 
 References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not:
 
   my $hash = { foo => 1 }; 
   $hash->{bar} = \{ $hash->{foo} }; 
   my $copy = clone( \%hash ); 
   $hash->{foo} = 2; 
   $copy->{foo} = 2; 
   ok( $hash->{bar} == $copy->{bar} );
 
 To report bugs via the CPAN web tracking system, go to 
 C<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone-PP> or send mail 
 to C<Dist=Clone-PP#rt.cpan.org>, replacing C<#> with C<@>.
 
 =head1 SEE ALSO
 
 L<Clone> - a baseclass which provides a C<clone()> method.
 
 L<MooseX::Clone> - find-grained cloning for Moose objects.
 
 The C<dclone()> function in L<Storable>.
 
 L<Data::Clone> -
 polymorphic data cloning (see its documentation for what that means).
 
 L<Clone::Any> - use whichever of the cloning methods is available.
 
 =head1 REPOSITORY
 
 L<https://github.com/neilbowers/Clone-PP>
 
 =head1 AUTHOR AND CREDITS
 
 Developed by Matthew Simon Cavalletto at Evolution Softworks. 
 More free Perl software is available at C<www.evoscript.org>.
 
 
 =head1 COPYRIGHT AND LICENSE
 
 Copyright 2003 Matthew Simon Cavalletto. You may contact the author
 directly at C<evo@cpan.org> or C<simonm@cavalletto.org>.
 
 Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff.
 
 Interface based by Clone by Ray Finch with contributions from chocolateboy.
 Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. 
 
 You may use, modify, and distribute this software under the same terms as Perl.
 
 =cut
### Complete.pm ###
 package Complete;
 
 our $DATE = '2015-03-04'; # DATE
 our $VERSION = '0.12'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 our $OPT_CI          = ($ENV{COMPLETE_OPT_CI}          // 1) ? 1:0;
 our $OPT_MAP_CASE    = ($ENV{COMPLETE_OPT_MAP_CASE}    // 1) ? 1:0;
 our $OPT_EXP_IM_PATH = ($ENV{COMPLETE_OPT_EXP_IM_PATH} // 1) ? 1:0;
 our $OPT_EXP_IM_PATH_MAX_LEN = ($ENV{COMPLETE_OPT_EXP_IM_PATH_MAX_LEN} // 2)+0;
 our $OPT_DIG_LEAF    = ($ENV{COMPLETE_OPT_DIG_LEAF}    // 1) ? 1:0;
 
 1;
 # ABSTRACT: Convention for Complete::* modules family and common settings
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete - Convention for Complete::* modules family and common settings
 
 =head1 VERSION
 
 This document describes version 0.12 of Complete (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-03-04.
 
 =head1 DESCRIPTION
 
 The namespace C<Complete::> is used for the family of modules that deal with
 completion (including, but not limited to, shell tab completion, tab completion
 feature in other CLI-based application, web autocomplete, completion in GUI,
 etc). This (family of) modules try to have a clear separation between general
 completion routine and shell-/environment specific ones, for more reusability.
 
 This POD page gives an overview of the modules in C<Complete::*> namespace,
 establishes convention, and declares common settings.
 
 =head2 Modules
 
 =head3 Generic (non-environment-specific) modules
 
 Modules usually are named after the type of completion answer they provide. For
 example: L<Complete::Unix> completes username/group name,
 L<Complete::Getopt::Long> completes from L<Getopt::Long> specification,
 L<Complete::Module> completes Perl module names, and so on. A current exception
 is L<Complete::Util> which contains several routines to complete from
 common/generic sources (array, hash, file, environment).
 
 =head3 Environment-specific modules
 
 C<Complete::Bash::*> modules are specific to bash shell. See L<Complete::Bash>
 on some of the ways to do bash tab completion with Perl. Other shells are also
 supported. For shell-specific information, please refer to L<Complete::Zsh>,
 L<Complete::Tcsh>, L<Complete::Fish>, as well as their submodules.
 
 C<Complete::*> modules for non-shell environment (like browser or GUI) have not
 been developed. Please check again from time to time in the future.
 
 =head2 C<complete_*()> functions
 
 The main functions that do the actual completion are the C<complete_*()>
 functions. These functions are generic completion routines: they accept the word
 to be completed, zero or more other arguments, and return a completion answer
 structure (see L</"Completion answer structure">).
 
  use Complete::Util qw(complete_array_elem);
  my $ary = complete_array_elem(array=>[qw/apple apricot banana/], word=>'ap');
  # -> ['apple', 'apricot']
 
 Convention for C<complete_*> function:
 
 =over
 
 =item * Accept a hash argument
 
 Example:
 
  complete_array_elem(%args)
 
 Required arguments: C<word> (the word to be completed). Sometimes, for
 lower-level functions, you can accept C<words> and C<cword> instead of C<word>,
 For example, in function C<Complete::Getopt::Long::complete_cli_arg>.
 
 Optional common arguments: C<ci> (bool, whether the matching should be
 case-insensitive, if unspecified should default to C<$Complete::OPT_CI>).
 
 Other arguments: you can define more arguments as you fit. Often there is at
 least one argument to specify or customize the source of completion, for example
 for the function C<Complete::Util::complete_array_elem> there is an C<array>
 argument to specify the source array.
 
 =item * Return completion answer structure
 
 See L</"Completion answer structure">.
 
 =item * Use defaults from global Complete settings, when applicable
 
 See L<"/SETTINGS">
 
 =back
 
 =head2 Completion answer structure
 
 C<complete_*()> functions return completion answer structure. Completion answer
 contains the completion entries as well as extra metadata to give hints to
 formatters/tools. It is a hashref which can contain the following keys:
 
 =over
 
 =item * words => array
 
 This key is required. Its value is an array of completion entries. A completion
 entry can be a string or a hashref. Example:
 
  ['apple', 'apricot'] # array of strings
 
  [{word=>'apple', summary=>'A delicious fruit with thousands of varieties'},
   {word=>'apricot', summary=>'Another delicious fruit'},] # array of hashes
 
 As you can see from the above, each entry can contain description (can be
 displayed in shells that support them, like fish and zsh).
 
 =item * type => str
 
 See L<Complete::Bash>.
 
 =item * path_sep => str
 
 See L<Complete::Bash>.
 
 =item * esc_mode => str
 
 See L<Complete::Bash>.
 
 =item * static => bool
 
 Specify that completion is "static", meaning that it does not depend on external
 state (like filesystem) or a custom code which can return different answer
 everytime completion is requested.
 
 This can be useful for code that wants to generate completion code, like bash
 completion or fish completion. Knowing that completion for an option value is
 static means that completion for that option can be answered from an array
 instead of having to call code/program (faster).
 
 =back
 
 As a shortcut, completion answer can also be an arrayref (just the C<words>)
 without any metadata.
 
 Examples:
 
  # hash form
  {words=>[qw/apple apricot/]}
 
  # another hash form. type=env instructs formatter not to escape '$'
  {words=>[qw/$HOME $ENV/], type=>'env'}
 
  # array form
  ['apple', 'apricot']
 
  # another array form, each entry is a hashref to include description
  [{word=>'apple', summary=>'A delicious fruit with thousands of varieties'},
   {word=>'apricot', summary=>'Another delicious fruit'},] # array of hashes
 
 =head1 SETTINGS
 
 This module also defines some configuration variable. C<Complete::*> modules
 should use the default from these settings, to make it convenient for users to
 change some behavior globally.
 
 The defaults are optimized for convenience and laziness for user typing and
 might change from release to release.
 
 =head2 C<$Complete::OPT_CI> => bool (default: from COMPLETE_OPT_CI or 1)
 
 If set to 1, matching is done case-insensitively. This setting should be
 consulted as the default for all C<ci> arguments in the C<complete_*> functions.
 But users can override this setting by providing value to C<ci> argument.
 
 In bash/readline, this is akin to setting C<completion-ignore-case>.
 
 =head2 C<$Complete::OPT_MAP_CASE> => bool (default: from COMPLETE_OPT_MAP_CASE or 1)
 
 This is exactly like C<completion-map-case> in readline/bash to treat C<_> and
 C<-> as the same when matching.
 
 All L<Complete::Path>-based modules (like L<Complete::Util>'s
 C<complete_file()>), L<Complete::Module>, or L<Complete::Riap> respect this
 setting.
 
 =head2 C<$Complete::OPT_EXP_IM_PATH> => bool (default: from COMPLETE_OPT_EXP_IM_PATH or 1)
 
 Whether to "expand intermediate paths". What is meant by this is something like
 zsh: when you type something like C<cd /h/u/b/myscript> it can be completed to
 C<cd /home/ujang/bin/myscript>.
 
 All L<Complete::Path>-based modules (like L<Complete::Util>'s
 C<complete_file()>, L<Complete::Module>, or L<Complete::Riap>) respect this
 setting.
 
 =head2 C<$Complete::OPT_EXP_IM_PATH_MAX_LEN> => int (default: from COMPLETE_OPT_EXP_IM_PATH_MAX_LEN or 2)
 
 Wehn OPT_EXP_IM_PATH is active, because of the way bash does completion (it cuts
 current word to the shortest common denominator of all completion candidates),
 in some cases this can be annoying because it prevents completion to be done the
 way we want. For example:
 
  l/D/Zi/Plugi/Author<tab>
 
 if we have:
 
  lib/Dist/Zilla/Plugin/Author/
  lib/Dist/Zilla/PluginBundle/Author/
 
 the completion candidates are both the above, and bash cuts our word at the
 buffer to:
 
  lib/Dist/Zilla/Plugin
 
 even if we type C</> and then Tab like this:
 
  lib/Dist/Zilla/Plugin/<tab>
 
 bash will again cuts the buffer to become:
 
  lib/Dist/Zilla/Plugin
 
 To work around (or compromise around) this, the setting
 C<OPT_EXP_IM_PATH_MAX_LEN> is introduced. The default is 2. So if a path element
 is over 2 characters long, expand will not be done. This means in this path:
 
  l/D/Zi/Plugi/Author<tab>
 
 we expand C<l>, C<D>, C<Zi>, but not C<Plugi>. So to get expansion you'll have
 to write:
 
  l/D/Zi/P/Author<tab>
  l/D/Zi/Pl/Author<tab>
 
 which is usually fine.
 
 =head2 C<$Complete::OPT_DIG_LEAF> => bool (default: from COMPLETE_OPT_DIG_LEAF or 1)
 
 (Experimental) When enabled, this option mimics what's seen on GitHub. If a
 directory entry only contains a single subentry, it will directly show the
 subentry (and subsubentry and so on) to save a number of tab presses.
 
 Suppose you have files like this:
 
  a
  b/c/d/e
  c
 
 If you complete for C<b> you will directly get C<b/c/d/e> (the leaf).
 
 This is currently experimental because if you want to complete only directories,
 you won't get b or b/c or b/c/d. Need to think how to solve this.
 
 =head1 ENVIRONMENT
 
 =head2 COMPLETE_OPT_CI => bool
 
 Set default for C<$Complete::OPT_CI>.
 
 =head2 COMPLETE_OPT_MAP_CASE => bool
 
 Set default for C<$Complete::OPT_MAP_CASE>.
 
 =head2 COMPLETE_OPT_EXP_IM_PATH => bool
 
 Set default for C<$Complete::OPT_EXP_IM_PATH>.
 
 =head2 COMPLETE_OPT_EXP_IM_PATH_MAX_LEN => int
 
 Set default for C<$Complete::OPT_EXP_IM_PATH_MAX_LEN>.
 
 =head2 COMPLETE_OPT_DIG_LEAF => bool
 
 Set default for C<$Complete::OPT_DIG_LEAF>.
 
 =head1 SEE ALSO
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Complete/Bash.pm ###
 package Complete::Bash;
 
 our $DATE = '2015-04-02'; # DATE
 our $VERSION = '0.19'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 #use Complete;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        parse_cmdline
                        parse_options
                        format_completion
                );
 
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'Completion module for bash shell',
     links => [
         {url => 'pm:Complete'},
     ],
 };
 
 sub _expand_tilde {
     my ($user, $slash) = @_;
     my @ent;
     if (length $user) {
         @ent = getpwnam($user);
     } else {
         @ent = getpwuid($>);
         $user = $ent[0];
     }
     return $ent[7] . $slash if @ent;
     "~$user$slash"; # return as-is when failed
 }
 
 sub _add_unquoted {
     no warnings 'uninitialized';
 
     my ($word, $is_cur_word, $after_ws) = @_;
 
     #say "D:add_unquoted word=$word is_cur_word=$is_cur_word after_ws=$after_ws";
 
     $word =~ s!^(~)(\w*)(/|\z) |  # 1) tilde  2) username  3) optional slash
                \\(.)           |  # 4) escaped char
                \$(\w+)            # 5) variable name
               !
                   $1 ? (not($after_ws) || $is_cur_word ? "$1$2$3" : _expand_tilde($2, $3)) :
                       $4 ? $4 :
                           ($is_cur_word ? "\$$5" : $ENV{$5})
                               !egx;
     $word;
 }
 
 sub _add_double_quoted {
     no warnings 'uninitialized';
 
     my ($word, $is_cur_word) = @_;
 
     $word =~ s!\\(.)           |  # 1) escaped char
                \$(\w+)            # 2) variable name
               !
                   $1 ? $1 :
                       ($is_cur_word ? "\$$2" : $ENV{$2})
                           !egx;
     $word;
 }
 
 sub _add_single_quoted {
     my $word = shift;
     $word =~ s/\\(.)/$1/g;
     $word;
 }
 
 $SPEC{parse_cmdline} = {
     v => 1.1,
     summary => 'Parse shell command-line for processing by completion routines',
     description => <<'_',
 
 This function basically converts COMP_LINE (str) and COMP_POINT (int) into
 something like (but not exactly the same as) COMP_WORDS (array) and COMP_CWORD
 (int) that bash supplies to shell functions.
 
 The differences with bash are (these differences are mostly for parsing
 convenience for programs that use this routine):
 
 1) quotes and backslashes are stripped (bash's COMP_WORDS contains all the
 quotes and backslashes);
 
 2) variables are substituted with their values from environment variables except
 for the current word (COMP_WORDS[COMP_CWORD]) (bash does not perform variable
 substitution for COMP_WORDS). However, note that special shell variables that
 are not environment variables like `$0`, `$_`, `$IFS` will not be replaced
 correctly because bash does not export those variables for us.
 
 3) tildes (~) are expanded with user's home directory except for the current
 word (bash does not perform tilde expansion for COMP_WORDS);
 
 4) no word-breaking characters aside from whitespaces and `=` are currently used
 (bash uses COMP_WORDBREAKS which by default also include `:`, `;`, and so on).
 This is done for convenience of parsing of Getopt::Long-based applications. More
 word-breaking characters might be used in the future, e.g. when we want to
 handle complex bash statements like pipes, redirection, etc.
 
 Caveats:
 
 * Due to the way bash parses the command line, the two below are equivalent:
 
     % cmd --foo=bar
     % cmd --foo = bar
 
 Because they both expand to `['--foo', '=', 'bar']`. But obviously
 `Getopt::Long` does not regard the two as equivalent.
 
 _
     args_as => 'array',
     args => {
         cmdline => {
             summary => 'Command-line, defaults to COMP_LINE environment',
             schema => 'str*',
             pos => 0,
         },
         point => {
             summary => 'Point/position to complete in command-line, '.
                 'defaults to COMP_POINT',
             schema => 'int*',
             pos => 1,
         },
     },
     result => {
         schema => ['array*', len=>2],
         description => <<'_',
 
 Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
 equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
 integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
 word to be completed is at `$words->[$cword]`.
 
 Note that COMP_LINE includes the command name. If you want the command-line
 arguments only (like in `@ARGV`), you need to strip the first element from
 `$words` and reduce `$cword` by 1.
 
 
 _
     },
     result_naked => 1,
     links => [
     ],
 };
 sub parse_cmdline {
     no warnings 'uninitialized';
     my ($line, $point) = @_;
 
     $line  //= $ENV{COMP_LINE};
     $point //= $ENV{COMP_POINT} // 0;
 
     die "$0: COMP_LINE not set, make sure this script is run under ".
         "bash completion (e.g. through complete -C)\n" unless defined $line;
 
     my @words;
     my $cword;
     my $pos = 0;
     my $pos_min_ws = 0;
     my $after_ws = 1;
     my $chunk;
     my $add_blank;
     my $is_cur_word;
     $line =~ s!(                                                 # 1) everything
                   (")((?: \\\\|\\"|[^"])*)(?:"|\z)(\s*)       |  # 2) open "  3) content  4) space after
                   (')((?: \\\\|\\'|[^'])*)(?:'|\z)(\s*)       |  # 5) open '  6) content  7) space after
                   ((?: \\\\|\\"|\\'|\\=|\\\s|[^"'=\s])+)(\s*) |  # 8) unquoted word  9) space after
                   = |
                   \s+
               )!
                   $pos += length($1);
                   #say "D:<$1> pos=$pos, point=$point, cword=$cword, after_ws=$after_ws";
 
                   if ($2 || $5 || defined($8)) {
                       # double-quoted/single-quoted/unquoted chunk
 
                       if (not(defined $cword)) {
                           $pos_min_ws = $pos - length($2 ? $4 : $5 ? $7 : $9);
                           #say "D:pos_min_ws=$pos_min_ws";
                           if ($point <= $pos_min_ws) {
                               $cword = @words - ($after_ws ? 0 : 1);
                           } elsif ($point < $pos) {
                               $cword = @words + 1 - ($after_ws ? 0 : 1);
                               $add_blank = 1;
                           }
                       }
 
                       if ($after_ws) {
                           $is_cur_word = defined($cword) && $cword==@words;
                       } else {
                           $is_cur_word = defined($cword) && $cword==@words-1;
                       }
                       $chunk =
                           $2 ? _add_double_quoted($3, $is_cur_word) :
                               $5 ? _add_single_quoted($6) :
                                   _add_unquoted($8, $is_cur_word, $after_ws);
                       if ($after_ws) {
                           push @words, $chunk;
                       } else {
                           $words[-1] .= $chunk;
                       }
                       if ($add_blank) {
                           push @words, '';
                           $add_blank = 0;
                       }
                       $after_ws = ($2 ? $4 : $5 ? $7 : $9) ? 1:0;
 
                   } elsif ($1 eq '=') {
                       # equal sign as word-breaking character
                       push @words, '=';
                       $after_ws = 1;
                   } else {
                       # whitespace
                       $after_ws = 1;
                   }
     !egx;
 
     $cword //= @words;
     $words[$cword] //= '';
 
     [\@words, $cword];
 }
 
 $SPEC{parse_options} = {
     v => 1.1,
     summary => 'Parse command-line for options and arguments, '.
         'more or less like Getopt::Long',
     description => <<'_',
 
 Parse command-line into words using `parse_cmdline()` then separate options and
 arguments. Since this routine does not accept `Getopt::Long` (this routine is
 meant to be a generic option parsing of command-lines), it uses a few simple
 rules to server the common cases:
 
 * After `--`, the rest of the words are arguments (just like Getopt::Long).
 
 * If we get something like `-abc` (a single dash followed by several letters) it
   is assumed to be a bundle of short options.
 
 * If we get something like `-MData::Dump` (a single dash, followed by a letter,
   followed by some letters *and* non-letters/numbers) it is assumed to be an
   option (`-M`) followed by a value.
 
 * If we get something like `--foo` it is a long option. If the next word is an
   option (starts with a `-`) then it is assumed that this option does not have
   argument. Otherwise, the next word is assumed to be this option's value.
 
 * Otherwise, it is an argument (that is, permute is assumed).
 
 _
 
     args => {
         cmdline => {
             summary => 'Command-line, defaults to COMP_LINE environment',
             schema => 'str*',
         },
         point => {
             summary => 'Point/position to complete in command-line, '.
                 'defaults to COMP_POINT',
             schema => 'int*',
         },
         words => {
             summary => 'Alternative to passing `cmdline` and `point`',
             schema => ['array*', of=>'str*'],
             description => <<'_',
 
 If you already did a `parse_cmdline()`, you can pass the words result (the first
 element) here to avoid calling `parse_cmdline()` twice.
 
 _
         },
         cword => {
             summary => 'Alternative to passing `cmdline` and `point`',
             schema => ['array*', of=>'str*'],
             description => <<'_',
 
 If you already did a `parse_cmdline()`, you can pass the cword result (the
 second element) here to avoid calling `parse_cmdline()` twice.
 
 _
         },
     },
     result => {
         schema => 'hash*',
     },
 };
 sub parse_options {
     my %args = @_;
 
     my ($words, $cword) = @_;
     if ($args{words}) {
         ($words, $cword) = ($args{words}, $args{cword});
     } else {
         ($words, $cword) = @{parse_cmdline($args{cmdline}, $args{point}, '=')};
     }
 
     my @types;
     my %opts;
     my @argv;
     my $type;
     $types[0] = 'command';
     my $i = 1;
     while ($i < @$words) {
         my $word = $words->[$i];
         if ($word eq '--') {
             if ($i == $cword) {
                 $types[$i] = 'opt_name';
                 $i++; next;
             }
             $types[$i] = 'separator';
             for ($i+1 .. @$words-1) {
                 $types[$_] = 'arg,' . @argv;
                 push @argv, $words->[$_];
             }
             last;
         } elsif ($word =~ /\A-(\w*)\z/) {
             $types[$i] = 'opt_name';
             for (split '', $1) {
                 push @{ $opts{$_} }, undef;
             }
             $i++; next;
         } elsif ($word =~ /\A-([\w?])(.*)/) {
             $types[$i] = 'opt_name';
             # XXX currently not completing option value
             push @{ $opts{$1} }, $2;
             $i++; next;
         } elsif ($word =~ /\A--(\w[\w-]*)\z/) {
             $types[$i] = 'opt_name';
             my $opt = $1;
             $i++;
             if ($i < @$words) {
                 if ($words->[$i] eq '=') {
                     $types[$i] = 'separator';
                     $i++;
                 }
                 if ($words->[$i] =~ /\A-/) {
                     push @{ $opts{$opt} }, undef;
                     next;
                 }
                 $types[$i] = 'opt_val';
                 push @{ $opts{$opt} }, $words->[$i];
                 $i++; next;
             }
         } else {
             $types[$i] = 'arg,' . @argv;
             push @argv, $word;
             $i++; next;
         }
     }
 
     return {
         opts      => \%opts,
         argv      => \@argv,
         cword     => $cword,
         words     => $words,
         word_type => $types[$cword],
         #_types    => \@types,
     };
 }
 
 $SPEC{format_completion} = {
     v => 1.1,
     summary => 'Format completion for output (for shell)',
     description => <<'_',
 
 Bash accepts completion reply in the form of one entry per line to STDOUT. Some
 characters will need to be escaped. This function helps you do the formatting,
 with some options.
 
 This function accepts completion answer structure as described in the `Complete`
 POD. Aside from `words`, this function also recognizes these keys:
 
 * `as` (str): Either `string` (the default) or `array` (to return array of lines
   instead of the lines joined together). Returning array is useful if you are
   doing completion inside `Term::ReadLine`, for example, where the library
   expects an array.
 
 * `esc_mode` (str): Escaping mode for entries. Either `default` (most
   nonalphanumeric characters will be escaped), `shellvar` (like `default`, but
   dollar sign `$` will not be escaped, convenient when completing environment
   variables for example), `filename` (currently equals to `default`), `option`
   (currently equals to `default`), or `none` (no escaping will be done).
 
 * `path_sep` (str): If set, will enable "path mode", useful for
   completing/drilling-down path. Below is the description of "path mode".
 
   In shell, when completing filename (e.g. `foo`) and there is only a single
   possible completion (e.g. `foo` or `foo.txt`), the shell will display the
   completion in the buffer and automatically add a space so the user can move to
   the next argument. This is also true when completing other values like
   variables or program names.
 
   However, when completing directory (e.g. `/et` or `Downloads`) and there is
   solely a single completion possible and it is a directory (e.g. `/etc` or
   `Downloads`), the shell automatically adds the path separator character
   instead (`/etc/` or `Downloads/`). The user can press Tab again to complete
   for files/directories inside that directory, and so on. This is obviously more
   convenient compared to when shell adds a space instead.
 
   The `path_sep` option, when set, will employ a trick to mimic this behaviour.
   The trick is, if you have a completion array of `['foo/']`, it will be changed
   to `['foo/', 'foo/ ']` (the second element is the first element with added
   space at the end) to prevent bash from adding a space automatically.
 
   Path mode is not restricted to completing filesystem paths. Anything path-like
   can use it. For example when you are completing Java or Perl module name (e.g.
   `com.company.product.whatever` or `File::Spec::Unix`) you can use this mode
   (with `path_sep` appropriately set to, e.g. `.` or `::`).
 
 _
     args_as => 'array',
     args => {
         completion => {
             summary => 'Completion answer structure',
             description => <<'_',
 
 Either an array or hash. See function description for more details.
 
 _
             schema=>['any*' => of => ['hash*', 'array*']],
             req=>1,
             pos=>0,
         },
         opts => {
             schema=>'hash*',
             pos=>1,
         },
     },
     result => {
         summary => 'Formatted string (or array, if `as` is set to `array`)',
         schema => ['any*' => of => ['str*', 'array*']],
     },
     result_naked => 1,
 };
 sub format_completion {
     my ($hcomp, $opts) = @_;
 
     $opts //= {};
 
     $hcomp = {words=>$hcomp} unless ref($hcomp) eq 'HASH';
     my $comp     = $hcomp->{words};
     my $as       = $hcomp->{as} // 'string';
     # 'escmode' key is deprecated (Complete 0.11-) and will be removed later
     my $esc_mode = $hcomp->{esc_mode} // $hcomp->{escmode} // 'default';
     my $path_sep = $hcomp->{path_sep};
 
     if (defined($path_sep) && @$comp == 1) {
         my $re = qr/\Q$path_sep\E\z/;
         my $word;
         if (ref($comp->[0]) eq 'HASH') {
             $comp = [$comp->[0], {word=>"$comp->[0] "}] if
                 $comp->[0]{word} =~ $re;
         } else {
             $comp = [$comp->[0], "$comp->[0] "]
                 if $comp->[0] =~ $re;
         }
     }
 
     # XXX this is currently an ad-hoc solution, need to formulate a
     # name/interface for the more generic solution. since bash breaks words
     # differently than us (we only break using '" and whitespace, while bash
     # breaks using characters in $COMP_WORDBREAKS, by default is "'><=;|&(:),
     # this presents a problem we often encounter: if we want to provide with a
     # list of strings containing ':', most often Perl modules/packages, if user
     # types e.g. "Text::AN" and we provide completion ["Text::ANSI"] then bash
     # will change the word at cursor to become "Text::Text::ANSI" since it sees
     # the current word as "AN" and not "Text::AN". the workaround is to chop
     # /^Text::/ from completion answers. btw, we actually chop /^text::/i to
     # handle case-insensitive matching, although this does not have the ability
     # to replace the current word (e.g. if we type 'text::an' then bash can only
     # replace the current word 'an' with 'ANSI). also, we currently only
     # consider ':' since that occurs often.
     if (defined($opts->{word})) {
         if ($opts->{word} =~ s/(.+:)//) {
             my $prefix = $1;
             for (@$comp) {
                 if (ref($_) eq 'HASH') {
                     $_->{word} =~ s/\A\Q$prefix\E//i;
                 } else {
                     s/\A\Q$prefix\E//i;
                 }
             }
         }
     }
 
     my @res;
     for my $entry (@$comp) {
         my $word = ref($entry) eq 'HASH' ? $entry->{word} : $entry;
         if ($esc_mode eq 'shellvar') {
             # don't escape $
             $word =~ s!([^A-Za-z0-9,+._/\$~-])!\\$1!g;
         } elsif ($esc_mode eq 'none') {
             # no escaping
         } else {
             # default
             $word =~ s!([^A-Za-z0-9,+._/:~-])!\\$1!g;
         }
         push @res, $word;
     }
 
     if ($as eq 'array') {
         return \@res;
     } else {
         return join("", map {($_, "\n")} @res);
     }
 }
 
 1;
 # ABSTRACT: Completion module for bash shell
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete::Bash - Completion module for bash shell
 
 =head1 VERSION
 
 This document describes version 0.19 of Complete::Bash (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-02.
 
 =head1 DESCRIPTION
 
 Bash allows completion to come from various sources. The simplest is from a list
 of words (C<-W>):
 
  % complete -W "one two three four" somecmd
  % somecmd t<Tab>
  two  three
 
 Another source is from a bash function (C<-F>). The function will receive input
 in two variables: C<COMP_WORDS> (array, command-line chopped into words) and
 C<COMP_CWORD> (integer, index to the array of words indicating the cursor
 position). It must set an array variable C<COMPREPLY> that contains the list of
 possible completion:
 
  % _foo()
  {
    local cur
    COMPREPLY=()
    cur=${COMP_WORDS[COMP_CWORD]}
    COMPREPLY=($( compgen -W '--help --verbose --version' -- $cur ) )
  }
  % complete -F _foo foo
  % foo <Tab>
  --help  --verbose  --version
 
 And yet another source is an external command (including, a Perl script). The
 command receives two environment variables: C<COMP_LINE> (string, raw
 command-line) and C<COMP_POINT> (integer, cursor location). Program must split
 C<COMP_LINE> into words, find the word to be completed, complete that, and
 return the list of words one per-line to STDOUT. An example:
 
  % cat foo-complete
  #!/usr/bin/perl
  use Complete::Bash qw(parse_cmdline format_completion);
  use Complete::Util qw(complete_array_elem);
  my ($words, $cword) = @{ parse_cmdline() };
  my $res = complete_array_elem(array=>[qw/--help --verbose --version/], word=>$words->[$cword]);
  print format_completion($res);
 
  % complete -C foo-complete foo
  % foo --v<Tab>
  --verbose --version
 
 This module provides routines for you to be doing the above.
 
 =head1 FUNCTIONS
 
 
 =head2 format_completion($completion, $opts) -> str|array
 
 Format completion for output (for shell).
 
 Bash accepts completion reply in the form of one entry per line to STDOUT. Some
 characters will need to be escaped. This function helps you do the formatting,
 with some options.
 
 This function accepts completion answer structure as described in the C<Complete>
 POD. Aside from C<words>, this function also recognizes these keys:
 
 =over
 
 =item * C<as> (str): Either C<string> (the default) or C<array> (to return array of lines
 instead of the lines joined together). Returning array is useful if you are
 doing completion inside C<Term::ReadLine>, for example, where the library
 expects an array.
 
 =item * C<esc_mode> (str): Escaping mode for entries. Either C<default> (most
 nonalphanumeric characters will be escaped), C<shellvar> (like C<default>, but
 dollar sign C<$> will not be escaped, convenient when completing environment
 variables for example), C<filename> (currently equals to C<default>), C<option>
 (currently equals to C<default>), or C<none> (no escaping will be done).
 
 =item * C<path_sep> (str): If set, will enable "path mode", useful for
 completing/drilling-down path. Below is the description of "path mode".
 
 In shell, when completing filename (e.g. C<foo>) and there is only a single
 possible completion (e.g. C<foo> or C<foo.txt>), the shell will display the
 completion in the buffer and automatically add a space so the user can move to
 the next argument. This is also true when completing other values like
 variables or program names.
 
 However, when completing directory (e.g. C</et> or C<Downloads>) and there is
 solely a single completion possible and it is a directory (e.g. C</etc> or
 C<Downloads>), the shell automatically adds the path separator character
 instead (C</etc/> or C<Downloads/>). The user can press Tab again to complete
 for files/directories inside that directory, and so on. This is obviously more
 convenient compared to when shell adds a space instead.
 
 The C<path_sep> option, when set, will employ a trick to mimic this behaviour.
 The trick is, if you have a completion array of C<['foo/']>, it will be changed
 to C<['foo/', 'foo/ ']> (the second element is the first element with added
 space at the end) to prevent bash from adding a space automatically.
 
 Path mode is not restricted to completing filesystem paths. Anything path-like
 can use it. For example when you are completing Java or Perl module name (e.g.
 C<com.company.product.whatever> or C<File::Spec::Unix>) you can use this mode
 (with C<path_sep> appropriately set to, e.g. C<.> or C<::>).
 
 =back
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<completion>* => I<hash|array>
 
 Completion answer structure.
 
 Either an array or hash. See function description for more details.
 
 =item * B<opts> => I<hash>
 
 =back
 
 Return value: Formatted string (or array, if `as` is set to `array`) (str|array)
 
 
 =head2 parse_cmdline($cmdline, $point) -> array
 
 Parse shell command-line for processing by completion routines.
 
 This function basically converts COMP_LINE (str) and COMP_POINT (int) into
 something like (but not exactly the same as) COMP_WORDS (array) and COMP_CWORD
 (int) that bash supplies to shell functions.
 
 The differences with bash are (these differences are mostly for parsing
 convenience for programs that use this routine):
 
 1) quotes and backslashes are stripped (bash's COMP_WORDS contains all the
 quotes and backslashes);
 
 2) variables are substituted with their values from environment variables except
 for the current word (COMP_WORDS[COMP_CWORD]) (bash does not perform variable
 substitution for COMP_WORDS). However, note that special shell variables that
 are not environment variables like C<$0>, C<$_>, C<$IFS> will not be replaced
 correctly because bash does not export those variables for us.
 
 3) tildes (~) are expanded with user's home directory except for the current
 word (bash does not perform tilde expansion for COMP_WORDS);
 
 4) no word-breaking characters aside from whitespaces and C<=> are currently used
 (bash uses COMP_WORDBREAKS which by default also include C<:>, C<;>, and so on).
 This is done for convenience of parsing of Getopt::Long-based applications. More
 word-breaking characters might be used in the future, e.g. when we want to
 handle complex bash statements like pipes, redirection, etc.
 
 Caveats:
 
 =over
 
 =item * Due to the way bash parses the command line, the two below are equivalent:
 
 % cmd --foo=bar
 % cmd --foo = bar
 
 =back
 
 Because they both expand to C<['--foo', '=', 'bar']>. But obviously
 C<Getopt::Long> does not regard the two as equivalent.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<cmdline> => I<str>
 
 Command-line, defaults to COMP_LINE environment.
 
 =item * B<point> => I<int>
 
 Point/position to complete in command-line, defaults to COMP_POINT.
 
 =back
 
 Return value:  (array)
 
 
 Return a 2-element array: C<[$words, $cword]>. C<$words> is array of str,
 equivalent to C<COMP_WORDS> provided by bash to shell functions. C<$cword> is an
 integer, equivalent to C<COMP_CWORD> provided by bash to shell functions. The
 word to be completed is at C<< $words-E<gt>[$cword] >>.
 
 Note that COMP_LINE includes the command name. If you want the command-line
 arguments only (like in C<@ARGV>), you need to strip the first element from
 C<$words> and reduce C<$cword> by 1.
 
 
 =head2 parse_options(%args) -> [status, msg, result, meta]
 
 Parse command-line for options and arguments, more or less like Getopt::Long.
 
 Parse command-line into words using C<parse_cmdline()> then separate options and
 arguments. Since this routine does not accept C<Getopt::Long> (this routine is
 meant to be a generic option parsing of command-lines), it uses a few simple
 rules to server the common cases:
 
 =over
 
 =item * After C<-->, the rest of the words are arguments (just like Getopt::Long).
 
 =item * If we get something like C<-abc> (a single dash followed by several letters) it
 is assumed to be a bundle of short options.
 
 =item * If we get something like C<-MData::Dump> (a single dash, followed by a letter,
 followed by some letters I<and> non-letters/numbers) it is assumed to be an
 option (C<-M>) followed by a value.
 
 =item * If we get something like C<--foo> it is a long option. If the next word is an
 option (starts with a C<->) then it is assumed that this option does not have
 argument. Otherwise, the next word is assumed to be this option's value.
 
 =item * Otherwise, it is an argument (that is, permute is assumed).
 
 =back
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<cmdline> => I<str>
 
 Command-line, defaults to COMP_LINE environment.
 
 =item * B<cword> => I<array[str]>
 
 Alternative to passing `cmdline` and `point`.
 
 If you already did a C<parse_cmdline()>, you can pass the cword result (the
 second element) here to avoid calling C<parse_cmdline()> twice.
 
 =item * B<point> => I<int>
 
 Point/position to complete in command-line, defaults to COMP_POINT.
 
 =item * B<words> => I<array[str]>
 
 Alternative to passing `cmdline` and `point`.
 
 If you already did a C<parse_cmdline()>, you can pass the words result (the first
 element) here to avoid calling C<parse_cmdline()> twice.
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (hash)
 
 =head1 SEE ALSO
 
 
 L<Complete>
 
 =head1 SEE ALSO (2)
 
 Other modules related to bash shell tab completion: L<Bash::Completion>,
 L<Getopt::Complete>. L<Term::Bash::Completion::Generator>
 
 Programmable Completion section in Bash manual:
 L<https://www.gnu.org/software/bash/manual/html_node/Programmable-Completion.html>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete-Bash>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete-Bash>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Bash>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Complete/Getopt/Long.pm ###
 package Complete::Getopt::Long;
 
 our $DATE = '2015-04-25'; # DATE
 our $VERSION = '0.32'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 use Log::Any::IfLOG '$log';
 
 #use Complete;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        complete_cli_arg
                );
 
 our %SPEC;
 
 sub _default_completion {
     my %args = @_;
     my $word = $args{word} // '';
 
     my $fres;
     $log->tracef('[comp][compgl] entering default completion routine');
 
     # try completing '$...' with shell variables
     if ($word =~ /\A\$/) {
         $log->tracef('[comp][compgl] completing shell variable');
         require Complete::Util;
         {
             my $compres = Complete::Util::complete_env(
                 word=>$word);
             last unless @$compres;
             $fres = {words=>$compres, esc_mode=>'shellvar'};
             goto RETURN_RES;
         }
         # if empty, fallback to searching file
     }
 
     # try completing '~foo' with user dir (appending / if user's home exists)
     if ($word =~ m!\A~([^/]*)\z!) {
         $log->tracef("[comp][compgl] completing userdir, user=%s", $1);
         {
             eval { require Unix::Passwd::File };
             last if $@;
             my $res = Unix::Passwd::File::list_users(detail=>1);
             last unless $res->[0] == 200;
             my $compres = Complete::Util::complete_array(
                 array=>[map {"~" . $_->{user} . ((-d $_->{home}) ? "/":"")}
                             @{ $res->[2] }],
                 word=>$word,
             );
             last unless @$compres;
             $fres = {words=>$compres, path_sep=>'/'};
             goto RETURN_RES;
         }
         # if empty, fallback to searching file
     }
 
     # try completing '~/blah' or '~foo/blah' as if completing file, but do not
     # expand ~foo (this is supported by complete_file(), so we just give it off
     # to the routine)
     if ($word =~ m!\A(~[^/]*)/!) {
         $log->tracef("[comp][compgl] completing file, path=<%s>", $word);
         $fres = {words=>Complete::Util::complete_file(word=>$word),
                  path_sep=>'/'};
         goto RETURN_RES;
     }
 
     # try completing something that contains wildcard with glob. for
     # convenience, we add '*' at the end so that when user type [AB] it is
     # treated like [AB]*.
     require String::Wildcard::Bash;
     if (String::Wildcard::Bash::contains_wildcard($word)) {
         $log->tracef("[comp][compgl] completing with wildcard glob, glob=<%s>", "$word*");
         {
             my $compres = [glob("$word*")];
             last unless @$compres;
             for (@$compres) {
                 $_ .= "/" if (-d $_);
             }
             $fres = {words=>$compres, path_sep=>'/'};
             goto RETURN_RES;
         }
         # if empty, fallback to searching file
     }
     $log->tracef("[comp][compgl] completing with file, file=<%s>", $word);
     $fres = {words=>Complete::Util::complete_file(word=>$word),
              path_sep=>'/'};
   RETURN_RES:
     $log->tracef("[comp][compgl] leaving default completion routine, result=%s", $fres);
     $fres;
 }
 
 # return the key/element if $opt matches exactly a key/element in $opts (which
 # can be an array/hash) OR expands unambiguously to exactly one key/element in
 # $opts, otherwise return undef. e.g. _expand1('--fo', [qw/--foo --bar --baz
 # --fee --feet/]) and _expand('--fee', ...) will respectively return '--foo' and
 # '--fee' because it expands/is unambiguous in the list, but _expand1('--ba',
 # ...) or _expand1('--qux', ...) will both return undef because '--ba' expands
 # ambiguously (--bar/--baz) while '--qux' cannot be expanded.
 sub _expand1 {
     my ($opt, $opts) = @_;
     my @candidates;
     my $is_hash = ref($opts) eq 'HASH';
     for ($is_hash ? (sort {length($a)<=>length($b)} keys %$opts) : @$opts) {
         next unless index($_, $opt) == 0;
         push @candidates, $is_hash ? $opts->{$_} : $_;
         last if $opt eq $_;
     }
     return @candidates == 1 ? $candidates[0] : undef;
 }
 
 # mark an option (and all its aliases) as seen
 sub _mark_seen {
     my ($seen_opts, $opt, $opts) = @_;
     my $opthash = $opts->{$opt};
     return unless $opthash;
     my $ospec = $opthash->{ospec};
     for (keys %$opts) {
         my $v = $opts->{$_};
         $seen_opts->{$_}++ if $v->{ospec} eq $ospec;
     }
 }
 
 $SPEC{complete_cli_arg} = {
     v => 1.1,
     summary => 'Complete command-line argument using '.
         'Getopt::Long specification',
     description => <<'_',
 
 This routine can complete option names, where the option names are retrieved
 from `Getopt::Long` specification. If you provide completion routine in
 `completion`, you can also complete _option values_ and _arguments_.
 
 Note that this routine does not use `Getopt::Long` (it does its own parsing) and
 currently is not affected by Getopt::Long's configuration. Its behavior mimics
 Getopt::Long under these configuration: `no_ignore_case`, `bundling` (or
 `no_bundling` if the `bundling` option is turned off). Which I think is the
 sensible default. This routine also does not currently support `auto_help` and
 `auto_version`, so you'll need to add those options specifically if you want to
 recognize `--help/-?` and `--version`, respectively.
 
 _
     args => {
         getopt_spec => {
             summary => 'Getopt::Long specification',
             schema  => 'hash*',
             req     => 1,
         },
         completion => {
             summary     =>
                 'Completion routine to complete option value/argument',
             schema      => 'code*',
             description => <<'_',
 
 Completion code will receive a hash of arguments (`%args`) containing these
 keys:
 
 * `type` (str, what is being completed, either `optval`, or `arg`)
 * `word` (str, word to be completed)
 * `cword` (int, position of words in the words array, starts from 0)
 * `opt` (str, option name, e.g. `--str`; undef if we're completing argument)
 * `ospec` (str, Getopt::Long option spec, e.g. `str|S=s`; undef when completing
   argument)
 * `argpos` (int, argument position, zero-based; undef if type='optval')
 * `nth` (int, the number of times this option has seen before, starts from 0
   that means this is the first time this option has been seen; undef when
   type='arg')
 * `seen_opts` (hash, all the options seen in `words`)
 * `parsed_opts` (hash, options parsed the standard/raw way)
 
 as well as all keys from `extras` (but these won't override the above keys).
 
 and is expected to return a completion answer structure as described in
 `Complete` which is either a hash or an array. The simplest form of answer is
 just to return an array of strings. The various `complete_*` function like those
 in `Complete::Util` or the other `Complete::*` modules are suitable to use here.
 
 Completion routine can also return undef to express declination, in which case
 the default completion routine will then be consulted. The default routine
 completes from shell environment variables (`$FOO`), Unix usernames (`~foo`),
 and files/directories.
 
 Example:
 
     use Complete::Unix qw(complete_user);
     use Complete::Util qw(complete_array_elem);
     complete_cli_arg(
         getopt_spec => {
             'help|h'   => sub{...},
             'format=s' => \$format,
             'user=s'   => \$user,
         },
         completion  => sub {
             my %args  = @_;
             my $word  = $args{word};
             my $ospec = $args{ospec};
             if ($ospec && $ospec eq 'format=s') {
                 complete_array(array=>[qw/json text xml yaml/], word=>$word);
             } else {
                 complete_user(word=>$word);
             }
         },
     );
 
 _
         },
         words => {
             summary     => 'Command line arguments, like @ARGV',
             description => <<'_',
 
 See function `parse_cmdline` in `Complete::Bash` on how to produce this (if
 you're using bash).
 
 _
             schema      => 'array*',
             req         => 1,
         },
         cword => {
             summary     =>
                 "Index in words of the word we're trying to complete",
             description => <<'_',
 
 See function `parse_cmdline` in `Complete::Bash` on how to produce this (if
 you're using bash).
 
 _
             schema      => 'int*',
             req         => 1,
         },
         extras => {
             summary => 'Add extra arguments to completion routine',
             schema  => 'hash',
             description => <<'_',
 
 The keys from this `extras` hash will be merged into the final `%args` passed to
 completion routines. Note that standard keys like `type`, `word`, and so on as
 described in the function description will not be overwritten by this.
 
 _
         },
         bundling => {
             schema  => 'bool*',
             default => 1,
             'summary.alt.bool.not' => 'Turn off bundling',
             description => <<'_',
 
 If you turn off bundling, completion of short-letter options won't support
 bundling (e.g. `-b<tab>` won't add more single-letter options), but single-dash
 multiletter options can be recognized. Currently only those specified with a
 single dash will be completed. For example if you have `-foo=s` in your option
 specification, `-f<tab>` can complete it.
 
 This can be used to complete old-style programs, e.g. emacs which has options
 like `-nw`, `-nbc` etc (but also have double-dash options like
 `--no-window-system` or `--no-blinking-cursor`).
 
 _
         },
     },
     result_naked => 1,
     result => {
         schema => ['any*' => of => ['hash*', 'array*']],
         description => <<'_',
 
 You can use `format_completion` function in `Complete::Bash` module to format
 the result of this function for bash.
 
 _
     },
 };
 sub complete_cli_arg {
     require Complete::Util;
     require Getopt::Long::Util;
 
     my %args = @_;
 
     my $fname = __PACKAGE__ . "::complete_cli_arg"; # XXX use __SUB__
     my $fres;
 
     $args{words} or die "Please specify words";
     my @words = @{ $args{words} };
     defined(my $cword = $args{cword}) or die "Please specify cword";
     my $gospec = $args{getopt_spec} or die "Please specify getopt_spec";
     my $comp = $args{completion};
     my $extras = $args{extras} // {};
     my $bundling = $args{bundling} // 1;
     my %parsed_opts;
 
     $log->tracef('[comp][compgl] entering %s(), words=%s, cword=%d, word=<%s>',
                  $fname, \@words, $cword, $words[$cword]);
 
     # parse all options first & supply default completion routine
     my %opts;
     for my $ospec (keys %$gospec) {
         my $res = Getopt::Long::Util::parse_getopt_long_opt_spec($ospec)
             or die "Can't parse option spec '$ospec'";
         $res->{min_vals} //= $res->{type} ? 1 : 0;
         $res->{max_vals} //= $res->{type} || $res->{opttype} ? 1:0;
         for my $o0 (@{ $res->{opts} }) {
             my @o = $res->{is_neg} && length($o0) > 1 ?
                 ($o0, "no$o0", "no-$o0") : ($o0);
             for my $o (@o) {
                 my $k = length($o)==1 ||
                     (!$bundling && $res->{dash_prefix} eq '-') ?
                         "-$o" : "--$o";
                 $opts{$k} = {
                     name => $k,
                     ospec => $ospec, # key to getopt specification
                     parsed => $res,
                 };
             }
         }
     }
     my @optnames = sort keys %opts;
 
     my %seen_opts;
 
     # for each word, we try to find out whether it's supposed to complete option
     # name, or option value, or argument, or separator (or more than one of
     # them). plus some other information.
     my @expects;
 
     my $i = -1;
     my $argpos = 0;
 
   WORD:
     while (1) {
         last WORD if ++$i >= @words;
         my $word = $words[$i];
         #say "D:i=$i, word=$word, ~~@words=",~~@words;
 
         if ($word eq '--' && $i != $cword) {
             $expects[$i] = {separator=>1};
             while (1) {
                 $i++;
                 last WORD if $i >= @words;
                 $expects[$i] = {arg=>1, argpos=>$argpos++};
             }
         }
 
         if ($word =~ /\A-/) {
 
             # split bundled short options
           SPLIT_BUNDLED:
             {
                 last unless $bundling;
                 my $shorts = $word;
                 if ($shorts =~ s/\A-([^-])(.*)/$2/) {
                     my $opt = "-$1";
                     my $opthash = $opts{$opt};
                     if (!$opthash || $opthash->{parsed}{max_vals}) {
                         last SPLIT_BUNDLED;
                     }
                     $words[$i] = $word = "-$1";
                     $expects[$i]{prefix} = $word;
                     $expects[$i]{word} = '';
                     $expects[$i]{short_only} = 1;
                     my $len_before_split = @words;
                     my $j = $i+1;
                   SHORTOPT:
                     while ($shorts =~ s/(.)//) {
                         $opt = "-$1";
                         $opthash = $opts{$opt};
                         if (!$opthash || $opthash->{parsed}{max_vals}) {
                             # end after unknown short option or short option
                             # expects value, and don't complete this optname
                             # later
                             $expects[$i]{do_complete_optname} = 0;
                             if (length $shorts) {
                                 splice @words, $j, 0, $opt, '=', $shorts;
                                 $j += 3;
                             } else {
                                 splice @words, $j, 0, $opt;
                                 $j++;
                             }
                             last SHORTOPT;
                         } else {
                             splice @words, $j, 0, $opt;
                             $j++;
                             # continue splitting
                         }
                     }
                     $cword += @words-$len_before_split if $cword > $i;
                     #say "D:words increases ", @words-$len_before_split;
                 }
             }
 
             # split --foo=val -> --foo, =, val
           SPLIT_EQUAL:
             {
                 if ($word =~ /\A(--?[^=]+)(=)(.*)/) {
                     splice @words, $i, 1, $1, $2, $3;
                     $word = $1;
                     $cword += 2 if $cword >= $i;
                 }
             }
 
             my $opt = $word;
             my $opthash = _expand1($opt, \%opts);
 
             if ($opthash) {
                 $opt = $opthash->{name};
                 $expects[$i]{optname} = $opt;
                 my $nth = $seen_opts{$opt} // 0;
                 $expects[$i]{nth} = $nth;
                 _mark_seen(\%seen_opts, $opt, \%opts);
 
                 my $min_vals = $opthash->{parsed}{min_vals};
                 my $max_vals = $opthash->{parsed}{max_vals};
                 #say "D:min_vals=$min_vals, max_vals=$max_vals";
 
                 # detect = after --opt
                 if ($i+1 < @words && $words[$i+1] eq '=') {
                     $i++;
                     $expects[$i] = {separator=>1, optval=>$opt, word=>'', nth=>$nth};
                     # force a value due to =
                     if (!$max_vals) { $min_vals = $max_vals = 1 }
                 }
 
                 push @{ $parsed_opts{$opt} }, $words[$i+1];
                 for (1 .. $min_vals) {
                     $i++;
                     last WORD if $i >= @words;
                     $expects[$i]{optval} = $opt;
                     $expects[$i]{nth} = $nth;
                 }
                 for (1 .. $max_vals-$min_vals) {
                     last if $i+$_ >= @words;
                     last if $words[$i+$_] =~ /\A-/; # a new option
                     $expects[$i+$_]{optval} = $opt; # but can also be optname
                     $expects[$i]{nth} = $nth;
                 }
             } else {
                 # an unknown option, assume it doesn't require argument, unless
                 # it's --opt= or --opt=foo
                 $opt = undef;
                 $expects[$i]{optname} = $opt;
 
                 # detect = after --opt
                 if ($i+1 < @words && $words[$i+1] eq '=') {
                     $i++;
                     $expects[$i] = {separator=>1, optval=>undef, word=>''};
                     if ($i+1 < @words) {
                         $i++;
                         $expects[$i]{optval} = $opt;
                     }
                 }
             }
         } else {
             $expects[$i]{optname} = '';
             $expects[$i]{arg} = 1;
             $expects[$i]{argpos} = $argpos++;
         }
     }
 
     #use DD; print "D:words: "; dd \@words;
     #say "D:cword: $cword";
     #use DD; print "D:expects: "; dd \@expects;
     #use DD; print "D:seen_opts: "; dd \%seen_opts;
     #use DD; print "D:parsed_opts: "; dd \%parsed_opts;
 
     my $exp = $expects[$cword];
     my $word = $exp->{word} // $words[$cword];
 
     my @answers;
 
     # complete option names
     {
         last unless exists $exp->{optname};
         last if defined($exp->{do_complete_optname}) &&
             !$exp->{do_complete_optname};
         my $opt = $exp->{optname};
         my @o;
         for (@optnames) {
             #say "D:$_";
             my $repeatable = 0;
             next if $exp->{short_only} && /\A--/;
             if ($seen_opts{$_}) {
                 my $opthash = $opts{$_};
                 my $ospecval = $gospec->{$opthash->{ospec}};
                 my $parsed = $opthash->{parsed};
                 if (ref($ospecval) eq 'ARRAY') {
                     $repeatable = 1;
                 } elsif ($parsed->{desttype} || $parsed->{is_inc}) {
                     $repeatable = 1;
                 }
             }
             # skip options that have been specified and not repeatable
             #use DD; dd {'$_'=>$_, seen=>$seen_opts{$_}, repeatable=>$repeatable, opt=>$opt};
             next if $seen_opts{$_} && !$repeatable && (
                 # long option has been specified
                 (!$opt || $opt ne $_) ||
                      # short option (in a bundle) has been specified
                     (defined($exp->{prefix}) &&
                          index($exp->{prefix}, substr($opt, 1, 1)) >= 0));
             if (defined $exp->{prefix}) {
                 my $o = $_; $o =~ s/\A-//;
                 push @o, "$exp->{prefix}$o";
             } else {
                 push @o, $_;
             }
         }
         #use DD; dd \@o;
         my $compres = Complete::Util::complete_array_elem(
             array => \@o, word => $word);
         $log->tracef('[comp][compgl] adding result from option names, '.
                          'matching options=%s', $compres);
         push @answers, $compres;
         if (!exists($exp->{optval}) && !exists($exp->{arg})) {
             $fres = {words=>$compres, esc_mode=>'option'};
             goto RETURN_RES;
         }
     }
 
     # complete option value
     {
         last unless exists($exp->{optval});
         my $opt = $exp->{optval};
         my $opthash = $opts{$opt} if $opt;
         my %compargs = (
             %$extras,
             type=>'optval', words=>\@words, cword=>$args{cword},
             word=>$word, opt=>$opt, ospec=>$opthash->{ospec},
             argpos=>undef, nth=>$exp->{nth}, seen_opts=>\%seen_opts,
             parsed_opts=>\%parsed_opts,
         );
         my $compres;
         if ($comp) {
             $log->tracef("[comp][compgl] invoking routine supplied from 'completion' argument to complete option value, option=<%s>", $opt);
             $compres = $comp->(%compargs);
             $log->tracef('[comp][compgl] adding result from routine: %s', $compres);
         }
         if (!$compres || !$comp) {
             $compres = _default_completion(%compargs);
             $log->tracef('[comp][compgl] adding result from default '.
                              'completion routine');
         }
         push @answers, $compres;
     }
 
     # complete argument
     {
         last unless exists($exp->{arg});
         my %compargs = (
             %$extras,
             type=>'arg', words=>\@words, cword=>$args{cword},
             word=>$word, opt=>undef, ospec=>undef,
             argpos=>$exp->{argpos}, seen_opts=>\%seen_opts,
             parsed_opts=>\%parsed_opts,
         );
         $log->tracef('[comp][compgl] invoking \'completion\' routine '.
                          'to complete argument');
         my $compres = $comp->(%compargs);
         if (!defined $compres) {
             $compres = _default_completion(%compargs);
             $log->tracef('[comp][compgl] adding result from default '.
                              'completion routine: %s', $compres);
         }
         push @answers, $compres;
     }
 
     $log->tracef("[comp][compgl] combining result from %d source(s)", ~~@answers);
     $fres = Complete::Util::combine_answers(@answers) // [];
 
   RETURN_RES:
     $log->tracef("[comp][compgl] leaving %s(), result=%s", $fname, $fres);
     $fres;
 }
 
 1;
 # ABSTRACT: Complete command-line argument using Getopt::Long specification
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete::Getopt::Long - Complete command-line argument using Getopt::Long specification
 
 =head1 VERSION
 
 This document describes version 0.32 of Complete::Getopt::Long (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-25.
 
 =head1 SYNOPSIS
 
 See L<Getopt::Long::Complete> for an easy way to use this module.
 
 =head1 DESCRIPTION
 
 Note that I deliberately do not support C<ci> (case-insensitive) option here.
 Options that differ only in case often are often and they mean different things.
 
 =head1 FUNCTIONS
 
 
 =head2 complete_cli_arg(%args) -> hash|array
 
 Complete command-line argument using Getopt::Long specification.
 
 This routine can complete option names, where the option names are retrieved
 from C<Getopt::Long> specification. If you provide completion routine in
 C<completion>, you can also complete I<option values> and I<arguments>.
 
 Note that this routine does not use C<Getopt::Long> (it does its own parsing) and
 currently is not affected by Getopt::Long's configuration. Its behavior mimics
 Getopt::Long under these configuration: C<no_ignore_case>, C<bundling> (or
 C<no_bundling> if the C<bundling> option is turned off). Which I think is the
 sensible default. This routine also does not currently support C<auto_help> and
 C<auto_version>, so you'll need to add those options specifically if you want to
 recognize C<--help/-?> and C<--version>, respectively.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<bundling> => I<bool> (default: 1)
 
 If you turn off bundling, completion of short-letter options won't support
 bundling (e.g. C<< -bE<lt>tabE<gt> >> won't add more single-letter options), but single-dash
 multiletter options can be recognized. Currently only those specified with a
 single dash will be completed. For example if you have C<-foo=s> in your option
 specification, C<< -fE<lt>tabE<gt> >> can complete it.
 
 This can be used to complete old-style programs, e.g. emacs which has options
 like C<-nw>, C<-nbc> etc (but also have double-dash options like
 C<--no-window-system> or C<--no-blinking-cursor>).
 
 =item * B<completion> => I<code>
 
 Completion routine to complete option value/argument.
 
 Completion code will receive a hash of arguments (C<%args>) containing these
 keys:
 
 =over
 
 =item * C<type> (str, what is being completed, either C<optval>, or C<arg>)
 
 =item * C<word> (str, word to be completed)
 
 =item * C<cword> (int, position of words in the words array, starts from 0)
 
 =item * C<opt> (str, option name, e.g. C<--str>; undef if we're completing argument)
 
 =item * C<ospec> (str, Getopt::Long option spec, e.g. C<str|S=s>; undef when completing
 argument)
 
 =item * C<argpos> (int, argument position, zero-based; undef if type='optval')
 
 =item * C<nth> (int, the number of times this option has seen before, starts from 0
 that means this is the first time this option has been seen; undef when
 type='arg')
 
 =item * C<seen_opts> (hash, all the options seen in C<words>)
 
 =item * C<parsed_opts> (hash, options parsed the standard/raw way)
 
 =back
 
 as well as all keys from C<extras> (but these won't override the above keys).
 
 and is expected to return a completion answer structure as described in
 C<Complete> which is either a hash or an array. The simplest form of answer is
 just to return an array of strings. The various C<complete_*> function like those
 in C<Complete::Util> or the other C<Complete::*> modules are suitable to use here.
 
 Completion routine can also return undef to express declination, in which case
 the default completion routine will then be consulted. The default routine
 completes from shell environment variables (C<$FOO>), Unix usernames (C<~foo>),
 and files/directories.
 
 Example:
 
  use Complete::Unix qw(complete_user);
  use Complete::Util qw(complete_array_elem);
  complete_cli_arg(
      getopt_spec => {
          'help|h'   => sub{...},
          'format=s' => \$format,
          'user=s'   => \$user,
      },
      completion  => sub {
          my %args  = @_;
          my $word  = $args{word};
          my $ospec = $args{ospec};
          if ($ospec && $ospec eq 'format=s') {
              complete_array(array=>[qw/json text xml yaml/], word=>$word);
          } else {
              complete_user(word=>$word);
          }
      },
  );
 
 =item * B<cword>* => I<int>
 
 Index in words of the word we're trying to complete.
 
 See function C<parse_cmdline> in C<Complete::Bash> on how to produce this (if
 you're using bash).
 
 =item * B<extras> => I<hash>
 
 Add extra arguments to completion routine.
 
 The keys from this C<extras> hash will be merged into the final C<%args> passed to
 completion routines. Note that standard keys like C<type>, C<word>, and so on as
 described in the function description will not be overwritten by this.
 
 =item * B<getopt_spec>* => I<hash>
 
 Getopt::Long specification.
 
 =item * B<words>* => I<array>
 
 Command line arguments, like @ARGV.
 
 See function C<parse_cmdline> in C<Complete::Bash> on how to produce this (if
 you're using bash).
 
 =back
 
 Return value:  (hash|array)
 
 
 You can use C<format_completion> function in C<Complete::Bash> module to format
 the result of this function for bash.
 
 =head1 SEE ALSO
 
 L<Getopt::Long::Complete>
 
 L<Complete>
 
 L<Complete::Bash>
 
 Other modules related to bash shell tab completion: L<Bash::Completion>,
 L<Getopt::Complete>.
 
 L<Perinci::CmdLine> - an alternative way to easily create command-line
 applications with completion feature.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete-Getopt-Long>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete-Getopt-Long>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Getopt-Long>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Complete/Path.pm ###
 package Complete::Path;
 
 our $DATE = '2015-01-09'; # DATE
 our $VERSION = '0.12'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use Complete;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        complete_path
                );
 
 sub _dig_leaf {
     my ($p, $list_func, $is_dir_func, $path_sep) = @_;
     my $num_dirs;
     my $listres = $list_func->($p, '', 0);
     return $p unless @$listres == 1;
     my $e = $listres->[0];
     my $p2 = $p =~ m!\Q$path_sep\E\z! ? "$p$e" : "$p$path_sep$e";
     my $is_dir;
     if ($e =~ m!\Q$path_sep\E\z!) {
         $is_dir++;
     } else {
         $is_dir = $is_dir_func && $is_dir_func->($p2);
     }
     return _dig_leaf($p2, $list_func, $is_dir_func, $path_sep) if $is_dir;
     $p2;
 }
 
 our %SPEC;
 
 $SPEC{complete_path} = {
     v => 1.1,
     summary => 'Complete path',
     description => <<'_',
 
 Complete path, for anything path-like. Meant to be used as backend for other
 functions like `Complete::Util::complete_file` or
 `Complete::Module::complete_module`. Provides features like case-insensitive
 matching, expanding intermediate paths, and case mapping.
 
 Algorithm is to split path into path elements, then list items (using the
 supplied `list_func`) and perform filtering (using the supplied `filter_func`)
 at every level.
 
 _
     args => {
         word => {
             schema  => [str=>{default=>''}],
             pos     => 0,
         },
         list_func => {
             summary => 'Function to list the content of intermediate "dirs"',
             schema => 'code*',
             req => 1,
             description => <<'_',
 
 Code will be called with arguments: ($path, $cur_path_elem, $is_intermediate).
 Code should return an arrayref containing list of elements. "Directories" can be
 marked by ending the name with the path separator (see `path_sep`). Or, you can
 also provide an `is_dir_func` function that will be consulted after filtering.
 If an item is a "directory" then its name will be suffixed with a path
 separator by `complete_path()`.
 
 _
         },
         is_dir_func => {
             summary => 'Function to check whether a path is a "dir"',
             schema  => 'code*',
             description => <<'_',
 
 Optional. You can provide this function to determine if an item is a "directory"
 (so its name can be suffixed with path separator). You do not need to do this if
 you already suffix names of "directories" with path separator in `list_func`.
 
 One reason you might want to provide this and not mark "directories" in
 `list_func` is when you want to do extra filtering with `filter_func`. Sometimes
 you do not want to suffix the names first (example: see `complete_file` in
 `Complete::Util`).
 
 _
         },
         starting_path => {
             schema => 'str*',
             req => 1,
             default => '',
         },
         filter_func => {
             schema  => 'code*',
             description => <<'_',
 
 Provide extra filtering. Code will be given path and should return 1 if the item
 should be included in the final result or 0 if the item should be excluded.
 
 _
         },
 
         path_sep => {
             schema  => 'str*',
             default => '/',
         },
         ci => {
             summary => 'Case-insensitive matching',
             schema  => 'bool',
         },
         map_case => {
             summary => 'Treat _ (underscore) and - (dash) as the same',
             schema  => 'bool',
             description => <<'_',
 
 This is another convenience option like `ci`, where you can type `-` (without
 pressing Shift, at least in US keyboard) and can still complete `_` (underscore,
 which is typed by pressing Shift, at least in US keyboard).
 
 This option mimics similar option in bash/readline: `completion-map-case`.
 
 _
         },
         exp_im_path => {
             summary => 'Expand intermediate paths',
             schema  => 'bool',
             description => <<'_',
 
 This option mimics feature in zsh where when you type something like `cd
 /h/u/b/myscript` and get `cd /home/ujang/bin/myscript` as a completion answer.
 
 _
         },
         dig_leaf => {
             summary => 'Dig leafs',
             schema => 'bool',
             description => <<'_',
 
 This feature mimics what's seen on GitHub. If a directory entry only contains a
 single entry, it will directly show the subentry (and subsubentry and so on) to
 save a number of tab presses.
 
 _
         },
         #result_prefix => {
         #    summary => 'Prefix each result with this string',
         #    schema  => 'str*',
         #},
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_path {
     my %args   = @_;
     my $word   = $args{word} // "";
     my $path_sep = $args{path_sep} // '/';
     my $list_func   = $args{list_func};
     my $is_dir_func = $args{is_dir_func};
     my $filter_func = $args{filter_func};
     my $ci          = $args{ci} // $Complete::OPT_CI;
     my $map_case    = $args{map_case} // $Complete::OPT_MAP_CASE;
     my $exp_im_path = $args{exp_im_path} // $Complete::OPT_EXP_IM_PATH;
     my $dig_leaf    = $args{dig_leaf} // $Complete::OPT_DIG_LEAF;
     my $result_prefix = $args{result_prefix};
     my $starting_path = $args{starting_path} // '';
 
     my $exp_im_path_max_len = $Complete::OPT_EXP_IM_PATH_MAX_LEN;
 
     my $re_ends_with_path_sep = qr!\A\z|\Q$path_sep\E\z!;
 
     # split word by into path elements, as we want to dig level by level (needed
     # when doing case-insensitive search on a case-sensitive tree).
     my @intermediate_dirs;
     {
         @intermediate_dirs = split qr/\Q$path_sep/, $word;
         @intermediate_dirs = ('') if !@intermediate_dirs;
         push @intermediate_dirs, '' if $word =~ $re_ends_with_path_sep;
     }
 
     # extract leaf path, because this one is treated differently
     my $leaf = pop @intermediate_dirs;
     @intermediate_dirs = ('') if !@intermediate_dirs;
 
     #say "D:starting_path=<$starting_path>";
     #say "D:intermediate_dirs=[",join(", ", map{"<$_>"} @intermediate_dirs),"]";
     #say "D:leaf=<$leaf>";
 
     # candidate for intermediate paths. when doing case-insensitive search,
     # there maybe multiple candidate paths for each dir, for example if
     # word='../foo/s' and there is '../foo/Surya', '../Foo/sri', '../FOO/SUPER'
     # then candidate paths would be ['../foo', '../Foo', '../FOO'] and the
     # filename should be searched inside all those dirs. everytime we drill down
     # to deeper subdirectories, we adjust this list by removing
     # no-longer-eligible candidates.
     my @candidate_paths;
 
     for my $i (0..$#intermediate_dirs) {
         my $intdir = $intermediate_dirs[$i];
         my @dirs;
         if ($i == 0) {
             # first path elem, we search starting_path first since
             # candidate_paths is still empty.
             @dirs = ($starting_path);
         } else {
             # subsequent path elem, we search all candidate_paths
             @dirs = @candidate_paths;
         }
 
         if ($i == $#intermediate_dirs && $intdir eq '') {
             @candidate_paths = @dirs;
             last;
         }
 
         my @new_candidate_paths;
         for my $dir (@dirs) {
             #say "D:  intdir list($dir)";
             my $listres = $list_func->($dir, $intdir, 1);
             next unless $listres && @$listres;
             # check if the deeper level is a candidate
             my $re = do {
                 my $s = $intdir;
                 $s =~ s/_/-/g if $map_case;
                 $exp_im_path && length($s) <= $exp_im_path_max_len ?
                     ($ci ? qr/\A\Q$s/i : qr/\A\Q$s/) :
                         ($ci ? qr/\A\Q$s\E(?:\Q$path_sep\E)?\z/i :
                              qr/\A\Q$s\E(?:\Q$path_sep\E)?\z/);
             };
             #say "D:  re=$re";
             for (@$listres) {
                 #say "D:  $_";
                 my $s = $_; $s =~ s/_/-/g if $map_case;
                 #say "D: <$s> =~ $re";
                 next unless $s =~ $re;
                 my $p = $dir =~ $re_ends_with_path_sep ?
                     "$dir$_" : "$dir$path_sep$_";
                 push @new_candidate_paths, $p;
             }
         }
         #say "D:  candidate_paths=[",join(", ", map{"<$_>"} @new_candidate_paths),"]";
         return [] unless @new_candidate_paths;
         @candidate_paths = @new_candidate_paths;
     }
 
     my $cut_chars = 0;
     if (length($starting_path)) {
         $cut_chars += length($starting_path);
         unless ($starting_path =~ /\Q$path_sep\E\z/) {
             $cut_chars += length($path_sep);
         }
     }
 
     my @res;
     for my $dir (@candidate_paths) {
         #say "D:opendir($dir)";
         my $listres = $list_func->($dir, $leaf, 0);
         next unless $listres && @$listres;
         my $re = do {
             my $s = $leaf;
             $s =~ s/_/-/g if $map_case;
             $ci ? qr/\A\Q$s/i : qr/\A\Q$s/;
         };
         #say "D:re=$re";
       L1:
         for my $e (@$listres) {
             my $s = $e; $s =~ s/_/-/g if $map_case;
             next unless $s =~ $re;
             my $p = $dir =~ $re_ends_with_path_sep ?
                 "$dir$e" : "$dir$path_sep$e";
             {
                 local $_ = $p; # convenience for filter func
                 next L1 if $filter_func && !$filter_func->($p);
             }
 
             my $is_dir;
             if ($e =~ $re_ends_with_path_sep) {
                 $is_dir = 1;
             } else {
                 local $_ = $p; # convenience for is_dir_func
                 $is_dir = $is_dir_func->($p);
             }
 
             if ($is_dir && $dig_leaf) {
                 $p = _dig_leaf($p, $list_func, $is_dir_func, $path_sep);
                 # check again
                 if ($p =~ $re_ends_with_path_sep) {
                     $is_dir = 1;
                 } else {
                     local $_ = $p; # convenience for is_dir_func
                     $is_dir = $is_dir_func->($p);
                 }
             }
 
             # process into final result
             my $p0 = $p;
             substr($p, 0, $cut_chars) = '' if $cut_chars;
             $p = "$result_prefix$p" if length($result_prefix);
             unless ($p =~ /\Q$path_sep\E\z/) {
                 $p .= $path_sep if $is_dir;
             }
             push @res, $p;
         }
     }
 
     \@res;
 }
 1;
 # ABSTRACT: Complete path
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete::Path - Complete path
 
 =head1 VERSION
 
 This document describes version 0.12 of Complete::Path (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-01-09.
 
 =head1 DESCRIPTION
 
 =head1 FUNCTIONS
 
 
 =head2 complete_path(%args) -> array
 
 {en_US Complete path}.
 
 {en_US 
 Complete path, for anything path-like. Meant to be used as backend for other
 functions like C<Complete::Util::complete_file> or
 C<Complete::Module::complete_module>. Provides features like case-insensitive
 matching, expanding intermediate paths, and case mapping.
 
 Algorithm is to split path into path elements, then list items (using the
 supplied C<list_func>) and perform filtering (using the supplied C<filter_func>)
 at every level.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<ci> => I<bool>
 
 {en_US Case-insensitive matching}.
 
 =item * B<dig_leaf> => I<bool>
 
 {en_US Dig leafs}.
 
 {en_US 
 This feature mimics what's seen on GitHub. If a directory entry only contains a
 single entry, it will directly show the subentry (and subsubentry and so on) to
 save a number of tab presses.
 }
 
 =item * B<exp_im_path> => I<bool>
 
 {en_US Expand intermediate paths}.
 
 {en_US 
 This option mimics feature in zsh where when you type something like C<cd
 /h/u/b/myscript> and get C<cd /home/ujang/bin/myscript> as a completion answer.
 }
 
 =item * B<filter_func> => I<code>
 
 {en_US 
 Provide extra filtering. Code will be given path and should return 1 if the item
 should be included in the final result or 0 if the item should be excluded.
 }
 
 =item * B<is_dir_func> => I<code>
 
 {en_US Function to check whether a path is a "dir"}.
 
 {en_US 
 Optional. You can provide this function to determine if an item is a "directory"
 (so its name can be suffixed with path separator). You do not need to do this if
 you already suffix names of "directories" with path separator in C<list_func>.
 
 One reason you might want to provide this and not mark "directories" in
 C<list_func> is when you want to do extra filtering with C<filter_func>. Sometimes
 you do not want to suffix the names first (example: see C<complete_file> in
 C<Complete::Util>).
 }
 
 =item * B<list_func>* => I<code>
 
 {en_US Function to list the content of intermediate "dirs"}.
 
 {en_US 
 Code will be called with arguments: ($path, $cur_path_elem, $is_intermediate).
 Code should return an arrayref containing list of elements. "Directories" can be
 marked by ending the name with the path separator (see C<path_sep>). Or, you can
 also provide an C<is_dir_func> function that will be consulted after filtering.
 If an item is a "directory" then its name will be suffixed with a path
 separator by C<complete_path()>.
 }
 
 =item * B<map_case> => I<bool>
 
 {en_US Treat _ (underscore) and - (dash) as the same}.
 
 {en_US 
 This is another convenience option like C<ci>, where you can type C<-> (without
 pressing Shift, at least in US keyboard) and can still complete C<_> (underscore,
 which is typed by pressing Shift, at least in US keyboard).
 
 This option mimics similar option in bash/readline: C<completion-map-case>.
 }
 
 =item * B<path_sep> => I<str> (default: "/")
 
 =item * B<starting_path>* => I<str> (default: "")
 
 =item * B<word> => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 =head1 SEE ALSO
 
 L<Complete>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete-Path>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete-Path>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Path>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Complete/Tcsh.pm ###
 package Complete::Tcsh;
 
 our $DATE = '2014-11-23'; # DATE
 our $VERSION = '0.01'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        parse_cmdline
                        format_completion
                );
 
 require Complete::Bash;
 
 our %SPEC;
 
 $SPEC{parse_cmdline} = {
     v => 1.1,
     summary => 'Parse shell command-line for processing by completion routines',
     description => <<'_',
 
 This function converts COMMAND_LINE (str) given by tcsh to become something like
 COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
 functions. Currently implemented using `Complete::Bash`'s `parse_cmdline`.
 
 _
     args_as => 'array',
     args => {
         cmdline => {
             summary => 'Command-line, defaults to COMMAND_LINE environment',
             schema => 'str*',
             pos => 0,
         },
     },
     result => {
         schema => ['array*', len=>2],
         description => <<'_',
 
 Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
 equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
 integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
 word to be completed is at `$words->[$cword]`.
 
 Note that COMP_LINE includes the command name. If you want the command-line
 arguments only (like in `@ARGV`), you need to strip the first element from
 `$words` and reduce `$cword` by 1.
 
 _
     },
     result_naked => 1,
 };
 sub parse_cmdline {
     my ($line) = @_;
 
     $line //= $ENV{COMMAND_LINE};
     Complete::Bash::parse_cmdline($line, length($line));
 }
 
 $SPEC{format_completion} = {
     v => 1.1,
     summary => 'Format completion for output (for shell)',
     description => <<'_',
 
 tcsh accepts completion reply in the form of one entry per line to STDOUT.
 Currently the formatting is done using `Complete::Bash`'s `format_completion`
 because escaping rule and so on are not yet well defined in tcsh.
 
 _
     args_as => 'array',
     args => {
         shell_completion => {
             summary => 'Result of shell completion',
             description => <<'_',
 
 Either an array or hash.
 
 _
             schema=>['any*' => of => ['hash*', 'array*']],
             req=>1,
             pos=>0,
         },
         as => {
             schema => ['str*', in=>['string', 'array']],
             default => 'string',
         },
     },
     result => {
         summary => 'Formatted string (or array, if `as` is set to `array`)',
         schema => ['any*' => of => ['str*', 'array*']],
     },
     result_naked => 1,
 };
 sub format_completion {
     Complete::Bash::format_completion(@_);
 }
 
 1;
 #ABSTRACT: Completion module for tcsh shell
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete::Tcsh - Completion module for tcsh shell
 
 =head1 VERSION
 
 This document describes version 0.01 of Complete::Tcsh (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2014-11-23.
 
 =head1 DESCRIPTION
 
 tcsh allows completion to come from various sources. One of the simplest is from
 a list of words:
 
  % complete CMDNAME 'p/*/(one two three)/'
 
 Another source is from an external command:
 
  % complete CMDNAME 'p/*/`mycompleter --somearg`/'
 
 The command receives one environment variables C<COMMAND_LINE> (string, raw
 command-line). Unlike bash, tcsh does not (yet) provide something akin to
 C<COMP_POINT> in bash. Command is expected to print completion entries, one line
 at a time.
 
  % cat mycompleter
  #!/usr/bin/perl
  use Complete::Tcsh qw(parse_cmdline format_completion);
  use Complete::Util qw(complete_array_elem);
  my ($words, $cword) = parse_cmdline();
  my $res = complete_array_elem(array=>[qw/--help --verbose --version/], word=>$words->[$cword]);
  print format_completion($res);
 
  % complete -C foo-complete foo
  % foo --v<Tab>
  --verbose --version
 
 This module provides routines for you to be doing the above.
 
 Also, unlike bash, currently tcsh does not allow delegating completion to a
 shell function.
 
 =head1 FUNCTIONS
 
 
 =head2 format_completion($shell_completion, $as) -> array|str
 
 Format completion for output (for shell).
 
 tcsh accepts completion reply in the form of one entry per line to STDOUT.
 Currently the formatting is done using C<Complete::Bash>'s C<format_completion>
 because escaping rule and so on are not yet well defined in tcsh.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<as> => I<str> (default: "string")
 
 =item * B<shell_completion>* => I<array|hash>
 
 Result of shell completion.
 
 Either an array or hash.
 
 =back
 
 Return value:
 
 Formatted string (or array, if `as` is set to `array`) (any)
 
 
 =head2 parse_cmdline($cmdline) -> array
 
 Parse shell command-line for processing by completion routines.
 
 This function converts COMMAND_LINE (str) given by tcsh to become something like
 COMP_WORDS (array) and COMP_CWORD (int), like what bash supplies to shell
 functions. Currently implemented using C<Complete::Bash>'s C<parse_cmdline>.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<cmdline> => I<str>
 
 Command-line, defaults to COMMAND_LINE environment.
 
 =back
 
 Return value:
 
  (array)
 
 Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
 equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
 integer, equivalent to `COMP_CWORD` provided by bash to shell functions. The
 word to be completed is at `$words->[$cword]`.
 
 Note that COMP_LINE includes the command name. If you want the command-line
 arguments only (like in `@ARGV`), you need to strip the first element from
 `$words` and reduce `$cword` by 1.
 
 =head1 TODOS
 
 =head1 SEE ALSO
 
 L<Complete>
 
 L<Complete::Bash>
 
 tcsh manual.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete-Tcsh>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete-Tcsh>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Tcsh>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Complete/Util.pm ###
 package Complete::Util;
 
 our $DATE = '2015-08-11'; # DATE
 our $VERSION = '0.32'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use Complete;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        hashify_answer
                        arrayify_answer
                        combine_answers
                        complete_array_elem
                        complete_hash_key
                        complete_env
                        complete_file
                        complete_program
                );
 
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'General completion routine',
 };
 
 $SPEC{hashify_answer} = {
     v => 1.1,
     summary => 'Make sure we return completion answer in hash form',
     description => <<'_',
 
 This function accepts a hash or an array. If it receives an array, will convert
 the array into `{words=>$ary}' first to make sure the completion answer is in
 hash form.
 
 Then will add keys from `meta` to the hash.
 
 _
     args => {
         arg => {
             summary => '',
             schema  => ['any*' => of => ['array*','hash*']],
             req => 1,
             pos => 0,
         },
         meta => {
             summary => 'Metadata (extra keys) for the hash',
             schema  => 'hash*',
             pos => 1,
         },
     },
     result_naked => 1,
     result => {
         schema => 'hash*',
     },
 };
 sub hashify_answer {
     my $ans = shift;
     if (ref($ans) ne 'HASH') {
         $ans = {words=>$ans};
     }
     if (@_) {
         my $meta = shift;
         for (keys %$meta) {
             $ans->{$_} = $meta->{$_};
         }
     }
     $ans;
 }
 
 $SPEC{arrayify_answer} = {
     v => 1.1,
     summary => 'Make sure we return completion answer in array form',
     description => <<'_',
 
 This is the reverse of `hashify_answer`. It accepts a hash or an array. If it
 receives a hash, will return its `words` key.
 
 _
     args => {
         arg => {
             summary => '',
             schema  => ['any*' => of => ['array*','hash*']],
             req => 1,
             pos => 0,
         },
     },
     result_naked => 1,
     result => {
         schema => 'array*',
     },
 };
 sub arrayify_answer {
     my $ans = shift;
     if (ref($ans) eq 'HASH') {
         $ans = $ans->{words};
     }
     $ans;
 }
 
 $SPEC{complete_array_elem} = {
     v => 1.1,
     summary => 'Complete from array',
     description => <<'_',
 
 Will sort the resulting completion list, so you don't have to presort the array.
 
 _
     args => {
         word    => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
         array   => { schema=>['array*'=>{of=>'str*'}], req=>1 },
         ci      => { schema=>['bool'] },
         exclude => { schema=>['array*'] },
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_array_elem {
     my %args  = @_;
     my $array = $args{array} or die "Please specify array";
     my $word  = $args{word} // "";
     my $ci    = $args{ci} // $Complete::OPT_CI;
 
     my $has_exclude = $args{exclude};
     my $exclude;
     if ($ci) {
         $exclude = [map {uc} @{ $args{exclude} // [] }];
     } else {
         $exclude = $args{exclude} // [];
     }
 
     my $wordu = uc($word);
     my @words;
     for my $el (@$array) {
         my $uc = uc($el) if $ci;
         next unless 0==($ci ? index($uc, $wordu) : index($el, $word));
         if ($has_exclude) {
             next if grep {($ci ? $uc : $el) eq $_} @$exclude;
         }
         push @words, $el;
     }
     $ci ? [sort {lc($a) cmp lc($b)} @words] : [sort @words];
 }
 
 *complete_array = \&complete_array_elem;
 
 $SPEC{complete_hash_key} = {
     v => 1.1,
     summary => 'Complete from hash keys',
     args => {
         word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
         hash  => { schema=>['hash*'=>{}], req=>1 },
         ci    => { schema=>['bool'] },
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_hash_key {
     my %args  = @_;
     my $hash  = $args{hash} or die "Please specify hash";
     my $word  = $args{word} // "";
     my $ci    = $args{ci} // $Complete::OPT_CI;
 
     complete_array_elem(word=>$word, array=>[keys %$hash], ci=>$ci);
 }
 
 $SPEC{complete_env} = {
     v => 1.1,
     summary => 'Complete from environment variables',
     description => <<'_',
 
 On Windows, environment variable names are all converted to uppercase. You can
 use case-insensitive option (`ci`) to match against original casing.
 
 _
     args => {
         word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
         ci    => { schema=>['bool'] },
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_env {
     my %args  = @_;
     my $word  = $args{word} // "";
     my $ci    = $args{ci} // $Complete::OPT_CI;
     if ($word =~ /^\$/) {
         complete_array_elem(word=>$word, array=>[map {"\$$_"} keys %ENV],
                             ci=>$ci);
     } else {
         complete_array_elem(word=>$word, array=>[keys %ENV], ci=>$ci);
     }
 }
 
 $SPEC{complete_program} = {
     v => 1.1,
     summary => 'Complete program name found in PATH',
     description => <<'_',
 
 Windows is supported, on Windows PATH will be split using /;/ instead of /:/.
 
 _
     args => {
         word  => { schema=>[str=>{default=>''}], pos=>0, req=>1 },
         ci    => { schema=>'bool' },
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_program {
     require List::MoreUtils;
 
     my %args = @_;
     my $word = $args{word} // "";
     my $ci   = $args{ci} // $Complete::OPT_CI;
 
     my $word_re = $ci ? qr/\A\Q$word/i : qr/\A\Q$word/;
 
     my @res;
     my @dirs = split(($^O =~ /Win32/ ? qr/;/ : qr/:/), $ENV{PATH});
     for my $dir (@dirs) {
         opendir my($dh), $dir or next;
         for (readdir($dh)) {
             push @res, $_ if $_ =~ $word_re && !(-d "$dir/$_") && (-x _);
         };
     }
 
     [sort(List::MoreUtils::uniq(@res))];
 }
 
 $SPEC{complete_file} = {
     v => 1.1,
     summary => 'Complete file and directory from local filesystem',
     args_rels => {
         choose_one => [qw/filter file_regex_filter/],
     },
     args => {
         word => {
             schema  => [str=>{default=>''}],
             req     => 1,
             pos     => 0,
         },
         ci => {
             summary => 'Case-insensitive matching',
             schema  => 'bool',
         },
         map_case => {
             schema  => 'bool',
         },
         exp_im_path => {
             schema  => 'bool',
         },
         dig_leaf => {
             schema  => 'bool',
         },
         filter => {
             summary => 'Only return items matching this filter',
             description => <<'_',
 
 Filter can either be a string or a code.
 
 For string filter, you can specify a pipe-separated groups of sequences of these
 characters: f, d, r, w, x. Dash can appear anywhere in the sequence to mean
 not/negate. An example: `f` means to only show regular files, `-f` means only
 show non-regular files, `drwx` means to show only directories which are
 readable, writable, and executable (cd-able). `wf|wd` means writable regular
 files or writable directories.
 
 For code filter, you supply a coderef. The coderef will be called for each item
 with these arguments: `$name`. It should return true if it wants the item to be
 included.
 
 _
             schema  => ['any*' => {of => ['str*', 'code*']}],
         },
         file_regex_filter => {
             summary => 'Filter shortcut for file regex',
             description => <<'_',
 
 This is a shortcut for constructing a filter. So instead of using `filter`, you
 use this option. This will construct a filter of including only directories or
 regular files, and the file must match a regex pattern. This use-case is common.
 
 _
             schema => 're*',
         },
         starting_path => {
             schema  => 'str*',
             default => '.',
         },
         handle_tilde => {
             schema  => 'bool',
             default => 1,
         },
         allow_dot => {
             summary => 'If turned off, will not allow "." or ".." in path',
             description => <<'_',
 
 This is most useful when combined with `starting_path` option to prevent user
 going up/outside the starting path.
 
 _
             schema  => 'bool',
             default => 1,
         },
     },
     result_naked => 1,
     result => {
         schema => 'array',
     },
 };
 sub complete_file {
     require Complete::Path;
     require File::Glob;
 
     my %args   = @_;
     my $word   = $args{word} // "";
     my $ci          = $args{ci} // $Complete::OPT_CI;
     my $map_case    = $args{map_case} // $Complete::OPT_MAP_CASE;
     my $exp_im_path = $args{exp_im_path} // $Complete::OPT_EXP_IM_PATH;
     my $dig_leaf    = $args{dig_leaf} // $Complete::OPT_DIG_LEAF;
     my $handle_tilde = $args{handle_tilde} // 1;
     my $allow_dot   = $args{allow_dot} // 1;
     my $filter = $args{filter};
 
     # if word is starts with "~/" or "~foo/" replace it temporarily with user's
     # name (so we can restore it back at the end). this is to mimic bash
     # support. note that bash does not support case-insensitivity for "foo".
     my $result_prefix;
     my $starting_path = $args{starting_path} // '.';
     if ($handle_tilde && $word =~ s!\A(~[^/]*)/!!) {
         $result_prefix = "$1/";
         my @dir = File::Glob::glob($1); # glob will expand ~foo to /home/foo
         return [] unless @dir;
         $starting_path = $dir[0];
     } elsif ($allow_dot && $word =~ s!\A((?:\.\.?/+)+|/+)!!) {
         # just an optimization to skip sequences of '../'
         $starting_path = $1;
         $result_prefix = $1;
         $starting_path =~ s#/+\z## unless $starting_path =~ m!\A/!;
     }
 
     # bail if we don't allow dot and the path contains dot
     return [] if !$allow_dot &&
         $word =~ m!(?:\A|/)\.\.?(?:\z|/)!;
 
     # prepare list_func
     my $list = sub {
         my ($path, $intdir, $isint) = @_;
         opendir my($dh), $path or return undef;
         my @res;
         for (sort readdir $dh) {
             # skip . and .. if leaf is empty, like in bash
             next if ($_ eq '.' || $_ eq '..') && $intdir eq '';
             next if $isint && !(-d "$path/$_");
             push @res, $_;
         }
         \@res;
     };
 
     # prepare filter_func
     if ($filter && !ref($filter)) {
         my @seqs = split /\s*\|\s*/, $filter;
         $filter = sub {
             my $name = shift;
             my @st = stat($name) or return 0;
             my $mode = $st[2];
             my $pass;
           SEQ:
             for my $seq (@seqs) {
                 my $neg = sub { $_[0] };
                 for my $c (split //, $seq) {
                     if    ($c eq '-') { $neg = sub { $_[0] ? 0 : 1 } }
                     elsif ($c eq 'r') { next SEQ unless $neg->($mode & 0400) }
                     elsif ($c eq 'w') { next SEQ unless $neg->($mode & 0200) }
                     elsif ($c eq 'x') { next SEQ unless $neg->($mode & 0100) }
                     elsif ($c eq 'f') { next SEQ unless $neg->($mode & 0100000)}
                     elsif ($c eq 'd') { next SEQ unless $neg->($mode & 0040000)}
                     else {
                         die "Unknown character in filter: $c (in $seq)";
                     }
                 }
                 $pass = 1; last SEQ;
             }
             $pass;
         };
     } elsif (!$filter && $args{file_regex_filter}) {
         $filter = sub {
             my $name = shift;
             return 1 if -d $name;
             return 0 unless -f _;
             return 1 if $name =~ $args{file_regex_filter};
             0;
         };
     }
 
     Complete::Path::complete_path(
         word => $word,
 
         ci => $ci,
         map_case => $map_case,
         exp_im_path => $exp_im_path,
         dig_leaf => $dig_leaf,
 
         list_func => $list,
         is_dir_func => sub { -d $_[0] },
         filter_func => $filter,
         starting_path => $starting_path,
         result_prefix => $result_prefix,
     );
 }
 
 $SPEC{combine_answers} = {
     v => 1.1,
     summary => 'Given two or more answers, combine them into one',
     description => <<'_',
 
 This function is useful if you want to provide a completion answer that is
 gathered from multiple sources. For example, say you are providing completion
 for the Perl tool `cpanm`, which accepts a filename (a tarball like `*.tar.gz`),
 a directory, or a module name. You can do something like this:
 
     combine_answers(
         complete_file(word=>$word, ci=>1),
         complete_module(word=>$word, ci=>1),
     );
 
 If a completion answer has a metadata `final` set to true, then that answer is
 used as the final answer without any combining with the other answers.
 
 _
     args => {
         answers => {
             schema => [
                 'array*' => {
                     of => ['any*', of=>['hash*','array*']], # XXX answer_t
                     min_len => 1,
                 },
             ],
             req => 1,
             pos => 0,
             greedy => 1,
         },
     },
     args_as => 'array',
     result_naked => 1,
     result => {
         schema => 'hash*',
         description => <<'_',
 
 Return a combined completion answer. Words from each input answer will be
 combined, order preserved and duplicates removed. The other keys from each
 answer will be merged.
 
 _
     },
 };
 sub combine_answers {
     require List::Util;
 
     return undef unless @_;
     return $_[0] if @_ < 2;
 
     my $final = {words=>[]};
     my $encounter_hash;
     my $add_words = sub {
         my $words = shift;
         for my $entry (@$words) {
             push @{ $final->{words} }, $entry
                 unless List::Util::first(
                     sub {
                         (ref($entry) ? $entry->{word} : $entry)
                             eq
                                 (ref($_) ? $_->{word} : $_)
                             }, @{ $final->{words} }
                         );
         }
     };
 
   ANSWER:
     for my $ans (@_) {
         if (ref($ans) eq 'ARRAY') {
             $add_words->($ans);
         } elsif (ref($ans) eq 'HASH') {
             $encounter_hash++;
 
             if ($ans->{final}) {
                 $final = $ans;
                 last ANSWER;
             }
 
             $add_words->($ans->{words} // []);
             for (keys %$ans) {
                 if ($_ eq 'words') {
                     next;
                 } elsif ($_ eq 'static') {
                     if (exists $final->{$_}) {
                         $final->{$_} &&= $ans->{$_};
                     } else {
                         $final->{$_} = $ans->{$_};
                     }
                 } else {
                     $final->{$_} = $ans->{$_};
                 }
             }
         }
     }
 
     # re-sort final words
     if ($final->{words}) {
         $final->{words} = [
             sort {
                 (ref($a) ? $a->{word} : $a) cmp
                     (ref($b) ? $b->{word} : $b);
             }
                 @{ $final->{words} }];
     }
 
     $encounter_hash ? $final : $final->{words};
 }
 
 # TODO: complete_filesystem (probably in a separate module)
 # TODO: complete_hostname (/etc/hosts, ~/ssh/.known_hosts, ...)
 # TODO: complete_package (deb, rpm, ...)
 
 1;
 # ABSTRACT: General completion routine
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Complete::Util - General completion routine
 
 =head1 VERSION
 
 This document describes version 0.32 of Complete::Util (from Perl distribution Complete-Util), released on 2015-08-11.
 
 =head1 DESCRIPTION
 
 =head1 FUNCTIONS
 
 
 =head2 arrayify_answer(%args) -> array
 
 {en_US Make sure we return completion answer in array form}.
 
 {en_US 
 This is the reverse of C<hashify_answer>. It accepts a hash or an array. If it
 receives a hash, will return its C<words> key.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<arg>* => I<array|hash>
 
 {en_US }.
 
 =back
 
 Return value:  (array)
 
 
 =head2 combine_answers($answers, ...) -> hash
 
 {en_US Given two or more answers, combine them into one}.
 
 {en_US 
 This function is useful if you want to provide a completion answer that is
 gathered from multiple sources. For example, say you are providing completion
 for the Perl tool C<cpanm>, which accepts a filename (a tarball like C<*.tar.gz>),
 a directory, or a module name. You can do something like this:
 
  combine_answers(
      complete_file(word=>$word, ci=>1),
      complete_module(word=>$word, ci=>1),
  );
 
 If a completion answer has a metadata C<final> set to true, then that answer is
 used as the final answer without any combining with the other answers.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<answers>* => I<array[hash|array]>
 
 =back
 
 Return value:  (hash)
 
 
 {en_US 
 Return a combined completion answer. Words from each input answer will be
 combined, order preserved and duplicates removed. The other keys from each
 answer will be merged.
 }
 
 
 =head2 complete_array_elem(%args) -> array
 
 {en_US Complete from array}.
 
 {en_US 
 Will sort the resulting completion list, so you don't have to presort the array.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<array>* => I<array[str]>
 
 =item * B<ci> => I<bool>
 
 =item * B<exclude> => I<array>
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_env(%args) -> array
 
 {en_US Complete from environment variables}.
 
 {en_US 
 On Windows, environment variable names are all converted to uppercase. You can
 use case-insensitive option (C<ci>) to match against original casing.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<ci> => I<bool>
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_file(%args) -> array
 
 {en_US Complete file and directory from local filesystem}.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<allow_dot> => I<bool> (default: 1)
 
 {en_US If turned off, will not allow "." or ".." in path}.
 
 {en_US 
 This is most useful when combined with C<starting_path> option to prevent user
 going up/outside the starting path.
 }
 
 =item * B<ci> => I<bool>
 
 {en_US Case-insensitive matching}.
 
 =item * B<dig_leaf> => I<bool>
 
 =item * B<exp_im_path> => I<bool>
 
 =item * B<file_regex_filter> => I<re>
 
 {en_US Filter shortcut for file regex}.
 
 {en_US 
 This is a shortcut for constructing a filter. So instead of using C<filter>, you
 use this option. This will construct a filter of including only directories or
 regular files, and the file must match a regex pattern. This use-case is common.
 }
 
 =item * B<filter> => I<str|code>
 
 {en_US Only return items matching this filter}.
 
 {en_US 
 Filter can either be a string or a code.
 
 For string filter, you can specify a pipe-separated groups of sequences of these
 characters: f, d, r, w, x. Dash can appear anywhere in the sequence to mean
 not/negate. An example: C<f> means to only show regular files, C<-f> means only
 show non-regular files, C<drwx> means to show only directories which are
 readable, writable, and executable (cd-able). C<wf|wd> means writable regular
 files or writable directories.
 
 For code filter, you supply a coderef. The coderef will be called for each item
 with these arguments: C<$name>. It should return true if it wants the item to be
 included.
 }
 
 =item * B<handle_tilde> => I<bool> (default: 1)
 
 =item * B<map_case> => I<bool>
 
 =item * B<starting_path> => I<str> (default: ".")
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_hash_key(%args) -> array
 
 {en_US Complete from hash keys}.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<ci> => I<bool>
 
 =item * B<hash>* => I<hash>
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_program(%args) -> array
 
 {en_US Complete program name found in PATH}.
 
 {en_US 
 Windows is supported, on Windows PATH will be split using /;/ instead of /:/.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<ci> => I<bool>
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Return value:  (array)
 
 
 =head2 hashify_answer(%args) -> hash
 
 {en_US Make sure we return completion answer in hash form}.
 
 {en_US 
 This function accepts a hash or an array. If it receives an array, will convert
 the array into `{words=>$ary}' first to make sure the completion answer is in
 hash form.
 
 Then will add keys from C<meta> to the hash.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<arg>* => I<array|hash>
 
 {en_US }.
 
 =item * B<meta> => I<hash>
 
 {en_US Metadata (extra keys) for the hash}.
 
 =back
 
 Return value:  (hash)
 
 =for Pod::Coverage ^(complete_array)$
 
 =head1 SEE ALSO
 
 L<Complete>
 
 If you want to do bash tab completion with Perl, take a look at
 L<Complete::Bash> or L<Getopt::Long::Complete> or L<Perinci::CmdLine>.
 
 Other C<Complete::*> modules.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Complete-Util>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Complete-Util>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Util>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Data/Clean/Base.pm ###
 package Data::Clean::Base;
 
 our $DATE = '2015-06-10'; # DATE
 our $VERSION = '0.28'; # VERSION
 
 use 5.010;
 use strict;
 use warnings;
 use Log::Any::IfLOG '$log';
 
 use Function::Fallback::CoreOrPP qw(clone);
 use Scalar::Util qw();
 
 sub new {
     my ($class, %opts) = @_;
     my $self = bless {opts=>\%opts}, $class;
     $log->tracef("Cleanser options: %s", \%opts);
     $self->_generate_cleanser_code;
     $self;
 }
 
 sub command_call_method {
     my ($self, $args) = @_;
     my $mn = $args->[0];
     die "Invalid method name syntax" unless $mn =~ /\A\w+\z/;
     return "{{var}} = {{var}}->$mn; \$ref = ref({{var}})";
 }
 
 sub command_call_func {
     my ($self, $args) = @_;
     my $fn = $args->[0];
     die "Invalid func name syntax" unless $fn =~ /\A\w+(::\w+)*\z/;
     return "{{var}} = $fn({{var}}); \$ref = ref({{var}})";
 }
 
 sub command_one_or_zero {
     my ($self, $args) = @_;
     return "{{var}} = {{var}} ? 1:0; \$ref = ''";
 }
 
 sub command_deref_scalar {
     my ($self, $args) = @_;
     return '{{var}} = ${ {{var}} }; $ref = ref({{var}})';
 }
 
 sub command_stringify {
     my ($self, $args) = @_;
     return '{{var}} = "{{var}}"';
 }
 
 sub command_replace_with_ref {
     my ($self, $args) = @_;
     return '{{var}} = $ref; $ref = ""';
 }
 
 sub command_replace_with_str {
     require String::PerlQuote;
 
     my ($self, $args) = @_;
     return "{{var}} = ".String::PerlQuote::double_quote($args->[0]).'; $ref=""';
 }
 
 sub command_unbless {
     my ($self, $args) = @_;
 
     # Data::Clone by default does not clone objects, so Acme::Damn can modify
     # the original object despite the use of clone(), so we need to know whether
     # user runs clone_and_clean() or clean_in_place() and avoid the use of
     # Acme::Damn for the former case. this workaround will be unnecessary when
     # Data::Clone clones objects.
 
     my $acme_damn_available = eval { require Acme::Damn; 1 } ? 1:0;
     return join(
         "",
         "if (!\$Data::Clean::Base::_clone && $acme_damn_available) { ",
         "{{var}} = Acme::Damn::damn({{var}}) ",
         "} else { ",
         "{{var}} = Function::Fallback::CoreOrPP::_unbless_fallback({{var}}) } ",
         "\$ref = ref({{var}})",
     );
 }
 
 sub command_clone {
     my $clone_func;
     eval { require Data::Clone };
     if ($@) {
         require Clone::PP;
         $clone_func = "Clone::PP::clone";
     } else {
         $clone_func = "Data::Clone::clone";
     }
 
     my ($self, $args) = @_;
     my $limit = $args->[0] // 1;
     return join(
         "",
         "if (++\$ctr_circ <= $limit) { ",
         "{{var}} = $clone_func({{var}}); redo ",
         "} else { ",
         "{{var}} = 'CIRCULAR' } ",
         "\$ref = ref({{var}})",
     );
 }
 
 # test
 sub command_die {
     my ($self, $args) = @_;
     return "die";
 }
 
 sub _generate_cleanser_code {
     my $self = shift;
     my $opts = $self->{opts};
 
     my (@code, @stmts_ary, @stmts_hash, @stmts_main);
 
     my $n = 0;
     my $add_stmt = sub {
         my $which = shift;
         if ($which eq 'if' || $which eq 'new_if') {
             my ($cond0, $act0) = @_;
             for ([\@stmts_ary, '$e', 'ary'],
                  [\@stmts_hash, '$h->{$k}', 'hash'],
                  [\@stmts_main, '$_', 'main']) {
                 my $act  = $act0 ; $act  =~ s/\Q{{var}}\E/$_->[1]/g;
                 my $cond = $cond0; $cond =~ s/\Q{{var}}\E/$_->[1]/g;
                 #unless (@{ $_->[0] }) { push @{ $_->[0] }, '    say "D:'.$_->[2].' val=", '.$_->[1].', ", ref=$ref"; # DEBUG'."\n" }
                 push @{ $_->[0] }, "    ".($n && $which ne 'new_if' ? "els":"")."if ($cond) { $act }\n";
             }
             $n++;
         } else {
             my ($stmt0) = @_;
             for ([\@stmts_ary, '$e', 'ary'],
                  [\@stmts_hash, '$h->{$k}', 'hash'],
                  [\@stmts_main, '$_', 'main']) {
                 my $stmt = $stmt0; $stmt =~ s/\Q{{var}}\E/$_->[1]/g;
                 push @{ $_->[0] }, "    $stmt;\n";
             }
         }
     };
     my $add_if = sub {
         $add_stmt->('if', @_);
     };
     my $add_new_if = sub {
         $add_stmt->('new_if', @_);
     };
     my $add_if_ref = sub {
         my ($ref, $act0) = @_;
         $add_if->("\$ref eq '$ref'", $act0);
     };
     my $add_new_if_ref = sub {
         my ($ref, $act0) = @_;
         $add_new_if->("\$ref eq '$ref'", $act0);
     };
 
     # catch object of specified classes (e.g. DateTime, etc)
     for my $on (grep {/\A\w*(::\w+)*\z/} sort keys %$opts) {
         my $o = $opts->{$on};
         next unless $o;
         my $meth = "command_$o->[0]";
         die "Can't handle command $o->[0] for option '$on'" unless $self->can($meth);
         my @args = @$o; shift @args;
         my $act = $self->$meth(\@args);
         $add_if_ref->($on, $act);
     }
 
     # catch general object not caught by previous
     for my $p ([-obj => 'Scalar::Util::blessed({{var}})']) {
         my $o = $opts->{$p->[0]};
         next unless $o;
         my $meth = "command_$o->[0]";
         die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
         my @args = @$o; shift @args;
         $add_if->($p->[1], $self->$meth(\@args));
     }
 
     # catch circular references
     my $circ = $opts->{-circular};
     if ($circ) {
         my $meth = "command_$circ->[0]";
         die "Can't handle command $circ->[0] for option '-circular'" unless $self->can($meth);
         my @args = @$circ; shift @args;
         my $act = $self->$meth(\@args);
         #$add_stmt->('stmt', 'say "ref=$ref, " . {{var}}'); # DEBUG
         $add_new_if->('$ref && $refs{ {{var}} }++', $act);
     }
 
     # recurse array and hash
     $add_new_if_ref->("ARRAY", '$process_array->({{var}})');
     $add_if_ref->("HASH" , '$process_hash->({{var}})');
 
     # lastly, catch any reference left
     for my $p ([-ref => '$ref']) {
         my $o = $opts->{$p->[0]};
         next unless $o;
         my $meth = "command_$o->[0]";
         die "Can't handle command $o->[0] for option '$p->[0]'" unless $self->can($meth);
         my @args = @$o; shift @args;
         $add_if->($p->[1], $self->$meth(\@args));
     }
 
     push @code, 'sub {'."\n";
     push @code, 'my $data = shift;'."\n";
     push @code, 'state %refs;'."\n" if $circ;
     push @code, 'state $ctr_circ;'."\n" if $circ;
     push @code, 'state $process_array;'."\n";
     push @code, 'state $process_hash;'."\n";
     push @code, 'if (!$process_array) { $process_array = sub { my $a = shift; for my $e (@$a) { my $ref=ref($e);'."\n".join("", @stmts_ary).'} } }'."\n";
     push @code, 'if (!$process_hash) { $process_hash = sub { my $h = shift; for my $k (keys %$h) { my $ref=ref($h->{$k});'."\n".join("", @stmts_hash).'} } }'."\n";
     push @code, '%refs = (); $ctr_circ=0;'."\n" if $circ;
     push @code, 'for ($data) { my $ref=ref($_);'."\n".join("", @stmts_main).'}'."\n";
     push @code, '$data'."\n";
     push @code, '}'."\n";
 
     my $code = join("", @code).";";
 
     if ($ENV{LOG_CLEANSER_CODE} && $log->is_trace) {
         require String::LineNumber;
         $log->tracef("Cleanser code:\n%s",
                      $ENV{LINENUM} // 1 ?
                          String::LineNumber::linenum($code) : $code);
     }
     eval "\$self->{code} = $code";
     die "Can't generate code: $@" if $@;
     $self->{src} = $code;
 }
 
 sub clean_in_place {
     my ($self, $data) = @_;
 
     $self->{code}->($data);
 }
 
 sub clone_and_clean {
     my ($self, $data) = @_;
     my $clone = clone($data);
     local $Data::Clean::Base::_clone = 1;
     $self->clean_in_place($clone);
 }
 
 1;
 # ABSTRACT: Base class for Data::Clean::*
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Data::Clean::Base - Base class for Data::Clean::*
 
 =head1 VERSION
 
 This document describes version 0.28 of Data::Clean::Base (from Perl distribution Data-Clean-JSON), released on 2015-06-10.
 
 =for Pod::Coverage ^(command_.+)$
 
 =head1 METHODS
 
 =head2 new(%opts) => $obj
 
 Create a new instance.
 
 Options specify what to do with problematic data. Option keys are either
 reference types or class names, or C<-obj> (to refer to objects, a.k.a. blessed
 references), C<-circular> (to refer to circular references), C<-ref> (to refer
 to references, used to process references not handled by other options). Option
 values are arrayrefs, the first element of the array is command name, to specify
 what to do with the reference/class. The rest are command arguments.
 
 Note that arrayrefs and hashrefs are always walked into, so it's not trapped by
 C<-ref>.
 
 Default for C<%opts>: C<< -ref => 'stringify' >>.
 
 Available commands:
 
 =over 4
 
 =item * ['stringify']
 
 This will stringify a reference like C<{}> to something like C<HASH(0x135f998)>.
 
 =item * ['replace_with_ref']
 
 This will replace a reference like C<{}> with C<HASH>.
 
 =item * ['replace_with_str', STR]
 
 This will replace a reference like C<{}> with I<STR>.
 
 =item * ['call_method']
 
 This will call a method and use its return as the replacement. For example:
 DateTime->from_epoch(epoch=>1000) when processed with [call_method => 'epoch']
 will become 1000.
 
 =item * ['call_func', STR]
 
 This will call a function named STR with value as argument and use its return as
 the replacement.
 
 =item * ['one_or_zero', STR]
 
 This will perform C<< $val ? 1:0 >>.
 
 =item * ['deref_scalar']
 
 This will replace a scalar reference like \1 with 1.
 
 =item * ['unbless']
 
 This will perform unblessing using L<Function::Fallback::CoreOrPP::unbless()>.
 Should be done only for objects (C<-obj>).
 
 =item * ['code', STR]
 
 This will replace with STR treated as Perl code.
 
 =item * ['clone', INT]
 
 This command is useful if you have circular references and want to expand/copy
 them. For example:
 
  my $def_opts = { opt1 => 'default', opt2 => 0 };
  my $users    = { alice => $def_opts, bob => $def_opts, charlie => $def_opts };
 
 C<$users> contains three references to the same data structure. With the default
 behaviour of C<< -circular => [replace_with_str => 'CIRCULAR'] >> the cleaned
 data structure will be:
 
  { alice   => { opt1 => 'default', opt2 => 0 },
    bob     => 'CIRCULAR',
    charlie => 'CIRCULAR' }
 
 But with C<< -circular => ['clone'] >> option, the data structure will be
 cleaned to become (the C<$def_opts> is cloned):
 
  { alice   => { opt1 => 'default', opt2 => 0 },
    bob     => { opt1 => 'default', opt2 => 0 },
    charlie => { opt1 => 'default', opt2 => 0 }, }
 
 The command argument specifies the number of references to clone as a limit (the
 default is 50), since a cyclical structure can lead to infinite cloning. Above
 this limit, the circular references will be replaced with a string
 C<"CIRCULAR">. For example:
 
  my $a = [1]; push @$a, $a;
 
 With C<< -circular => ['clone', 2] >> the data will be cleaned as:
 
  [1, [1, [1, "CIRCULAR"]]]
 
 With C<< -circular => ['clone', 3] >> the data will be cleaned as:
 
  [1, [1, [1, [1, "CIRCULAR"]]]]
 
 =back
 
 =head2 $obj->clean_in_place($data) => $cleaned
 
 Clean $data. Modify data in-place.
 
 =head2 $obj->clone_and_clean($data) => $cleaned
 
 Clean $data. Clone $data first.
 
 =head1 ENVIRONMENT
 
 =over
 
 =item * LOG_CLEANSER_CODE => BOOL (default: 0)
 
 Can be enabled if you want to see the generated cleanser code. It is logged at
 level C<trace>.
 
 =item * LINENUM => BOOL (default: 1)
 
 When logging cleanser code, whether to give line numbers.
 
 =back
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-JSON>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Data-Clean-JSON>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean-JSON>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Data/Clean/JSON.pm ###
 package Data::Clean::JSON;
 
 our $DATE = '2015-06-10'; # DATE
 our $VERSION = '0.28'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use parent qw(Data::Clean::Base);
 
 sub new {
     my ($class, %opts) = @_;
     $opts{DateTime}  //= [call_method => 'epoch'];
     $opts{'Time::Moment'} //= [call_method => 'epoch'];
     $opts{Regexp}    //= ['stringify'];
     $opts{SCALAR}    //= ['deref_scalar'];
     $opts{-ref}      //= ['replace_with_ref'];
     $opts{-circular} //= ['clone'];
     $opts{-obj}      //= ['unbless'];
     $class->SUPER::new(%opts);
 }
 
 sub get_cleanser {
     my $class = shift;
     state $singleton = $class->new;
     $singleton;
 }
 
 1;
 # ABSTRACT: Clean data so it is safe to output to JSON
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Data::Clean::JSON - Clean data so it is safe to output to JSON
 
 =head1 VERSION
 
 This document describes version 0.28 of Data::Clean::JSON (from Perl distribution Data-Clean-JSON), released on 2015-06-10.
 
 =head1 SYNOPSIS
 
  use Data::Clean::JSON;
  my $cleanser = Data::Clean::JSON->get_cleanser;
  my $data     = { code=>sub {}, re=>qr/abc/i };
 
  my $cleaned;
 
  # modifies data in-place
  $cleaned = $cleanser->clean_in_place($data);
 
  # ditto, but deep clone first, return
  $cleaned = $cleanser->clone_and_clean($data);
 
  # now output it
  use JSON;
  print encode_json($cleaned); # prints '{"code":"CODE","re":"(?^i:abc)"}'
 
 =head1 DESCRIPTION
 
 This class cleans data from anything that might be problematic when encoding to
 JSON. This includes coderefs, globs, and so on.
 
 Data that has been cleaned will probably not be convertible back to the
 original, due to information loss (for example, coderefs converted to string
 C<"CODE">).
 
 The design goals are good performance, good defaults, and just enough
 flexibility. The original use-case is for returning JSON response in HTTP API
 service.
 
 This module is significantly faster than modules like L<Data::Rmap> or
 L<Data::Visitor::Callback> because with something like Data::Rmap you repeatedly
 invoke callback for each data item. This module, on the other hand, generates a
 cleanser code using eval(), using native Perl for() loops.
 
 If C<LOG_CLEANSER_CODE> environment is set to true, the generated cleanser code
 will be logged using L<Log::Any> at trace level. You can see it, e.g. using
 L<Log::Any::App>:
 
  % LOG=1 LOG_CLEANSER_CODE=1 TRACE=1 perl -MLog::Any::App -MData::Clean::JSON \
    -e'$c=Data::Clean::JSON->new; ...'
 
 =head1 METHODS
 
 =head2 CLASS->get_cleanser => $obj
 
 Return a singleton instance, with default options. Use C<new()> if you want to
 customize options.
 
 =head2 CLASS->new(%opts) => $obj
 
 Create a new instance. For list of known options, see L<Data::Clean::Base>.
 Data::Clean::JSON sets some defaults.
 
     DateTime  => [call_method => 'epoch']
     Regexp    => ['stringify']
     SCALAR    => ['deref_scalar']
     -ref      => ['replace_with_ref']
     -circular => ['clone']
     -obj      => ['unbless']
 
 =head2 $obj->clean_in_place($data) => $cleaned
 
 Clean $data. Modify data in-place.
 
 =head2 $obj->clone_and_clean($data) => $cleaned
 
 Clean $data. Clone $data first.
 
 =head1 ENVIRONMENT
 
 LOG_CLEANSER_CODE
 
 =head1 FAQ
 
 =head2 Why clone/modify? Why not directly output JSON?
 
 So that the data can be used for other stuffs, like outputting to YAML, etc.
 
 =head2 Why is it slow?
 
 If you use C<new()> instead of C<get_cleanser()>, make sure that you do not
 construct the Data::Clean::JSON object repeatedly, as the constructor generates
 the cleanser code first using eval(). A short benchmark (run on my slow Atom
 netbook):
 
  % bench -MData::Clean::JSON -b'$c=Data::Clean::JSON->new' \
      'Data::Clean::JSON->new->clone_and_clean([1..100])' \
      '$c->clone_and_clean([1..100])'
  Benchmarking sub { Data::Clean::JSON->new->clean_in_place([1..100]) }, sub { $c->clean_in_place([1..100]) } ...
  a: 302 calls (291.3/s), 1.037s (3.433ms/call)
  b: 7043 calls (4996/s), 1.410s (0.200ms/call)
  Fastest is b (17.15x a)
 
 Second, you can turn off some checks if you are sure you will not be getting bad
 data. For example, if you know that your input will not contain circular
 references, you can turn off circular detection:
 
  $cleanser = Data::Clean::JSON->new(-circular => 0);
 
 Benchmark:
 
  $ perl -MData::Clean::JSON -MBench -E '
    $data = [[1],[2],[3],[4],[5]];
    bench {
        circ   => sub { state $c = Data::Clean::JSON->new;               $c->clone_and_clean($data) },
        nocirc => sub { state $c = Data::Clean::JSON->new(-circular=>0); $c->clone_and_clean($data) }
    }, -1'
  circ: 9456 calls (9425/s), 1.003s (0.106ms/call)
  nocirc: 13161 calls (12885/s), 1.021s (0.0776ms/call)
  Fastest is nocirc (1.367x circ)
 
 The less number of checks you do, the faster the cleansing process will be.
 
 =head2 Why am I getting 'Not a CODE reference at lib/Data/Clean/Base.pm line xxx'?
 
 [2013-08-07 ] This error message is from Data::Clone::clone() when it is cloning
 an object. If you are cleaning objects, instead of using clone_and_clean(), try
 using clean_in_place(). Or, clone your data first using something else like
 L<Sereal>.
 
 =head1 SEE ALSO
 
 L<Data::Rmap>
 
 L<Data::Visitor::Callback>
 
 L<Data::Abridge> is similar in goal, which is to let Perl data structures (which
 might contain stuffs unsupported in JSON) be encodeable to JSON. But unlike
 Data::Clean::JSON, it has some (currently) non-configurable rules, like changing
 a coderef with a hash C<< {CODE=>'\&main::__ANON__'} >> or a scalar ref with C<<
 {SCALAR=>'value'} >> and so on. Note that the abridging process is similarly
 unidirectional (you cannot convert back the original Perl data structure).
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-JSON>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Data-Clean-JSON>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Clean-JSON>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Data/Sah/Normalize.pm ###
 package Data::Sah::Normalize;
 
 use 5.010001;
 use strict;
 use warnings;
 
 our $DATE = '2015-04-24'; # DATE
 our $VERSION = '0.03'; # VERSION
 
 require Exporter;
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw(
                        normalize_clset
                        normalize_schema
 
                        $type_re
                        $clause_name_re
                        $clause_re
                        $attr_re
                        $funcset_re
                        $compiler_re
                );
 
 our $type_re        = qr/\A(?:[A-Za-z_]\w*::)*[A-Za-z_]\w*\z/;
 our $clause_name_re = qr/\A[A-Za-z_]\w*\z/;
 our $clause_re      = qr/\A[A-Za-z_]\w*(?:\.[A-Za-z_]\w*)*\z/;
 our $attr_re        = $clause_re;
 our $funcset_re     = qr/\A(?:[A-Za-z_]\w*::)*[A-Za-z_]\w*\z/;
 our $compiler_re    = qr/\A[A-Za-z_]\w*\z/;
 our $clause_attr_on_empty_clause_re = qr/\A(?:\.[A-Za-z_]\w*)+\z/;
 
 sub normalize_clset($;$) {
     my ($clset0, $opts) = @_;
     $opts //= {};
 
     my $clset = {};
     for my $c (sort keys %$clset0) {
         my $c0 = $c;
 
         my $v = $clset0->{$c};
 
         # ignore expression
         my $expr;
         if ($c =~ s/=\z//) {
             $expr++;
             # XXX currently can't disregard merge prefix when checking
             # conflict
             die "Conflict between '$c=' and '$c'" if exists $clset0->{$c};
             $clset->{"$c.is_expr"} = 1;
             }
 
         my $sc = "";
         my $cn;
         {
             my $errp = "Invalid clause name syntax '$c0'"; # error prefix
             if (!$expr && $c =~ s/\A!(?=.)//) {
                 die "$errp, syntax should be !CLAUSE"
                     unless $c =~ $clause_name_re;
                 $sc = "!";
             } elsif (!$expr && $c =~ s/(?<=.)\|\z//) {
                 die "$errp, syntax should be CLAUSE|"
                     unless $c =~ $clause_name_re;
                 $sc = "|";
             } elsif (!$expr && $c =~ s/(?<=.)\&\z//) {
                 die "$errp, syntax should be CLAUSE&"
                     unless $c =~ $clause_name_re;
                 $sc = "&";
             } elsif (!$expr && $c =~ /\A([^.]+)(?:\.(.+))?\((\w+)\)\z/) {
                 my ($c2, $a, $lang) = ($1, $2, $3);
                 die "$errp, syntax should be CLAUSE(LANG) or C.ATTR(LANG)"
                     unless $c2 =~ $clause_name_re &&
                         (!defined($a) || $a =~ $attr_re);
                 $sc = "(LANG)";
                 $cn = $c2 . (defined($a) ? ".$a" : "") . ".alt.lang.$lang";
             } elsif ($c !~ $clause_re &&
                          $c !~ $clause_attr_on_empty_clause_re) {
                 die "$errp, please use letter/digit/underscore only";
             }
         }
 
         # XXX can't disregard merge prefix when checking conflict
         if ($sc eq '!') {
             die "Conflict between clause shortcuts '!$c' and '$c'"
                 if exists $clset0->{$c};
             die "Conflict between clause shortcuts '!$c' and '$c|'"
                 if exists $clset0->{"$c|"};
             die "Conflict between clause shortcuts '!$c' and '$c&'"
                 if exists $clset0->{"$c&"};
             $clset->{$c} = $v;
             $clset->{"$c.op"} = "not";
         } elsif ($sc eq '&') {
             die "Conflict between clause shortcuts '$c&' and '$c'"
                 if exists $clset0->{$c};
             die "Conflict between clause shortcuts '$c&' and '$c|'"
                 if exists $clset0->{"$c|"};
             die "Clause 'c&' value must be an array"
                 unless ref($v) eq 'ARRAY';
             $clset->{$c} = $v;
             $clset->{"$c.op"} = "and";
         } elsif ($sc eq '|') {
             die "Conflict between clause shortcuts '$c|' and '$c'"
                 if exists $clset0->{$c};
             die "Clause 'c|' value must be an array"
                 unless ref($v) eq 'ARRAY';
             $clset->{$c} = $v;
             $clset->{"$c.op"} = "or";
         } elsif ($sc eq '(LANG)') {
             die "Conflict between clause '$c' and '$cn'"
                 if exists $clset0->{$cn};
             $clset->{$cn} = $v;
         } else {
             $clset->{$c} = $v;
         }
 
     }
     $clset->{req} = 1 if $opts->{has_req};
 
     # XXX option to recursively normalize clset, any's of, all's of, ...
     #if ($clset->{clset}) {
     #    local $opts->{has_req};
     #    if ($clset->{'clset.op'} && $clset->{'clset.op'} =~ /and|or/) {
     #        # multiple clause sets
     #        $clset->{clset} = map { $self->normalize_clset($_, $opts) }
     #            @{ $clset->{clset} };
     #    } else {
     #        $clset->{clset} = $self->normalize_clset($_, $opts);
     #    }
     #}
 
     $clset;
 }
 
 sub normalize_schema($) {
     my $s = shift;
 
     my $ref = ref($s);
     if (!defined($s)) {
 
         die "Schema is missing";
 
     } elsif (!$ref) {
 
         my $has_req = $s =~ s/\*\z//;
         $s =~ $type_re or die "Invalid type syntax $s, please use ".
             "letter/digit/underscore only";
         return [$s, $has_req ? {req=>1} : {}, {}];
 
     } elsif ($ref eq 'ARRAY') {
 
         my $t = $s->[0];
         my $has_req = $t && $t =~ s/\*\z//;
         if (!defined($t)) {
             die "For array form, at least 1 element is needed for type";
         } elsif (ref $t) {
             die "For array form, first element must be a string";
         }
         $t =~ $type_re or die "Invalid type syntax $s, please use ".
             "letter/digit/underscore only";
 
         my $clset0;
         my $extras;
         if (defined($s->[1])) {
             if (ref($s->[1]) eq 'HASH') {
                 $clset0 = $s->[1];
                 $extras = $s->[2];
                 die "For array form, there should not be more than 3 elements"
                     if @$s > 3;
             } else {
                 # flattened clause set [t, c=>1, c2=>2, ...]
                 die "For array in the form of [t, c1=>1, ...], there must be ".
                     "3 elements (or 5, 7, ...)"
                         unless @$s % 2;
                 $clset0 = { @{$s}[1..@$s-1] };
             }
         } else {
             $clset0 = {};
         }
 
         # check clauses and parse shortcuts (!c, c&, c|, c=)
         my $clset = normalize_clset($clset0, {has_req=>$has_req});
         if (defined $extras) {
             die "For array form with 3 elements, extras must be hash"
                 unless ref($extras) eq 'HASH';
             die "'def' in extras must be a hash"
                 if exists $extras->{def} && ref($extras->{def}) ne 'HASH';
             return [$t, $clset, { %{$extras} }];
         } else {
             return [$t, $clset, {}];
         }
     }
 
     die "Schema must be a string or arrayref (not $ref)";
 }
 
 1;
 # ABSTRACT: Normalize Sah schema
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Data::Sah::Normalize - Normalize Sah schema
 
 =head1 VERSION
 
 This document describes version 0.03 of Data::Sah::Normalize (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-24.
 
 =head1 SYNOPSIS
 
  use Data::Sah::Normalize qw(normalize_clset normalize_schema);
 
  my $nclset = normalize_clset({'!a'=>1}); # -> {a=>1, 'a.op'=>'not'}
  my $nsch   = normalize_schema("int");    # -> ["int", {}, {}]
 
 =head1 DESCRIPTION
 
 This often-needed functionality is split from the main L<Data::Sah> to keep it
 in a small and minimal-dependencies package.
 
 =head1 FUNCTIONS
 
 =head2 normalize_clset($clset) => HASH
 
 Normalize a clause set (hash). Return a shallow copy of the original hash. Die
 on failure.
 
 TODO: option to recursively normalize clause which contains sah clauses (e.g.
 C<of>).
 
 =head2 normalize_schema($sch) => ARRAY
 
 Normalize a Sah schema (scalar or array). Return an array. Produce a 2-level
 copy of schema, so it's safe to add/delete/modify the normalized schema's clause
 set and extras (but clause set's and extras' values are still references to the
 original). Die on failure.
 
 TODO: recursively normalize clause which contains sah clauses (e.g. C<of>).
 
 =head1 SEE ALSO
 
 L<Sah>, L<Data::Sah>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Normalize>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Data-Sah-Normalize>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah-Normalize>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### DefHash.pm ###
 package DefHash;
 
 our $VERSION = '1.0.10'; # VERSION
 
 1;
 # ABSTRACT: Define things according to a specification, using hashes
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 DefHash - Define things according to a specification, using hashes
 
 =head1 VERSION
 
 This document describes version 1.0.10 of DefHash (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-24.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/DefHash>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-DefHash>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=DefHash>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Exporter/Shiny.pm ###
 package Exporter::Shiny;
 
 use 5.006001;
 use strict;
 use warnings;
 
 use Exporter::Tiny ();
 
 our $AUTHORITY = 'cpan:TOBYINK';
 our $VERSION   = '0.042';
 
 sub import {
 	my $me     = shift;
 	my $caller = caller;
 	
 	(my $nominal_file = $caller) =~ s(::)(/)g;
 	$INC{"$nominal_file\.pm"} ||= __FILE__;
 	
 	if (@_ == 2 and $_[0] eq -setup)
 	{
 		my (undef, $opts) = @_;
 		@_ = @{ delete($opts->{exports}) || [] };
 		
 		if (%$opts) {
 			Exporter::Tiny::_croak(
 				'Unsupported Sub::Exporter-style options: %s',
 				join(q[, ], sort keys %$opts),
 			);
 		}
 	}
 	
 	ref($_) && Exporter::Tiny::_croak('Expected sub name, got ref %s', $_) for @_;
 	
 	no strict qw(refs);
 	push @{"$caller\::ISA"}, 'Exporter::Tiny';
 	push @{"$caller\::EXPORT_OK"}, @_;
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding utf-8
 
 =head1 NAME
 
 Exporter::Shiny - shortcut for Exporter::Tiny
 
 =head1 SYNOPSIS
 
    use Exporter::Shiny qw( foo bar );
 
 Is a shortcut for:
 
    use base "Exporter::Tiny";
    push our(@EXPORT_OK), qw( foo bar );
 
 For compatibility with L<Sub::Exporter>, the following longer syntax is
 also supported:
 
    use Exporter::Shiny -setup => {
       exports => [qw( foo bar )],
    };
 
 =head1 DESCRIPTION
 
 This is a very small wrapper to simplify using L<Exporter::Tiny>.
 
 It does the following:
 
 =over
 
 =item * Marks your package as loaded in C<< %INC >>;
 
 =item * Pushes any function names in the import list onto your C<< @EXPORT_OK >>; and
 
 =item * Pushes C<< "Exporter::Tiny" >> onto your C<< @ISA >>.
 
 =back
 
 It doesn't set up C<< %EXPORT_TAGS >> or C<< @EXPORT >>, but there's
 nothing stopping you doing that yourself.
 
 =head1 BUGS
 
 Please report any bugs to
 L<http://rt.cpan.org/Dist/Display.html?Queue=Exporter-Tiny>.
 
 =head1 SEE ALSO
 
 L<Exporter::Tiny>.
 
 =head1 AUTHOR
 
 Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
 
 =head1 COPYRIGHT AND LICENCE
 
 This software is copyright (c) 2014 by Toby Inkster.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =head1 DISCLAIMER OF WARRANTIES
 
 THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
### Exporter/Tiny.pm ###
 package Exporter::Tiny;
 
 use 5.006001;
 use strict;
 use warnings; no warnings qw(void once uninitialized numeric redefine);
 
 our $AUTHORITY = 'cpan:TOBYINK';
 our $VERSION   = '0.042';
 our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;
 
 sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
 sub _carp  ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }
 
 my $_process_optlist = sub
 {
 	my $class = shift;
 	my ($global_opts, $opts, $want, $not_want) = @_;
 	
 	while (@$opts)
 	{
 		my $opt = shift @{$opts};
 		my ($name, $value) = @$opt;
 		
 		($name =~ m{\A\!(/.+/[msixpodual]+)\z}) ?
 			do {
 				my @not = $class->_exporter_expand_regexp($1, $value, $global_opts);
 				++$not_want->{$_->[0]} for @not;
 			} :
 		($name =~ m{\A\!(.+)\z}) ?
 			(++$not_want->{$1}) :
 		($name =~ m{\A[:-](.+)\z}) ?
 			push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) :
 		($name =~ m{\A/.+/[msixpodual]+\z}) ?
 			push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
 		# else ?
 			push(@$want, $opt);
 	}
 };
 
 sub import
 {
 	my $class = shift;
 	my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
 	$global_opts->{into} = caller unless exists $global_opts->{into};
 	
 	my @want;
 	my %not_want; $global_opts->{not} = \%not_want;
 	my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
 	my $opts = mkopt(\@args);
 	$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
 	
 	my $permitted = $class->_exporter_permitted_regexp($global_opts);
 	$class->_exporter_validate_opts($global_opts);
 	
 	for my $wanted (@want)
 	{
 		next if $not_want{$wanted->[0]};
 		
 		my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
 		$class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
 			for keys %symbols;
 	}
 }
 
 sub unimport
 {
 	my $class = shift;
 	my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
 	$global_opts->{into} = caller unless exists $global_opts->{into};
 	$global_opts->{is_unimport} = 1;
 	
 	my @want;
 	my %not_want; $global_opts->{not} = \%not_want;
 	my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
 	my $opts = mkopt(\@args);
 	$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
 	
 	my $permitted = $class->_exporter_permitted_regexp($global_opts);
 	$class->_exporter_validate_unimport_opts($global_opts);
 	
 	my $expando = $class->can('_exporter_expand_sub');
 	$expando = undef if $expando == \&_exporter_expand_sub;
 	
 	for my $wanted (@want)
 	{
 		next if $not_want{$wanted->[0]};
 		
 		if ($wanted->[1])
 		{
 			_carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
 				unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
 		}
 		
 		my %symbols = defined($expando)
 			? $class->$expando(@$wanted, $global_opts, $permitted)
 			: ($wanted->[0] => sub { "dummy" });
 		$class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
 			for keys %symbols;
 	}
 }
 
 # Called once per import/unimport, passed the "global" import options.
 # Expected to validate the options and carp or croak if there are problems.
 # Can also take the opportunity to do other stuff if needed.
 #
 sub _exporter_validate_opts          { 1 }
 sub _exporter_validate_unimport_opts { 1 }
 
 # Called after expanding a tag or regexp to merge the tag's options with
 # any sub-specific options.
 #
 sub _exporter_merge_opts
 {
 	my $class = shift;
 	my ($tag_opts, $global_opts, @stuff) = @_;
 	
 	$tag_opts = {} unless ref($tag_opts) eq q(HASH);
 	_croak('Cannot provide an -as option for tags')
 		if exists $tag_opts->{-as};
 	
 	my $optlist = mkopt(\@stuff);
 	for my $export (@$optlist)
 	{
 		next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
 		
 		my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
 		$sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
 			if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
 		$sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
 			if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
 		$export->[1] = \%sub_opts;
 	}
 	return @$optlist;
 }
 
 # Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
 # associated functions. The default implementation magically handles tags
 # "all" and "default". The default implementation interprets any undefined
 # tags as being global options.
 # 
 sub _exporter_expand_tag
 {
 	no strict qw(refs);
 	
 	my $class = shift;
 	my ($name, $value, $globals) = @_;
 	my $tags  = \%{"$class\::EXPORT_TAGS"};
 	
 	return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
 		if ref($tags->{$name}) eq q(CODE);
 	
 	return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}})
 		if exists $tags->{$name};
 	
 	return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"})
 		if $name eq 'all';
 	
 	return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"})
 		if $name eq 'default';
 	
 	$globals->{$name} = $value || 1;
 	return;
 }
 
 # Given a regexp-like string, looks it up in @EXPORT_OK and returns the
 # list of matching functions.
 # 
 sub _exporter_expand_regexp
 {
 	no strict qw(refs);
 	our %TRACKED;
 	
 	my $class = shift;
 	my ($name, $value, $globals) = @_;
 	my $compiled = eval("qr$name");
 	
 	my @possible = $globals->{is_unimport}
 		? keys( %{$TRACKED{$class}{$globals->{into}}} )
 		: @{"$class\::EXPORT_OK"};
 	
 	$class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible);
 }
 
 # Helper for _exporter_expand_sub. Returns a regexp matching all subs in
 # the exporter package which are available for export.
 #
 sub _exporter_permitted_regexp
 {
 	no strict qw(refs);
 	my $class = shift;
 	my $re = join "|", map quotemeta, sort {
 		length($b) <=> length($a) or $a cmp $b
 	} @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"};
 	qr{^(?:$re)$}ms;
 }
 
 # Given a sub name, returns a hash of subs to install (usually just one sub).
 # Keys are sub names, values are coderefs.
 #
 sub _exporter_expand_sub
 {
 	my $class = shift;
 	my ($name, $value, $globals, $permitted) = @_;
 	$permitted ||= $class->_exporter_permitted_regexp($globals);
 	
 	no strict qw(refs);
 	
 	if ($name =~ $permitted)
 	{
 		my $generator = $class->can("_generate_$name");
 		return $name => $class->$generator($name, $value, $globals) if $generator;
 		
 		my $sub = $class->can($name);
 		return $name => $sub if $sub;
 	}
 	
 	$class->_exporter_fail(@_);
 }
 
 # Called by _exporter_expand_sub if it is unable to generate a key-value
 # pair for a sub.
 #
 sub _exporter_fail
 {
 	my $class = shift;
 	my ($name, $value, $globals) = @_;
 	return if $globals->{is_unimport};
 	_croak("Could not find sub '%s' exported by %s", $name, $class);
 }
 
 # Actually performs the installation of the sub into the target package. This
 # also handles renaming the sub.
 #
 sub _exporter_install_sub
 {
 	my $class = shift;
 	my ($name, $value, $globals, $sym) = @_;
 	
 	my $into      = $globals->{into};
 	my $installer = $globals->{installer} || $globals->{exporter};
 	
 	$name = $value->{-as} || $name;
 	unless (ref($name) eq q(SCALAR))
 	{
 		my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
 		my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
 		$name = "$prefix$name$suffix";
 	}
 	
 	return ($$name = $sym)                       if ref($name) eq q(SCALAR);
 	return ($into->{$name} = $sym)               if ref($into) eq q(HASH);
 	
 	no strict qw(refs);
 	
 	if (exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym)
 	{
 		my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0);
 		my $action = {
 			carp     => \&_carp,
 			0        => \&_carp,
 			''       => \&_carp,
 			warn     => \&_carp,
 			nonfatal => \&_carp,
 			croak    => \&_croak,
 			fatal    => \&_croak,
 			die      => \&_croak,
 		}->{$level} || sub {};
 		
 		$action->(
 			$action == \&_croak
 				? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s"
 				: "Overwriting existing sub '%s::%s' with sub '%s' exported by %s",
 			$into,
 			$name,
 			$_[0],
 			$class,
 		);
 	}
 	
 	our %TRACKED;
 	$TRACKED{$class}{$into}{$name} = $sym;
 	
 	no warnings qw(prototype);
 	$installer
 		? $installer->($globals, [$name, $sym])
 		: (*{"$into\::$name"} = $sym);
 }
 
 sub _exporter_uninstall_sub
 {
 	our %TRACKED;
 	my $class = shift;
 	my ($name, $value, $globals, $sym) = @_;
 	my $into = $globals->{into};
 	ref $into and return;
 	
 	no strict qw(refs);
 	
 	# Cowardly refuse to uninstall a sub that differs from the one
 	# we installed!
 	my $our_coderef = $TRACKED{$class}{$into}{$name};
 	my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1;
 	return unless $our_coderef == $cur_coderef;
 	
 	my $stash     = \%{"$into\::"};
 	my $old       = delete $stash->{$name};
 	my $full_name = join('::', $into, $name);
 	foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE
 	{
 		next unless defined(*{$old}{$type});
 		*$full_name = *{$old}{$type};
 	}
 	
 	delete $TRACKED{$class}{$into}{$name};
 }
 
 sub mkopt
 {
 	my $in = shift or return [];
 	my @out;
 	
 	$in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)]
 		if ref($in) eq q(HASH);
 	
 	for (my $i = 0; $i < @$in; $i++)
 	{
 		my $k = $in->[$i];
 		my $v;
 		
 		($i == $#$in)         ? ($v = undef) :
 		!defined($in->[$i+1]) ? (++$i, ($v = undef)) :
 		!ref($in->[$i+1])     ? ($v = undef) :
 		($v = $in->[++$i]);
 		
 		push @out, [ $k => $v ];
 	}
 	
 	\@out;
 }
 
 sub mkopt_hash
 {
 	my $in  = shift or return;
 	my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) };
 	\%out;
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding utf-8
 
 =for stopwords frobnicate greps regexps
 
 =head1 NAME
 
 Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies
 
 =head1 SYNOPSIS
 
    package MyUtils;
    use base "Exporter::Tiny";
    our @EXPORT = qw(frobnicate);
    sub frobnicate { my $n = shift; ... }
    1;
 
    package MyScript;
    use MyUtils "frobnicate" => { -as => "frob" };
    print frob(42);
    exit;
 
 =head1 DESCRIPTION
 
 Exporter::Tiny supports many of Sub::Exporter's external-facing features
 including renaming imported functions with the C<< -as >>, C<< -prefix >> and
 C<< -suffix >> options; explicit destinations with the C<< into >> option;
 and alternative installers with the C<< installler >> option. But it's written
 in only about 40% as many lines of code and with zero non-core dependencies.
 
 Its internal-facing interface is closer to Exporter.pm, with configuration
 done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >>
 package variables.
 
 Exporter::Tiny performs most of its internal duties (including resolution
 of tag names to sub names, resolution of sub names to coderefs, and
 installation of coderefs into the target package) as method calls, which
 means they can be overridden to provide interesting behaviour.
 
 =head2 Utility Functions
 
 These are really for internal use, but can be exported if you need them.
 
 =over
 
 =item C<< mkopt(\@array) >>
 
 Similar to C<mkopt> from L<Data::OptList>. It doesn't support all the
 fancy options that Data::OptList does (C<moniker>, C<require_unique>,
 C<must_be> and C<name_test>) but runs about 50% faster.
 
 =item C<< mkopt_hash(\@array) >>
 
 Similar to C<mkopt_hash> from L<Data::OptList>. See also C<mkopt>.
 
 =back
 
 =head1 TIPS AND TRICKS IMPORTING FROM EXPORTER::TINY
 
 For the purposes of this discussion we'll assume we have a module called
 C<< MyUtils >> which exports one function, C<< frobnicate >>. C<< MyUtils >>
 inherits from Exporter::Tiny.
 
 Many of these tricks may seem familiar from L<Sub::Exporter>. That is
 intentional. Exporter::Tiny doesn't attempt to provide every feature of
 Sub::Exporter, but where it does it usually uses a fairly similar API.
 
 =head2 Basic importing
 
    # import "frobnicate" function
    use MyUtils "frobnicate";
 
    # import all functions that MyUtils offers
    use MyUtils -all;
 
 =head2 Renaming imported functions
 
    # call it "frob"
    use MyUtils "frobnicate" => { -as => "frob" };
 
    # call it "my_frobnicate"
    use MyUtils "frobnicate" => { -prefix => "my_" };
 
    # can set a prefix for *all* functions imported from MyUtils
    # by placing the options hashref *first*.
    use MyUtils { prefix => "my_" }, "frobnicate";
    # (note the lack of hyphen before `prefix`.)
 
    # call it "frobnicate_util"
    use MyUtils "frobnicate" => { -suffix => "_util" };
    use MyUtils { suffix => "_util" }, "frobnicate";
 
    # import it twice with two different names
    use MyUtils
       "frobnicate" => { -as => "frob" },
       "frobnicate" => { -as => "frbnct" };
 
 =head2 Lexical subs
 
    {
       use Sub::Exporter::Lexical lexical_installer => { -as => "lex" };
       use MyUtils { installer => lex }, "frobnicate";
       
       frobnicate(...);  # ok
    }
    
    frobnicate(...);  # not ok
 
 =head2 Import functions into another package
 
    use MyUtils { into => "OtherPkg" }, "frobnicate";
    
    OtherPkg::frobincate(...);
 
 =head2 Import functions into a scalar
 
    my $func;
    use MyUtils "frobnicate" => { -as => \$func };
    
    $func->(...);
 
 =head2 Import functions into a hash
 
 OK, Sub::Exporter doesn't do this...
 
    my %funcs;
    use MyUtils { into => \%funcs }, "frobnicate";
    
    $funcs{frobnicate}->(...);
 
 =head2 DO NOT WANT!
 
 This imports everything except "frobnicate":
 
    use MyUtils qw( -all !frobnicate );
 
 Negated imports always "win", so the following will not import
 "frobnicate", no matter how many times you repeat it...
 
    use MyUtils qw( !frobnicate frobnicate frobnicate frobnicate );
 
 =head2 Importing by regexp
 
 Here's how you could import all functions beginning with an "f":
 
    use MyUtils qw( /^F/i );
 
 Or import everything except functions beginning with a "z":
 
    use MyUtils qw( -all !/^Z/i );
 
 Note that regexps are always supplied as I<strings> starting with
 C<< "/" >>, and not as quoted regexp references (C<< qr/.../ >>).
 
 =head2 Unimporting
 
 You can unimport the functions that MyUtils added to your namespace:
 
    no MyUtils;
 
 Or just specific ones:
 
    no MyUtils qw(frobnicate);
 
 If you renamed a function when you imported it, you should unimport by
 the new name:
 
    use MyUtils frobnicate => { -as => "frob" };
    ...;
    no MyUtils "frob";
 
 Unimporting using tags and regexps should mostly do what you want.
 
 =head1 TIPS AND TRICKS EXPORTING USING EXPORTER::TINY
 
 Simple configuration works the same as L<Exporter>; inherit from this module,
 and use the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >>
 package variables to list subs to export.
 
 =head2 Generators
 
 Exporter::Tiny has always allowed exported subs to be generated (like
 L<Sub::Exporter>), but until version 0.025 did not have an especially nice
 API for it.
 
 Now, it's easy. If you want to generate a sub C<foo> to export, list it in
 C<< @EXPORT >> or C<< @EXPORT_OK >> as usual, and then simply give your
 exporter module a class method called C<< _generate_foo >>.
 
    push @EXPORT_OK, 'foo';
    
    sub _generate_foo {
       my $class = shift;
       my ($name, $args, $globals) = @_;
       
       return sub {
          ...;
       }
    }
 
 You can also generate tags:
 
    my %constants;
    BEGIN {
       %constants = (FOO => 1, BAR => 2);
    }
    use constant \%constants;
    
    $EXPORT_TAGS{constants} = sub {
       my $class = shift;
       my ($name, $args, $globals) = @_;
       
       return keys(%constants);
    };
 
 =head2 Overriding Internals
 
 An important difference between L<Exporter> and Exporter::Tiny is that
 the latter calls all its internal functions as I<< class methods >>. This
 means that your subclass can I<< override them >> to alter their behaviour.
 
 The following methods are available to be overridden. Despite being named
 with a leading underscore, they are considered public methods. (The underscore
 is there to avoid accidentally colliding with any of your own function names.)
 
 =over
 
 =item C<< _exporter_validate_opts($globals) >>
 
 This method is called once each time C<import> is called. It is passed a
 reference to the global options hash. (That is, the optional leading hashref
 in the C<use> statement, where the C<into> and C<installer> options can be
 provided.)
 
 You may use this method to munge the global options, or validate them,
 throwing an exception or printing a warning.
 
 The default implementation does nothing interesting.
 
 =item C<< _exporter_validate_unimport_opts($globals) >>
 
 Like C<_exporter_validate_opts>, but called for C<unimport>.
 
 =item C<< _exporter_merge_opts($tag_opts, $globals, @exports) >>
 
 Called to merge options which have been provided for a tag into the
 options provided for the exports that the tag expanded to.
 
 =item C<< _exporter_expand_tag($name, $args, $globals) >>
 
 This method is called to expand an import tag (e.g. C<< ":constants" >>).
 It is passed the tag name (minus the leading ":"), an optional hashref
 of options (like C<< { -prefix => "foo_" } >>), and the global options
 hashref.
 
 It is expected to return a list of ($name, $args) arrayref pairs. These
 names can be sub names to export, or further tag names (which must have
 their ":"). If returning tag names, be careful to avoid creating a tag
 expansion loop!
 
 The default implementation uses C<< %EXPORT_TAGS >> to expand tags, and
 provides fallbacks for the C<< :default >> and C<< :all >> tags.
 
 =item C<< _exporter_expand_regexp($regexp, $args, $globals) >>
 
 Like C<_exporter_expand_regexp>, but given a regexp-like string instead
 of a tag name.
 
 The default implementation greps through C<< @EXPORT_OK >> for imports,
 and the list of already-imported functions for exports.
 
 =item C<< _exporter_expand_sub($name, $args, $globals) >>
 
 This method is called to translate a sub name to a hash of name => coderef
 pairs for exporting to the caller. In general, this would just be a hash with
 one key and one value, but, for example, L<Type::Library> overrides this
 method so that C<< "+Foo" >> gets expanded to:
 
    (
       Foo         => sub { $type },
       is_Foo      => sub { $type->check(@_) },
       to_Foo      => sub { $type->assert_coerce(@_) },
       assert_Foo  => sub { $type->assert_return(@_) },
    )
 
 The default implementation checks that the name is allowed to be exported
 (using the C<_exporter_permitted_regexp> method), gets the coderef using
 the generator if there is one (or by calling C<< can >> on your exporter
 otherwise) and calls C<_exporter_fail> if it's unable to generate or
 retrieve a coderef.
 
 =item C<< _exporter_permitted_regexp($globals) >>
 
 This method is called to retrieve a regexp for validating the names of
 exportable subs. If a sub doesn't match the regexp, then the default
 implementation of C<_exporter_expand_sub> will refuse to export it. (Of
 course, you may override the default C<_exporter_expand_sub>.)
 
 The default implementation of this method assembles the regexp from
 C<< @EXPORT >> and C<< @EXPORT_OK >>.
 
 =item C<< _exporter_fail($name, $args, $globals) >>
 
 Called by C<_exporter_expand_sub> if it can't find a coderef to export.
 
 The default implementation just throws an exception. But you could emit
 a warning instead, or just ignore the failed export.
 
 If you don't throw an exception then you should be aware that this
 method is called in list context, and any list it returns will be treated
 as an C<_exporter_expand_sub>-style hash of names and coderefs for
 export.
 
 =item C<< _exporter_install_sub($name, $args, $globals, $coderef) >>
 
 This method actually installs the exported sub into its new destination.
 Its return value is ignored.
 
 The default implementation handles sub renaming (i.e. the C<< -as >>,
 C<< -prefix >> and C<< -suffix >> functions. This method does a lot of
 stuff; if you need to override it, it's probably a good idea to just
 pre-process the arguments and then call the super method rather than
 trying to handle all of it yourself.
 
 =item C<< _exporter_uninstall_sub($name, $args, $globals) >>
 
 The opposite of C<_exporter_install_sub>.
 
 =back
 
 =head1 DIAGNOSTICS
 
 =over
 
 =item B<< Overwriting existing sub '%s::%s' with sub '%s' exported by %s >>
 
 A warning issued if Exporter::Tiny is asked to export a symbol which
 will result in an existing sub being overwritten. This warning can be
 suppressed using either of the following:
 
    use MyUtils { replace => 1 }, "frobnicate";
    use MyUtils "frobnicate" => { -replace => 1 };
 
 Or can be upgraded to a fatal error:
 
    use MyUtils { replace => "die" }, "frobnicate";
    use MyUtils "frobnicate" => { -replace => "die" };
 
 =item B<< Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s >>
 
 The fatal version of the above warning.
 
 =item B<< Could not find sub '%s' exported by %s >>
 
 You requested to import a sub which the package does not provide.
 
 =item B<< Cannot provide an -as option for tags >>
 
 Because a tag may provide more than one function, it does not make sense
 to request a single name for it. Instead use C<< -prefix >> or C<< -suffix >>.
 
 =item B<< Passing options to unimport '%s' makes no sense >>
 
 When you import a sub, it occasionally makes sense to pass some options
 for it. However, when unimporting, options do nothing, so this warning
 is issued.
 
 =back
 
 =head1 HISTORY
 
 L<Type::Library> had a bunch of custom exporting code which poked coderefs
 into its caller's stash. It needed this to be something more powerful than
 most exporters so that it could switch between exporting Moose, Mouse and
 Moo-compatible objects on request. L<Sub::Exporter> would have been capable,
 but had too many dependencies for the Type::Tiny project.
 
 Meanwhile L<Type::Utils>, L<Types::TypeTiny> and L<Test::TypeTiny> each
 used the venerable L<Exporter.pm|Exporter>. However, this meant they were
 unable to use the features like L<Sub::Exporter>-style function renaming
 which I'd built into Type::Library:
 
    ## import "Str" but rename it to "String".
    use Types::Standard "Str" => { -as => "String" };
 
 And so I decided to factor out code that could be shared by all Type-Tiny's
 exporters into a single place: Exporter::TypeTiny.
 
 As of version 0.026, Exporter::TypeTiny was also made available as
 L<Exporter::Tiny>, distributed independently on CPAN. CHOCOLATEBOY had
 convinced me that it was mature enough to live a life of its own.
 
 As of version 0.030, Type-Tiny depends on Exporter::Tiny and
 Exporter::TypeTiny is being phased out.
 
 =head1 OBLIGATORY EXPORTER COMPARISON
 
 Exporting is unlikely to be your application's performance bottleneck, but
 nonetheless here are some comparisons.
 
 B<< Comparative sizes according to L<Devel::SizeMe>: >>
 
    Exporter                     217.1Kb
    Sub::Exporter::Progressive   263.2Kb
    Exporter::Tiny               267.7Kb
    Exporter + Exporter::Heavy   281.5Kb
    Exporter::Renaming           406.2Kb
    Sub::Exporter                701.0Kb
 
 B<< Performance exporting a single sub: >>
 
               Rate     SubExp    ExpTiny SubExpProg      ExpPM
 SubExp      2489/s         --       -56%       -85%       -88%
 ExpTiny     5635/s       126%         --       -67%       -72%
 SubExpProg 16905/s       579%       200%         --       -16%
 ExpPM      20097/s       707%       257%        19%         --
 
 (Exporter::Renaming globally changes the behaviour of Exporter.pm, so could
 not be included in the same benchmarks.)
 
 B<< (Non-Core) Dependencies: >>
 
    Exporter                    -1
    Exporter::Renaming           0
    Exporter::Tiny               0
    Sub::Exporter::Progressive   0
    Sub::Exporter                3
 
 B<< Features: >>
 
                                       ExpPM   ExpTiny SubExp  SubExpProg
  Can export code symbols............. Yes     Yes     Yes     Yes      
  Can export non-code symbols......... Yes                              
  Groups/tags......................... Yes     Yes     Yes     Yes      
  Export by regexp.................... Yes     Yes                      
  Bang prefix......................... Yes     Yes                      
  Allows renaming of subs.............         Yes     Yes     Maybe    
  Install code into scalar refs.......         Yes     Yes     Maybe    
  Can be passed an "into" parameter...         Yes     Yes     Maybe    
  Can be passed an "installer" sub....         Yes     Yes     Maybe    
  Config avoids package variables.....                 Yes              
  Supports generators.................         Yes     Yes              
  Sane API for generators.............         Yes     Yes              
  Unimport............................         Yes                      
 
 (Certain Sub::Exporter::Progressive features are only available if
 Sub::Exporter is installed.)
 
 =head1 BUGS
 
 Please report any bugs to
 L<http://rt.cpan.org/Dist/Display.html?Queue=Exporter-Tiny>.
 
 =head1 SUPPORT
 
 B<< IRC: >> support is available through in the I<< #moops >> channel
 on L<irc.perl.org|http://www.irc.perl.org/channels.html>.
 
 =head1 SEE ALSO
 
 L<Exporter::Shiny>,
 L<Sub::Exporter>,
 L<Exporter>.
 
 =head1 AUTHOR
 
 Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
 
 =head1 COPYRIGHT AND LICENCE
 
 This software is copyright (c) 2013-2014 by Toby Inkster.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =head1 DISCLAIMER OF WARRANTIES
 
 THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
### Function/Fallback/CoreOrPP.pm ###
 package Function::Fallback::CoreOrPP;
 
 use 5.010001;
 use strict;
 use warnings;
 
 our $VERSION = '0.06'; # VERSION
 
 our $USE_NONCORE_XS_FIRST = 1;
 
 require Exporter;
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw(
                        clone
                        unbless
                        uniq
                );
 
 sub clone {
     my $data = shift;
     goto FALLBACK unless $USE_NONCORE_XS_FIRST;
     goto FALLBACK unless eval { require Data::Clone; 1 };
 
   STANDARD:
     return Data::Clone::clone($data);
 
   FALLBACK:
     require Clone::PP;
     return Clone::PP::clone($data);
 }
 
 sub _unbless_fallback {
     my $ref = shift;
 
     my $r = ref($ref);
     # not a reference
     return $ref unless $r;
 
     # return if not a blessed ref
     my ($r2, $r3) = "$ref" =~ /(.+)=(.+?)\(/
         or return $ref;
 
     if ($r3 eq 'HASH') {
         return { %$ref };
     } elsif ($r3 eq 'ARRAY') {
         return [ @$ref ];
     } elsif ($r3 eq 'SCALAR') {
         return \( my $copy = ${$ref} );
     } else {
         die "Can't handle $ref";
     }
 }
 
 sub unbless {
     my $ref = shift;
 
     goto FALLBACK unless $USE_NONCORE_XS_FIRST;
     goto FALLBACK unless eval { require Acme::Damn; 1 };
 
   STANDARD:
     return Acme::Damn::damn($ref);
 
   FALLBACK:
     return _unbless_fallback($ref);
 }
 
 sub uniq {
     goto FALLBACK unless $USE_NONCORE_XS_FIRST;
     goto FALLBACK unless eval { require List::MoreUtils; 1 };
 
   STANDARD:
     return List::MoreUtils::uniq(@_);
 
   FALLBACK:
     my %h;
     my @res;
     for (@_) {
         push @res, $_ unless $h{$_}++;
     }
     return @res;
 }
 
 1;
 #ABSTRACT: Functions that use non-core XS module but provide pure-Perl/core fallback
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Function::Fallback::CoreOrPP - Functions that use non-core XS module but provide pure-Perl/core fallback
 
 =head1 VERSION
 
 This document describes version 0.06 of Function::Fallback::CoreOrPP (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2014-09-16.
 
 =head1 SYNOPSIS
 
  use Function::Fallback::CoreOrPP qw(clone unbless uniq);
 
  my $clone = clone({blah=>1});
  my $unblessed = unbless($blessed_ref);
  my @uniq  = uniq(1, 3, 2, 1, 4);  # -> (1, 3, 2, 4)
 
 =head1 DESCRIPTION
 
 This module provides functions that use non-core XS modules (for best speed,
 reliability, feature, etc) but falls back to those that use core XS or pure-Perl
 modules when the non-core XS module is not available.
 
 This module helps when you want to bootstrap your Perl application with a
 portable, dependency-free Perl script. In a vanilla Perl installation (having
 only core modules), you can use L<App::FatPacker> to include non-core pure-Perl
 dependencies to your script.
 
 =for Pod::Coverage ^()$
 
 =head1 FUNCTIONS
 
 =head2 clone($data) => $cloned
 
 Try to use L<Data::Clone>'s C<clone>, but fall back to using L<Clone::PP>'s
 C<clone>.
 
 =head2 unbless($ref) => $unblessed_ref
 
 Try to use L<Acme::Damn>'s C<damn> to unbless a reference but fall back to
 shallow copying.
 
 NOTE: C<damn()> B<MODIFIES> the original reference. (XXX in the future an option
 to clone the reference first will be provided), while shallow copying will
 return a shallow copy.
 
 NOTE: The shallow copy method currently only handles blessed
 {scalar,array,hash}ref as those are the most common.
 
 =head2 uniq(@ary) => @uniq_ary
 
 Try to use L<List::MoreUtils>'s C<uniq>, but fall back to using slower,
 pure-Perl implementation.
 
 =head1 SEE ALSO
 
 L<Clone::Any> can also uses multiple backends, but I avoid it because I don't
 think L<Storable>'s C<dclone> should be used (no Regexp support out of the box +
 must use deparse to handle coderefs).
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Function-Fallback-CoreOrPP>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Function-Fallback-CoreOrPP>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Function-Fallback-CoreOrPP>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Getopt/Long/Negate/EN.pm ###
 package Getopt::Long::Negate::EN;
 
 our $DATE = '2015-03-19'; # DATE
 our $VERSION = '0.01'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use Exporter qw(import);
 our @EXPORT_OK = qw(negations_for_option);
 
 sub negations_for_option {
     my $word = shift;
     if    ($word =~ /\Awith([_-].+)/   ) { return ("without$1") }
     elsif ($word =~ /\Awithout([_-].+)/) { return ("with$1")    }
     elsif ($word =~ /\Ais([_-].+)/     ) { return ("isnt$1")    }
     elsif ($word =~ /\Aisnt([_-].+)/   ) { return ("is$1")      }
     elsif ($word =~ /\Aare([_-].+)/    ) { return ("arent$1")   }
     elsif ($word =~ /\Aarent([_-].+)/  ) { return ("are$1")     }
     elsif ($word =~ /\Ano[_-](.+)/     ) { return ($1)          }
     else {
         # default from Getopt::Long
         return ("no-$word", "no$word");
     }
 }
 
 1;
 # ABSTRACT: Better negation of boolean option names
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Getopt::Long::Negate::EN - Better negation of boolean option names
 
 =head1 VERSION
 
 This document describes version 0.01 of Getopt::Long::Negate::EN (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-03-19.
 
 =head1 SYNOPSIS
 
  use Getopt::Long::Negate::EN qw(negations_for_option);
 
  # the Getopt::Long's default
  @negs = negations_for_option('foo'); # ('no-foo', 'nofoo')
 
  @negs = negations_for_option('with-foo');    # ('without-foo')
  @negs = negations_for_option('without-foo'); # ('with-foo')
 
  @negs = negations_for_option('is-foo');      # ('isnt-foo')
  @negs = negations_for_option('isnt-foo');    # ('is-foo')
 
  @negs = negations_for_option('are-foo');     # ('isnt-foo')
  @negs = negations_for_option('arent-foo');   # ('arent-foo')
 
  @negs = negations_for_option('no-foo');      # ('foo')
 
 =head1 DESCRIPTION
 
 This module aims to provide a nicer negative boolean option names. By default,
 L<Getopt::Long> provides options C<--foo> as well as C<--no-foo> and C<--nofoo>
 if you specify boolean option specification C<foo!>. But this produces
 awkward/incorrect English word like C<--nowith-foo> or C<--no-is-foo>. In those
 two cases, C<--without-foo> and C<--isnt-foo> are better option names.
 
 =head1 FUNCTIONS
 
 None are exported by default, but they are exportable.
 
 =head2 negations_for_option($str) => list
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-Negate-EN>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-Negate-EN>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Long-Negate-EN>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Getopt/Long/Util.pm ###
 package Getopt::Long::Util;
 
 our $DATE = '2015-06-11'; # DATE
 our $VERSION = '0.83'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw(
                        parse_getopt_long_opt_spec
                        humanize_getopt_long_opt_spec
                        detect_getopt_long_script
                );
 
 our %SPEC;
 
 $SPEC{parse_getopt_long_opt_spec} = {
     v => 1.1,
     summary => 'Parse a single Getopt::Long option specification',
     description => <<'_',
 
 Will produce a hash with some keys: `opts` (array of option names, in the order
 specified in the opt spec), `type` (string, type name), `desttype` (either '',
 or '@' or '%'), `is_neg` (true for `--opt!`), `is_inc` (true for `--opt+`),
 `min_vals` (int, usually 0 or 1), `max_vals` (int, usually 0 or 1 except for
 option that requires multiple values),
 
 Will return undef if it can't parse the string.
 
 _
     args => {
         optspec => {
             schema => 'str*',
             req => 1,
             pos => 0,
         },
     },
     args_as => 'array',
     result_naked => 1,
     result => {
         schema => 'hash*',
     },
     examples => [
         {
             args => {optspec => 'help|h|?'},
             result => {dash_prefix=>'', opts=>['help', 'h', '?']},
         },
         {
             args => {optspec=>'--foo=s'},
             result => {dash_prefix=>'--', opts=>['foo'], type=>'s', desttype=>''},
         },
     ],
 };
 # BEGIN_BLOCK: parse_getopt_long_opt_spec
 sub parse_getopt_long_opt_spec {
     my $optspec = shift;
     $optspec =~ qr/\A
                (?P<dash_prefix>-{0,2})
                (?P<name>[A-Za-z0-9_][A-Za-z0-9_-]*)
                (?P<aliases> (?: \| (?:[^:|!+=:-][^:|!+=:]*) )*)?
                (?:
                    (?P<is_neg>!) |
                    (?P<is_inc>\+) |
                    (?:
                        =
                        (?P<type>[siof])
                        (?P<desttype>|[%@])?
                        (?:
                            \{
                            (?: (?P<min_vals>\d+), )?
                            (?P<max_vals>\d+)
                            \}
                        )?
                    ) |
                    (?:
                        :
                        (?P<opttype>[siof])
                        (?P<desttype>|[%@])
                    ) |
                    (?:
                        :
                        (?P<optnum>\d+)
                        (?P<desttype>|[%@])
                    )
                    (?:
                        :
                        (?P<optplus>\+)
                        (?P<desttype>|[%@])
                    )
                )?
                \z/x
                    or return undef;
     my %res = %+;
 
     if ($res{aliases}) {
         my @als;
         for my $al (split /\|/, $res{aliases}) {
             next unless length $al;
             next if $al eq $res{name};
             next if grep {$_ eq $al} @als;
             push @als, $al;
         }
         $res{opts} = [$res{name}, @als];
     } else {
         $res{opts} = [$res{name}];
     }
     delete $res{name};
     delete $res{aliases};
 
     $res{is_neg} = 1 if $res{is_neg};
     $res{is_inc} = 1 if $res{is_inc};
 
     \%res;
 }
 # END_BLOCK: parse_getopt_long_opt_spec
 
 $SPEC{humanize_getopt_long_opt_spec} = {
     v => 1.1,
     description => <<'_',
 
 Convert `Getopt::Long` option specification like `help|h|?` or `--foo=s` or
 `debug!` into, respectively, `--help, -h, -?` or `--foo=s` or `--(no)debug`.
 Will die if can't parse the string. The output is suitable for including in
 help/usage text.
 
 _
     args => {
         optspec => {
             schema => 'str*',
             req => 1,
             pos => 0,
         },
     },
     args_as => 'array',
     result_naked => 1,
     result => {
         schema => 'str*',
     },
 };
 sub humanize_getopt_long_opt_spec {
     my $optspec = shift;
 
     my $parse = parse_getopt_long_opt_spec($optspec)
         or die "Can't parse opt spec $optspec";
 
     my $res = '';
     my $i = 0;
     for (@{ $parse->{opts} }) {
         $i++;
         $res .= ", " if length($res);
         if ($parse->{is_neg} && length($_) > 1) {
             $res .= "--(no)$_";
         } else {
             if (length($_) > 1) {
                 $res .= "--$_";
             } else {
                 $res .= "-$_";
             }
             $res .= "=$parse->{type}" if $i==1 && $parse->{type};
         }
     }
     $res;
 }
 
 $SPEC{detect_getopt_long_script} = {
     v => 1.1,
     summary => 'Detect whether a file is a Getopt::Long-based CLI script',
     description => <<'_',
 
 The criteria are:
 
 * the file must exist and readable;
 
 * (optional, if `include_noexec` is false) file must have its executable mode
   bit set;
 
 * content must start with a shebang C<#!>;
 
 * either: must be perl script (shebang line contains 'perl') and must contain
   something like `use Getopt::Long`;
 
 _
     args => {
         filename => {
             summary => 'Path to file to be checked',
             schema => 'str*',
             description => <<'_',
 
 Either `filename` or `string` must be specified.
 
 _
         },
         string => {
             summary => 'Path to file to be checked',
             schema => 'buf*',
             description => <<'_',
 
 Either `file` or `string` must be specified.
 
 _
         },
         include_noexec => {
             summary => 'Include scripts that do not have +x mode bit set',
             schema  => 'bool*',
             default => 1,
         },
     },
 };
 sub detect_getopt_long_script {
     my %args = @_;
 
     (defined($args{filename}) xor defined($args{string}))
         or return [400, "Please specify either filename or string"];
     my $include_noexec  = $args{include_noexec}  // 1;
 
     my $yesno = 0;
     my $reason = "";
 
     my $str = $args{string};
   DETECT:
     {
         if (defined $args{filename}) {
             my $fn = $args{filename};
             unless (-f $fn) {
                 $reason = "'$fn' is not a file";
                 last;
             };
             if (!$include_noexec && !(-x _)) {
                 $reason = "'$fn' is not an executable";
                 last;
             }
             my $fh;
             unless (open $fh, "<", $fn) {
                 $reason = "Can't be read";
                 last;
             }
             # for efficiency, we read a bit only here
             read $fh, $str, 2;
             unless ($str eq '#!') {
                 $reason = "Does not start with a shebang (#!) sequence";
                 last;
             }
             my $shebang = <$fh>;
             unless ($shebang =~ /perl/) {
                 $reason = "Does not have 'perl' in the shebang line";
                 last;
             }
             seek $fh, 0, 0;
             {
                 local $/;
                 $str = <$fh>;
             }
         }
         unless ($str =~ /\A#!/) {
             $reason = "Does not start with a shebang (#!) sequence";
             last;
         }
         unless ($str =~ /\A#!.*perl/) {
             $reason = "Does not have 'perl' in the shebang line";
             last;
         }
         if ($str =~ /^\s*(use|require)\s+Getopt::Long(\s|;)/m) {
             $yesno = 1;
             last DETECT;
         }
         $reason = "Can't find any statement requiring Getopt::Long module";
     } # DETECT
 
     [200, "OK", $yesno, {"func.reason"=>$reason}];
 }
 
 # ABSTRACT: Utilities for Getopt::Long
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Getopt::Long::Util - Utilities for Getopt::Long
 
 =head1 VERSION
 
 This document describes version 0.83 of Getopt::Long::Util (from Perl distribution Getopt-Long-Util), released on 2015-06-11.
 
 =head1 SEE ALSO
 
 L<Getopt::Long>
 
 L<Getopt::Long::Spec>, which can also parse Getopt::Long spec into hash as well
 as transform back the hash to Getopt::Long spec. OO interface. I should've found
 this module first before writing my own C<parse_getopt_long_opt_spec()>. But at
 least currently C<parse_getopt_long_opt_spec()> is at least about 30-100+%
 faster than Getopt::Long::Spec::Parser, has a much simpler implementation (a
 single regex match), and can handle valid Getopt::Long specs that
 Getopt::Long::Spec::Parser fails to parse, e.g. C<foo|f=s@>.
 
 =head1 FUNCTIONS
 
 
 =head2 detect_getopt_long_script(%args) -> [status, msg, result, meta]
 
 Detect whether a file is a Getopt::Long-based CLI script.
 
 The criteria are:
 
 =over
 
 =item * the file must exist and readable;
 
 =item * (optional, if C<include_noexec> is false) file must have its executable mode
 bit set;
 
 =item * content must start with a shebang C<#!>;
 
 =item * either: must be perl script (shebang line contains 'perl') and must contain
 something like C<use Getopt::Long>;
 
 =back
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<filename> => I<str>
 
 Path to file to be checked.
 
 Either C<filename> or C<string> must be specified.
 
 =item * B<include_noexec> => I<bool> (default: 1)
 
 Include scripts that do not have +x mode bit set.
 
 =item * B<string> => I<buf>
 
 Path to file to be checked.
 
 Either C<file> or C<string> must be specified.
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (any)
 
 
 =head2 humanize_getopt_long_opt_spec($optspec) -> str
 
 Convert C<Getopt::Long> option specification like C<help|h|?> or C<--foo=s> or
 C<debug!> into, respectively, C<--help, -h, -?> or C<--foo=s> or C<--(no)debug>.
 Will die if can't parse the string. The output is suitable for including in
 help/usage text.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<optspec>* => I<str>
 
 =back
 
 Return value:  (str)
 
 
 =head2 parse_getopt_long_opt_spec($optspec) -> hash
 
 Parse a single Getopt::Long option specification.
 
 Examples:
 
  parse_getopt_long_opt_spec("help|h|?"); # -> { dash_prefix => "", opts => ["help", "h", "?"] }
  parse_getopt_long_opt_spec("--foo=s"); # -> { dash_prefix => "--", desttype => "", opts => ["foo"], type => "s" }
 Will produce a hash with some keys: C<opts> (array of option names, in the order
 specified in the opt spec), C<type> (string, type name), C<desttype> (either '',
 or '@' or '%'), C<is_neg> (true for C<--opt!>), C<is_inc> (true for C<--opt+>),
 C<min_vals> (int, usually 0 or 1), C<max_vals> (int, usually 0 or 1 except for
 option that requires multiple values),
 
 Will return undef if it can't parse the string.
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<optspec>* => I<str>
 
 =back
 
 Return value:  (hash)
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Getopt-Long-Util>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Getopt-Long-Util>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Getopt-Long-Util>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### JSON/PP.pm ###
 package JSON::PP;
 
 # JSON-2.0
 
 use 5.005;
 use strict;
 use base qw(Exporter);
 use overload ();
 
 use Carp ();
 use B ();
 #use Devel::Peek;
 
 $JSON::PP::VERSION = '2.27300';
 
 @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
 
 # instead of hash-access, i tried index-access for speed.
 # but this method is not faster than what i expected. so it will be changed.
 
 use constant P_ASCII                => 0;
 use constant P_LATIN1               => 1;
 use constant P_UTF8                 => 2;
 use constant P_INDENT               => 3;
 use constant P_CANONICAL            => 4;
 use constant P_SPACE_BEFORE         => 5;
 use constant P_SPACE_AFTER          => 6;
 use constant P_ALLOW_NONREF         => 7;
 use constant P_SHRINK               => 8;
 use constant P_ALLOW_BLESSED        => 9;
 use constant P_CONVERT_BLESSED      => 10;
 use constant P_RELAXED              => 11;
 
 use constant P_LOOSE                => 12;
 use constant P_ALLOW_BIGNUM         => 13;
 use constant P_ALLOW_BAREKEY        => 14;
 use constant P_ALLOW_SINGLEQUOTE    => 15;
 use constant P_ESCAPE_SLASH         => 16;
 use constant P_AS_NONBLESSED        => 17;
 
 use constant P_ALLOW_UNKNOWN        => 18;
 
 use constant OLD_PERL => $] < 5.008 ? 1 : 0;
 
 BEGIN {
     my @xs_compati_bit_properties = qw(
             latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
             allow_blessed convert_blessed relaxed allow_unknown
     );
     my @pp_bit_properties = qw(
             allow_singlequote allow_bignum loose
             allow_barekey escape_slash as_nonblessed
     );
 
     # Perl version check, Unicode handling is enable?
     # Helper module sets @JSON::PP::_properties.
     if ($] < 5.008 ) {
         my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
         eval qq| require $helper |;
         if ($@) { Carp::croak $@; }
     }
 
     for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
         my $flag_name = 'P_' . uc($name);
 
         eval qq/
             sub $name {
                 my \$enable = defined \$_[1] ? \$_[1] : 1;
 
                 if (\$enable) {
                     \$_[0]->{PROPS}->[$flag_name] = 1;
                 }
                 else {
                     \$_[0]->{PROPS}->[$flag_name] = 0;
                 }
 
                 \$_[0];
             }
 
             sub get_$name {
                 \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
             }
         /;
     }
 
 }
 
 
 
 # Functions
 
 my %encode_allow_method
      = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
                           allow_blessed convert_blessed indent indent_length allow_bignum
                           as_nonblessed
                         /;
 my %decode_allow_method
      = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
                           allow_barekey max_size relaxed/;
 
 
 my $JSON; # cache
 
 sub encode_json ($) { # encode
     ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
 }
 
 
 sub decode_json { # decode
     ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
 }
 
 # Obsoleted
 
 sub to_json($) {
    Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
 }
 
 
 sub from_json($) {
    Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
 }
 
 
 # Methods
 
 sub new {
     my $class = shift;
     my $self  = {
         max_depth   => 512,
         max_size    => 0,
         indent      => 0,
         FLAGS       => 0,
         fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
         indent_length => 3,
     };
 
     bless $self, $class;
 }
 
 
 sub encode {
     return $_[0]->PP_encode_json($_[1]);
 }
 
 
 sub decode {
     return $_[0]->PP_decode_json($_[1], 0x00000000);
 }
 
 
 sub decode_prefix {
     return $_[0]->PP_decode_json($_[1], 0x00000001);
 }
 
 
 # accessor
 
 
 # pretty printing
 
 sub pretty {
     my ($self, $v) = @_;
     my $enable = defined $v ? $v : 1;
 
     if ($enable) { # indent_length(3) for JSON::XS compatibility
         $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
     }
     else {
         $self->indent(0)->space_before(0)->space_after(0);
     }
 
     $self;
 }
 
 # etc
 
 sub max_depth {
     my $max  = defined $_[1] ? $_[1] : 0x80000000;
     $_[0]->{max_depth} = $max;
     $_[0];
 }
 
 
 sub get_max_depth { $_[0]->{max_depth}; }
 
 
 sub max_size {
     my $max  = defined $_[1] ? $_[1] : 0;
     $_[0]->{max_size} = $max;
     $_[0];
 }
 
 
 sub get_max_size { $_[0]->{max_size}; }
 
 
 sub filter_json_object {
     $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
     $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
     $_[0];
 }
 
 sub filter_json_single_key_object {
     if (@_ > 1) {
         $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
     }
     $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
     $_[0];
 }
 
 sub indent_length {
     if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
         Carp::carp "The acceptable range of indent_length() is 0 to 15.";
     }
     else {
         $_[0]->{indent_length} = $_[1];
     }
     $_[0];
 }
 
 sub get_indent_length {
     $_[0]->{indent_length};
 }
 
 sub sort_by {
     $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
     $_[0];
 }
 
 sub allow_bigint {
     Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
 }
 
 ###############################
 
 ###
 ### Perl => JSON
 ###
 
 
 { # Convert
 
     my $max_depth;
     my $indent;
     my $ascii;
     my $latin1;
     my $utf8;
     my $space_before;
     my $space_after;
     my $canonical;
     my $allow_blessed;
     my $convert_blessed;
 
     my $indent_length;
     my $escape_slash;
     my $bignum;
     my $as_nonblessed;
 
     my $depth;
     my $indent_count;
     my $keysort;
 
 
     sub PP_encode_json {
         my $self = shift;
         my $obj  = shift;
 
         $indent_count = 0;
         $depth        = 0;
 
         my $idx = $self->{PROPS};
 
         ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
             $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
          = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                     P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
 
         ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
 
         $keysort = $canonical ? sub { $a cmp $b } : undef;
 
         if ($self->{sort_by}) {
             $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                      : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                      : sub { $a cmp $b };
         }
 
         encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
              if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
 
         my $str  = $self->object_to_json($obj);
 
         $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
 
         unless ($ascii or $latin1 or $utf8) {
             utf8::upgrade($str);
         }
 
         if ($idx->[ P_SHRINK ]) {
             utf8::downgrade($str, 1);
         }
 
         return $str;
     }
 
 
     sub object_to_json {
         my ($self, $obj) = @_;
         my $type = ref($obj);
 
         if($type eq 'HASH'){
             return $self->hash_to_json($obj);
         }
         elsif($type eq 'ARRAY'){
             return $self->array_to_json($obj);
         }
         elsif ($type) { # blessed object?
             if (blessed($obj)) {
 
                 return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
 
                 if ( $convert_blessed and $obj->can('TO_JSON') ) {
                     my $result = $obj->TO_JSON();
                     if ( defined $result and ref( $result ) ) {
                         if ( refaddr( $obj ) eq refaddr( $result ) ) {
                             encode_error( sprintf(
                                 "%s::TO_JSON method returned same object as was passed instead of a new one",
                                 ref $obj
                             ) );
                         }
                     }
 
                     return $self->object_to_json( $result );
                 }
 
                 return "$obj" if ( $bignum and _is_bignum($obj) );
                 return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
 
                 encode_error( sprintf("encountered object '%s', but neither allow_blessed "
                     . "nor convert_blessed settings are enabled", $obj)
                 ) unless ($allow_blessed);
 
                 return 'null';
             }
             else {
                 return $self->value_to_json($obj);
             }
         }
         else{
             return $self->value_to_json($obj);
         }
     }
 
 
     sub hash_to_json {
         my ($self, $obj) = @_;
         my @res;
 
         encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                          if (++$depth > $max_depth);
 
         my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
         my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
 
         for my $k ( _sort( $obj ) ) {
             if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
             push @res, string_to_json( $self, $k )
                           .  $del
                           . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
         }
 
         --$depth;
         $self->_down_indent() if ($indent);
 
         return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
     }
 
 
     sub array_to_json {
         my ($self, $obj) = @_;
         my @res;
 
         encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                          if (++$depth > $max_depth);
 
         my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
 
         for my $v (@$obj){
             push @res, $self->object_to_json($v) || $self->value_to_json($v);
         }
 
         --$depth;
         $self->_down_indent() if ($indent);
 
         return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
     }
 
 
     sub value_to_json {
         my ($self, $value) = @_;
 
         return 'null' if(!defined $value);
 
         my $b_obj = B::svref_2object(\$value);  # for round trip problem
         my $flags = $b_obj->FLAGS;
 
         return $value # as is 
             if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
 
         my $type = ref($value);
 
         if(!$type){
             return string_to_json($self, $value);
         }
         elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
             return $$value == 1 ? 'true' : 'false';
         }
         elsif ($type) {
             if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
                 return $self->value_to_json("$value");
             }
 
             if ($type eq 'SCALAR' and defined $$value) {
                 return   $$value eq '1' ? 'true'
                        : $$value eq '0' ? 'false'
                        : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
                        : encode_error("cannot encode reference to scalar");
             }
 
              if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
                  return 'null';
              }
              else {
                  if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                     encode_error("cannot encode reference to scalar");
                  }
                  else {
                     encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                  }
              }
 
         }
         else {
             return $self->{fallback}->($value)
                  if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
             return 'null';
         }
 
     }
 
 
     my %esc = (
         "\n" => '\n',
         "\r" => '\r',
         "\t" => '\t',
         "\f" => '\f',
         "\b" => '\b',
         "\"" => '\"',
         "\\" => '\\\\',
         "\'" => '\\\'',
     );
 
 
     sub string_to_json {
         my ($self, $arg) = @_;
 
         $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
         $arg =~ s/\//\\\//g if ($escape_slash);
         $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
 
         if ($ascii) {
             $arg = JSON_PP_encode_ascii($arg);
         }
 
         if ($latin1) {
             $arg = JSON_PP_encode_latin1($arg);
         }
 
         if ($utf8) {
             utf8::encode($arg);
         }
 
         return '"' . $arg . '"';
     }
 
 
     sub blessed_to_json {
         my $reftype = reftype($_[1]) || '';
         if ($reftype eq 'HASH') {
             return $_[0]->hash_to_json($_[1]);
         }
         elsif ($reftype eq 'ARRAY') {
             return $_[0]->array_to_json($_[1]);
         }
         else {
             return 'null';
         }
     }
 
 
     sub encode_error {
         my $error  = shift;
         Carp::croak "$error";
     }
 
 
     sub _sort {
         defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
     }
 
 
     sub _up_indent {
         my $self  = shift;
         my $space = ' ' x $indent_length;
 
         my ($pre,$post) = ('','');
 
         $post = "\n" . $space x $indent_count;
 
         $indent_count++;
 
         $pre = "\n" . $space x $indent_count;
 
         return ($pre,$post);
     }
 
 
     sub _down_indent { $indent_count--; }
 
 
     sub PP_encode_box {
         {
             depth        => $depth,
             indent_count => $indent_count,
         };
     }
 
 } # Convert
 
 
 sub _encode_ascii {
     join('',
         map {
             $_ <= 127 ?
                 chr($_) :
             $_ <= 65535 ?
                 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
         } unpack('U*', $_[0])
     );
 }
 
 
 sub _encode_latin1 {
     join('',
         map {
             $_ <= 255 ?
                 chr($_) :
             $_ <= 65535 ?
                 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
         } unpack('U*', $_[0])
     );
 }
 
 
 sub _encode_surrogates { # from perlunicode
     my $uni = $_[0] - 0x10000;
     return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
 }
 
 
 sub _is_bignum {
     $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
 }
 
 
 
 #
 # JSON => Perl
 #
 
 my $max_intsize;
 
 BEGIN {
     my $checkint = 1111;
     for my $d (5..64) {
         $checkint .= 1;
         my $int   = eval qq| $checkint |;
         if ($int =~ /[eE]/) {
             $max_intsize = $d - 1;
             last;
         }
     }
 }
 
 { # PARSE 
 
     my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
         b    => "\x8",
         t    => "\x9",
         n    => "\xA",
         f    => "\xC",
         r    => "\xD",
         '\\' => '\\',
         '"'  => '"',
         '/'  => '/',
     );
 
     my $text; # json data
     my $at;   # offset
     my $ch;   # 1chracter
     my $len;  # text length (changed according to UTF8 or NON UTF8)
     # INTERNAL
     my $depth;          # nest counter
     my $encoding;       # json text encoding
     my $is_valid_utf8;  # temp variable
     my $utf8_len;       # utf8 byte length
     # FLAGS
     my $utf8;           # must be utf8
     my $max_depth;      # max nest nubmer of objects and arrays
     my $max_size;
     my $relaxed;
     my $cb_object;
     my $cb_sk_object;
 
     my $F_HOOK;
 
     my $allow_bigint;   # using Math::BigInt
     my $singlequote;    # loosely quoting
     my $loose;          # 
     my $allow_barekey;  # bareKey
 
     # $opt flag
     # 0x00000001 .... decode_prefix
     # 0x10000000 .... incr_parse
 
     sub PP_decode_json {
         my ($self, $opt); # $opt is an effective flag during this decode_json.
 
         ($self, $text, $opt) = @_;
 
         ($at, $ch, $depth) = (0, '', 0);
 
         if ( !defined $text or ref $text ) {
             decode_error("malformed JSON string, neither array, object, number, string or atom");
         }
 
         my $idx = $self->{PROPS};
 
         ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
             = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
 
         if ( $utf8 ) {
             utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
         }
         else {
             utf8::upgrade( $text );
             utf8::encode( $text );
         }
 
         $len = length $text;
 
         ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
              = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
 
         if ($max_size > 1) {
             use bytes;
             my $bytes = length $text;
             decode_error(
                 sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
                     , $bytes, $max_size), 1
             ) if ($bytes > $max_size);
         }
 
         # Currently no effect
         # should use regexp
         my @octets = unpack('C4', $text);
         $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
                     : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
                     : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
                     : ( $octets[2]                ) ? 'UTF-16LE'
                     : (!$octets[2]                ) ? 'UTF-32LE'
                     : 'unknown';
 
         white(); # remove head white space
 
         my $valid_start = defined $ch; # Is there a first character for JSON structure?
 
         my $result = value();
 
         return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
 
         decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
 
         if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
                 decode_error(
                 'JSON text must be an object or array (but found number, string, true, false or null,'
                        . ' use allow_nonref to allow this)', 1);
         }
 
         Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
 
         my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
 
         white(); # remove tail white space
 
         if ( $ch ) {
             return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
             decode_error("garbage after JSON object");
         }
 
         ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
     }
 
 
     sub next_chr {
         return $ch = undef if($at >= $len);
         $ch = substr($text, $at++, 1);
     }
 
 
     sub value {
         white();
         return          if(!defined $ch);
         return object() if($ch eq '{');
         return array()  if($ch eq '[');
         return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
         return number() if($ch =~ /[0-9]/ or $ch eq '-');
         return word();
     }
 
     sub string {
         my ($i, $s, $t, $u);
         my $utf16;
         my $is_utf8;
 
         ($is_valid_utf8, $utf8_len) = ('', 0);
 
         $s = ''; # basically UTF8 flag on
 
         if($ch eq '"' or ($singlequote and $ch eq "'")){
             my $boundChar = $ch;
 
             OUTER: while( defined(next_chr()) ){
 
                 if($ch eq $boundChar){
                     next_chr();
 
                     if ($utf16) {
                         decode_error("missing low surrogate character in surrogate pair");
                     }
 
                     utf8::decode($s) if($is_utf8);
 
                     return $s;
                 }
                 elsif($ch eq '\\'){
                     next_chr();
                     if(exists $escapes{$ch}){
                         $s .= $escapes{$ch};
                     }
                     elsif($ch eq 'u'){ # UNICODE handling
                         my $u = '';
 
                         for(1..4){
                             $ch = next_chr();
                             last OUTER if($ch !~ /[0-9a-fA-F]/);
                             $u .= $ch;
                         }
 
                         # U+D800 - U+DBFF
                         if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
                             $utf16 = $u;
                         }
                         # U+DC00 - U+DFFF
                         elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
                             unless (defined $utf16) {
                                 decode_error("missing high surrogate character in surrogate pair");
                             }
                             $is_utf8 = 1;
                             $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
                             $utf16 = undef;
                         }
                         else {
                             if (defined $utf16) {
                                 decode_error("surrogate pair expected");
                             }
 
                             if ( ( my $hex = hex( $u ) ) > 127 ) {
                                 $is_utf8 = 1;
                                 $s .= JSON_PP_decode_unicode($u) || next;
                             }
                             else {
                                 $s .= chr $hex;
                             }
                         }
 
                     }
                     else{
                         unless ($loose) {
                             $at -= 2;
                             decode_error('illegal backslash escape sequence in string');
                         }
                         $s .= $ch;
                     }
                 }
                 else{
 
                     if ( ord $ch  > 127 ) {
                         unless( $ch = is_valid_utf8($ch) ) {
                             $at -= 1;
                             decode_error("malformed UTF-8 character in JSON string");
                         }
                         else {
                             $at += $utf8_len - 1;
                         }
 
                         $is_utf8 = 1;
                     }
 
                     if (!$loose) {
                         if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
                             $at--;
                             decode_error('invalid character encountered while parsing JSON string');
                         }
                     }
 
                     $s .= $ch;
                 }
             }
         }
 
         decode_error("unexpected end of string while parsing JSON string");
     }
 
 
     sub white {
         while( defined $ch  ){
             if($ch le ' '){
                 next_chr();
             }
             elsif($ch eq '/'){
                 next_chr();
                 if(defined $ch and $ch eq '/'){
                     1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
                 }
                 elsif(defined $ch and $ch eq '*'){
                     next_chr();
                     while(1){
                         if(defined $ch){
                             if($ch eq '*'){
                                 if(defined(next_chr()) and $ch eq '/'){
                                     next_chr();
                                     last;
                                 }
                             }
                             else{
                                 next_chr();
                             }
                         }
                         else{
                             decode_error("Unterminated comment");
                         }
                     }
                     next;
                 }
                 else{
                     $at--;
                     decode_error("malformed JSON string, neither array, object, number, string or atom");
                 }
             }
             else{
                 if ($relaxed and $ch eq '#') { # correctly?
                     pos($text) = $at;
                     $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                     $at = pos($text);
                     next_chr;
                     next;
                 }
 
                 last;
             }
         }
     }
 
 
     sub array {
         my $a  = $_[0] || []; # you can use this code to use another array ref object.
 
         decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                     if (++$depth > $max_depth);
 
         next_chr();
         white();
 
         if(defined $ch and $ch eq ']'){
             --$depth;
             next_chr();
             return $a;
         }
         else {
             while(defined($ch)){
                 push @$a, value();
 
                 white();
 
                 if (!defined $ch) {
                     last;
                 }
 
                 if($ch eq ']'){
                     --$depth;
                     next_chr();
                     return $a;
                 }
 
                 if($ch ne ','){
                     last;
                 }
 
                 next_chr();
                 white();
 
                 if ($relaxed and $ch eq ']') {
                     --$depth;
                     next_chr();
                     return $a;
                 }
 
             }
         }
 
         decode_error(", or ] expected while parsing array");
     }
 
 
     sub object {
         my $o = $_[0] || {}; # you can use this code to use another hash ref object.
         my $k;
 
         decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                 if (++$depth > $max_depth);
         next_chr();
         white();
 
         if(defined $ch and $ch eq '}'){
             --$depth;
             next_chr();
             if ($F_HOOK) {
                 return _json_object_hook($o);
             }
             return $o;
         }
         else {
             while (defined $ch) {
                 $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
                 white();
 
                 if(!defined $ch or $ch ne ':'){
                     $at--;
                     decode_error("':' expected");
                 }
 
                 next_chr();
                 $o->{$k} = value();
                 white();
 
                 last if (!defined $ch);
 
                 if($ch eq '}'){
                     --$depth;
                     next_chr();
                     if ($F_HOOK) {
                         return _json_object_hook($o);
                     }
                     return $o;
                 }
 
                 if($ch ne ','){
                     last;
                 }
 
                 next_chr();
                 white();
 
                 if ($relaxed and $ch eq '}') {
                     --$depth;
                     next_chr();
                     if ($F_HOOK) {
                         return _json_object_hook($o);
                     }
                     return $o;
                 }
 
             }
 
         }
 
         $at--;
         decode_error(", or } expected while parsing object/hash");
     }
 
 
     sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
         my $key;
         while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
             $key .= $ch;
             next_chr();
         }
         return $key;
     }
 
 
     sub word {
         my $word =  substr($text,$at-1,4);
 
         if($word eq 'true'){
             $at += 3;
             next_chr;
             return $JSON::PP::true;
         }
         elsif($word eq 'null'){
             $at += 3;
             next_chr;
             return undef;
         }
         elsif($word eq 'fals'){
             $at += 3;
             if(substr($text,$at,1) eq 'e'){
                 $at++;
                 next_chr;
                 return $JSON::PP::false;
             }
         }
 
         $at--; # for decode_error report
 
         decode_error("'null' expected")  if ($word =~ /^n/);
         decode_error("'true' expected")  if ($word =~ /^t/);
         decode_error("'false' expected") if ($word =~ /^f/);
         decode_error("malformed JSON string, neither array, object, number, string or atom");
     }
 
 
     sub number {
         my $n    = '';
         my $v;
 
         # According to RFC4627, hex or oct digts are invalid.
         if($ch eq '0'){
             my $peek = substr($text,$at,1);
             my $hex  = $peek =~ /[xX]/; # 0 or 1
 
             if($hex){
                 decode_error("malformed number (leading zero must not be followed by another digit)");
                 ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
             }
             else{ # oct
                 ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
                 if (defined $n and length $n > 1) {
                     decode_error("malformed number (leading zero must not be followed by another digit)");
                 }
             }
 
             if(defined $n and length($n)){
                 if (!$hex and length($n) == 1) {
                    decode_error("malformed number (leading zero must not be followed by another digit)");
                 }
                 $at += length($n) + $hex;
                 next_chr;
                 return $hex ? hex($n) : oct($n);
             }
         }
 
         if($ch eq '-'){
             $n = '-';
             next_chr;
             if (!defined $ch or $ch !~ /\d/) {
                 decode_error("malformed number (no digits after initial minus)");
             }
         }
 
         while(defined $ch and $ch =~ /\d/){
             $n .= $ch;
             next_chr;
         }
 
         if(defined $ch and $ch eq '.'){
             $n .= '.';
 
             next_chr;
             if (!defined $ch or $ch !~ /\d/) {
                 decode_error("malformed number (no digits after decimal point)");
             }
             else {
                 $n .= $ch;
             }
 
             while(defined(next_chr) and $ch =~ /\d/){
                 $n .= $ch;
             }
         }
 
         if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
             $n .= $ch;
             next_chr;
 
             if(defined($ch) and ($ch eq '+' or $ch eq '-')){
                 $n .= $ch;
                 next_chr;
                 if (!defined $ch or $ch =~ /\D/) {
                     decode_error("malformed number (no digits after exp sign)");
                 }
                 $n .= $ch;
             }
             elsif(defined($ch) and $ch =~ /\d/){
                 $n .= $ch;
             }
             else {
                 decode_error("malformed number (no digits after exp sign)");
             }
 
             while(defined(next_chr) and $ch =~ /\d/){
                 $n .= $ch;
             }
 
         }
 
         $v .= $n;
 
         if ($v !~ /[.eE]/ and length $v > $max_intsize) {
             if ($allow_bigint) { # from Adam Sussman
                 require Math::BigInt;
                 return Math::BigInt->new($v);
             }
             else {
                 return "$v";
             }
         }
         elsif ($allow_bigint) {
             require Math::BigFloat;
             return Math::BigFloat->new($v);
         }
 
         return 0+$v;
     }
 
 
     sub is_valid_utf8 {
 
         $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
                   : $_[0] =~ /[\xC2-\xDF]/  ? 2
                   : $_[0] =~ /[\xE0-\xEF]/  ? 3
                   : $_[0] =~ /[\xF0-\xF4]/  ? 4
                   : 0
                   ;
 
         return unless $utf8_len;
 
         my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
 
         return ( $is_valid_utf8 =~ /^(?:
              [\x00-\x7F]
             |[\xC2-\xDF][\x80-\xBF]
             |[\xE0][\xA0-\xBF][\x80-\xBF]
             |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
             |[\xED][\x80-\x9F][\x80-\xBF]
             |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
             |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
             |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
             |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
         )$/x )  ? $is_valid_utf8 : '';
     }
 
 
     sub decode_error {
         my $error  = shift;
         my $no_rep = shift;
         my $str    = defined $text ? substr($text, $at) : '';
         my $mess   = '';
         my $type   = $] >= 5.008           ? 'U*'
                    : $] <  5.006           ? 'C*'
                    : utf8::is_utf8( $str ) ? 'U*' # 5.6
                    : 'C*'
                    ;
 
         for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
             $mess .=  $c == 0x07 ? '\a'
                     : $c == 0x09 ? '\t'
                     : $c == 0x0a ? '\n'
                     : $c == 0x0d ? '\r'
                     : $c == 0x0c ? '\f'
                     : $c <  0x20 ? sprintf('\x{%x}', $c)
                     : $c == 0x5c ? '\\\\'
                     : $c <  0x80 ? chr($c)
                     : sprintf('\x{%x}', $c)
                     ;
             if ( length $mess >= 20 ) {
                 $mess .= '...';
                 last;
             }
         }
 
         unless ( length $mess ) {
             $mess = '(end of string)';
         }
 
         Carp::croak (
             $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
         );
 
     }
 
 
     sub _json_object_hook {
         my $o    = $_[0];
         my @ks = keys %{$o};
 
         if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
             my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
             if (@val == 1) {
                 return $val[0];
             }
         }
 
         my @val = $cb_object->($o) if ($cb_object);
         if (@val == 0 or @val > 1) {
             return $o;
         }
         else {
             return $val[0];
         }
     }
 
 
     sub PP_decode_box {
         {
             text    => $text,
             at      => $at,
             ch      => $ch,
             len     => $len,
             depth   => $depth,
             encoding      => $encoding,
             is_valid_utf8 => $is_valid_utf8,
         };
     }
 
 } # PARSE
 
 
 sub _decode_surrogates { # from perlunicode
     my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
     my $un  = pack('U*', $uni);
     utf8::encode( $un );
     return $un;
 }
 
 
 sub _decode_unicode {
     my $un = pack('U', hex shift);
     utf8::encode( $un );
     return $un;
 }
 
 #
 # Setup for various Perl versions (the code from JSON::PP58)
 #
 
 BEGIN {
 
     unless ( defined &utf8::is_utf8 ) {
        require Encode;
        *utf8::is_utf8 = *Encode::is_utf8;
     }
 
     if ( $] >= 5.008 ) {
         *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
         *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
         *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
         *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
     }
 
     if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
         package JSON::PP;
         require subs;
         subs->import('join');
         eval q|
             sub join {
                 return '' if (@_ < 2);
                 my $j   = shift;
                 my $str = shift;
                 for (@_) { $str .= $j . $_; }
                 return $str;
             }
         |;
     }
 
 
     sub JSON::PP::incr_parse {
         local $Carp::CarpLevel = 1;
         ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
     }
 
 
     sub JSON::PP::incr_skip {
         ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
     }
 
 
     sub JSON::PP::incr_reset {
         ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
     }
 
     eval q{
         sub JSON::PP::incr_text : lvalue {
             $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
 
             if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
                 Carp::croak("incr_text can not be called when the incremental parser already started parsing");
             }
             $_[0]->{_incr_parser}->{incr_text};
         }
     } if ( $] >= 5.006 );
 
 } # Setup for various Perl versions (the code from JSON::PP58)
 
 
 ###############################
 # Utilities
 #
 
 BEGIN {
     eval 'require Scalar::Util';
     unless($@){
         *JSON::PP::blessed = \&Scalar::Util::blessed;
         *JSON::PP::reftype = \&Scalar::Util::reftype;
         *JSON::PP::refaddr = \&Scalar::Util::refaddr;
     }
     else{ # This code is from Sclar::Util.
         # warn $@;
         eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
         *JSON::PP::blessed = sub {
             local($@, $SIG{__DIE__}, $SIG{__WARN__});
             ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
         };
         my %tmap = qw(
             B::NULL   SCALAR
             B::HV     HASH
             B::AV     ARRAY
             B::CV     CODE
             B::IO     IO
             B::GV     GLOB
             B::REGEXP REGEXP
         );
         *JSON::PP::reftype = sub {
             my $r = shift;
 
             return undef unless length(ref($r));
 
             my $t = ref(B::svref_2object($r));
 
             return
                 exists $tmap{$t} ? $tmap{$t}
               : length(ref($$r)) ? 'REF'
               :                    'SCALAR';
         };
         *JSON::PP::refaddr = sub {
           return undef unless length(ref($_[0]));
 
           my $addr;
           if(defined(my $pkg = blessed($_[0]))) {
             $addr .= bless $_[0], 'Scalar::Util::Fake';
             bless $_[0], $pkg;
           }
           else {
             $addr .= $_[0]
           }
 
           $addr =~ /0x(\w+)/;
           local $^W;
           #no warnings 'portable';
           hex($1);
         }
     }
 }
 
 
 # shamely copied and modified from JSON::XS code.
 
 $JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
 $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
 
 sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
 
 sub true  { $JSON::PP::true  }
 sub false { $JSON::PP::false }
 sub null  { undef; }
 
 ###############################
 
 package JSON::PP::Boolean;
 
 use overload (
    "0+"     => sub { ${$_[0]} },
    "++"     => sub { $_[0] = ${$_[0]} + 1 },
    "--"     => sub { $_[0] = ${$_[0]} - 1 },
    fallback => 1,
 );
 
 
 ###############################
 
 package JSON::PP::IncrParser;
 
 use strict;
 
 use constant INCR_M_WS   => 0; # initial whitespace skipping
 use constant INCR_M_STR  => 1; # inside string
 use constant INCR_M_BS   => 2; # inside backslash
 use constant INCR_M_JSON => 3; # outside anything, count nesting
 use constant INCR_M_C0   => 4;
 use constant INCR_M_C1   => 5;
 
 $JSON::PP::IncrParser::VERSION = '1.01';
 
 my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
 
 sub new {
     my ( $class ) = @_;
 
     bless {
         incr_nest    => 0,
         incr_text    => undef,
         incr_parsing => 0,
         incr_p       => 0,
     }, $class;
 }
 
 
 sub incr_parse {
     my ( $self, $coder, $text ) = @_;
 
     $self->{incr_text} = '' unless ( defined $self->{incr_text} );
 
     if ( defined $text ) {
         if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
             utf8::upgrade( $self->{incr_text} ) ;
             utf8::decode( $self->{incr_text} ) ;
         }
         $self->{incr_text} .= $text;
     }
 
 
     my $max_size = $coder->get_max_size;
 
     if ( defined wantarray ) {
 
         $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
 
         if ( wantarray ) {
             my @ret;
 
             $self->{incr_parsing} = 1;
 
             do {
                 push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
 
                 unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
                     $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
                 }
 
             } until ( length $self->{incr_text} >= $self->{incr_p} );
 
             $self->{incr_parsing} = 0;
 
             return @ret;
         }
         else { # in scalar context
             $self->{incr_parsing} = 1;
             my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
             $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
             return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
         }
 
     }
 
 }
 
 
 sub _incr_parse {
     my ( $self, $coder, $text, $skip ) = @_;
     my $p = $self->{incr_p};
     my $restore = $p;
 
     my @obj;
     my $len = length $text;
 
     if ( $self->{incr_mode} == INCR_M_WS ) {
         while ( $len > $p ) {
             my $s = substr( $text, $p, 1 );
             $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
             $self->{incr_mode} = INCR_M_JSON;
             last;
        }
     }
 
     while ( $len > $p ) {
         my $s = substr( $text, $p++, 1 );
 
         if ( $s eq '"' ) {
             if (substr( $text, $p - 2, 1 ) eq '\\' ) {
                 next;
             }
 
             if ( $self->{incr_mode} != INCR_M_STR  ) {
                 $self->{incr_mode} = INCR_M_STR;
             }
             else {
                 $self->{incr_mode} = INCR_M_JSON;
                 unless ( $self->{incr_nest} ) {
                     last;
                 }
             }
         }
 
         if ( $self->{incr_mode} == INCR_M_JSON ) {
 
             if ( $s eq '[' or $s eq '{' ) {
                 if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                     Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                 }
             }
             elsif ( $s eq ']' or $s eq '}' ) {
                 last if ( --$self->{incr_nest} <= 0 );
             }
             elsif ( $s eq '#' ) {
                 while ( $len > $p ) {
                     last if substr( $text, $p++, 1 ) eq "\n";
                 }
             }
 
         }
 
     }
 
     $self->{incr_p} = $p;
 
     return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
     return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
 
     return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
 
     local $Carp::CarpLevel = 2;
 
     $self->{incr_p} = $restore;
     $self->{incr_c} = $p;
 
     my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
 
     $self->{incr_text} = substr( $self->{incr_text}, $p );
     $self->{incr_p} = 0;
 
     return $obj || '';
 }
 
 
 sub incr_text {
     if ( $_[0]->{incr_parsing} ) {
         Carp::croak("incr_text can not be called when the incremental parser already started parsing");
     }
     $_[0]->{incr_text};
 }
 
 
 sub incr_skip {
     my $self  = shift;
     $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
     $self->{incr_p} = 0;
 }
 
 
 sub incr_reset {
     my $self = shift;
     $self->{incr_text}    = undef;
     $self->{incr_p}       = 0;
     $self->{incr_mode}    = 0;
     $self->{incr_nest}    = 0;
     $self->{incr_parsing} = 0;
 }
 
 ###############################
 
 
 1;
 __END__
 =pod
 
 =head1 NAME
 
 JSON::PP - JSON::XS compatible pure-Perl module.
 
 =head1 SYNOPSIS
 
  use JSON::PP;
 
  # exported functions, they croak on error
  # and expect/generate UTF-8
 
  $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
  $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
 
  # OO-interface
 
  $coder = JSON::PP->new->ascii->pretty->allow_nonref;
  
  $json_text   = $json->encode( $perl_scalar );
  $perl_scalar = $json->decode( $json_text );
  
  $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
  
  # Note that JSON version 2.0 and above will automatically use
  # JSON::XS or JSON::PP, so you should be able to just:
  
  use JSON;
 
 
 =head1 VERSION
 
     2.27300
 
 L<JSON::XS> 2.27 (~2.30) compatible.
 
 =head1 NOTE
 
 JSON::PP had been inculded in JSON distribution (CPAN module).
 It was a perl core module in Perl 5.14.
 
 =head1 DESCRIPTION
 
 This module is L<JSON::XS> compatible pure Perl module.
 (Perl 5.8 or later is recommended)
 
 JSON::XS is the fastest and most proper JSON module on CPAN.
 It is written by Marc Lehmann in C, so must be compiled and
 installed in the used environment.
 
 JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
 
 
 =head2 FEATURES
 
 =over
 
 =item * correct unicode handling
 
 This module knows how to handle Unicode (depending on Perl version).
 
 See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
 
 
 =item * round-trip integrity
 
 When you serialise a perl data structure using only data types supported
 by JSON and Perl, the deserialised data structure is identical on the Perl
 level. (e.g. the string "2.0" doesn't suddenly become "2" just because
 it looks like a number). There I<are> minor exceptions to this, read the
 MAPPING section below to learn about those.
 
 
 =item * strict checking of JSON correctness
 
 There is no guessing, no generating of illegal JSON texts by default,
 and only JSON is accepted as input by default (the latter is a security feature).
 But when some options are set, loose chcking features are available.
 
 =back
 
 =head1 FUNCTIONAL INTERFACE
 
 Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
 
 =head2 encode_json
 
     $json_text = encode_json $perl_scalar
 
 Converts the given Perl data structure to a UTF-8 encoded, binary string.
 
 This function call is functionally identical to:
 
     $json_text = JSON::PP->new->utf8->encode($perl_scalar)
 
 =head2 decode_json
 
     $perl_scalar = decode_json $json_text
 
 The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
 to parse that as an UTF-8 encoded JSON text, returning the resulting
 reference.
 
 This function call is functionally identical to:
 
     $perl_scalar = JSON::PP->new->utf8->decode($json_text)
 
 =head2 JSON::PP::is_bool
 
     $is_boolean = JSON::PP::is_bool($scalar)
 
 Returns true if the passed scalar represents either JSON::PP::true or
 JSON::PP::false, two constants that act like C<1> and C<0> respectively
 and are also used to represent JSON C<true> and C<false> in Perl strings.
 
 =head2 JSON::PP::true
 
 Returns JSON true value which is blessed object.
 It C<isa> JSON::PP::Boolean object.
 
 =head2 JSON::PP::false
 
 Returns JSON false value which is blessed object.
 It C<isa> JSON::PP::Boolean object.
 
 =head2 JSON::PP::null
 
 Returns C<undef>.
 
 See L<MAPPING>, below, for more information on how JSON values are mapped to
 Perl.
 
 
 =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
 
 This section supposes that your perl vresion is 5.8 or later.
 
 If you know a JSON text from an outer world - a network, a file content, and so on,
 is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
 with C<utf8> enable. And the decoded result will contain UNICODE characters.
 
   # from network
   my $json        = JSON::PP->new->utf8;
   my $json_text   = CGI->new->param( 'json_data' );
   my $perl_scalar = $json->decode( $json_text );
   
   # from file content
   local $/;
   open( my $fh, '<', 'json.data' );
   $json_text   = <$fh>;
   $perl_scalar = decode_json( $json_text );
 
 If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
 
   use Encode;
   local $/;
   open( my $fh, '<', 'json.data' );
   my $encoding = 'cp932';
   my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
   
   # or you can write the below code.
   #
   # open( my $fh, "<:encoding($encoding)", 'json.data' );
   # $unicode_json_text = <$fh>;
 
 In this case, C<$unicode_json_text> is of course UNICODE string.
 So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
 Instead of them, you use C<JSON> module object with C<utf8> disable.
 
   $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
 
 Or C<encode 'utf8'> and C<decode_json>:
 
   $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
   # this way is not efficient.
 
 And now, you want to convert your C<$perl_scalar> into JSON data and
 send it to an outer world - a network or a file content, and so on.
 
 Your data usually contains UNICODE strings and you want the converted data to be encoded
 in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
 
   print encode_json( $perl_scalar ); # to a network? file? or display?
   # or
   print $json->utf8->encode( $perl_scalar );
 
 If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
 for some reason, then its characters are regarded as B<latin1> for perl
 (because it does not concern with your $encoding).
 You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
 Instead of them, you use C<JSON> module object with C<utf8> disable.
 Note that the resulted text is a UNICODE string but no problem to print it.
 
   # $perl_scalar contains $encoding encoded string values
   $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
   # $unicode_json_text consists of characters less than 0x100
   print $unicode_json_text;
 
 Or C<decode $encoding> all string values and C<encode_json>:
 
   $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
   # ... do it to each string values, then encode_json
   $json_text = encode_json( $perl_scalar );
 
 This method is a proper way but probably not efficient.
 
 See to L<Encode>, L<perluniintro>.
 
 
 =head1 METHODS
 
 Basically, check to L<JSON> or L<JSON::XS>.
 
 =head2 new
 
     $json = JSON::PP->new
 
 Rturns a new JSON::PP object that can be used to de/encode JSON
 strings.
 
 All boolean flags described below are by default I<disabled>.
 
 The mutators for flags all return the JSON object again and thus calls can
 be chained:
 
    my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
    => {"a": [1, 2]}
 
 =head2 ascii
 
     $json = $json->ascii([$enable])
     
     $enabled = $json->get_ascii
 
 If $enable is true (or missing), then the encode method will not generate characters outside
 the code range 0..127. Any Unicode characters outside that range will be escaped using either
 a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
 (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
 
 In Perl 5.005, there is no character having high value (more than 255).
 See to L<UNICODE HANDLING ON PERLS>.
 
 If $enable is false, then the encode method will not escape Unicode characters unless
 required by the JSON syntax or other flags. This results in a faster and more compact format.
 
   JSON::PP->new->ascii(1)->encode([chr 0x10401])
   => ["\ud801\udc01"]
 
 =head2 latin1
 
     $json = $json->latin1([$enable])
     
     $enabled = $json->get_latin1
 
 If $enable is true (or missing), then the encode method will encode the resulting JSON
 text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
 
 If $enable is false, then the encode method will not escape Unicode characters
 unless required by the JSON syntax or other flags.
 
   JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
   => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
 
 See to L<UNICODE HANDLING ON PERLS>.
 
 =head2 utf8
 
     $json = $json->utf8([$enable])
     
     $enabled = $json->get_utf8
 
 If $enable is true (or missing), then the encode method will encode the JSON result
 into UTF-8, as required by many protocols, while the decode method expects to be handled
 an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
 characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
 
 (In Perl 5.005, any character outside the range 0..255 does not exist.
 See to L<UNICODE HANDLING ON PERLS>.)
 
 In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
 encoding families, as described in RFC4627.
 
 If $enable is false, then the encode method will return the JSON string as a (non-encoded)
 Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
 (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
 
 Example, output UTF-16BE-encoded JSON:
 
   use Encode;
   $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
 
 Example, decode UTF-32LE-encoded JSON:
 
   use Encode;
   $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
 
 
 =head2 pretty
 
     $json = $json->pretty([$enable])
 
 This enables (or disables) all of the C<indent>, C<space_before> and
 C<space_after> flags in one call to generate the most readable
 (or most compact) form possible.
 
 Equivalent to:
 
    $json->indent->space_before->space_after
 
 =head2 indent
 
     $json = $json->indent([$enable])
     
     $enabled = $json->get_indent
 
 The default indent space length is three.
 You can use C<indent_length> to change the length.
 
 =head2 space_before
 
     $json = $json->space_before([$enable])
     
     $enabled = $json->get_space_before
 
 If C<$enable> is true (or missing), then the C<encode> method will add an extra
 optional space before the C<:> separating keys from values in JSON objects.
 
 If C<$enable> is false, then the C<encode> method will not add any extra
 space at those places.
 
 This setting has no effect when decoding JSON texts.
 
 Example, space_before enabled, space_after and indent disabled:
 
    {"key" :"value"}
 
 =head2 space_after
 
     $json = $json->space_after([$enable])
     
     $enabled = $json->get_space_after
 
 If C<$enable> is true (or missing), then the C<encode> method will add an extra
 optional space after the C<:> separating keys from values in JSON objects
 and extra whitespace after the C<,> separating key-value pairs and array
 members.
 
 If C<$enable> is false, then the C<encode> method will not add any extra
 space at those places.
 
 This setting has no effect when decoding JSON texts.
 
 Example, space_before and indent disabled, space_after enabled:
 
    {"key": "value"}
 
 =head2 relaxed
 
     $json = $json->relaxed([$enable])
     
     $enabled = $json->get_relaxed
 
 If C<$enable> is true (or missing), then C<decode> will accept some
 extensions to normal JSON syntax (see below). C<encode> will not be
 affected in anyway. I<Be aware that this option makes you accept invalid
 JSON texts as if they were valid!>. I suggest only to use this option to
 parse application-specific files written by humans (configuration files,
 resource files etc.)
 
 If C<$enable> is false (the default), then C<decode> will only accept
 valid JSON texts.
 
 Currently accepted extensions are:
 
 =over 4
 
 =item * list items can have an end-comma
 
 JSON I<separates> array elements and key-value pairs with commas. This
 can be annoying if you write JSON texts manually and want to be able to
 quickly append elements, so this extension accepts comma at the end of
 such items not just between them:
 
    [
       1,
       2, <- this comma not normally allowed
    ]
    {
       "k1": "v1",
       "k2": "v2", <- this comma not normally allowed
    }
 
 =item * shell-style '#'-comments
 
 Whenever JSON allows whitespace, shell-style comments are additionally
 allowed. They are terminated by the first carriage-return or line-feed
 character, after which more white-space and comments are allowed.
 
   [
      1, # this comment not allowed in JSON
         # neither this one...
   ]
 
 =back
 
 =head2 canonical
 
     $json = $json->canonical([$enable])
     
     $enabled = $json->get_canonical
 
 If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
 by sorting their keys. This is adding a comparatively high overhead.
 
 If C<$enable> is false, then the C<encode> method will output key-value
 pairs in the order Perl stores them (which will likely change between runs
 of the same script).
 
 This option is useful if you want the same data structure to be encoded as
 the same JSON text (given the same overall settings). If it is disabled,
 the same hash might be encoded differently even if contains the same data,
 as key-value pairs have no inherent ordering in Perl.
 
 This setting has no effect when decoding JSON texts.
 
 If you want your own sorting routine, you can give a code referece
 or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
 
 =head2 allow_nonref
 
     $json = $json->allow_nonref([$enable])
     
     $enabled = $json->get_allow_nonref
 
 If C<$enable> is true (or missing), then the C<encode> method can convert a
 non-reference into its corresponding string, number or null JSON value,
 which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
 values instead of croaking.
 
 If C<$enable> is false, then the C<encode> method will croak if it isn't
 passed an arrayref or hashref, as JSON texts must either be an object
 or array. Likewise, C<decode> will croak if given something that is not a
 JSON object or array.
 
    JSON::PP->new->allow_nonref->encode ("Hello, World!")
    => "Hello, World!"
 
 =head2 allow_unknown
 
     $json = $json->allow_unknown ([$enable])
     
     $enabled = $json->get_allow_unknown
 
 If $enable is true (or missing), then "encode" will *not* throw an
 exception when it encounters values it cannot represent in JSON (for
 example, filehandles) but instead will encode a JSON "null" value.
 Note that blessed objects are not included here and are handled
 separately by c<allow_nonref>.
 
 If $enable is false (the default), then "encode" will throw an
 exception when it encounters anything it cannot encode as JSON.
 
 This option does not affect "decode" in any way, and it is
 recommended to leave it off unless you know your communications
 partner.
 
 =head2 allow_blessed
 
     $json = $json->allow_blessed([$enable])
     
     $enabled = $json->get_allow_blessed
 
 If C<$enable> is true (or missing), then the C<encode> method will not
 barf when it encounters a blessed reference. Instead, the value of the
 B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
 disabled or no C<TO_JSON> method found) or a representation of the
 object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
 encoded. Has no effect on C<decode>.
 
 If C<$enable> is false (the default), then C<encode> will throw an
 exception when it encounters a blessed object.
 
 =head2 convert_blessed
 
     $json = $json->convert_blessed([$enable])
     
     $enabled = $json->get_convert_blessed
 
 If C<$enable> is true (or missing), then C<encode>, upon encountering a
 blessed object, will check for the availability of the C<TO_JSON> method
 on the object's class. If found, it will be called in scalar context
 and the resulting scalar will be encoded instead of the object. If no
 C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
 to do.
 
 The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
 returns other blessed objects, those will be handled in the same
 way. C<TO_JSON> must take care of not causing an endless recursion cycle
 (== crash) in this case. The name of C<TO_JSON> was chosen because other
 methods called by the Perl core (== not by the user of the object) are
 usually in upper case letters and to avoid collisions with the C<to_json>
 function or method.
 
 This setting does not yet influence C<decode> in any way.
 
 If C<$enable> is false, then the C<allow_blessed> setting will decide what
 to do when a blessed object is found.
 
 =head2 filter_json_object
 
     $json = $json->filter_json_object([$coderef])
 
 When C<$coderef> is specified, it will be called from C<decode> each
 time it decodes a JSON object. The only argument passed to the coderef
 is a reference to the newly-created hash. If the code references returns
 a single scalar (which need not be a reference), this value
 (i.e. a copy of that scalar to avoid aliasing) is inserted into the
 deserialised data structure. If it returns an empty list
 (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
 hash will be inserted. This setting can slow down decoding considerably.
 
 When C<$coderef> is omitted or undefined, any existing callback will
 be removed and C<decode> will not change the deserialised hash in any
 way.
 
 Example, convert all JSON objects into the integer 5:
 
    my $js = JSON::PP->new->filter_json_object (sub { 5 });
    # returns [5]
    $js->decode ('[{}]'); # the given subroutine takes a hash reference.
    # throw an exception because allow_nonref is not enabled
    # so a lone 5 is not allowed.
    $js->decode ('{"a":1, "b":2}');
 
 =head2 filter_json_single_key_object
 
     $json = $json->filter_json_single_key_object($key [=> $coderef])
 
 Works remotely similar to C<filter_json_object>, but is only called for
 JSON objects having a single key named C<$key>.
 
 This C<$coderef> is called before the one specified via
 C<filter_json_object>, if any. It gets passed the single value in the JSON
 object. If it returns a single value, it will be inserted into the data
 structure. If it returns nothing (not even C<undef> but the empty list),
 the callback from C<filter_json_object> will be called next, as if no
 single-key callback were specified.
 
 If C<$coderef> is omitted or undefined, the corresponding callback will be
 disabled. There can only ever be one callback for a given key.
 
 As this callback gets called less often then the C<filter_json_object>
 one, decoding speed will not usually suffer as much. Therefore, single-key
 objects make excellent targets to serialise Perl objects into, especially
 as single-key JSON objects are as close to the type-tagged value concept
 as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
 support this in any way, so you need to make sure your data never looks
 like a serialised Perl hash.
 
 Typical names for the single object key are C<__class_whatever__>, or
 C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
 things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
 with real hashes.
 
 Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
 into the corresponding C<< $WIDGET{<id>} >> object:
 
    # return whatever is in $WIDGET{5}:
    JSON::PP
       ->new
       ->filter_json_single_key_object (__widget__ => sub {
             $WIDGET{ $_[0] }
          })
       ->decode ('{"__widget__": 5')
 
    # this can be used with a TO_JSON method in some "widget" class
    # for serialisation to json:
    sub WidgetBase::TO_JSON {
       my ($self) = @_;
 
       unless ($self->{id}) {
          $self->{id} = ..get..some..id..;
          $WIDGET{$self->{id}} = $self;
       }
 
       { __widget__ => $self->{id} }
    }
 
 =head2 shrink
 
     $json = $json->shrink([$enable])
     
     $enabled = $json->get_shrink
 
 In JSON::XS, this flag resizes strings generated by either
 C<encode> or C<decode> to their minimum size possible.
 It will also try to downgrade any strings to octet-form if possible.
 
 In JSON::PP, it is noop about resizing strings but tries
 C<utf8::downgrade> to the returned string by C<encode>.
 See to L<utf8>.
 
 See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
 
 =head2 max_depth
 
     $json = $json->max_depth([$maximum_nesting_depth])
     
     $max_depth = $json->get_max_depth
 
 Sets the maximum nesting level (default C<512>) accepted while encoding
 or decoding. If a higher nesting level is detected in JSON text or a Perl
 data structure, then the encoder and decoder will stop and croak at that
 point.
 
 Nesting level is defined by number of hash- or arrayrefs that the encoder
 needs to traverse to reach a given point or the number of C<{> or C<[>
 characters without their matching closing parenthesis crossed to reach a
 given character in a string.
 
 If no argument is given, the highest possible setting will be used, which
 is rarely useful.
 
 See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
 
 When a large value (100 or more) was set and it de/encodes a deep nested object/text,
 it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
 
 =head2 max_size
 
     $json = $json->max_size([$maximum_string_size])
     
     $max_size = $json->get_max_size
 
 Set the maximum length a JSON text may have (in bytes) where decoding is
 being attempted. The default is C<0>, meaning no limit. When C<decode>
 is called on a string that is longer then this many bytes, it will not
 attempt to decode the string but throw an exception. This setting has no
 effect on C<encode> (yet).
 
 If no argument is given, the limit check will be deactivated (same as when
 C<0> is specified).
 
 See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
 
 =head2 encode
 
     $json_text = $json->encode($perl_scalar)
 
 Converts the given Perl data structure (a simple scalar or a reference
 to a hash or array) to its JSON representation. Simple scalars will be
 converted into JSON string or number sequences, while references to arrays
 become JSON arrays and references to hashes become JSON objects. Undefined
 Perl values (e.g. C<undef>) become JSON C<null> values.
 References to the integers C<0> and C<1> are converted into C<true> and C<false>.
 
 =head2 decode
 
     $perl_scalar = $json->decode($json_text)
 
 The opposite of C<encode>: expects a JSON text and tries to parse it,
 returning the resulting simple scalar or reference. Croaks on error.
 
 JSON numbers and strings become simple Perl scalars. JSON arrays become
 Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
 C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
 C<null> becomes C<undef>.
 
 =head2 decode_prefix
 
     ($perl_scalar, $characters) = $json->decode_prefix($json_text)
 
 This works like the C<decode> method, but instead of raising an exception
 when there is trailing garbage after the first JSON object, it will
 silently stop parsing there and return the number of characters consumed
 so far.
 
    JSON->new->decode_prefix ("[1] the tail")
    => ([], 3)
 
 =head1 INCREMENTAL PARSING
 
 Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
 
 In some cases, there is the need for incremental parsing of JSON texts.
 This module does allow you to parse a JSON stream incrementally.
 It does so by accumulating text until it has a full JSON object, which
 it then can decode. This process is similar to using C<decode_prefix>
 to see if a full JSON object is available, but is much more efficient
 (and can be implemented with a minimum of method calls).
 
 This module will only attempt to parse the JSON text once it is sure it
 has enough text to get a decisive result, using a very simple but
 truly incremental parser. This means that it sometimes won't stop as
 early as the full parser, for example, it doesn't detect parenthese
 mismatches. The only thing it guarantees is that it starts decoding as
 soon as a syntactically valid JSON text has been seen. This means you need
 to set resource limits (e.g. C<max_size>) to ensure the parser will stop
 parsing in the presence if syntax errors.
 
 The following methods implement this incremental parser.
 
 =head2 incr_parse
 
     $json->incr_parse( [$string] ) # void context
     
     $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
     
     @obj_or_empty = $json->incr_parse( [$string] ) # list context
 
 This is the central parsing function. It can both append new text and
 extract objects from the stream accumulated so far (both of these
 functions are optional).
 
 If C<$string> is given, then this string is appended to the already
 existing JSON fragment stored in the C<$json> object.
 
 After that, if the function is called in void context, it will simply
 return without doing anything further. This can be used to add more text
 in as many chunks as you want.
 
 If the method is called in scalar context, then it will try to extract
 exactly I<one> JSON object. If that is successful, it will return this
 object, otherwise it will return C<undef>. If there is a parse error,
 this method will croak just as C<decode> would do (one can then use
 C<incr_skip> to skip the errornous part). This is the most common way of
 using the method.
 
 And finally, in list context, it will try to extract as many objects
 from the stream as it can find and return them, or the empty list
 otherwise. For this to work, there must be no separators between the JSON
 objects or arrays, instead they must be concatenated back-to-back. If
 an error occurs, an exception will be raised as in the scalar context
 case. Note that in this case, any previously-parsed JSON texts will be
 lost.
 
 Example: Parse some JSON arrays/objects in a given string and return them.
 
     my @objs = JSON->new->incr_parse ("[5][7][1,2]");
 
 =head2 incr_text
 
     $lvalue_string = $json->incr_text
 
 This method returns the currently stored JSON fragment as an lvalue, that
 is, you can manipulate it. This I<only> works when a preceding call to
 C<incr_parse> in I<scalar context> successfully returned an object. Under
 all other circumstances you must not call this function (I mean it.
 although in simple tests it might actually work, it I<will> fail under
 real world conditions). As a special exception, you can also call this
 method before having parsed anything.
 
 This function is useful in two cases: a) finding the trailing text after a
 JSON object or b) parsing multiple JSON objects separated by non-JSON text
 (such as commas).
 
     $json->incr_text =~ s/\s*,\s*//;
 
 In Perl 5.005, C<lvalue> attribute is not available.
 You must write codes like the below:
 
     $string = $json->incr_text;
     $string =~ s/\s*,\s*//;
     $json->incr_text( $string );
 
 =head2 incr_skip
 
     $json->incr_skip
 
 This will reset the state of the incremental parser and will remove the
 parsed text from the input buffer. This is useful after C<incr_parse>
 died, in which case the input buffer and incremental parser state is left
 unchanged, to skip the text parsed so far and to reset the parse state.
 
 =head2 incr_reset
 
     $json->incr_reset
 
 This completely resets the incremental parser, that is, after this call,
 it will be as if the parser had never parsed anything.
 
 This is useful if you want ot repeatedly parse JSON objects and want to
 ignore any trailing data, which means you have to reset the parser after
 each successful decode.
 
 See to L<JSON::XS/INCREMENTAL PARSING> for examples.
 
 
 =head1 JSON::PP OWN METHODS
 
 =head2 allow_singlequote
 
     $json = $json->allow_singlequote([$enable])
 
 If C<$enable> is true (or missing), then C<decode> will accept
 JSON strings quoted by single quotations that are invalid JSON
 format.
 
     $json->allow_singlequote->decode({"foo":'bar'});
     $json->allow_singlequote->decode({'foo':"bar"});
     $json->allow_singlequote->decode({'foo':'bar'});
 
 As same as the C<relaxed> option, this option may be used to parse
 application-specific files written by humans.
 
 
 =head2 allow_barekey
 
     $json = $json->allow_barekey([$enable])
 
 If C<$enable> is true (or missing), then C<decode> will accept
 bare keys of JSON object that are invalid JSON format.
 
 As same as the C<relaxed> option, this option may be used to parse
 application-specific files written by humans.
 
     $json->allow_barekey->decode('{foo:"bar"}');
 
 =head2 allow_bignum
 
     $json = $json->allow_bignum([$enable])
 
 If C<$enable> is true (or missing), then C<decode> will convert
 the big integer Perl cannot handle as integer into a L<Math::BigInt>
 object and convert a floating number (any) into a L<Math::BigFloat>.
 
 On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
 objects into JSON numbers with C<allow_blessed> enable.
 
    $json->allow_nonref->allow_blessed->allow_bignum;
    $bigfloat = $json->decode('2.000000000000000000000000001');
    print $json->encode($bigfloat);
    # => 2.000000000000000000000000001
 
 See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
 
 =head2 loose
 
     $json = $json->loose([$enable])
 
 The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
 and the module doesn't allow to C<decode> to these (except for \x2f).
 If C<$enable> is true (or missing), then C<decode>  will accept these
 unescaped strings.
 
     $json->loose->decode(qq|["abc
                                    def"]|);
 
 See L<JSON::XS/SSECURITY CONSIDERATIONS>.
 
 =head2 escape_slash
 
     $json = $json->escape_slash([$enable])
 
 According to JSON Grammar, I<slash> (U+002F) is escaped. But default
 JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
 
 If C<$enable> is true (or missing), then C<encode> will escape slashes.
 
 =head2 indent_length
 
     $json = $json->indent_length($length)
 
 JSON::XS indent space length is 3 and cannot be changed.
 JSON::PP set the indent space length with the given $length.
 The default is 3. The acceptable range is 0 to 15.
 
 =head2 sort_by
 
     $json = $json->sort_by($function_name)
     $json = $json->sort_by($subroutine_ref)
 
 If $function_name or $subroutine_ref are set, its sort routine are used
 in encoding JSON objects.
 
    $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
    # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
 
    $js = $pc->sort_by('own_sort')->encode($obj);
    # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
 
    sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
 
 As the sorting routine runs in the JSON::PP scope, the given
 subroutine name and the special variables C<$a>, C<$b> will begin
 'JSON::PP::'.
 
 If $integer is set, then the effect is same as C<canonical> on.
 
 =head1 INTERNAL
 
 For developers.
 
 =over
 
 =item PP_encode_box
 
 Returns
 
         {
             depth        => $depth,
             indent_count => $indent_count,
         }
 
 
 =item PP_decode_box
 
 Returns
 
         {
             text    => $text,
             at      => $at,
             ch      => $ch,
             len     => $len,
             depth   => $depth,
             encoding      => $encoding,
             is_valid_utf8 => $is_valid_utf8,
         };
 
 =back
 
 =head1 MAPPING
 
 This section is copied from JSON::XS and modified to C<JSON::PP>.
 JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
 
 See to L<JSON::XS/MAPPING>.
 
 =head2 JSON -> PERL
 
 =over 4
 
 =item object
 
 A JSON object becomes a reference to a hash in Perl. No ordering of object
 keys is preserved (JSON does not preserver object key ordering itself).
 
 =item array
 
 A JSON array becomes a reference to an array in Perl.
 
 =item string
 
 A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
 are represented by the same codepoints in the Perl string, so no manual
 decoding is necessary.
 
 =item number
 
 A JSON number becomes either an integer, numeric (floating point) or
 string scalar in perl, depending on its range and any fractional parts. On
 the Perl level, there is no difference between those as Perl handles all
 the conversion details, but an integer may take slightly less memory and
 might represent more values exactly than floating point numbers.
 
 If the number consists of digits only, C<JSON> will try to represent
 it as an integer value. If that fails, it will try to represent it as
 a numeric (floating point) value if that is possible without loss of
 precision. Otherwise it will preserve the number as a string value (in
 which case you lose roundtripping ability, as the JSON number will be
 re-encoded toa JSON string).
 
 Numbers containing a fractional or exponential part will always be
 represented as numeric (floating point) values, possibly at a loss of
 precision (in which case you might lose perfect roundtripping ability, but
 the JSON number will still be re-encoded as a JSON number).
 
 Note that precision is not accuracy - binary floating point values cannot
 represent most decimal fractions exactly, and when converting from and to
 floating point, C<JSON> only guarantees precision up to but not including
 the leats significant bit.
 
 When C<allow_bignum> is enable, the big integers 
 and the numeric can be optionally converted into L<Math::BigInt> and
 L<Math::BigFloat> objects.
 
 =item true, false
 
 These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
 respectively. They are overloaded to act almost exactly like the numbers
 C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
 the C<JSON::is_bool> function.
 
    print JSON::PP::true . "\n";
     => true
    print JSON::PP::true + 1;
     => 1
 
    ok(JSON::true eq  '1');
    ok(JSON::true == 1);
 
 C<JSON> will install these missing overloading features to the backend modules.
 
 
 =item null
 
 A JSON null atom becomes C<undef> in Perl.
 
 C<JSON::PP::null> returns C<unddef>.
 
 =back
 
 
 =head2 PERL -> JSON
 
 The mapping from Perl to JSON is slightly more difficult, as Perl is a
 truly typeless language, so we can only guess which JSON type is meant by
 a Perl value.
 
 =over 4
 
 =item hash references
 
 Perl hash references become JSON objects. As there is no inherent ordering
 in hash keys (or JSON objects), they will usually be encoded in a
 pseudo-random order that can change between runs of the same program but
 stays generally the same within a single run of a program. C<JSON>
 optionally sort the hash keys (determined by the I<canonical> flag), so
 the same datastructure will serialise to the same JSON text (given same
 settings and version of JSON::XS), but this incurs a runtime overhead
 and is only rarely useful, e.g. when you want to compare some JSON text
 against another for equality.
 
 
 =item array references
 
 Perl array references become JSON arrays.
 
 =item other references
 
 Other unblessed references are generally not allowed and will cause an
 exception to be thrown, except for references to the integers C<0> and
 C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
 also use C<JSON::false> and C<JSON::true> to improve readability.
 
    to_json [\0,JSON::PP::true]      # yields [false,true]
 
 =item JSON::PP::true, JSON::PP::false, JSON::PP::null
 
 These special values become JSON true and JSON false values,
 respectively. You can also use C<\1> and C<\0> directly if you want.
 
 JSON::PP::null returns C<undef>.
 
 =item blessed objects
 
 Blessed objects are not directly representable in JSON. See the
 C<allow_blessed> and C<convert_blessed> methods on various options on
 how to deal with this: basically, you can choose between throwing an
 exception, encoding the reference as if it weren't blessed, or provide
 your own serialiser method.
 
 See to L<convert_blessed>.
 
 =item simple scalars
 
 Simple Perl scalars (any scalar that is not a reference) are the most
 difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
 JSON C<null> values, scalars that have last been used in a string context
 before encoding as JSON strings, and anything else as number value:
 
    # dump as number
    encode_json [2]                      # yields [2]
    encode_json [-3.0e17]                # yields [-3e+17]
    my $value = 5; encode_json [$value]  # yields [5]
 
    # used as string, so dump as string
    print $value;
    encode_json [$value]                 # yields ["5"]
 
    # undef becomes null
    encode_json [undef]                  # yields [null]
 
 You can force the type to be a string by stringifying it:
 
    my $x = 3.1; # some variable containing a number
    "$x";        # stringified
    $x .= "";    # another, more awkward way to stringify
    print $x;    # perl does it for you, too, quite often
 
 You can force the type to be a number by numifying it:
 
    my $x = "3"; # some variable containing a string
    $x += 0;     # numify it, ensuring it will be dumped as a number
    $x *= 1;     # same thing, the choise is yours.
 
 You can not currently force the type in other, less obscure, ways.
 
 Note that numerical precision has the same meaning as under Perl (so
 binary to decimal conversion follows the same rules as in Perl, which
 can differ to other languages). Also, your perl interpreter might expose
 extensions to the floating point numbers of your platform, such as
 infinities or NaN's - these cannot be represented in JSON, and it is an
 error to pass those in.
 
 =item Big Number
 
 When C<allow_bignum> is enable, 
 C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
 objects into JSON numbers.
 
 
 =back
 
 =head1 UNICODE HANDLING ON PERLS
 
 If you do not know about Unicode on Perl well,
 please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
 
 =head2 Perl 5.8 and later
 
 Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
 
     $json->allow_nonref->encode(chr hex 3042);
     $json->allow_nonref->encode(chr hex 12345);
 
 Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
 
     $json->allow_nonref->decode('"\u3042"');
     $json->allow_nonref->decode('"\ud808\udf45"');
 
 Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
 
 Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
 so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
 
 
 =head2 Perl 5.6
 
 Perl can handle Unicode and the JSON::PP de/encode methods also work.
 
 =head2 Perl 5.005
 
 Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
 That means the unicode handling is not available.
 
 In encoding,
 
     $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
     $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
 
 Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
 as C<$value % 256>, so the above codes are equivalent to :
 
     $json->allow_nonref->encode(chr 66);
     $json->allow_nonref->encode(chr 69);
 
 In decoding,
 
     $json->decode('"\u00e3\u0081\u0082"');
 
 The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
 japanese character (C<HIRAGANA LETTER A>).
 And if it is represented in Unicode code point, C<U+3042>.
 
 Next, 
 
     $json->decode('"\u3042"');
 
 We ordinary expect the returned value is a Unicode character C<U+3042>.
 But here is 5.005 world. This is C<0xE3 0x81 0x82>.
 
     $json->decode('"\ud808\udf45"');
 
 This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
 
 
 =head1 TODO
 
 =over
 
 =item speed
 
 =item memory saving
 
 =back
 
 
 =head1 SEE ALSO
 
 Most of the document are copied and modified from JSON::XS doc.
 
 L<JSON::XS>
 
 RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
 
 =head1 AUTHOR
 
 Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
 
 
 =head1 COPYRIGHT AND LICENSE
 
 Copyright 2007-2014 by Makamaka Hannyaharamitu
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself. 
 
 =cut
### Lingua/EN/PluralToSingular.pm ###
 package Lingua::EN::PluralToSingular;
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT_OK = qw/to_singular is_plural/;
 use warnings;
 use strict;
 our $VERSION = '0.14';
 
 # Irregular plurals.
 
 # References:
 # http://www.macmillandictionary.com/thesaurus-category/british/Irregular-plurals
 # http://web2.uvcs.uvic.ca/elc/studyzone/330/grammar/irrplu.htm
 # http://www.scribd.com/doc/3271143/List-of-100-Irregular-Plural-Nouns-in-English
 
 # This mixes latin/greek plurals and anglo-saxon together. It may be
 # desirable to split things like corpora and genera from "feet" and
 # "geese" at some point.
 
 my %irregular = (qw/
     analyses analysis
     children child
     corpora corpus
     craftsmen craftsman
     crises crisis
     criteria criterion
     curricula curriculum
     feet foot
     fungi fungus
     geese goose
     genera genus
     indices index
     lice louse
     matrices matrix
     memoranda memorandum
     men man
     mice mouse
     monies money
     neuroses neurosis
     nuclei nucleus
     oases oasis
     pence penny
     people person
     phenomena phenomenon
     quanta quantum
     strata stratum
     teeth tooth
     testes testis
     these this
     theses thesis
     those that
     women woman
 /);
 
 # Words ending in ves need care, since the ves may become "f" or "fe".
 
 # References:
 # http://www.macmillandictionary.com/thesaurus-category/british/Irregular-plurals
 
 my %ves = (qw/
     calves calf
     dwarves dwarf
     elves elf
     halves half
     knives knife
     leaves leaf
     lives life
     loaves loaf
     scarves scarf
     sheaves sheaf
     shelves shelf
     wharves wharf 
     wives wife
     wolves wolf
 /);
 
 # A dictionary of plurals.
 
 my %plural = (
     # Words ending in "us" which are plural, in contrast to words like
     # "citrus" or "bogus".
     'menus' => 'menu',
     'buses' => 'bus',
     %ves,
     %irregular,
 );
 
 # A store of words which are the same in both singular and plural.
 
 my @no_change = qw/
                       clothes
                       deer
                       ides
                       fish
                       means
                       offspring
                       series
                       sheep
                       species
                   /;
 
 @plural{@no_change} = @no_change;
 
 # A store of words which look like plurals but are not.
 
 # References:
 
 # http://wiki.answers.com/Q/What_are_some_examples_of_singular_nouns_ending_in_S
 # http://virtuallinguist.typepad.com/the_virtual_linguist/2009/10/singular-nouns-ending-in-s.html
 
 my @not_plural = (qw/
     Charles
     Texas
 Hades 
 Hercules 
 Hermes 
 Gonzales 
 Holmes 
 Hughes 
 Ives 
 Jacques 
 James 
 Keyes 
 Mercedes 
 Naples 
 Oates 
 Raines 
 
     dias
     iris
     molasses
     this
     yes
     chaos
     lens
     corps
     mews
     news
 
     athletics
     mathematics
     physics
     metaphysics
 
 
     bogus
     bus
     cactus
     citrus
     corpus
     hippopotamus
     homunculus
     minus
     narcissus
     octopus
     papyrus
     platypus
     plus
     pus
     stylus
     various
     previous
     devious
     metropolis
     miscellaneous
     perhaps
     thus
     famous
     mrs
 sometimes
 
 ourselves
 themselves
 cannabis
 /);
 
 my %not_plural;
 
 @not_plural{@not_plural} = (1) x @not_plural;
 
 # A store of words which end in "oe" and whose plural ends in "oes".
 
 # References
 # http://www.scrabblefinder.com/ends-with/oe/
 
 my @oes = (qw/
 		 foes
 		 shoes
                  hoes
 		 throes
                  toes
 		 oboes
              /);
 
 my %oes;
 
 @oes{@oes} = (1) x @oes;
 
 # A store of words which end in "ie" and whose plural ends in "ies".
 
 # References:
 # http://www.scrabblefinder.com/ends-with/ie/
 # (most of the words are invalid, the above list was manually searched
 # for useful words).
 
 my @ies = (qw/
 calories
 genies
 lies
 movies
 neckties
 pies
 ties
 /);
 
 my %ies;
 
 @ies{@ies} = (1) x @ies;
 
 # Words which end in -se, so that we want the singular to change from
 # -ses to -se.
 
 my @ses = (qw/
 horses
 tenses
 /);
 
 my %ses;
 @ses{@ses} = (1) x @ses;
 
 # A regular expression which matches the end of words like "dishes"
 # and "sandwiches". $1 is a capture which contains the part of the
 # word which should be kept in a substitution.
 
 my $es_re = qr/([^aeiou]s|ch|sh)es$/;
 
 # See documentation below.
 
 sub to_singular
 {
     my ($word) = @_;
     # The return value.
     my $singular = $word;
     if (! $not_plural{$word}) {
         # The word is not in the list of exceptions.
         if ($plural{$word}) {
             # The word has an irregular plural, like "children", or
             # "geese", so look up the singular in the table.
             $singular = $plural{$word};
         }
         elsif ($word =~ /s$/) {
             # The word ends in "s".
 	    if ($word =~ /'s$/) {
 		# report's, etc.
 		;
 	    }
 	    elsif (length ($word) <= 2) {
 		# is, as, letter s, etc.
 		;
 	    }
 	    elsif ($word =~ /ss$/) {
 		# useless, etc.
 		;
 	    }
 	    elsif ($word =~ /sis$/) {
 		# basis, dialysis etc.
 		;
 	    }
             elsif ($word =~ /ies$/) {
                 # The word ends in "ies".
                 if ($ies{$word}) {
                     # Lies -> lie
                     $singular =~ s/ies$/ie/;
                 }
                 else {
                     # Fries -> fry
                     $singular =~ s/ies$/y/;
                 }
             }
             elsif ($word =~ /oes$/) {
                 # The word ends in "oes".
                 if ($oes{$word}) {
                     # Toes -> toe
                     $singular =~ s/oes$/oe/;
                 }
                 else {
                     # Potatoes -> potato
                     $singular =~ s/oes$/o/;
                 }
             }
             elsif ($word =~ /xes$/) {
                 # The word ends in "xes".
 		$singular =~ s/xes$/x/;
             }
 	    elsif ($word =~ /ses$/) {
 		if ($ses{$word}) {
 		    $singular =~ s/ses$/se/;
 		}
 		else {
 		    $singular =~ s/ses$/s/;
 		}
 	    }
             elsif ($word =~ $es_re) {
                 # Sandwiches -> sandwich
                 # Dishes -> dish
                 $singular =~ s/$es_re/$1/;
             }
             else {
                 # Now the program has checked for every exception it
                 # can think of, so it assumes that it is OK to remove
                 # the "s" from the end of the word.
                 $singular =~ s/s$//;
             }
         }
     }            
     return $singular;
 }
 
 sub is_plural
 {
     my ($word) = @_;
     my $singular = to_singular ($word);
     my $is_plural;
     if ($singular ne $word) {
 	$is_plural = 1;
     }
     elsif ($plural{$singular} && $plural{$singular} eq $singular) {
 	$is_plural = 1;
     }
     else {
 	$is_plural = 0;
     }
     return $is_plural;
 }
 
 1;
 
### List/MoreUtils.pm ###
 package List::MoreUtils;
 
 use 5.006;
 use strict;
 use warnings;
 
 BEGIN
 {
     our $VERSION = '0.412';
 }
 
 use Exporter::Tiny qw();
 use List::MoreUtils::XS qw();    # try loading XS
 
 my @junctions = qw(any all none notall);
 my @v0_22     = qw(
   true false
   firstidx lastidx
   insert_after insert_after_string
   apply indexes
   after after_incl before before_incl
   firstval lastval
   each_array each_arrayref
   pairwise natatime
   mesh uniq
   minmax part
 );
 my @v0_24  = qw(bsearch);
 my @v0_33  = qw(sort_by nsort_by);
 my @v0_400 = qw(one any_u all_u none_u notall_u one_u
   firstres onlyidx onlyval onlyres lastres
   singleton bsearchidx
 );
 
 my @all_functions = ( @junctions, @v0_22, @v0_24, @v0_33, @v0_400 );
 
 my %alias_list = (
     v0_22 => {
         first_index => "firstidx",
         last_index  => "lastidx",
         first_value => "firstval",
         last_value  => "lastval",
         zip         => "mesh",
     },
     v0_33 => {
         distinct => "uniq",
     },
     v0_400 => {
         first_result  => "firstres",
         only_index    => "onlyidx",
         only_value    => "onlyval",
         only_result   => "onlyres",
         last_result   => "lastres",
         bsearch_index => "bsearchidx",
     },
 );
 
 our @ISA         = qw(Exporter::Tiny);
 our @EXPORT_OK   = ( @all_functions, map { keys %$_ } values %alias_list );
 our %EXPORT_TAGS = (
     all         => \@EXPORT_OK,
     'like_0.22' => [
         any_u    => { -as => 'any' },
         all_u    => { -as => 'all' },
         none_u   => { -as => 'none' },
         notall_u => { -as => 'notall' },
         @v0_22,
         keys %{ $alias_list{v0_22} },
     ],
     'like_0.24' => [
         any_u    => { -as => 'any' },
         all_u    => { -as => 'all' },
         notall_u => { -as => 'notall' },
         'none',
         @v0_22,
         @v0_24,
         keys %{ $alias_list{v0_22} },
     ],
     'like_0.33' => [
         @junctions,
         @v0_22,
         # v0_24 functions were omitted
         @v0_33,
         keys %{ $alias_list{v0_22} },
         keys %{ $alias_list{v0_33} },
     ],
 );
 
 for my $set ( values %alias_list )
 {
     for my $alias ( keys %$set )
     {
         no strict qw(refs);
         *$alias = __PACKAGE__->can( $set->{$alias} );
     }
 }
 
 =pod
 
 =head1 NAME
 
 List::MoreUtils - Provide the stuff missing in List::Util
 
 =head1 SYNOPSIS
 
     # import specific functions
 
     use List::MoreUtils qw(any uniq);
 
     if ( any { /foo/ } uniq @has_duplicates ) {
         # do stuff
     }
 
     # import everything
 
     use List::MoreUtils ':all';
 
     # import by API
 
     # has "original" any/all/none/notall behavior
     use List::MoreUtils ':like_0.22';
     # 0.22 + bsearch
     use List::MoreUtils ':like_0.24';
     # has "simplified" any/all/none/notall behavior + (n)sort_by
     use List::MoreUtils ':like_0.33';
 
 =head1 DESCRIPTION
 
 B<List::MoreUtils> provides some trivial but commonly needed functionality on
 lists which is not going to go into L<List::Util>.
 
 All of the below functions are implementable in only a couple of lines of Perl
 code. Using the functions from this module however should give slightly better
 performance as everything is implemented in C. The pure-Perl implementation of
 these functions only serves as a fallback in case the C portions of this module
 couldn't be compiled on this machine.
 
 =head1 EXPORTS
 
 =head2 Default behavior
 
 Nothing by default. To import all of this module's symbols use the C<:all> tag.
 Otherwise functions can be imported by name as usual:
 
     use List::MoreUtils ':all';
 
     use List::MoreUtils qw{ any firstidx };
 
 Because historical changes to the API might make upgrading List::MoreUtils
 difficult for some projects, the legacy API is available via special import
 tags.
 
 =head2 Like version 0.22 (last release with original API)
 
 This API was available from 2006 to 2009, returning undef for empty lists on
 C<all>/C<any>/C<none>/C<notall>:
 
     use List::MoreUtils ':like_0.22';
 
 This import tag will import all functions available as of version 0.22.
 However, it will import C<any_u> as C<any>, C<all_u> as C<all>, C<none_u> as
 C<none>, and C<notall_u> as C<notall>.
 
 =head2 Like version 0.24 (first incompatible change)
 
 This API was available from 2010 to 2011.  It changed the return value of C<none>
 and added the C<bsearch> function.
 
     use List::MoreUtils ':like_0.24';
 
 This import tag will import all functions available as of version 0.24.
 However it will import C<any_u> as C<any>, C<all_u> as C<all>, and
 C<notall_u> as C<notall>.  It will import C<none> as described in
 the documentation below (true for empty list).
 
 =head2 Like version 0.33 (second incompatible change)
 
 This API was available from 2011 to 2014. It is widely used in several CPAN
 modules and thus it's closest to the current API.  It changed the return values
 of C<any>, C<all>, and C<notall>.  It added the C<sort_by> and C<nsort_by> functions
 and the C<distinct> alias for C<uniq>.  It omitted C<bsearch>.
 
     use List::MoreUtils ':like_0.33';
 
 This import tag will import all functions available as of version 0.33.  Note:
 it will not import C<bsearch> for consistency with the 0.33 API.
 
 =head1 FUNCTIONS
 
 =head2 Junctions
 
 =head3 I<Treatment of an empty list>
 
 There are two schools of thought for how to evaluate a junction on an
 empty list:
 
 =over
 
 =item *
 
 Reduction to an identity (boolean)
 
 =item *
 
 Result is undefined (three-valued)
 
 =back
 
 In the first case, the result of the junction applied to the empty list is
 determined by a mathematical reduction to an identity depending on whether
 the underlying comparison is "or" or "and".  Conceptually:
 
                     "any are true"      "all are true"
                     --------------      --------------
     2 elements:     A || B || 0         A && B && 1
     1 element:      A || 0              A && 1
     0 elements:     0                   1
 
 In the second case, three-value logic is desired, in which a junction
 applied to an empty list returns C<undef> rather than true or false 
 
 Junctions with a C<_u> suffix implement three-valued logic.  Those
 without are boolean.
 
 =head3 all BLOCK LIST
 
 =head3 all_u BLOCK LIST
 
 Returns a true value if all items in LIST meet the criterion given through
 BLOCK. Sets C<$_> for each item in LIST in turn:
 
   print "All values are non-negative"
     if all { $_ >= 0 } ($x, $y, $z);
 
 For an empty LIST, C<all> returns true (i.e. no values failed the condition)
 and C<all_u> returns C<undef>.
 
 Thus, C<< all_u(@list) >> is equivalent to C<< @list ? all(@list) : undef >>.
 
 B<Note>: because Perl treats C<undef> as false, you must check the return value
 of C<all_u> with C<defined> or you will get the opposite result of what you
 expect.
 
 =head3 any BLOCK LIST
 
 =head3 any_u BLOCK LIST
 
 Returns a true value if any item in LIST meets the criterion given through
 BLOCK. Sets C<$_> for each item in LIST in turn:
 
   print "At least one non-negative value"
     if any { $_ >= 0 } ($x, $y, $z);
 
 For an empty LIST, C<any> returns false and C<any_u> returns C<undef>.
 
 Thus, C<< any_u(@list) >> is equivalent to C<< @list ? any(@list) : undef >>.
 
 =head3 none BLOCK LIST
 
 =head3 none_u BLOCK LIST
 
 Logically the negation of C<any>. Returns a true value if no item in LIST meets
 the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn:
 
   print "No non-negative values"
     if none { $_ >= 0 } ($x, $y, $z);
 
 For an empty LIST, C<none> returns true (i.e. no values failed the condition)
 and C<none_u> returns C<undef>.
 
 Thus, C<< none_u(@list) >> is equivalent to C<< @list ? none(@list) : undef >>.
 
 B<Note>: because Perl treats C<undef> as false, you must check the return value
 of C<none_u> with C<defined> or you will get the opposite result of what you
 expect.
 
 =head3 notall BLOCK LIST
 
 =head3 notall_u BLOCK LIST
 
 Logically the negation of C<all>. Returns a true value if not all items in LIST
 meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in
 turn:
 
   print "Not all values are non-negative"
     if notall { $_ >= 0 } ($x, $y, $z);
 
 For an empty LIST, C<notall> returns false and C<notall_u> returns C<undef>.
 
 Thus, C<< notall_u(@list) >> is equivalent to C<< @list ? notall(@list) : undef >>.
 
 =head3 one BLOCK LIST
 
 =head3 one_u BLOCK LIST
 
 Returns a true value if precisely one item in LIST meets the criterion
 given through BLOCK. Sets C<$_> for each item in LIST in turn:
 
     print "Precisely one value defined"
         if one { defined($_) } @list;
 
 Returns false otherwise.
 
 For an empty LIST, C<one> returns false and C<one_u> returns C<undef>.
 
 The expression C<one BLOCK LIST> is almost equivalent to
 C<1 == true BLOCK LIST>, except for short-cutting.
 Evaluation of BLOCK will immediately stop at the second true value.
 
 =head2 Transformation
 
 =head3 apply BLOCK LIST
 
 Applies BLOCK to each item in LIST and returns a list of the values after BLOCK
 has been applied. In scalar context, the last element is returned.  This
 function is similar to C<map> but will not modify the elements of the input
 list:
 
   my @list = (1 .. 4);
   my @mult = apply { $_ *= 2 } @list;
   print "\@list = @list\n";
   print "\@mult = @mult\n";
   __END__
   @list = 1 2 3 4
   @mult = 2 4 6 8
 
 Think of it as syntactic sugar for
 
   for (my @mult = @list) { $_ *= 2 }
 
 =head3 insert_after BLOCK VALUE LIST
 
 Inserts VALUE after the first item in LIST for which the criterion in BLOCK is
 true. Sets C<$_> for each item in LIST in turn.
 
   my @list = qw/This is a list/;
   insert_after { $_ eq "a" } "longer" => @list;
   print "@list";
   __END__
   This is a longer list
 
 =head3 insert_after_string STRING VALUE LIST
 
 Inserts VALUE after the first item in LIST which is equal to STRING. 
 
   my @list = qw/This is a list/;
   insert_after_string "a", "longer" => @list;
   print "@list";
   __END__
   This is a longer list
 
 =head3 pairwise BLOCK ARRAY1 ARRAY2
 
 Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a
 new list consisting of BLOCK's return values. The two elements are set to C<$a>
 and C<$b>.  Note that those two are aliases to the original value so changing
 them will modify the input arrays.
 
   @a = (1 .. 5);
   @b = (11 .. 15);
   @x = pairwise { $a + $b } @a, @b;     # returns 12, 14, 16, 18, 20
 
   # mesh with pairwise
   @a = qw/a b c/;
   @b = qw/1 2 3/;
   @x = pairwise { ($a, $b) } @a, @b;    # returns a, 1, b, 2, c, 3
 
 =head3 mesh ARRAY1 ARRAY2 [ ARRAY3 ... ]
 
 =head3 zip ARRAY1 ARRAY2 [ ARRAY3 ... ]
 
 Returns a list consisting of the first elements of each array, then
 the second, then the third, etc, until all arrays are exhausted.
 
 Examples:
 
   @x = qw/a b c d/;
   @y = qw/1 2 3 4/;
   @z = mesh @x, @y;         # returns a, 1, b, 2, c, 3, d, 4
 
   @a = ('x');
   @b = ('1', '2');
   @c = qw/zip zap zot/;
   @d = mesh @a, @b, @c;   # x, 1, zip, undef, 2, zap, undef, undef, zot
 
 C<zip> is an alias for C<mesh>.
 
 =head3 uniq LIST
 
 =head3 distinct LIST
 
 Returns a new list by stripping duplicate values in LIST by comparing
 the values as hash keys, except that undef is considered separate from ''.
 The order of elements in the returned list is the same as in LIST. In
 scalar context, returns the number of unique elements in LIST.
 
   my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4
   my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5
   # returns "Mike", "Michael", "Richard", "Rick"
   my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick"
   # returns '', 'S1', A5' and complains about "Use of uninitialized value"
   my @s = distinct '', undef, 'S1', 'A5'
   # returns undef, 'S1', A5' and complains about "Use of uninitialized value"
   my @w = uniq undef, '', 'S1', 'A5'
 
 C<distinct> is an alias for C<uniq>.
 
 B<RT#49800> can be used to give feedback about this behavior.
 
 =head3 singleton
 
 Returns a new list by stripping values in LIST occurring more than once by
 comparing the values as hash keys, except that undef is considered separate
 from ''.  The order of elements in the returned list is the same as in LIST.
 In scalar context, returns the number of elements occurring only once in LIST.
 
   my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5
 
 =head2 Partitioning
 
 =head3 after BLOCK LIST
 
 Returns a list of the values of LIST after (and not including) the point
 where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn.
 
   @x = after { $_ % 5 == 0 } (1..9);    # returns 6, 7, 8, 9
 
 =head3 after_incl BLOCK LIST
 
 Same as C<after> but also includes the element for which BLOCK is true.
 
 =head3 before BLOCK LIST
 
 Returns a list of values of LIST up to (and not including) the point where BLOCK
 returns a true value. Sets C<$_> for each element in LIST in turn.
 
 =head3 before_incl BLOCK LIST
 
 Same as C<before> but also includes the element for which BLOCK is true.
 
 =head3 part BLOCK LIST
 
 Partitions LIST based on the return value of BLOCK which denotes into which
 partition the current value is put.
 
 Returns a list of the partitions thusly created. Each partition created is a
 reference to an array.
 
   my $i = 0;
   my @part = part { $i++ % 2 } 1 .. 8;   # returns [1, 3, 5, 7], [2, 4, 6, 8]
 
 You can have a sparse list of partitions as well where non-set partitions will
 be undef:
 
   my @part = part { 2 } 1 .. 10;            # returns undef, undef, [ 1 .. 10 ]
 
 Be careful with negative values, though:
 
   my @part = part { -1 } 1 .. 10;
   __END__
   Modification of non-creatable array value attempted, subscript -1 ...
 
 Negative values are only ok when they refer to a partition previously created:
 
   my @idx  = ( 0, 1, -1 );
   my $i    = 0;
   my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8]
 
 =head2 Iteration
 
 =head3 each_array ARRAY1 ARRAY2 ...
 
 Creates an array iterator to return the elements of the list of arrays ARRAY1,
 ARRAY2 throughout ARRAYn in turn.  That is, the first time it is called, it
 returns the first element of each array.  The next time, it returns the second
 elements.  And so on, until all elements are exhausted.
 
 This is useful for looping over more than one array at once:
 
   my $ea = each_array(@a, @b, @c);
   while ( my ($a, $b, $c) = $ea->() )   { .... }
 
 The iterator returns the empty list when it reached the end of all arrays.
 
 If the iterator is passed an argument of 'C<index>', then it returns
 the index of the last fetched set of values, as a scalar.
 
 =head3 each_arrayref LIST
 
 Like each_array, but the arguments are references to arrays, not the
 plain arrays.
 
 =head3 natatime EXPR, LIST
 
 Creates an array iterator, for looping over an array in chunks of
 C<$n> items at a time.  (n at a time, get it?).  An example is
 probably a better explanation than I could give in words.
 
 Example:
 
   my @x = ('a' .. 'g');
   my $it = natatime 3, @x;
   while (my @vals = $it->())
   {
     print "@vals\n";
   }
 
 This prints
 
   a b c
   d e f
   g
 
 =head2 Searching
 
 =head3 bsearch BLOCK LIST
 
 Performs a binary search on LIST which must be a sorted list of values. BLOCK
 must return a negative value if the current element (stored in C<$_>) is smaller,
 a positive value if it is bigger and zero if it matches.
 
 Returns a boolean value in scalar context. In list context, it returns the element
 if it was found, otherwise the empty list.
 
 =head3 bsearchidx BLOCK LIST
 
 =head3 bsearch_index BLOCK LIST
 
 Performs a binary search on LIST which must be a sorted list of values. BLOCK
 must return a negative value if the current element (stored in C<$_>) is smaller,
 a positive value if it is bigger and zero if it matches.
 
 Returns the index of found element, otherwise C<-1>.
 
 C<bsearch_index> is an alias for C<bsearchidx>.
 
 =head3 firstval BLOCK LIST
 
 =head3 first_value BLOCK LIST
 
 Returns the first element in LIST for which BLOCK evaluates to true. Each
 element of LIST is set to C<$_> in turn. Returns C<undef> if no such element
 has been found.
 
 C<first_value> is an alias for C<firstval>.
 
 =head3 onlyval BLOCK LIST
 
 =head3 only_value BLOCK LIST
 
 Returns the only element in LIST for which BLOCK evaluates to true. Sets
 C<$_> for each item in LIST in turn. Returns C<undef> if no such element
 has been found.
 
 C<only_value> is an alias for C<onlyval>.
 
 =head3 lastval BLOCK LIST
 
 =head3 last_value BLOCK LIST
 
 Returns the last value in LIST for which BLOCK evaluates to true. Each element
 of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been
 found.
 
 C<last_value> is an alias for C<lastval>.
 
 =head3 firstres BLOCK LIST
 
 =head3 first_result BLOCK LIST
 
 Returns the result of BLOCK for the first element in LIST for which BLOCK
 evaluates to true. Each element of LIST is set to C<$_> in turn. Returns
 C<undef> if no such element has been found.
 
 C<first_result> is an alias for C<firstres>.
 
 =head3 onlyres BLOCK LIST
 
 =head3 only_result BLOCK LIST
 
 Returns the result of BLOCK for the first element in LIST for which BLOCK
 evaluates to true. Sets C<$_> for each item in LIST in turn. Returns
 C<undef> if no such element has been found.
 
 C<only_result> is an alias for C<onlyres>.
 
 =head3 lastres BLOCK LIST
 
 =head3 last_result BLOCK LIST
 
 Returns the result of BLOCK for the last element in LIST for which BLOCK
 evaluates to true. Each element of LIST is set to C<$_> in turn. Returns
 C<undef> if no such element has been found.
 
 C<last_result> is an alias for C<lastres>.
 
 =head3 indexes BLOCK LIST
 
 Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list
 of the indices of those elements for which BLOCK returned a true value. This is
 just like C<grep> only that it returns indices instead of values:
 
   @x = indexes { $_ % 2 == 0 } (1..10);   # returns 1, 3, 5, 7, 9
 
 =head3 firstidx BLOCK LIST
 
 =head3 first_index BLOCK LIST
 
 Returns the index of the first element in LIST for which the criterion in BLOCK
 is true. Sets C<$_> for each item in LIST in turn:
 
   my @list = (1, 4, 3, 2, 4, 6);
   printf "item with index %i in list is 4", firstidx { $_ == 4 } @list;
   __END__
   item with index 1 in list is 4
 
 Returns C<-1> if no such item could be found.
 
 C<first_index> is an alias for C<firstidx>.
 
 =head3 onlyidx BLOCK LIST
 
 =head3 only_index BLOCK LIST
 
 Returns the index of the only element in LIST for which the criterion
 in BLOCK is true. Sets C<$_> for each item in LIST in turn:
 
     my @list = (1, 3, 4, 3, 2, 4);
     printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list;
     __END__
     unique index of item 2 in list is 4
 
 Returns C<-1> if either no such item or more than one of these
 has been found.
 
 C<only_index> is an alias for C<onlyidx>.
 
 =head3 lastidx BLOCK LIST
 
 =head3 last_index BLOCK LIST
 
 Returns the index of the last element in LIST for which the criterion in BLOCK
 is true. Sets C<$_> for each item in LIST in turn:
 
   my @list = (1, 4, 3, 2, 4, 6);
   printf "item with index %i in list is 4", lastidx { $_ == 4 } @list;
   __END__
   item with index 4 in list is 4
 
 Returns C<-1> if no such item could be found.
 
 C<last_index> is an alias for C<lastidx>.
 
 =head2 Sorting
 
 =head3 sort_by BLOCK LIST
 
 Returns the list of values sorted according to the string values returned by the
 KEYFUNC block or function. A typical use of this may be to sort objects according
 to the string value of some accessor, such as
 
   sort_by { $_->name } @people
 
 The key function is called in scalar context, being passed each value in turn as
 both $_ and the only argument in the parameters, @_. The values are then sorted
 according to string comparisons on the values returned.
 This is equivalent to
 
   sort { $a->name cmp $b->name } @people
 
 except that it guarantees the name accessor will be executed only once per value.
 One interesting use-case is to sort strings which may have numbers embedded in them
 "naturally", rather than lexically.
 
   sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings
 
 This sorts strings by generating sort keys which zero-pad the embedded numbers to
 some level (9 digits in this case), helping to ensure the lexical sort puts them
 in the correct order.
 
 =head3 nsort_by BLOCK LIST
 
 Similar to sort_by but compares its key values numerically.
 
 =head2 Counting and calculation
 
 =head3 true BLOCK LIST
 
 Counts the number of elements in LIST for which the criterion in BLOCK is true.
 Sets C<$_> for  each item in LIST in turn:
 
   printf "%i item(s) are defined", true { defined($_) } @list;
 
 =head3 false BLOCK LIST
 
 Counts the number of elements in LIST for which the criterion in BLOCK is false.
 Sets C<$_> for each item in LIST in turn:
 
   printf "%i item(s) are not defined", false { defined($_) } @list;
 
 =head3 minmax LIST
 
 Calculates the minimum and maximum of LIST and returns a two element list with
 the first element being the minimum and the second the maximum. Returns the
 empty list if LIST was empty.
 
 The C<minmax> algorithm differs from a naive iteration over the list where each
 element is compared to two values being the so far calculated min and max value
 in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient
 possible algorithm.
 
 However, the Perl implementation of it has some overhead simply due to the fact
 that there are more lines of Perl code involved. Therefore, LIST needs to be
 fairly big in order for C<minmax> to win over a naive implementation. This
 limitation does not apply to the XS version.
 
 =head1 ENVIRONMENT
 
 When C<LIST_MOREUTILS_PP> is set, the module will always use the pure-Perl
 implementation and not the XS one. This environment variable is really just
 there for the test-suite to force testing the Perl implementation, and possibly
 for reporting of bugs. I don't see any reason to use it in a production
 environment.
 
 =head1 MAINTENANCE
 
 The maintenance goal is to preserve the documented semantics of the API;
 bug fixes that bring actual behavior in line with semantics are allowed.
 New API functions may be added over time.  If a backwards incompatible
 change is unavoidable, we will attempt to provide support for the legacy
 API using the same export tag mechanism currently in place.
 
 This module attempts to use few non-core dependencies. Non-core
 configuration and testing modules will be bundled when reasonable;
 run-time dependencies will be added only if they deliver substantial
 benefit.
 
 =head1 CONTRIBUTING
 
 While contributions are appreciated, a contribution should not cause more
 effort for the maintainer than the contribution itself saves (see
 L<Open Source Contribution Etiquette|http://tirania.org/blog/archive/2010/Dec-31.html>).
 
 To get more familiar where help could be needed - see L<List::MoreUtils::Contributing>.
 
 =head1 BUGS
 
 There is a problem with a bug in 5.6.x perls. It is a syntax error to write
 things like:
 
     my @x = apply { s/foo/bar/ } qw{ foo bar baz };
 
 It has to be written as either
 
     my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz';
 
 or
 
     my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/;
 
 Perl 5.5.x and Perl 5.8.x don't suffer from this limitation.
 
 If you have a functionality that you could imagine being in this module, please
 drop me a line. This module's policy will be less strict than L<List::Util>'s
 when it comes to additions as it isn't a core module.
 
 When you report bugs, it would be nice if you could additionally give me the
 output of your program with the environment variable C<LIST_MOREUTILS_PP> set
 to a true value. That way I know where to look for the problem (in XS,
 pure-Perl or possibly both).
 
 =head1 SUPPORT
 
 Bugs should always be submitted via the CPAN bug tracker.
 
 You can find documentation for this module with the perldoc command.
 
     perldoc List::MoreUtils
 
 You can also look for information at:
 
 =over 4
 
 =item * RT: CPAN's request tracker
 
 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=List-MoreUtils>
 
 =item * AnnoCPAN: Annotated CPAN documentation
 
 L<http://annocpan.org/dist/List-MoreUtils>
 
 =item * CPAN Ratings
 
 L<http://cpanratings.perl.org/l/List-MoreUtils>
 
 =item * CPAN Search
 
 L<http://search.cpan.org/dist/List-MoreUtils/>
 
 =item * Git Repository
 
 L<https://github.com/perl5-utils/List-MoreUtils>
 
 =back
 
 =head2 Where can I go for help?
 
 If you have a bug report, a patch or a suggestion, please open a new
 report ticket at CPAN (but please check previous reports first in case
 your issue has already been addressed) or open an issue on GitHub.
 
 Report tickets should contain a detailed description of the bug or
 enhancement request and at least an easily verifiable way of
 reproducing the issue or fix. Patches are always welcome, too - and
 it's cheap to send pull-requests on GitHub. Please keep in mind that
 code changes are more likely accepted when they're bundled with an
 approving test.
 
 If you think you've found a bug then please read
 "How to Report Bugs Effectively" by Simon Tatham:
 L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
 
 =head2 Where can I go for help with a concrete version?
 
 Bugs and feature requests are accepted against the latest version
 only. To get patches for earlier versions, you need to get an
 agreement with a developer of your choice - who may or not report the
 issue and a suggested fix upstream (depends on the license you have
 chosen).
 
 =head2 Business support and maintenance
 
 Generally, in volunteered projects, there is no right for support.
 While every maintainer is happy to improve the provided software,
 spare time is limited.
 
 For those who have a use case which requires guaranteed support, one of
 the maintainers should be hired or contracted.  For business support you
 can contact Jens via his CPAN email address rehsackATcpan.org. Please
 keep in mind that business support is neither available for free nor
 are you eligible to receive any support based on the license distributed
 with this package.
 
 =head1 THANKS
 
 =head2 Tassilo von Parseval
 
 Credits go to a number of people: Steve Purkis for giving me namespace advice
 and James Keenan and Terrence Branno for their effort of keeping the CPAN
 tidier by making L<List::Utils> obsolete.
 
 Brian McCauley suggested the inclusion of apply() and provided the pure-Perl
 implementation for it.
 
 Eric J. Roode asked me to add all functions from his module C<List::MoreUtil>
 into this one. With minor modifications, the pure-Perl implementations of those
 are by him.
 
 The bunch of people who almost immediately pointed out the many problems with
 the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers).
 
 A particularly nasty memory leak was spotted by Thomas A. Lowery.
 
 Lars Thegler made me aware of problems with older Perl versions.
 
 Anno Siegel de-orphaned each_arrayref().
 
 David Filmer made me aware of a problem in each_arrayref that could ultimately
 lead to a segfault.
 
 Ricardo Signes suggested the inclusion of part() and provided the
 Perl-implementation.
 
 Robin Huston kindly fixed a bug in perl's MULTICALL API to make the
 XS-implementation of part() work.
 
 =head2 Jens Rehsack
 
 Credits goes to all people contributing feedback during the v0.400
 development releases.
 
 Special thanks goes to David Golden who spent a lot of effort to develop
 a design to support current state of CPAN as well as ancient software
 somewhere in the dark. He also contributed a lot of patches to refactor
 the API frontend to welcome any user of List::MoreUtils - from ancient
 past to recently last used.
 
 Toby Inkster provided a lot of useful feedback for sane importer code
 and was a nice sounding board for API discussions.
 
 Peter Rabbitson provided a sane git repository setup containing entire
 package history.
 
 =head1 TODO
 
 A pile of requests from other people is still pending further processing in
 my mailbox. This includes:
 
 =over 4
 
 =item * List::Util export pass-through
 
 Allow B<List::MoreUtils> to pass-through the regular L<List::Util>
 functions to end users only need to C<use> the one module.
 
 =item * uniq_by(&@)
 
 Use code-reference to extract a key based on which the uniqueness is
 determined. Suggested by Aaron Crane.
 
 =item * delete_index
 
 =item * random_item
 
 =item * random_item_delete_index
 
 =item * list_diff_hash
 
 =item * list_diff_inboth
 
 =item * list_diff_infirst
 
 =item * list_diff_insecond
 
 These were all suggested by Dan Muey.
 
 =item * listify
 
 Always return a flat list when either a simple scalar value was passed or an
 array-reference. Suggested by Mark Summersault.
 
 =back
 
 =head1 SEE ALSO
 
 L<List::Util>, L<List::AllUtils>, L<List::UtilsBy>
 
 =head1 AUTHOR
 
 Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
 
 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 
 Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
 Some parts copyright 2011 Aaron Crane.
 
 Copyright 2004 - 2010 by Tassilo von Parseval
 
 Copyright 2013 - 2015 by Jens Rehsack
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself, either Perl version 5.8.4 or,
 at your option, any later version of Perl 5 you may have available.
 
 =cut
 
 1;
### List/MoreUtils/PP.pm ###
 package List::MoreUtils::PP;
 
 use 5.006;
 use strict;
 use warnings;
 
 our $VERSION = '0.412';
 
 =pod
 
 =head1 NAME
 
 List::MoreUtils::PP - Provide List::MoreUtils pure Perl implementation
 
 =head1 SYNOPSIS
 
   BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; }
   use List::MoreUtils qw(:all);
 
 =cut
 
 sub any (&@)
 {
     my $f = shift;
     foreach (@_)
     {
         return 1 if $f->();
     }
     return 0;
 }
 
 sub all (&@)
 {
     my $f = shift;
     foreach (@_)
     {
         return 0 unless $f->();
     }
     return 1;
 }
 
 sub none (&@)
 {
     my $f = shift;
     foreach (@_)
     {
         return 0 if $f->();
     }
     return 1;
 }
 
 sub notall (&@)
 {
     my $f = shift;
     foreach (@_)
     {
         return 1 unless $f->();
     }
     return 0;
 }
 
 sub one (&@)
 {
     my $f     = shift;
     my $found = 0;
     foreach (@_)
     {
         $f->() and $found++ and return 0;
     }
     $found;
 }
 
 sub any_u (&@)
 {
     my $f = shift;
     return if !@_;
     $f->() and return 1 foreach (@_);
     return 0;
 }
 
 sub all_u (&@)
 {
     my $f = shift;
     return if !@_;
     $f->() or return 0 foreach (@_);
     return 1;
 }
 
 sub none_u (&@)
 {
     my $f = shift;
     return if !@_;
     $f->() and return 0 foreach (@_);
     return 1;
 }
 
 sub notall_u (&@)
 {
     my $f = shift;
     return if !@_;
     $f->() or return 1 foreach (@_);
     return 0;
 }
 
 sub one_u (&@)
 {
     my $f = shift;
     return if !@_;
     my $found = 0;
     foreach (@_)
     {
         $f->() and $found++ and return 0;
     }
     $found;
 }
 
 sub true (&@)
 {
     my $f     = shift;
     my $count = 0;
     $f->() and ++$count foreach (@_);
     return $count;
 }
 
 sub false (&@)
 {
     my $f     = shift;
     my $count = 0;
     $f->() or ++$count foreach (@_);
     return $count;
 }
 
 sub firstidx (&@)
 {
     my $f = shift;
     foreach my $i ( 0 .. $#_ )
     {
         local *_ = \$_[$i];
         return $i if $f->();
     }
     return -1;
 }
 
 sub firstval (&@)
 {
     my $test = shift;
     foreach (@_)
     {
         return $_ if $test->();
     }
     return undef;
 }
 
 sub firstres (&@)
 {
     my $test = shift;
     foreach (@_)
     {
         my $testval = $test->();
         $testval and return $testval;
     }
     return undef;
 }
 
 sub onlyidx (&@)
 {
     my $f = shift;
     my $found;
     foreach my $i ( 0 .. $#_ )
     {
         local *_ = \$_[$i];
         $f->() or next;
         defined $found and return -1;
         $found = $i;
     }
     return defined $found ? $found : -1;
 }
 
 sub onlyval (&@)
 {
     my $test   = shift;
     my $result = undef;
     my $found  = 0;
     foreach (@_)
     {
         $test->() or next;
         $result = $_;
         $found++ and return undef;
     }
     return $result;
 }
 
 sub onlyres (&@)
 {
     my $test   = shift;
     my $result = undef;
     my $found  = 0;
     foreach (@_)
     {
         my $rv = $test->() or next;
         $result = $rv;
         $found++ and return undef;
     }
     return $found ? $result : undef;
 }
 
 sub lastidx (&@)
 {
     my $f = shift;
     foreach my $i ( reverse 0 .. $#_ )
     {
         local *_ = \$_[$i];
         return $i if $f->();
     }
     return -1;
 }
 
 sub lastval (&@)
 {
     my $test = shift;
     my $ix;
     for ( $ix = $#_; $ix >= 0; $ix-- )
     {
         local *_ = \$_[$ix];
         my $testval = $test->();
 
         # Simulate $_ as alias
         $_[$ix] = $_;
         return $_ if $testval;
     }
     return undef;
 }
 
 sub lastres (&@)
 {
     my $test = shift;
     my $ix;
     for ( $ix = $#_; $ix >= 0; $ix-- )
     {
         local *_ = \$_[$ix];
         my $testval = $test->();
 
         # Simulate $_ as alias
         $_[$ix] = $_;
         return $testval if $testval;
     }
     return undef;
 }
 
 sub insert_after (&$\@)
 {
     my ( $f, $val, $list ) = @_;
     my $c = &firstidx( $f, @$list );
     @$list = ( @{$list}[ 0 .. $c ], $val, @{$list}[ $c + 1 .. $#$list ], ) and return 1 if $c != -1;
     return 0;
 }
 
 sub insert_after_string ($$\@)
 {
     my ( $string, $val, $list ) = @_;
     my $c = firstidx { defined $_ and $string eq $_ } @$list;
     @$list = ( @{$list}[ 0 .. $c ], $val, @{$list}[ $c + 1 .. $#$list ], ) and return 1 if $c != -1;
     return 0;
 }
 
 sub apply (&@)
 {
     my $action = shift;
     &$action foreach my @values = @_;
     wantarray ? @values : $values[-1];
 }
 
 sub after (&@)
 {
     my $test = shift;
     my $started;
     my $lag;
     grep $started ||= do
     {
         my $x = $lag;
         $lag = $test->();
         $x;
     }, @_;
 }
 
 sub after_incl (&@)
 {
     my $test = shift;
     my $started;
     grep $started ||= $test->(), @_;
 }
 
 sub before (&@)
 {
     my $test = shift;
     my $more = 1;
     grep $more &&= !$test->(), @_;
 }
 
 sub before_incl (&@)
 {
     my $test = shift;
     my $more = 1;
     my $lag  = 1;
     grep $more &&= do
     {
         my $x = $lag;
         $lag = !$test->();
         $x;
     }, @_;
 }
 
 sub indexes (&@)
 {
     my $test = shift;
     grep {
         local *_ = \$_[$_];
         $test->()
     } 0 .. $#_;
 }
 
 sub pairwise (&\@\@)
 {
     my $op = shift;
 
     # Symbols for caller's input arrays
     use vars qw{ @A @B };
     local ( *A, *B ) = @_;
 
     # Localise $a, $b
     my ( $caller_a, $caller_b ) = do
     {
         my $pkg = caller();
         no strict 'refs';
         \*{ $pkg . '::a' }, \*{ $pkg . '::b' };
     };
 
     # Loop iteration limit
     my $limit = $#A > $#B ? $#A : $#B;
 
     # This map expression is also the return value
     local ( *$caller_a, *$caller_b );
     map {
         # Assign to $a, $b as refs to caller's array elements
         ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] );
 
         # Perform the transformation
         $op->();
     } 0 .. $limit;
 }
 
 sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
 {
     return each_arrayref(@_);
 }
 
 sub each_arrayref
 {
     my @list  = @_;    # The list of references to the arrays
     my $index = 0;     # Which one the caller will get next
     my $max   = 0;     # Number of elements in longest array
 
     # Get the length of the longest input array
     foreach (@list)
     {
         unless ( ref $_ eq 'ARRAY' )
         {
             require Carp;
             Carp::croak("each_arrayref: argument is not an array reference\n");
         }
         $max = @$_ if @$_ > $max;
     }
 
     # Return the iterator as a closure wrt the above variables.
     return sub {
         if (@_)
         {
             my $method = shift;
             unless ( $method eq 'index' )
             {
                 require Carp;
                 Carp::croak("each_array: unknown argument '$method' passed to iterator.");
             }
 
             # Return current (last fetched) index
             return undef if $index == 0 || $index > $max;
             return $index - 1;
         }
 
         # No more elements to return
         return if $index >= $max;
         my $i = $index++;
 
         # Return ith elements
         return map $_->[$i], @list;
       }
 }
 
 sub natatime ($@)
 {
     my $n    = shift;
     my @list = @_;
     return sub {
         return splice @list, 0, $n;
       }
 }
 
 sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
 {
     my $max = -1;
     $max < $#$_ && ( $max = $#$_ ) foreach @_;
     map {
         my $ix = $_;
         map $_->[$ix], @_;
     } 0 .. $max;
 }
 
 sub uniq (@)
 {
     my %seen = ();
     my $k;
     my $seen_undef;
     grep { defined $_ ? not $seen{ $k = $_ }++ : not $seen_undef++ } @_;
 }
 
 sub singleton (@)
 {
     my %seen = ();
     my $k;
     my $seen_undef;
     grep { 1 == ( defined $_ ? $seen{ $k = $_ } : $seen_undef ) }
       grep { defined $_ ? not $seen{ $k = $_ }++ : not $seen_undef++ } @_;
 }
 
 sub minmax (@)
 {
     return unless @_;
     my $min = my $max = $_[0];
 
     for ( my $i = 1; $i < @_; $i += 2 )
     {
         if ( $_[ $i - 1 ] <= $_[$i] )
         {
             $min = $_[ $i - 1 ] if $min > $_[ $i - 1 ];
             $max = $_[$i]       if $max < $_[$i];
         }
         else
         {
             $min = $_[$i]       if $min > $_[$i];
             $max = $_[ $i - 1 ] if $max < $_[ $i - 1 ];
         }
     }
 
     if ( @_ & 1 )
     {
         my $i = $#_;
         if ( $_[ $i - 1 ] <= $_[$i] )
         {
             $min = $_[ $i - 1 ] if $min > $_[ $i - 1 ];
             $max = $_[$i]       if $max < $_[$i];
         }
         else
         {
             $min = $_[$i]       if $min > $_[$i];
             $max = $_[ $i - 1 ] if $max < $_[ $i - 1 ];
         }
     }
 
     return ( $min, $max );
 }
 
 sub part (&@)
 {
     my ( $code, @list ) = @_;
     my @parts;
     push @{ $parts[ $code->($_) ] }, $_ foreach @list;
     return @parts;
 }
 
 sub bsearch(&@)
 {
     my $code = shift;
 
     my $rc;
     my $i = 0;
     my $j = @_;
     do
     {
         my $k = int( ( $i + $j ) / 2 );
 
         $k >= @_ and return;
 
         local *_ = \$_[$k];
         $rc = $code->();
 
         $rc == 0
           and return wantarray ? $_ : 1;
 
         if ( $rc < 0 )
         {
             $i = $k + 1;
         }
         else
         {
             $j = $k - 1;
         }
     } until $i > $j;
 
     return;
 }
 
 sub bsearchidx(&@)
 {
     my $code = shift;
 
     my $rc;
     my $i = 0;
     my $j = @_;
     do
     {
         my $k = int( ( $i + $j ) / 2 );
 
         $k >= @_ and return -1;
 
         local *_ = \$_[$k];
         $rc = $code->();
 
         $rc == 0 and return $k;
 
         if ( $rc < 0 )
         {
             $i = $k + 1;
         }
         else
         {
             $j = $k - 1;
         }
     } until $i > $j;
 
     return -1;
 }
 
 sub sort_by(&@)
 {
     my ( $code, @list ) = @_;
     return map { $_->[0] }
       sort     { $a->[1] cmp $b->[1] }
       map { [ $_, scalar( $code->() ) ] } @list;
 }
 
 sub nsort_by(&@)
 {
     my ( $code, @list ) = @_;
     return map { $_->[0] }
       sort     { $a->[1] <=> $b->[1] }
       map { [ $_, scalar( $code->() ) ] } @list;
 }
 
 sub _XScompiled { 0 }
 
 =head1 SEE ALSO
 
 L<List::Util>
 
 =head1 AUTHOR
 
 Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
 
 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 
 Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
 Some parts copyright 2011 Aaron Crane.
 
 Copyright 2004 - 2010 by Tassilo von Parseval
 
 Copyright 2013 - 2015 by Jens Rehsack
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself, either Perl version 5.8.4 or,
 at your option, any later version of Perl 5 you may have available.
 
 =cut
 
 1;
### List/MoreUtils/XS.pm ###
 package List::MoreUtils::XS;
 
 use 5.006;
 use strict;
 use warnings;
 
 use vars qw{$VERSION @ISA};
 
 BEGIN
 {
     $VERSION = '0.412';
 
     # Load the XS at compile-time so that redefinition warnings will be
     # thrown correctly if the XS versions of part or indexes loaded
     my $ldr = <<EOLDR;
 	package List::MoreUtils;
 
 	# PERL_DL_NONLAZY must be false, or any errors in loading will just
 	# cause the perl code to be tested
 	local \$ENV{PERL_DL_NONLAZY} = 0 if \$ENV{PERL_DL_NONLAZY};
 
 	use XSLoader ();
 	XSLoader::load("List::MoreUtils", "$VERSION");
 
 	1;
 EOLDR
 
     eval $ldr unless $ENV{LIST_MOREUTILS_PP};
 
     # ensure to catch even PP only subs
     my @pp_imp = map { "List::MoreUtils->can(\"$_\") or *$_ = \\&List::MoreUtils::PP::$_;" }
       qw(any all none notall one any_u all_u none_u notall_u one_u true false
       firstidx firstval firstres lastidx lastval lastres onlyidx onlyval onlyres
       insert_after insert_after_string
       apply after after_incl before before_incl
       each_array each_arrayref pairwise
       natatime mesh uniq singleton minmax part indexes bsearch bsearchidx
       sort_by nsort_by _XScompiled);
     my $pp_stuff = join( "\n", "use List::MoreUtils::PP;", "package List::MoreUtils;", @pp_imp );
     eval $pp_stuff;
     die $@ if $@;
 }
 
 =pod
 
 =head1 NAME
 
 List::MoreUtils::XS - Provide compiled List::MoreUtils functions
 
 =head1 SYNOPSIS
 
   BEGIN { delete $ENV{LIST_MOREUTILS_PP}; }
   use List::MoreUtils ...;
 
 =head1 SEE ALSO
 
 L<List::Util>, L<List::AllUtils>
 
 =head1 AUTHOR
 
 Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
 
 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 
 Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
 Some parts copyright 2011 Aaron Crane.
 
 Copyright 2004 - 2010 by Tassilo von Parseval
 
 Copyright 2013 - 2015 by Jens Rehsack
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself, either Perl version 5.8.4 or,
 at your option, any later version of Perl 5 you may have available.
 
 =cut
 
 1;
### Log/Any.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any;
 
 # ABSTRACT: Bringing loggers and listeners together
 our $VERSION = '1.032';
 
 use Log::Any::Manager;
 use Log::Any::Adapter::Util qw(
   require_dynamic
   detection_aliases
   detection_methods
   log_level_aliases
   logging_aliases
   logging_and_detection_methods
   logging_methods
 );
 
 # This is overridden in Log::Any::Test
 our $OverrideDefaultAdapterClass;
 our $OverrideDefaultProxyClass;
 
 # singleton and accessor
 {
     my $manager = Log::Any::Manager->new();
     sub _manager { return $manager }
 }
 
 sub import {
     my $class  = shift;
     my $caller = caller();
 
     my @export_params = ( $caller, @_ );
     $class->_export_to_caller(@export_params);
 }
 
 sub _export_to_caller {
     my $class  = shift;
     my $caller = shift;
 
     # Parse parameters passed to 'use Log::Any'
     my $saw_log_param;
     my @params;
     while ( my $param = shift @_ ) {
         if ( $param eq '$log' ) {
             $saw_log_param = 1;    # defer until later
             next;                  # singular
         }
         else {
             push @params, $param, shift @_;    # pairwise
         }
     }
 
     unless ( @params % 2 == 0 ) {
         require Carp;
         Carp::croak("Argument list not balanced: @params");
     }
 
     # get logger if one was requested
     if ($saw_log_param) {
         no strict 'refs';
         my $proxy = $class->get_logger( category => $caller, @params );
         my $varname = "$caller\::log";
         *$varname = \$proxy;
     }
 }
 
 sub get_logger {
     my ( $class, %params ) = @_;
     no warnings 'once';
 
     my $proxy_class = $class->_get_proxy_class( delete $params{proxy_class} );
     my $category =
       defined $params{category} ? delete $params{'category'} : caller;
 
     if ( my $default = delete $params{'default_adapter'} ) {
         $class->_manager->set_default( $category, $default );
     }
 
     my $adapter = $class->_manager->get_adapter( $category );
 
     require_dynamic($proxy_class);
     return $proxy_class->new(
         %params, adapter => $adapter, category => $category,
     );
 }
 
 sub _get_proxy_class {
     my ( $self, $proxy_name ) = @_;
     return $Log::Any::OverrideDefaultProxyClass
       if $Log::Any::OverrideDefaultProxyClass;
     return "Log::Any::Proxy" unless $proxy_name;
     my $proxy_class = (
           substr( $proxy_name, 0, 1 ) eq '+'
         ? substr( $proxy_name, 1 )
         : "Log::Any::Proxy::$proxy_name"
     );
     return $proxy_class;
 }
 
 # For backward compatibility
 sub set_adapter {
     my $class = shift;
     Log::Any->_manager->set(@_);
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any - Bringing loggers and listeners together
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
 In a CPAN or other module:
 
     package Foo;
     use Log::Any qw($log);
 
     # log a string
     $log->error("an error occurred");
 
     # log a string and data using a formatting filter
     $log->debugf("arguments are: %s", \@_);
 
 In a Moo/Moose-based module:
 
     package Foo;
     use Moo;
 
     has log => (
         is => 'ro',
         isa => 'Log::Any::Proxy',
         default => sub { Log::Any->get_logger },
     );
 
 In your application:
 
     use Foo;
     use Log::Any::Adapter;
 
     # Send all logs to Log::Log4perl
     Log::Any::Adapter->set('Log4perl');
 
     # Send all logs to Log::Dispatch
     my $log = Log::Dispatch->new(outputs => [[ ... ]]);
     Log::Any::Adapter->set( 'Dispatch', dispatcher => $log );
 
     # See Log::Any::Adapter documentation for more options
 
 =head1 DESCRIPTION
 
 C<Log::Any> provides a standard log production API for modules.
 L<Log::Any::Adapter> allows applications to choose the mechanism for log
 consumption, whether screen, file or another logging mechanism like
 L<Log::Dispatch> or L<Log::Log4perl>.
 
 Many modules have something interesting to say. Unfortunately there is no
 standard way for them to say it - some output to STDERR, others to C<warn>,
 others to custom file logs. And there is no standard way to get a module to
 start talking - sometimes you must call a uniquely named method, other times
 set a package variable.
 
 This being Perl, there are many logging mechanisms available on CPAN.  Each has
 their pros and cons. Unfortunately, the existence of so many mechanisms makes
 it difficult for a CPAN author to commit his/her users to one of them. This may
 be why many CPAN modules invent their own logging or choose not to log at all.
 
 To untangle this situation, we must separate the two parts of a logging API.
 The first, I<log production>, includes methods to output logs (like
 C<$log-E<gt>debug>) and methods to inspect whether a log level is activated
 (like C<$log-E<gt>is_debug>). This is generally all that CPAN modules care
 about. The second, I<log consumption>, includes a way to configure where
 logging goes (a file, the screen, etc.) and the code to send it there. This
 choice generally belongs to the application.
 
 A CPAN module uses C<Log::Any> to get a log producer object.  An application,
 in turn, may choose one or more logging mechanisms via L<Log::Any::Adapter>, or
 none at all.
 
 C<Log::Any> has a very tiny footprint and no dependencies beyond Perl 5.8.1,
 which makes it appropriate for even small CPAN modules to use. It defaults to
 'null' logging activity, so a module can safely log without worrying about
 whether the application has chosen (or will ever choose) a logging mechanism.
 
 See L<http://www.openswartz.com/2007/09/06/standard-logging-api/> for the
 original post proposing this module.
 
 =head1 LOG LEVELS
 
 C<Log::Any> supports the following log levels and aliases, which is meant to be
 inclusive of the major logging packages:
 
      trace
      debug
      info (inform)
      notice
      warning (warn)
      error (err)
      critical (crit, fatal)
      alert
      emergency
 
 Levels are translated as appropriate to the underlying logging mechanism. For
 example, log4perl only has six levels, so we translate 'notice' to 'info' and
 the top three levels to 'fatal'.  See the documentation of an adapter class
 for specifics.
 
 =head1 CATEGORIES
 
 Every logger has a category, generally the name of the class that asked for the
 logger. Some logging mechanisms, like log4perl, can direct logs to different
 places depending on category.
 
 =head1 PRODUCING LOGS (FOR MODULES)
 
 =head2 Getting a logger
 
 The most convenient way to get a logger in your module is:
 
     use Log::Any qw($log);
 
 This creates a package variable I<$log> and assigns it to the logger for the
 current package. It is equivalent to
 
     our $log = Log::Any->get_logger;
 
 In general, to get a logger for a specified category:
 
     my $log = Log::Any->get_logger(category => $category)
 
 If no category is specified, the calling package is used.
 
 A logger object is an instance of L<Log::Any::Proxy>, which passes
 on messages to the L<Log::Any::Adapter> handling its category.
 
 =head2 Logging
 
 To log a message, pass a single string to any of the log levels or aliases. e.g.
 
     $log->error("this is an error");
     $log->warn("this is a warning");
     $log->warning("this is also a warning");
 
 You should B<not> include a newline in your message; that is the responsibility
 of the logging mechanism, which may or may not want the newline.
 
 There are also versions of each of these methods with an additional "f" suffix
 (C<infof>, C<errorf>, C<debugf>, etc.) that format a list of arguments.  The
 specific formatting mechanism and meaning of the arguments is controlled by the
 L<Log::Any::Proxy> object.
 
     $log->errorf("an error occurred: %s", $@);
     $log->debugf("called with %d params: %s", $param_count, \@params);
 
 By default it renders like C<sprintf>, with the following additional features:
 
 =over
 
 =item *
 
 Any complex references (like C<\@params> above) are automatically converted to
 single-line strings with C<Data::Dumper>.
 
 =item *
 
 Any undefined values are automatically converted to the string "<undef>".
 
 =back
 
 =head2 Log level detection
 
 To detect whether a log level is on, use "is_" followed by any of the log
 levels or aliases. e.g.
 
     if ($log->is_info()) { ... }
     $log->debug("arguments are: " . Dumper(\@_))
         if $log->is_debug();
 
 This is important for efficiency, as you can avoid the work of putting together
 the logging message (in the above case, stringifying C<@_>) if the log level is
 not active.
 
 The formatting methods (C<infof>, C<errorf>, etc.) check the log level for you.
 
 Some logging mechanisms don't support detection of log levels. In these cases
 the detection methods will always return 1.
 
 In contrast, the default logging mechanism - Null - will return 0 for all
 detection methods.
 
 =head2 Setting an alternate default logger
 
 To choose something other than Null as the default, pass it as a parameter when
 loading C<Log::Any>
 
     use Log::Any '$log', default_adapter => 'Stderr';
 
 The name of the default class follows the same rules as used by L<Log::Any::Adapter>.
 
 =head2 Configuring the proxy
 
 Any parameter passed on the import line or via the C<get_logger> method
 are passed on the the L<Log::Any::Proxy> constructor.
 
     use Log::Any '$log', filter => \&myfilter;
 
 =head2 Testing
 
 L<Log::Any::Test> provides a mechanism to test code that uses C<Log::Any>.
 
 =head1 CONSUMING LOGS (FOR APPLICATIONS)
 
 Log::Any provides modules with a L<Log::Any::Proxy> object, which is the log
 producer.  To consume its output and direct it where you want (a file, the
 screen, syslog, etc.), you use L<Log::Any::Adapter> along with a
 destination-specific subclass.
 
 For example, to send output to a file via L<Log::Any::Adapter::File>, your
 application could do this:
 
     use Log::Any::Adapter ('File', '/path/to/file.log');
 
 See the L<Log::Any::Adapter> documentation for more details.
 
 =head1 Q & A
 
 =over
 
 =item Isn't Log::Any just yet another logging mechanism?
 
 No. C<Log::Any> does not include code that knows how to log to a particular
 place (file, screen, etc.) It can only forward logging requests to another
 logging mechanism.
 
 =item Why don't you just pick the best logging mechanism, and use and promote it?
 
 Each of the logging mechanisms have their pros and cons, particularly in terms
 of how they are configured. For example, log4perl offers a great deal of power
 and flexibility but uses a global and potentially heavy configuration, whereas
 C<Log::Dispatch> is extremely configuration-light but doesn't handle
 categories. There is also the unnamed future logger that may have advantages
 over either of these two, and all the custom in-house loggers people have
 created and cannot (for whatever reason) stop using.
 
 =item Is it safe for my critical module to depend on Log::Any?
 
 Our intent is to keep C<Log::Any> minimal, and change it only when absolutely
 necessary. Most of the "innovation", if any, is expected to occur in
 C<Log::Any::Adapter>, which your module should not have to depend on (unless it
 wants to direct logs somewhere specific). C<Log::Any> has no non-core dependencies.
 
 =item Why doesn't Log::Any use I<insert modern Perl technique>?
 
 To encourage CPAN module authors to adopt and use C<Log::Any>, we aim to have
 as few dependencies and chances of breakage as possible. Thus, no C<Moose> or
 other niceties.
 
 =back
 
 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
 
 =head1 SUPPORT
 
 =head2 Bugs / Feature Requests
 
 Please report any bugs or feature requests through the issue tracker
 at L<https://github.com/dagolden/Log-Any/issues>.
 You will be notified automatically of any progress on your issue.
 
 =head2 Source Code
 
 This is open source software.  The code repository is available for
 public review and contribution under the terms of the license.
 
 L<https://github.com/dagolden/Log-Any>
 
   git clone https://github.com/dagolden/Log-Any.git
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 CONTRIBUTORS
 
 =for stopwords Maxim Vuets Stephen Thirlwall
 
 =over 4
 
 =item *
 
 Maxim Vuets <maxim.vuets@booking.com>
 
 =item *
 
 Stephen Thirlwall <sdt@dr.com>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter;
 
 # ABSTRACT: Tell Log::Any where to send its logs
 our $VERSION = '1.032';
 
 use Log::Any;
 
 sub import {
     my $pkg = shift;
     Log::Any->_manager->set(@_) if (@_);
 }
 
 sub set {
     my $pkg = shift;
     Log::Any->_manager->set(@_)
 }
 
 sub remove {
     my $pkg = shift;
     Log::Any->_manager->remove(@_)
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter - Tell Log::Any where to send its logs
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     # Log to a file, or stdout, or stderr for all categories
     #
     use Log::Any::Adapter ('File', '/path/to/file.log');
     use Log::Any::Adapter ('Stdout');
     use Log::Any::Adapter ('Stderr');
 
     # Use Log::Log4perl for all categories
     #
     Log::Log4perl::init('/etc/log4perl.conf');
     Log::Any::Adapter->set('Log4perl');
 
     # Use Log::Dispatch for Foo::Baz
     #
     use Log::Dispatch;
     my $log = Log::Dispatch->new(outputs => [[ ... ]]);
     Log::Any::Adapter->set( { category => 'Foo::Baz' },
         'Dispatch', dispatcher => $log );
 
     # Use Log::Dispatch::Config for Foo::Baz and its subcategories
     #
     use Log::Dispatch::Config;
     Log::Dispatch::Config->configure('/path/to/log.conf');
     Log::Any::Adapter->set(
         { category => qr/^Foo::Baz/ },
         'Dispatch', dispatcher => Log::Dispatch::Config->instance() );
 
     # Use your own adapter for all categories
     #
     Log::Any::Adapter->set('+My::Log::Any::Adapter', ...);
 
 =head1 DESCRIPTION
 
 Log::Any::Adapter connects log producers and log consumers.  Its methods
 instantiate a logging adapter (a subclass of L<Log::Any::Adapter::Base>)
 and route log messages from one or more categories to it.
 
 =head1 ADAPTERS
 
 In order to use a logging mechanism with C<Log::Any>, there needs to be an
 adapter class for it. Typically this is named Log::Any::Adapter::I<something>.
 
 =head2 Adapters in this distribution
 
 Three basic adapters come with this distribution -- L<Log::Any::Adapter::File>,
 L<Log::Any::Adapter::Stdout> and L<Log::Any::Adapter::Stderr>:
 
     use Log::Any::Adapter ('File', '/path/to/file.log');
     use Log::Any::Adapter ('Stdout');
     use Log::Any::Adapter ('Stderr');
 
     # or
 
     use Log::Any::Adapter;
     Log::Any::Adapter->set('File', '/path/to/file.log');
     Log::Any::Adapter->set('Stdout');
     Log::Any::Adapter->set('Stderr');
 
 All of them simply output the message and newline to the specified destination;
 a datestamp prefix is added in the C<File> case. For anything more complex
 you'll want to use a more robust adapter from CPAN.
 
 =head2 Adapters on CPAN
 
 A sampling of adapters available on CPAN as of this writing:
 
 =over
 
 =item *
 
 L<Log::Any::Adapter::Log4perl|Log::Any::Adapter::Log4perl>
 
 =item *
 
 L<Log::Any::Adapter::Dispatch|Log::Any::Adapter::Dispatch>
 
 =item *
 
 L<Log::Any::Adapter::FileHandle|Log::Any::Adapter::FileHandle>
 
 =item *
 
 L<Log::Any::Adapter::Syslog|Log::Any::Adapter::Syslog>
 
 =back
 
 You may find other adapters on CPAN by searching for "Log::Any::Adapter", or
 create your own adapter. See
 L<Log::Any::Adapter::Development|Log::Any::Adapter::Development> for more
 information on the latter.
 
 =head1 SETTING AND REMOVING ADAPTERS
 
 =over
 
 =item Log::Any::Adapter->set ([options, ]adapter_name, adapter_params...)
 
 This method sets the adapter to use for all log categories, or for a particular
 set of categories.
 
 I<adapter_name> is the name of an adapter. It is automatically prepended with
 "Log::Any::Adapter::". If instead you want to pass the full name of an adapter,
 prefix it with a "+". e.g.
 
     # Use My::Adapter class
     Log::Any::Adapter->set('+My::Adapter', arg => $value);
 
 I<adapter_params> are passed along to the adapter constructor. See the
 documentation for the individual adapter classes for more information.
 
 An optional hash of I<options> may be passed as the first argument. Options
 are:
 
 =over
 
 =item category
 
 A string containing a category name, or a regex (created with C<qr//>) matching
 multiple categories.  If not specified, all categories will be routed to the
 adapter.
 
 =item lexically
 
 A reference to a lexical variable. When the variable goes out of scope, the
 adapter setting will be removed. e.g.
 
     {
         Log::Any::Adapter->set({lexically => \my $lex}, ...);
 
         # in effect here
         ...
     }
     # no longer in effect here
 
 =back
 
 C<set> returns an entry object, which can be passed to C<remove>.
 
 =item use Log::Any::Adapter (...)
 
 If you pass arguments to C<use Log::Any::Adapter>, it calls C<<
 Log::Any::Adapter->set >> with those arguments.
 
 =item Log::Any::Adapter->remove (entry)
 
 Remove an I<entry> previously returned by C<set>.
 
 =back
 
 =head1 MULTIPLE ADAPTER SETTINGS
 
 C<Log::Any> maintains a stack of entries created via C<set>.
 
 When you get a logger for a particular category, C<Log::Any> will work its way
 down the stack and use the first matching entry.
 
 Whenever the stack changes, any C<Log::Any> loggers that have previously been
 created will automatically adjust to the new stack. For example:
 
     my $log = Log::Any->get_logger();
     $log->error("aiggh!");   # this goes nowhere
     ...
     {
         Log::Any::Adapter->set({ lexically => \my $lex }, 'Log4perl');
         $log->error("aiggh!");   # this goes to log4perl
         ...
     }
     $log->error("aiggh!");   # this goes nowhere again
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter/Base.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Base;
 
 our $VERSION = '1.032';
 
 # we import these in case any legacy adapter uses them as class methods
 use Log::Any::Adapter::Util qw/make_method dump_one_line/;
 
 sub new {
     my $class = shift;
     my $self  = {@_};
     bless $self, $class;
     $self->init(@_);
     return $self;
 }
 
 sub init { }
 
 # Create stub logging methods
 for my $method ( Log::Any::Adapter::Util::logging_and_detection_methods() ) {
     no strict 'refs';
     *$method = sub {
         my $class = ref( $_[0] ) || $_[0];
         die "$class does not implement $method";
     };
 }
 
 # This methods installs a method that delegates to an object attribute
 sub delegate_method_to_slot {
     my ( $class, $slot, $method, $adapter_method ) = @_;
 
     make_method( $method,
         sub { my $self = shift; return $self->{$slot}->$adapter_method(@_) },
         $class );
 }
 
 1;
### Log/Any/Adapter/File.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::File;
 
 # ABSTRACT: Simple adapter for logging to files
 our $VERSION = '1.032';
 
 use Config;
 use Fcntl qw/:flock/;
 use IO::File;
 use Log::Any::Adapter::Util ();
 
 use base qw/Log::Any::Adapter::Base/;
 
 my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
 
 my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
 sub new {
     my ( $class, $file, @args ) = @_;
     return $class->SUPER::new( file => $file, log_level => $trace_level, @args );
 }
 
 sub init {
     my $self = shift;
     if ( exists $self->{log_level} ) {
         $self->{log_level} = Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
             unless $self->{log_level} =~ /^\d+$/;
     }
     else {
         $self->{log_level} = $trace_level;
     }
     my $file = $self->{file};
     open( $self->{fh}, ">>", $file )
       or die "cannot open '$file' for append: $!";
     $self->{fh}->autoflush(1);
 }
 
 foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
     no strict 'refs';
     my $method_level = Log::Any::Adapter::Util::numeric_level( $method );
     *{$method} = sub {
         my ( $self, $text ) = @_;
         return if $method_level > $self->{log_level};
         my $msg = sprintf( "[%s] %s\n", scalar(localtime), $text );
         flock($self->{fh}, LOCK_EX) if $HAS_FLOCK;
         $self->{fh}->print($msg);
         flock($self->{fh}, LOCK_UN) if $HAS_FLOCK;
       }
 }
 
 foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
     no strict 'refs';
     my $base = substr($method,3);
     my $method_level = Log::Any::Adapter::Util::numeric_level( $base );
     *{$method} = sub {
         return !!(  $method_level <= $_[0]->{log_level} );
     };
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter::File - Simple adapter for logging to files
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     use Log::Any::Adapter ('File', '/path/to/file.log');
 
     # or
 
     use Log::Any::Adapter;
     ...
     Log::Any::Adapter->set('File', '/path/to/file.log');
 
     # with minimum level 'warn'
 
     use Log::Any::Adapter (
         'File', '/path/to/file.log', log_level => 'warn',
     );
 
 =head1 DESCRIPTION
 
 This simple built-in L<Log::Any|Log::Any> adapter logs each message to the
 specified file, with a datestamp prefix and newline appended. The file is
 opened for append with autoflush on.  If C<flock> is available, the handle
 will be locked when writing.
 
 The C<log_level> attribute may be set to define a minimum level to log.
 
 Category is ignored.
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter/Null.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Null;
 
 # ABSTRACT: Discards all log messages
 our $VERSION = '1.032';
 
 use base qw/Log::Any::Adapter::Base/;
 
 use Log::Any::Adapter::Util ();
 
 # All methods are no-ops and return false
 
 foreach my $method (Log::Any::Adapter::Util::logging_and_detection_methods()) {
     no strict 'refs';
     *{$method} = sub { return '' }; # false
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter::Null - Discards all log messages
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     Log::Any::Adapter->set('Null');
 
 =head1 DESCRIPTION
 
 This Log::Any adapter discards all log messages and returns false for all
 detection methods (e.g. is_debug). This is the default adapter when Log::Any is
 loaded.
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter/Stderr.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Stderr;
 
 # ABSTRACT: Simple adapter for logging to STDERR
 our $VERSION = '1.032';
 
 use Log::Any::Adapter::Util ();
 
 use base qw/Log::Any::Adapter::Base/;
 
 my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
 
 sub init {
     my ($self) = @_;
     if ( exists $self->{log_level} ) {
         $self->{log_level} =
           Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
           unless $self->{log_level} =~ /^\d+$/;
     }
     else {
         $self->{log_level} = $trace_level;
     }
 }
 
 foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
     no strict 'refs';
     my $method_level = Log::Any::Adapter::Util::numeric_level($method);
     *{$method} = sub {
         my ( $self, $text ) = @_;
         return if $method_level > $self->{log_level};
         print STDERR "$text\n";
     };
 }
 
 foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
     no strict 'refs';
     my $base = substr( $method, 3 );
     my $method_level = Log::Any::Adapter::Util::numeric_level($base);
     *{$method} = sub {
         return !!( $method_level <= $_[0]->{log_level} );
     };
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter::Stderr - Simple adapter for logging to STDERR
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     use Log::Any::Adapter ('Stderr');
 
     # or
 
     use Log::Any::Adapter;
     ...
     Log::Any::Adapter->set('Stderr');
 
     # with minimum level 'warn'
 
     use Log::Any::Adapter ('Stderr', log_level => 'warn' );
 
 =head1 DESCRIPTION
 
 This simple built-in L<Log::Any|Log::Any> adapter logs each message to STDERR
 with a newline appended. Category is ignored.
 
 The C<log_level> attribute may be set to define a minimum level to log.
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter/Stdout.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Stdout;
 
 # ABSTRACT: Simple adapter for logging to STDOUT
 our $VERSION = '1.032';
 
 use Log::Any::Adapter::Util ();
 
 use base qw/Log::Any::Adapter::Base/;
 
 my $trace_level = Log::Any::Adapter::Util::numeric_level('trace');
 
 sub init {
     my ($self) = @_;
     if ( exists $self->{log_level} ) {
         $self->{log_level} =
           Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
           unless $self->{log_level} =~ /^\d+$/;
     }
     else {
         $self->{log_level} = $trace_level;
     }
 }
 
 foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
     no strict 'refs';
     my $method_level = Log::Any::Adapter::Util::numeric_level($method);
     *{$method} = sub {
         my ( $self, $text ) = @_;
         return if $method_level > $self->{log_level};
         print STDOUT "$text\n";
     };
 }
 
 foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
     no strict 'refs';
     my $base = substr( $method, 3 );
     my $method_level = Log::Any::Adapter::Util::numeric_level($base);
     *{$method} = sub {
         return !!( $method_level <= $_[0]->{log_level} );
     };
 }
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter::Stdout - Simple adapter for logging to STDOUT
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     use Log::Any::Adapter ('Stdout');
 
     # or
 
     use Log::Any::Adapter;
     ...
     Log::Any::Adapter->set('Stdout');
 
     # with minimum level 'warn'
 
     use Log::Any::Adapter ('Stdout', log_level => 'warn' );
 
 =head1 DESCRIPTION
 
 This simple built-in L<Log::Any|Log::Any> adapter logs each message to STDOUT
 with a newline appended. Category is ignored.
 
 The C<log_level> attribute may be set to define a minimum level to log.
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>, L<Log::Any::Adapter|Log::Any::Adapter>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Adapter/Test.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Test;
 
 our $VERSION = '1.032';
 
 use Log::Any::Adapter::Util qw/dump_one_line/;
 use Test::Builder;
 
 use base qw/Log::Any::Adapter::Base/;
 
 my $tb = Test::Builder->new();
 my @msgs;
 
 # Ignore arguments for the original adapter if we're overriding, but recover
 # category from argument list; this depends on category => $category being put
 # at the end of the list in Log::Any::Manager. If not overriding, allow
 # arguments as usual.
 
 sub new {
     my $class = shift;
     if ( defined $Log::Any::OverrideDefaultAdapterClass
         && $Log::Any::OverrideDefaultAdapterClass eq __PACKAGE__ )
     {
         my $category = pop @_;
         return $class->SUPER::new( category => $category );
     }
     else {
         return $class->SUPER::new(@_);
     }
 }
 
 # All detection methods return true
 #
 foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
     no strict 'refs';
     *{$method} = sub { 1 };
 }
 
 # All logging methods push onto msgs array
 #
 foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
     no strict 'refs';
     *{$method} = sub {
         my ( $self, $msg ) = @_;
         push(
             @msgs,
             {
                 message  => $msg,
                 level    => $method,
                 category => $self->{category}
             }
         );
     };
 }
 
 # Testing methods below
 #
 
 sub msgs {
     my $self = shift;
 
     return \@msgs;
 }
 
 sub clear {
     my ($self) = @_;
 
     @msgs = ();
 }
 
 sub contains_ok {
     my ( $self, $regex, $test_name ) = @_;
 
     $test_name ||= "log contains '$regex'";
     my $found =
       _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
     if ( $found != -1 ) {
         splice( @{ $self->msgs }, $found, 1 );
         $tb->ok( 1, $test_name );
     }
     else {
         $tb->ok( 0, $test_name );
         $tb->diag( "could not find message matching $regex; log contains: "
               . $self->dump_one_line( $self->msgs ) );
     }
 }
 
 sub category_contains_ok {
     my ( $self, $category, $regex, $test_name ) = @_;
 
     $test_name ||= "log for $category contains '$regex'";
     my $found =
       _first_index(
         sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
         @{ $self->msgs } );
     if ( $found != -1 ) {
         splice( @{ $self->msgs }, $found, 1 );
         $tb->ok( 1, $test_name );
     }
     else {
         $tb->ok( 0, $test_name );
         $tb->diag(
             "could not find $category message matching $regex; log contains: "
               . $self->dump_one_line( $self->msgs ) );
     }
 }
 
 sub does_not_contain_ok {
     my ( $self, $regex, $test_name ) = @_;
 
     $test_name ||= "log does not contain '$regex'";
     my $found =
       _first_index( sub { $_->{message} =~ /$regex/ }, @{ $self->msgs } );
     if ( $found != -1 ) {
         $tb->ok( 0, $test_name );
         $tb->diag( "found message matching $regex: " . $self->msgs->[$found] );
     }
     else {
         $tb->ok( 1, $test_name );
     }
 }
 
 sub category_does_not_contain_ok {
     my ( $self, $category, $regex, $test_name ) = @_;
 
     $test_name ||= "log for $category contains '$regex'";
     my $found =
       _first_index(
         sub { $_->{category} eq $category && $_->{message} =~ /$regex/ },
         @{ $self->msgs } );
     if ( $found != -1 ) {
         $tb->ok( 0, $test_name );
         $tb->diag( "found $category message matching $regex: "
               . $self->msgs->[$found] );
     }
     else {
         $tb->ok( 1, $test_name );
     }
 }
 
 sub empty_ok {
     my ( $self, $test_name ) = @_;
 
     $test_name ||= "log is empty";
     if ( !@{ $self->msgs } ) {
         $tb->ok( 1, $test_name );
     }
     else {
         $tb->ok( 0, $test_name );
         $tb->diag( "log is not empty; contains "
               . $self->dump_one_line( $self->msgs ) );
         $self->clear();
     }
 }
 
 sub contains_only_ok {
     my ( $self, $regex, $test_name ) = @_;
 
     $test_name ||= "log contains only '$regex'";
     my $count = scalar( @{ $self->msgs } );
     if ( $count == 1 ) {
         local $Test::Builder::Level = $Test::Builder::Level + 1;
         $self->contains_ok( $regex, $test_name );
     }
     else {
         $tb->ok( 0, $test_name );
         $tb->diag( "log contains $count messages: "
               . $self->dump_one_line( $self->msgs ) );
     }
 }
 
 sub _first_index {
     my $f = shift;
     for my $i ( 0 .. $#_ ) {
         local *_ = \$_[$i];
         return $i if $f->();
     }
     return -1;
 }
 
 1;
### Log/Any/Adapter/Util.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Adapter::Util;
 
 # ABSTRACT: Common utility functions for Log::Any
 our $VERSION = '1.032';
 
 use Data::Dumper;
 use base qw(Exporter);
 
 my %LOG_LEVELS;
 BEGIN {
     %LOG_LEVELS = (
         EMERGENCY => 0,
         ALERT     => 1,
         CRITICAL  => 2,
         ERROR     => 3,
         WARNING   => 4,
         NOTICE    => 5,
         INFO      => 6,
         DEBUG     => 7,
         TRACE     => 8,
     );
 }
 
 use constant \%LOG_LEVELS;
 
 our @EXPORT_OK = qw(
   cmp_deeply
   detection_aliases
   detection_methods
   dump_one_line
   log_level_aliases
   logging_aliases
   logging_and_detection_methods
   logging_methods
   make_method
   numeric_level
   read_file
   require_dynamic
 );
 
 push @EXPORT_OK, keys %LOG_LEVELS;
 
 our %EXPORT_TAGS = ( 'levels' => [ keys %LOG_LEVELS ] );
 
 my ( %LOG_LEVEL_ALIASES, @logging_methods, @logging_aliases, @detection_methods,
     @detection_aliases, @logging_and_detection_methods );
 
 BEGIN {
     %LOG_LEVEL_ALIASES = (
         inform => 'info',
         warn   => 'warning',
         err    => 'error',
         crit   => 'critical',
         fatal  => 'critical'
     );
     @logging_methods =
       qw(trace debug info notice warning error critical alert emergency);
     @logging_aliases               = keys(%LOG_LEVEL_ALIASES);
     @detection_methods             = map { "is_$_" } @logging_methods;
     @detection_aliases             = map { "is_$_" } @logging_aliases;
     @logging_and_detection_methods = ( @logging_methods, @detection_methods );
 }
 
 #pod =func logging_methods
 #pod
 #pod Returns a list of all logging method. E.g. "trace", "info", etc.
 #pod
 #pod =cut
 
 sub logging_methods               { @logging_methods }
 
 #pod =func detection_methods
 #pod
 #pod Returns a list of detection methods.  E.g. "is_trace", "is_info", etc.
 #pod
 #pod =cut
 
 sub detection_methods             { @detection_methods }
 
 #pod =func logging_and_detection_methods
 #pod
 #pod Returns a list of logging and detection methods (but not aliases).
 #pod
 #pod =cut
 
 sub logging_and_detection_methods { @logging_and_detection_methods }
 
 #pod =func log_level_aliases
 #pod
 #pod Returns key/value pairs mapping aliases to "official" names.  E.g. "err" maps
 #pod to "error".
 #pod
 #pod =cut
 
 sub log_level_aliases             { %LOG_LEVEL_ALIASES }
 
 #pod =func logging_aliases
 #pod
 #pod Returns a list of logging alias names.  These are the keys from
 #pod L</log_level_aliases>.
 #pod
 #pod =cut
 
 sub logging_aliases               { @logging_aliases }
 
 #pod =func detection_aliases
 #pod
 #pod Returns a list of detection aliases.  E.g. "is_err", "is_fatal", etc.
 #pod
 #pod =cut
 
 sub detection_aliases             { @detection_aliases }
 
 #pod =func numeric_level
 #pod
 #pod Given a level name (or alias), returns the numeric value described above under
 #pod log level constants.  E.g. "err" would return 3.
 #pod
 #pod =cut
 
 sub numeric_level {
     my ($level) = @_;
     my $canonical =
       exists $LOG_LEVEL_ALIASES{$level} ? $LOG_LEVEL_ALIASES{$level} : $level;
     return $LOG_LEVELS{ uc($canonical) };
 }
 
 #pod =func dump_one_line
 #pod
 #pod Given a reference, returns a one-line L<Data::Dumper> dump with keys sorted.
 #pod
 #pod =cut
 
 sub dump_one_line {
     my ($value) = @_;
 
     return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
       ->Terse(1)->Dump();
 }
 
 #pod =func make_method
 #pod
 #pod Given a method name, a code reference and a package name, installs the code
 #pod reference as a method in the package.
 #pod
 #pod =cut
 
 sub make_method {
     my ( $method, $code, $pkg ) = @_;
 
     $pkg ||= caller();
     no strict 'refs';
     *{ $pkg . "::$method" } = $code;
 }
 
 #pod =func require_dynamic (DEPRECATED)
 #pod
 #pod Given a class name, attempts to load it via require unless the class
 #pod already has a constructor available.  Throws an error on failure. Used
 #pod internally and may become private in the future.
 #pod
 #pod =cut
 
 sub require_dynamic {
     my ($class) = @_;
 
     return 1 if $class->can('new'); # duck-type that class is loaded
 
     unless ( defined( eval "require $class; 1" ) )
     {    ## no critic (ProhibitStringyEval)
         die $@;
     }
 }
 
 #pod =func read_file (DEPRECATED)
 #pod
 #pod Slurp a file.  Does *not* apply any layers.  Used for testing and may
 #pod become private in the future.
 #pod
 #pod =cut
 
 sub read_file {
     my ($file) = @_;
 
     local $/ = undef;
     open( my $fh, '<', $file )
       or die "cannot open '$file': $!";
     my $contents = <$fh>;
     return $contents;
 }
 
 #pod =func cmp_deeply (DEPRECATED)
 #pod
 #pod Compares L<dump_one_line> results for two references.  Also takes a test
 #pod label as a third argument.  Used for testing and may become private in the
 #pod future.
 #pod
 #pod =cut
 
 sub cmp_deeply {
     my ( $ref1, $ref2, $name ) = @_;
 
     my $tb = Test::Builder->new();
     $tb->is_eq( dump_one_line($ref1), dump_one_line($ref2), $name );
 }
 
 # 0.XX version loaded Log::Any and some adapters relied on this happening
 # behind the scenes.  Since Log::Any now uses this module, we load Log::Any
 # via require after compilation to mitigate circularity.
 require Log::Any;
 
 1;
 
 
 # vim: ts=4 sts=4 sw=4 et tw=75:
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Adapter::Util - Common utility functions for Log::Any
 
 =head1 VERSION
 
 version 1.032
 
 =head1 DESCRIPTION
 
 This module has utility functions to help develop L<Log::Any::Adapter>
 subclasses or L<Log::Any::Proxy> formatters/filters.  It also has some
 functions used in internal testing.
 
 =head1 USAGE
 
 Nothing is exported by default.
 
 =head2 Log level constants
 
 If the C<:levels> tag is included in the import list, the following numeric
 constants will be imported:
 
     EMERGENCY => 0
     ALERT     => 1
     CRITICAL  => 2
     ERROR     => 3
     WARNING   => 4
     NOTICE    => 5
     INFO      => 6
     DEBUG     => 7
     TRACE     => 8
 
 =head1 FUNCTIONS
 
 =head2 logging_methods
 
 Returns a list of all logging method. E.g. "trace", "info", etc.
 
 =head2 detection_methods
 
 Returns a list of detection methods.  E.g. "is_trace", "is_info", etc.
 
 =head2 logging_and_detection_methods
 
 Returns a list of logging and detection methods (but not aliases).
 
 =head2 log_level_aliases
 
 Returns key/value pairs mapping aliases to "official" names.  E.g. "err" maps
 to "error".
 
 =head2 logging_aliases
 
 Returns a list of logging alias names.  These are the keys from
 L</log_level_aliases>.
 
 =head2 detection_aliases
 
 Returns a list of detection aliases.  E.g. "is_err", "is_fatal", etc.
 
 =head2 numeric_level
 
 Given a level name (or alias), returns the numeric value described above under
 log level constants.  E.g. "err" would return 3.
 
 =head2 dump_one_line
 
 Given a reference, returns a one-line L<Data::Dumper> dump with keys sorted.
 
 =head2 make_method
 
 Given a method name, a code reference and a package name, installs the code
 reference as a method in the package.
 
 =head2 require_dynamic (DEPRECATED)
 
 Given a class name, attempts to load it via require unless the class
 already has a constructor available.  Throws an error on failure. Used
 internally and may become private in the future.
 
 =head2 read_file (DEPRECATED)
 
 Slurp a file.  Does *not* apply any layers.  Used for testing and may
 become private in the future.
 
 =head2 cmp_deeply (DEPRECATED)
 
 Compares L<dump_one_line> results for two references.  Also takes a test
 label as a third argument.  Used for testing and may become private in the
 future.
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/IfLOG.pm ###
 package Log::Any::IfLOG;
 
 our $DATE = '2015-08-17'; # DATE
 our $VERSION = '0.07'; # VERSION
 
 our $DEBUG;
 our $ENABLE_LOG;
 
 my $log_singleton;
 sub __log_singleton {
     if (!$log_singleton) { $log_singleton = Object::Dumb->new }
     $log_singleton;
 }
 
 sub __log_enabled {
     if (defined $ENABLE_LOG) {
         return $ENABLE_LOG;
     } elsif ($INC{'Log/Any.pm'}) {
         # Log::Any has been loaded, so we have absorbed the cost anyway
         return 1;
     } else {
         return
             $ENV{LOG} || $ENV{TRACE} || $ENV{DEBUG} ||
             $ENV{VERBOSE} || $ENV{QUIET} || $ENV{LOG_LEVEL};
     }
 }
 
 sub import {
     my $self = shift;
 
     my $caller = caller();
     if (__log_enabled()) {
         require Log::Any;
         Log::Any->_export_to_caller($caller, @_);
     } else {
         my $saw_log_param = grep { $_ eq '$log' } @_;
         if ($saw_log_param) {
             __log_singleton(); # to init $log_singleton
             *{"$caller\::log"} = \$log_singleton;
         }
     }
 }
 
 sub get_logger {
     if (__log_enabled()) {
         require Log::Any;
         my $class = shift;
         if ($class eq 'Log::Any::IfLOG') {
             Log::Any->get_logger(@_);
         } else {
             Log::Any::get_logger($class, @_);
         }
     } else {
         return __log_singleton();
     }
 }
 
 package
     Object::Dumb;
 sub new { my $o = ""; bless \$o, shift }
 sub AUTOLOAD { 0 }
 
 1;
 # ABSTRACT: Load Log::Any only if "logging is enabled"
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::IfLOG - Load Log::Any only if "logging is enabled"
 
 =head1 VERSION
 
 This document describes version 0.07 of Log::Any::IfLOG (from Perl distribution Log-Any-IfLOG), released on 2015-08-17.
 
 =head1 SYNOPSIS
 
  use Log::Any::IfLOG '$log';
 
 =head1 DESCRIPTION
 
 This module is a drop-in replacement/wrapper for L<Log::Any> to be used from
 your modules. This is a quick-hack solution to avoid the cost of loading
 Log::Any under "normal condition". Since Log::Any 1.00, startup overhead
 increases to about 7-10ms on my PC/laptop (from under 1ms for the previous
 version). Because I want to keep startup overhead of CLI apps under 50ms (see
 L<Perinci::CmdLine::Lite>) to keep tab completion from getting a noticeable lag,
 every millisecond counts.
 
 This module will only load L<Log::Any> when "logging is enabled". Otherwise, it
 will just return without loading anything. If C<$log> is requested in import, a
 fake object is returned that responds to methods like C<debug>, C<is_debug> and
 so on but will do nothing when called and just return 0.
 
 To determine "logging is enabled":
 
 =over
 
 =item * Is $ENABLE_LOG defined?
 
 This package variable can be used to force "logging enabled" (if true) or
 "logging disabled" (if false). Normally, you don't need to do this except for
 testing.
 
 =item * Is Log::Any is already loaded (from %INC)?
 
 If Log::Any is already loaded, it means we have taken the overhead hit anyway so
 logging is enabled.
 
 =item * Is one of log-related environment variables true?
 
 If one of L<LOG>, C<TRACE>, or C<DEBUG>, or C<VERBOSE>, or C<QUIET>, or
 C<LOG_LEVEL> is true then logging is enabled. These variables are used by
 L<Perinci::CmdLine>.
 
 Otherwise, logging is disabled.
 
 =back
 
 =for Pod::Coverage ^(.+)$
 
 =head1 ENVIRONMENT
 
 =head2 LOG => bool
 
 =head2 TRACE => bool
 
 =head2 DEBUG => bool
 
 =head2 VERBOSE => bool
 
 =head2 QUIET => bool
 
 =head2 LOG_LEVEL => str
 
 =head1 VARIABLES
 
 =head2 $ENABLE_LOG => bool
 
 This setting can be forced to force loading Log::Any or not.
 
 =head1 SEE ALSO
 
 L<Log::Any>
 
 L<http://github.com/dagolden/Log-Any/issues/24>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Log-Any-IfLOG>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Log-Any-IfLOG>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Log-Any-IfLOG>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Manager.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Manager;
 
 our $VERSION = '1.032';
 
 sub new {
     my $class = shift;
     my $self  = {
         entries         => [],
         category_cache  => {},
         default_adapter => {},
     };
     bless $self, $class;
 
     return $self;
 }
 
 sub get_adapter {
     my ( $self, $category ) = @_;
 
     # Create a new adapter for this category if it is not already in cache
     #
     my $category_cache = $self->{category_cache};
     if ( !defined( $category_cache->{$category} ) ) {
         my $entry = $self->_choose_entry_for_category($category);
         my $adapter = $self->_new_adapter_for_entry( $entry, $category );
         $category_cache->{$category} = { entry => $entry, adapter => $adapter };
     }
     return $category_cache->{$category}->{adapter};
 }
 
 {
     no warnings 'once';
     *get_logger = \&get_adapter;    # backwards compatibility
 }
 
 sub _choose_entry_for_category {
     my ( $self, $category ) = @_;
 
     foreach my $entry ( @{ $self->{entries} } ) {
         if ( $category =~ $entry->{pattern} ) {
             return $entry;
         }
     }
     # nothing requested so fallback to default
     my $default = $self->{default_adapter}{$category}
         || [ $self->_get_adapter_class("Null"), [] ];
     my ($adapter_class, $adapter_params) = @$default;
     _require_dynamic($adapter_class);
     return {
         adapter_class  => $adapter_class,
         adapter_params => $adapter_params,
     };
 }
 
 sub _new_adapter_for_entry {
     my ( $self, $entry, $category ) = @_;
 
     return $entry->{adapter_class}
       ->new( @{ $entry->{adapter_params} }, category => $category );
 }
 
 sub set_default {
     my ( $self, $category, $adapter_name, @adapter_params ) = @_;
     my $adapter_class = $self->_get_adapter_class($adapter_name);
     $self->{default_adapter}{$category} = [$adapter_class, \@adapter_params];
 }
 
 sub set {
     my $self = shift;
     my $options;
     if ( ref( $_[0] ) eq 'HASH' ) {
         $options = shift(@_);
     }
     my ( $adapter_name, @adapter_params ) = @_;
 
     unless ( defined($adapter_name) && $adapter_name =~ /\S/ ) {
         require Carp;
         Carp::croak("expected adapter name");
     }
 
     my $pattern = $options->{category};
     if ( !defined($pattern) ) {
         $pattern = qr/.*/;
     }
     elsif ( !ref($pattern) ) {
         $pattern = qr/^\Q$pattern\E$/;
     }
 
     my $adapter_class = $self->_get_adapter_class($adapter_name);
     _require_dynamic($adapter_class);
 
     my $entry = $self->_new_entry( $pattern, $adapter_class, \@adapter_params );
     unshift( @{ $self->{entries} }, $entry );
 
     $self->_reselect_matching_adapters($pattern);
 
     if ( my $lex_ref = $options->{lexically} ) {
         $$lex_ref = Log::Any::Manager::_Guard->new(
             sub { $self->remove($entry) unless _in_global_destruction() } );
     }
 
     return $entry;
 }
 
 sub remove {
     my ( $self, $entry ) = @_;
 
     my $pattern = $entry->{pattern};
     $self->{entries} = [ grep { $_ ne $entry } @{ $self->{entries} } ];
     $self->_reselect_matching_adapters($pattern);
 }
 
 sub _new_entry {
     my ( $self, $pattern, $adapter_class, $adapter_params ) = @_;
 
     return {
         pattern        => $pattern,
         adapter_class  => $adapter_class,
         adapter_params => $adapter_params,
     };
 }
 
 sub _reselect_matching_adapters {
     my ( $self, $pattern ) = @_;
 
     return if _in_global_destruction();
 
     # Reselect adapter for each category matching $pattern
     #
     while ( my ( $category, $category_info ) =
         each( %{ $self->{category_cache} } ) )
     {
         my $new_entry = $self->_choose_entry_for_category($category);
         if ( $new_entry ne $category_info->{entry} ) {
             my $new_adapter =
               $self->_new_adapter_for_entry( $new_entry, $category );
             %{ $category_info->{adapter} } = %$new_adapter;
             bless( $category_info->{adapter}, ref($new_adapter) );
             $category_info->{entry} = $new_entry;
         }
     }
 }
 
 sub _get_adapter_class {
     my ( $self, $adapter_name ) = @_;
     return $Log::Any::OverrideDefaultAdapterClass if $Log::Any::OverrideDefaultAdapterClass;
     $adapter_name =~ s/^Log:://;    # Log::Dispatch -> Dispatch, etc.
     my $adapter_class = (
           substr( $adapter_name, 0, 1 ) eq '+'
         ? substr( $adapter_name, 1 )
         : "Log::Any::Adapter::$adapter_name"
     );
     return $adapter_class;
 }
 
 # This is adapted from the pure perl parts of Devel::GlobalDestruction
 if ( defined ${^GLOBAL_PHASE} ) {
     eval 'sub _in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1' ## no critic
       or die $@;
 }
 else {
     require B;
     my $started = !B::main_start()->isa(q[B::NULL]);
     unless ($started) {
         eval '0 && $started; CHECK { $started = 1 }; 1' ## no critic
           or die $@;
     }
     eval ## no critic
       '0 && $started; sub _in_global_destruction () { $started && B::main_start()->isa(q[B::NULL]) }; 1'
       or die $@;
 }
 
 # XXX not DRY and not a great way to do this, but oh, well.
 sub _require_dynamic {
     my ($class) = @_;
 
     return 1 if $class->can('new'); # duck-type that class is loaded
 
     unless ( defined( eval "require $class; 1" ) )
     {    ## no critic (ProhibitStringyEval)
         die $@;
     }
 }
 
 package    # hide from PAUSE
   Log::Any::Manager::_Guard;
 
 sub new { bless $_[1], $_[0] }
 
 sub DESTROY { $_[0]->() }
 
 1;
### Log/Any/Proxy.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Proxy;
 
 # ABSTRACT: Log::Any generator proxy object
 our $VERSION = '1.032';
 
 use Log::Any::Adapter::Util ();
 
 sub _default_formatter {
     my ( $cat, $lvl, $format, @params ) = @_;
     my @new_params =
       map { !defined($_) ? '<undef>' : ref($_) ? _dump_one_line($_) : $_ }
       @params;
     return sprintf( $format, @new_params );
 }
 
 sub _dump_one_line {
     my ($value) = @_;
 
     return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
       ->Terse(1)->Useqq(1)->Dump();
 }
 
 sub new {
     my $class = shift;
     my $self = { formatter => \&_default_formatter, @_ };
     unless ( $self->{adapter} ) {
         require Carp;
         Carp::croak("$class requires an 'adapter' parameter");
     }
     unless ( $self->{category} ) {
         require Carp;
         Carp::croak("$class requires an 'category' parameter")
     }
     bless $self, $class;
     $self->init(@_);
     return $self;
 }
 
 sub init { }
 
 for my $attr (qw/adapter filter formatter prefix/) {
     no strict 'refs';
     *{$attr} = sub { return $_[0]->{$attr} };
 }
 
 my %aliases = Log::Any::Adapter::Util::log_level_aliases();
 
 # Set up methods/aliases and detection methods/aliases
 foreach my $name ( Log::Any::Adapter::Util::logging_methods(), keys(%aliases) )
 {
     my $realname    = $aliases{$name} || $name;
     my $namef       = $name . "f";
     my $is_name     = "is_$name";
     my $is_realname = "is_$realname";
     my $numeric     = Log::Any::Adapter::Util::numeric_level($realname);
     no strict 'refs';
     *{$is_name} = sub {
         my ($self) = @_;
         return $self->{adapter}->$is_realname;
     };
     *{$name} = sub {
         my ( $self, @parts ) = @_;
         my $message = join(" ", grep { defined($_) && length($_) } @parts );
         return unless length $message;
         $message = $self->{filter}->( $self->{category}, $numeric, $message )
           if defined $self->{filter};
         return unless defined $message and length $message;
         $message = "$self->{prefix}$message"
           if defined $self->{prefix} && length $self->{prefix};
         return $self->{adapter}->$realname($message);
     };
     *{$namef} = sub {
         my ( $self, @args ) = @_;
         return unless $self->{adapter}->$is_realname;
         my $message =
           $self->{formatter}->( $self->{category}, $numeric, @args );
         return unless defined $message and length $message;
         return $self->$name($message);
     };
 }
 
 1;
 
 
 # vim: ts=4 sts=4 sw=4 et tw=75:
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Proxy - Log::Any generator proxy object
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     # prefix log messages
     use Log::Any '$log', prefix => 'MyApp: ';
 
     # transform log messages
     use Log::Any '$log', filter => \&myfilter;
 
     # format with String::Flogger instead of the default
     use String::Flogger;
     use Log::Any '$log', formatter => sub {
         my ($cat, $lvl, @args) = @_;
         String::Flogger::flog( @args );
     };
 
 =head1 DESCRIPTION
 
 Log::Any::Proxy objects are what modules use to produce log messages.  They
 construct messages and pass them along to a configured adapter.
 
 =head1 USAGE
 
 =head2 Simple logging
 
 Your library can do simple logging using logging methods corresponding to
 the log levels (or aliases):
 
 =over 4
 
 =item *
 
 trace
 
 =item *
 
 debug
 
 =item *
 
 info (inform)
 
 =item *
 
 notice
 
 =item *
 
 warning (warn)
 
 =item *
 
 error (err)
 
 =item *
 
 critical (crit, fatal)
 
 =item *
 
 alert
 
 =item *
 
 emergency
 
 =back
 
 Pass a string to be logged.  Do not include a newline.
 
     $log->info("Got some new for you.");
 
 The log string will be tranformed via the C<filter> attribute (if any) and
 the C<prefix> (if any) will be prepended.
 
 B<NOTE>: While you are encouraged to pass a single string to be logged, if
 multiple arguments are passed, they are concatenated with a space character
 into a single string before processing.  This ensures consistency across
 adapters, some of which may support multiple arguments to their logging
 functions (and which concatenate in different ways) and some of which do
 not.
 
 =head2 Advanced logging
 
 Your library can do advanced logging using logging methods corresponding to
 the log levels (or aliases), but with an "f" appended:
 
 =over 4
 
 =item *
 
 tracef
 
 =item *
 
 debugf
 
 =item *
 
 infof (informf)
 
 =item *
 
 noticef
 
 =item *
 
 warningf (warnf)
 
 =item *
 
 errorf (errf)
 
 =item *
 
 criticalf (critf, fatalf)
 
 =item *
 
 alertf
 
 =item *
 
 emergencyf
 
 =back
 
 When these methods are called, the adapter is first checked to see if it is
 logging at that level.  If not, the method returns without logging.
 
 Next, arguments are transformed to a message string via the C<formatter>
 attribute.  The default acts like C<sprintf> with some helpful formatting.
 
 Finally, the message string is logged via the simple logging functions, which
 can transform or prefix as described above.
 
 =head1 ATTRIBUTES
 
 =head2 adapter
 
 A L<Log::Any::Adapter> object to receive any messages logged.  This is
 generated by L<Log::Any> and can not be overridden.
 
 =head2 category
 
 The category name of the proxy.  If not provided, L<Log::Any> will set it
 equal to the calling when the proxy is constructed.
 
 =head2 filter
 
 A code reference to transform messages before passing them to a
 Log::Any::Adapter.  It gets three arguments: a category, a numeric level
 and a string.  It should return a string to be logged.
 
     sub {
         my ($cat, $lvl, $msg) = @_;
         return "[$lvl] $msg";
     }
 
 If the return value is undef or the empty string, no message will be
 logged.  Otherwise, the return value is passed to the logging adapter.
 
 Numeric levels range from 0 (emergency) to 8 (trace).  Constant functions
 for these levels are available from L<Log::Any::Adapter::Util>.
 
 =head2 formatter
 
 A code reference to format messages given to the C<*f> methods (C<tracef>,
 C<debugf>, C<infof>, etc..)
 
 It get three or more arguments: a category, a numeric level and the list
 of arguments passsed to the C<*f> method.  It should return a string to
 be logged.
 
     sub {
         my ($cat, $lvl, $format, @args) = @_;
         return sprintf($format, @args);
     }
 
 The default formatter acts like C<sprintf>, except that undef arguments are
 changed to C<< <undef> >> and any references or objects are dumped via
 L<Data::Dumper> (but without newlines).
 
 Numeric levels range from 0 (emergency) to 8 (trace).  Constant functions
 for these levels are available from L<Log::Any::Adapter::Util>.
 
 =head2 prefix
 
 If defined, this string will be prepended to all messages.  It will not
 include a trailing space, so add that yourself if you want.  This is less
 flexible/powerful than L</filter>, but avoids an extra function call.
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Log/Any/Proxy/Test.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Proxy::Test;
 
 our $VERSION = '1.032';
 
 use base qw/Log::Any::Proxy/;
 
 my @test_methods = qw(
   msgs
   clear
   contains_ok
   category_contains_ok
   does_not_contain_ok
   category_does_not_contain_ok
   empty_ok
   contains_only_ok
 );
 
 foreach my $name (@test_methods) {
     no strict 'refs';
     *{$name} = sub {
         my $self = shift;
         $self->{adapter}->$name(@_);
     };
 }
 
 1;
### Log/Any/Test.pm ###
 use 5.008001;
 use strict;
 use warnings;
 
 package Log::Any::Test;
 
 # ABSTRACT: Test what you're logging with Log::Any
 our $VERSION = '1.032';
 
 no warnings 'once';
 $Log::Any::OverrideDefaultAdapterClass = 'Log::Any::Adapter::Test';
 $Log::Any::OverrideDefaultProxyClass   = 'Log::Any::Proxy::Test';
 
 1;
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Log::Any::Test - Test what you're logging with Log::Any
 
 =head1 VERSION
 
 version 1.032
 
 =head1 SYNOPSIS
 
     use Test::More;
     use Log::Any::Test;    # should appear before 'use Log::Any'!
     use Log::Any qw($log);
 
     # ...
     # call something that logs using Log::Any
     # ...
 
     # now test to make sure you logged the right things
 
     $log->contains_ok(qr/good log message/, "good message was logged");
     $log->does_not_contain_ok(qr/unexpected log message/, "unexpected message was not logged");
     $log->empty_ok("no more logs");
 
     # or
 
     my $msgs = $log->msgs;
     cmp_deeply($msgs, [{message => 'msg1', level => 'debug'}, ...]);
 
 =head1 DESCRIPTION
 
 C<Log::Any::Test> is a simple module that allows you to test what has been
 logged with Log::Any. Most of its API and implementation have been taken from
 L<Log::Any::Dispatch|Log::Any::Dispatch>.
 
 Using C<Log::Any::Test> sends all subsequent Log::Any log messages to a single
 global in-memory buffer.  It should be used before L<Log::Any|Log::Any>.
 
 =head1 METHODS
 
 The test_name is optional in the *_ok methods; a reasonable default will be
 provided.
 
 =over
 
 =item msgs ()
 
 Returns the current contents of the global log buffer as an array reference,
 where each element is a hash containing a I<category>, I<level>, and I<message>
 key.  e.g.
 
   {
     category => 'Foo',
     level => 'error',
     message => 'this is an error'
   },
   {
     category => 'Bar::Baz',
     level => 'debug',
     message => 'this is a debug'
   }
 
 =item contains_ok ($regex[, $test_name])
 
 Tests that a message in the log buffer matches I<$regex>. On success, the
 message is I<removed> from the log buffer (but any other matches are left
 untouched).
 
 =item does_not_contain_ok ($regex[, $test_name])
 
 Tests that no message in the log buffer matches I<$regex>.
 
 =item category_contains_ok ($category, $regex[, $test_name])
 
 Tests that a message in the log buffer from a specific category matches
 I<$regex>. On success, the message is I<removed> from the log buffer (but any
 other matches are left untouched).
 
 =item category_does_not_contain_ok ($category, $regex[, $test_name])
 
 Tests that no message from a specific category in the log buffer matches
 I<$regex>.
 
 =item empty_ok ([$test_name])
 
 Tests that there is no log buffer left. On failure, the log buffer is cleared
 to limit further cascading failures.
 
 =item contains_only_ok ($regex[, $test_name])
 
 Tests that there is a single message in the log buffer and it matches
 I<$regex>. On success, the message is removed.
 
 =item clear ()
 
 Clears the log buffer.
 
 =back
 
 =head1 SEE ALSO
 
 L<Log::Any|Log::Any>, L<Test::Log::Dispatch|Test::Log::Dispatch>
 
 =head1 AUTHORS
 
 =over 4
 
 =item *
 
 Jonathan Swartz <swartz@pobox.com>
 
 =item *
 
 David Golden <dagolden@cpan.org>
 
 =back
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Jonathan Swartz and David Golden.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Module/Path/More.pm ###
 package Module::Path::More;
 
 our $DATE = '2015-04-15'; # DATE
 our $VERSION = '0.28'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw(module_path pod_path);
 
 my $SEPARATOR;
 
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'Get path to locally installed Perl module',
 };
 
 BEGIN {
     if ($^O =~ /^(dos|os2)/i) {
         $SEPARATOR = '\\';
     } elsif ($^O =~ /^MacOS/i) {
         $SEPARATOR = ':';
     } else {
         $SEPARATOR = '/';
     }
 }
 
 $SPEC{module_path} = {
     v => 1.1,
     summary => 'Get path to locally installed Perl module',
     description => <<'_',
 
 Search `@INC` (reference entries are skipped) and return path(s) to Perl module
 files with the requested name.
 
 This function is like the one from `Module::Path`, except with a different
 interface and more options (finding all matches instead of the first, the option
 of not absolutizing paths, finding `.pmc` & `.pod` files, finding module
 prefixes).
 
 _
     args => {
         module => {
             summary => 'Module name to search',
             schema  => 'str*',
             req     => 1,
             pos     => 0,
         },
         find_pm => {
             summary => 'Whether to find .pm files',
             schema  => 'bool',
             default => 1,
         },
         find_pmc => {
             summary => 'Whether to find .pmc files',
             schema  => 'bool',
             default => 1,
         },
         find_pod => {
             summary => 'Whether to find .pod files',
             schema  => 'bool',
             default => 0,
         },
         find_prefix => {
             summary => 'Whether to find module prefixes',
             schema  => 'bool',
             default => 0,
         },
         all => {
             summary => 'Return all results instead of just the first',
             schema  => 'bool',
             default => 0,
         },
         abs => {
             summary => 'Whether to return absolute paths',
             schema  => 'bool',
             default => 0,
         },
     },
     result => {
         schema => ['any' => of => ['str*', ['array*' => of => 'str*']]],
     },
     result_naked => 1,
 };
 sub module_path {
     my %args = @_;
 
     my $module = $args{module} or die "Please specify module";
 
     $args{abs}         //= 0;
     $args{all}         //= 0;
     $args{find_pm}     //= 1;
     $args{find_pmc}    //= 1;
     $args{find_pod}    //= 0;
     $args{find_prefix} //= 0;
 
     require Cwd if $args{abs};
 
     my @res;
     my $add = sub { push @res, $args{abs} ? Cwd::abs_path($_[0]) : $_[0] };
 
     my $relpath;
 
     ($relpath = $module) =~ s/::/$SEPARATOR/g;
     $relpath =~ s/\.(pm|pmc|pod)\z//i;
 
     foreach my $dir (@INC) {
         next if not defined($dir);
         next if ref($dir);
 
         my $prefix = $dir . $SEPARATOR . $relpath;
         if ($args{find_pmc}) {
             my $file = $prefix . ".pmc";
             if (-f $file) {
                 $add->($file);
                 last unless $args{all};
             }
         }
         if ($args{find_pm}) {
             my $file = $prefix . ".pm";
             if (-f $file) {
                 $add->($file);
                 last unless $args{all};
             }
         }
         if ($args{find_pod}) {
             my $file = $prefix . ".pod";
             if (-f $file) {
                 $add->($file);
                 last unless $args{all};
             }
         }
         if ($args{find_prefix}) {
             if (-d $prefix) {
                 $add->($prefix);
                 last unless $args{all};
             }
         }
     }
 
     if ($args{all}) {
         return \@res;
     } else {
         return @res ? $res[0] : undef;
     }
 }
 
 $SPEC{pod_path} = {
     v => 1.1,
     summary => 'Get path to locally installed POD',
     description => <<'_',
 
 This is a shortcut for:
 
     module_path(%args, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0)
 
 _
     args => {
         module => {
             summary => 'Module name to search',
             schema  => 'str*',
             req     => 1,
             pos     => 0,
         },
         all => {
             summary => 'Return all results instead of just the first',
             schema  => 'bool',
             default => 0,
         },
         abs => {
             summary => 'Whether to return absolute paths',
             schema  => 'bool',
             default => 0,
         },
     },
     result => {
         schema => ['any' => of => ['str*', ['array*' => of => 'str*']]],
     },
     result_naked => 1,
 };
 sub pod_path {
     module_path(@_, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0);
 }
 
 1;
 # ABSTRACT: Get path to locally installed Perl module
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Module::Path::More - Get path to locally installed Perl module
 
 =head1 VERSION
 
 This document describes version 0.28 of Module::Path::More (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-15.
 
 =head1 SYNOPSIS
 
  use Module::Path::More qw(module_path pod_path);
 
  $path = module_path(module=>'Test::More');
  if (defined($path)) {
    print "Test::More found at $path\n";
  } else {
    print "Danger Will Robinson!\n";
  }
 
  # find all found modules, as well as .pmc and .pod files
  @path = module_path(module=>'Foo::Bar', all=>1, find_pmc=>1, find_pod=>1);
 
  # just a shortcut for module_path(module=>'Foo',
  #                                 find_pm=>0, find_pmc=>0, find_pod=>1);
  $path = pod_path(module=>'Foo');
 
 =head1 DESCRIPTION
 
 Module::Path::More provides a function, C<module_path()>, which will find where
 a module (or module prefix, or .pod file) is installed locally. (There is also
 another function C<pod_path()> which is just a convenience wrapper.)
 
 It works by looking in all the directories in @INC for an appropriately named
 file. If module is C<Foo::Bar>, will search for C<Foo/Bar.pm>, C<Foo/Bar.pmc>
 (if C<find_pmc> argument is true), C<Foo/Bar> directory (if C<find_prefix>
 argument is true), or C<Foo/Bar.pod> (if C<find_pod> argument is true).
 
 Caveats: Obviously this only works where the module you're after has its own
 C<.pm> file. If a file defines multiple packages, this won't work. This also
 won't find any modules that are being loaded in some special way, for example
 using a code reference in C<@INC>, as described in C<require> in L<perlfunc>.
 
 To check whether a module is available/loadable, it's generally better to use
 something like:
 
  if (eval { require Some::Module; 1 }) {
      # module is available
  }
 
 because this works with fatpacking or any other C<@INC> hook that might be
 installed. If you use:
 
  if (module_path(module => "Some::Module")) {
      # module is available
  }
 
 then it only works if the module is locatable in the filesystem. But on the
 other hand this method can avoid actual loading of the module.
 
 =head1 FUNCTIONS
 
 
 =head2 module_path(%args) -> str|array[str]
 
 Get path to locally installed Perl module.
 
 Search C<@INC> (reference entries are skipped) and return path(s) to Perl module
 files with the requested name.
 
 This function is like the one from C<Module::Path>, except with a different
 interface and more options (finding all matches instead of the first, the option
 of not absolutizing paths, finding C<.pmc> & C<.pod> files, finding module
 prefixes).
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<abs> => I<bool> (default: 0)
 
 Whether to return absolute paths.
 
 =item * B<all> => I<bool> (default: 0)
 
 Return all results instead of just the first.
 
 =item * B<find_pm> => I<bool> (default: 1)
 
 Whether to find .pm files.
 
 =item * B<find_pmc> => I<bool> (default: 1)
 
 Whether to find .pmc files.
 
 =item * B<find_pod> => I<bool> (default: 0)
 
 Whether to find .pod files.
 
 =item * B<find_prefix> => I<bool> (default: 0)
 
 Whether to find module prefixes.
 
 =item * B<module>* => I<str>
 
 Module name to search.
 
 =back
 
 Return value:  (str|array[str])
 
 
 =head2 pod_path(%args) -> str|array[str]
 
 Get path to locally installed POD.
 
 This is a shortcut for:
 
  module_path(%args, find_pm=>0, find_pmc=>0, find_pod=>1, find_prefix=>0)
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<abs> => I<bool> (default: 0)
 
 Whether to return absolute paths.
 
 =item * B<all> => I<bool> (default: 0)
 
 Return all results instead of just the first.
 
 =item * B<module>* => I<str>
 
 Module name to search.
 
 =back
 
 Return value:  (str|array[str])
 
 =head1 SEE ALSO
 
 L<Module::Path>. Module::Path::More is actually a fork of Module::Path.
 Module::Path::More contains features that are not (or have not been accepted) in
 the original module, namely: finding all matches instead of the first found
 match, and finding C<.pmc/.pod> in addition to .pm files. B<Note that the
 interface is different> (Module::Path::More accepts hash/named arguments) so the
 two modules are not drop-in replacements for each other. Also, note that by
 default Module::Path::More does B<not> do an C<abs_path()> to each file it
 finds. I think this module's choice (not doing abs_path) is a more sensible
 default, because usually there is no actual need to do so and doing abs_path()
 or resolving symlinks will sometimes fail or expose filesystem quirks that we
 might not want to deal with at all. However, if you want to do abs_path, you can
 do so by setting C<abs> option to true.
 
 Command-line utility is not included in this distribution, unlike L<mpath> in
 C<Module-Path>. However, you can use L<pmpath> from C<App-PMUtils> which uses
 this module.
 
 References:
 
 =over
 
 =item * L<https://github.com/neilbowers/Module-Path/issues/6>
 
 =item * L<https://github.com/neilbowers/Module-Path/issues/7>
 
 =item * L<https://github.com/neilbowers/Module-Path/issues/10>
 
 =item * L<https://rt.cpan.org/Public/Bug/Display.html?id=100979>
 
 =back
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Module-Path-More>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Module-Path-More>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Path-More>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/ArgEntity.pm ###
 package Perinci::Sub::ArgEntity;
 
 our $DATE = '2015-03-01'; # DATE
 our $VERSION = '0.01'; # VERSION
 
 1;
 # ABSTRACT: Convention for Perinci::Sub::ArgEntity::* modules
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::ArgEntity - Convention for Perinci::Sub::ArgEntity::* modules
 
 =head1 VERSION
 
 This document describes version 0.01 of Perinci::Sub::ArgEntity (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-03-01.
 
 =head1 SYNOPSIS
 
 In your L<Rinci> function metadata:
 
  {
      v => 1.1,
      summary => 'Some function',
      args => {
          file => {
              # specification for 'file' argument
              schema  => 'str*',
              'x.schema.entity' => 'filename',
          },
          url => {
              # specification for 'url' argument
              schema  => ['array*', of => 'str*'],
              'x.schema.element_entity' => 'riap_url',
          },
      },
  }
 
 Now in command-line application:
 
  % myprog --file <tab>
 
 will use completion routine from function C<complete_arg_val> in module
 L<Perinci::Sub::ArgEntity::filename>, while:
 
  % myprog --url <tab>
 
 will use element completion routine from function C<complete_arg_val> in module
 L<Perinci::Sub::ArgEntity::riap_url>.
 
 =head1 DESCRIPTION
 
 The namespace C<Perinci::Sub::ArgEntity::*> is used to put data and routine
 related to certain types (entities) of function arguments.
 
 =head2 Completion
 
 The idea is: instead of having to put completion routine (coderef) directly in
 argument specification, like:
 
  file => {
      # specification for 'file' argument
      schema  => 'str*',
      completion => \&Complete::Util::complete_file,
  },
 
 you just specify the argument as being of a certain entity using the attribute
 C<x.schema.entity>:
 
  file => {
      # specification for 'file' argument
      schema  => 'str*',
      'x.schema.entity' => 'filename',
  },
 
 and module like L<Perinci::Sub::Complete> will search the appropriate completion
 routine (if any) for your argument. In this case, it will search for the module
 named C<Perinci::Sub::ArgEntity::> + I<entity_name> and then look up the
 function C<complete_arg_val>.
 
 Note that aside from completion, there are other uses for the C<x.schema.entity>
 attribute, e.g. in help message generation, etc. More things will be formally
 specified in the future.
 
 =head1 SEE ALSO
 
 L<Rinci>, L<Rinci::function>
 
 L<Complete>, L<Perinci::Sub::Complete>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-ArgEntity>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-ArgEntity>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-ArgEntity>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/Complete.pm ###
 package Perinci::Sub::Complete;
 
 our $DATE = '2015-08-11'; # DATE
 our $VERSION = '0.80'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 use Log::Any::IfLOG '$log';
 
 use Complete;
 use Complete::Util qw(hashify_answer complete_array_elem combine_answers);
 use Perinci::Sub::Util qw(gen_modified_sub);
 
 require Exporter;
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw(
                        complete_from_schema
                        complete_arg_val
                        complete_arg_elem
                        complete_cli_arg
                );
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'Complete command-line argument using Rinci metadata',
 };
 
 my %common_args_riap = (
     riap_client => {
         summary => 'Optional, to perform complete_arg_val to the server',
         schema  => 'obj*',
         description => <<'_',
 
 When the argument spec in the Rinci metadata contains `completion` key, this
 means there is custom completion code for that argument. However, if retrieved
 from a remote server, sometimes the `completion` key no longer contains the code
 (it has been cleansed into a string). Moreover, the completion code needs to run
 on the server.
 
 If supplied this argument and te `riap_server_url` argument, the function will
 try to request to the server (via Riap request `complete_arg_val`). Otherwise,
 the function will just give up/decline completing.
 
 _
         },
     riap_server_url => {
         summary => 'Optional, to perform complete_arg_val to the server',
         schema  => 'str*',
         description => <<'_',
 
 See the `riap_client` argument.
 
 _
     },
     riap_uri => {
         summary => 'Optional, to perform complete_arg_val to the server',
         schema  => 'str*',
         description => <<'_',
 
 See the `riap_client` argument.
 
 _
     },
 );
 
 $SPEC{complete_from_schema} = {
     v => 1.1,
     summary => 'Complete a value from schema',
     description => <<'_',
 
 Employ some heuristics to complete a value from Sah schema. For example, if
 schema is `[str => in => [qw/new open resolved rejected/]]`, then we can
 complete from the `in` clause. Or for something like `[int => between => [1,
 20]]` we can complete using values from 1 to 20.
 
 _
     args => {
         schema => {
             summary => 'Must be normalized',
             req => 1,
         },
         word => {
             schema => [str => default => ''],
             req => 1,
         },
         ci => {
             schema => 'bool',
         },
     },
 };
 sub complete_from_schema {
     my %args = @_;
     my $sch  = $args{schema}; # must be normalized
     my $word = $args{word} // "";
     my $ci   = $args{ci} // $Complete::OPT_CI;
 
     my $fres;
     $log->tracef("[comp][periscomp] entering complete_from_schema, word=<%s>, schema=%s", $word, $sch);
 
     my ($type, $cs) = @{$sch};
 
     my $static;
     my $words;
     eval {
         if ($cs->{is} && !ref($cs->{is})) {
             $log->tracef("[comp][periscomp] adding completion from 'is' clause");
             push @$words, $cs->{is};
             $static++;
             return; # from eval. there should not be any other value
         }
         if ($cs->{in}) {
             $log->tracef("[comp][periscomp] adding completion from 'in' clause");
             push @$words, grep {!ref($_)} @{ $cs->{in} };
             $static++;
             return; # from eval. there should not be any other value
         }
         if ($type eq 'any') {
             # because currently Data::Sah::Normalize doesn't recursively
             # normalize schemas in 'of' clauses, etc.
             require Data::Sah::Normalize;
             if ($cs->{of} && @{ $cs->{of} }) {
                 $fres = combine_answers(
                     grep { defined } map {
                         complete_from_schema(
                             schema=>Data::Sah::Normalize::normalize_schema($_),
                             word => $word,
                             ci => $ci,
                         )
                     } @{ $cs->{of} }
                 );
                 goto RETURN_RES; # directly return result
             }
         }
         if ($type eq 'bool') {
             $log->tracef("[comp][periscomp] adding completion from possible values of bool");
             push @$words, 0, 1;
             $static++;
             return; # from eval
         }
         if ($type eq 'int') {
             my $limit = 100;
             if ($cs->{between} &&
                     $cs->{between}[0] - $cs->{between}[0] <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'between' clause");
                 push @$words, $cs->{between}[0] .. $cs->{between}[1];
                 $static++;
             } elsif ($cs->{xbetween} &&
                          $cs->{xbetween}[0] - $cs->{xbetween}[0] <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'xbetween' clause");
                 push @$words, $cs->{xbetween}[0]+1 .. $cs->{xbetween}[1]-1;
                 $static++;
             } elsif (defined($cs->{min}) && defined($cs->{max}) &&
                          $cs->{max}-$cs->{min} <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'min' & 'max' clauses");
                 push @$words, $cs->{min} .. $cs->{max};
                 $static++;
             } elsif (defined($cs->{min}) && defined($cs->{xmax}) &&
                          $cs->{xmax}-$cs->{min} <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'min' & 'xmax' clauses");
                 push @$words, $cs->{min} .. $cs->{xmax}-1;
                 $static++;
             } elsif (defined($cs->{xmin}) && defined($cs->{max}) &&
                          $cs->{max}-$cs->{xmin} <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'xmin' & 'max' clauses");
                 push @$words, $cs->{xmin}+1 .. $cs->{max};
                 $static++;
             } elsif (defined($cs->{xmin}) && defined($cs->{xmax}) &&
                          $cs->{xmax}-$cs->{xmin} <= $limit) {
                 $log->tracef("[comp][periscomp] adding completion from 'xmin' & 'xmax' clauses");
                 push @$words, $cs->{xmin}+1 .. $cs->{xmax}-1;
                 $static++;
             } elsif (length($word) && $word !~ /\A-?\d*\z/) {
                 $log->tracef("[comp][periscomp] word not an int");
                 $words = [];
             } else {
                 # do a digit by digit completion
                 $words = [];
                 for my $sign ("", "-") {
                     for ("", 0..9) {
                         my $i = $sign . $word . $_;
                         next unless length $i;
                         next unless $i =~ /\A-?\d+\z/;
                         next if $i eq '-0';
                         next if $i =~ /\A-?0\d/;
                         next if $cs->{between} &&
                             ($i < $cs->{between}[0] ||
                                  $i > $cs->{between}[1]);
                         next if $cs->{xbetween} &&
                             ($i <= $cs->{xbetween}[0] ||
                                  $i >= $cs->{xbetween}[1]);
                         next if defined($cs->{min} ) && $i <  $cs->{min};
                         next if defined($cs->{xmin}) && $i <= $cs->{xmin};
                         next if defined($cs->{max} ) && $i >  $cs->{max};
                         next if defined($cs->{xmin}) && $i >= $cs->{xmax};
                         push @$words, $i;
                     }
                 }
                 $words = [sort @$words];
             }
             return; # from eval
         }
         if ($type eq 'float') {
             if (length($word) && $word !~ /\A-?\d*(\.\d*)?\z/) {
                 $log->tracef("[comp][periscomp] word not a float");
                 $words = [];
             } else {
                 $words = [];
                 for my $sig ("", "-") {
                     for ("", 0..9,
                          ".0",".1",".2",".3",".4",".5",".6",".7",".8",".9") {
                         my $f = $sig . $word . $_;
                         next unless length $f;
                         next unless $f =~ /\A-?\d+(\.\d+)?\z/;
                         next if $f eq '-0';
                         next if $f =~ /\A-?0\d\z/;
                         next if $cs->{between} &&
                             ($f < $cs->{between}[0] ||
                                  $f > $cs->{between}[1]);
                         next if $cs->{xbetween} &&
                             ($f <= $cs->{xbetween}[0] ||
                                  $f >= $cs->{xbetween}[1]);
                         next if defined($cs->{min} ) && $f <  $cs->{min};
                         next if defined($cs->{xmin}) && $f <= $cs->{xmin};
                         next if defined($cs->{max} ) && $f >  $cs->{max};
                         next if defined($cs->{xmin}) && $f >= $cs->{xmax};
                         push @$words, $f;
                     }
                 }
             }
             return; # from eval
         }
     }; # eval
 
     $log->tracef("[periscomp] complete_from_schema died: %s", $@) if $@;
 
     goto RETURN_RES unless $words;
     $fres = hashify_answer(
         complete_array_elem(array=>$words, word=>$word, ci=>$ci),
         {static=>$static && $word eq '' ? 1:0},
     );
 
   RETURN_RES:
     $log->tracef("[comp][periscomp] leaving complete_from_schema, result=%s", $fres);
     $fres;
 }
 
 $SPEC{complete_arg_val} = {
     v => 1.1,
     summary => 'Given argument name and function metadata, complete value',
     description => <<'_',
 
 Will attempt to complete using the completion routine specified in the argument
 specification (the `completion` property, or in the case of `complete_arg_elem`
 function, the `element_completion` property), or if that is not specified, from
 argument's schema using `complete_from_schema`.
 
 Completion routine will get `%args`, with the following keys:
 
 * `word` (str, the word to be completed)
 * `ci` (bool, whether string matching should be case-insensitive)
 * `arg` (str, the argument name which value is currently being completed)
 * `index (int, only for the `complete_arg_elem` function, the index in the
    argument array that is currently being completed, starts from 0)
 * `args` (hash, the argument hash to the function, so far)
 
 as well as extra keys from `extras` (but these won't overwrite the above
 standard keys).
 
 Completion routine should return a completion answer structure (described in
 `Complete`) which is either a hash or an array. The simplest form of answer is
 just to return an array of strings. Completion routine can also return undef to
 express declination.
 
 _
     args => {
         meta => {
             summary => 'Rinci function metadata, must be normalized',
             schema => 'hash*',
             req => 1,
         },
         arg => {
             summary => 'Argument name',
             schema => 'str*',
             req => 1,
         },
         word => {
             summary => 'Word to be completed',
             schema => ['str*', default => ''],
         },
         ci => {
             summary => 'Whether to be case-insensitive',
             schema => ['bool*'],
         },
         args => {
             summary => 'Collected arguments so far, '.
                 'will be passed to completion routines',
             schema  => 'hash',
         },
         extras => {
             summary => 'Add extra arguments to completion routine',
             schema  => 'hash',
             description => <<'_',
 
 The keys from this `extras` hash will be merged into the final `%args` passed to
 completion routines. Note that standard keys like `word`, `cword`, `ci`, and so
 on as described in the function description will not be overwritten by this.
 
 _
         },
 
         %common_args_riap,
     },
     result_naked => 1,
     result => {
         schema => 'array', # XXX of => str*
     },
 };
 sub complete_arg_val {
     my %args = @_;
 
     $log->tracef("[comp][periscomp] entering complete_arg_val, arg=<%s>", $args{arg});
     my $fres;
 
     my $extras = $args{extras} // {};
 
     my $meta = $args{meta} or do {
         $log->tracef("[comp][periscomp] meta is not supplied, declining");
         goto RETURN_RES;
     };
     my $arg  = $args{arg} or do {
         $log->tracef("[comp][periscomp] arg is not supplied, declining");
         goto RETURN_RES;
     };
     my $ci   = $args{ci} // $Complete::OPT_CI;
     my $word = $args{word} // '';
 
     # XXX reject if meta's v is not 1.1
 
     my $args_prop = $meta->{args} // {};
     my $arg_spec = $args_prop->{$arg} or do {
         $log->tracef("[comp][periscomp] arg '$arg' is not specified in meta, declining");
         goto RETURN_RES;
     };
 
     my $static;
     eval { # completion sub can die, etc.
 
         my $comp;
       GET_COMP_ROUTINE:
         {
             $comp = $arg_spec->{completion};
             if ($comp) {
                 $log->tracef("[comp][periscomp] using arg completion routine from 'completion' property");
                 last GET_COMP_ROUTINE;
             }
             my $xcomp = $arg_spec->{'x.completion'};
             if ($xcomp) {
                 require Module::Path::More;
                 my $mod = "Perinci::Sub::XCompletion::$xcomp->[0]";
                 if (Module::Path::More::module_path(module=>$mod)) {
                     $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                     my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                     require $mod_pm;
                     my $fref = \&{"$mod\::gen_completion"};
                     $comp = $fref->(%{ $xcomp->[1] });
                 }
                 if ($comp) {
                     $log->tracef("[comp][periscomp] using arg completion routine from 'x.completion' attribute");
                     last GET_COMP_ROUTINE;
                 }
             }
             my $ent = $arg_spec->{'x.schema.entity'};
             if ($ent) {
                 require Module::Path::More;
                 my $mod = "Perinci::Sub::ArgEntity::$ent";
                 if (Module::Path::More::module_path(module=>$mod)) {
                     $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                     my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                     require $mod_pm;
                     if (defined &{"$mod\::complete_arg_val"}) {
                         $log->tracef("[comp][periscomp] using arg completion routine from complete_arg_val() from %s", $mod);
                         $comp = \&{"$mod\::complete_arg_val"};
                         last GET_COMP_ROUTINE;
                     }
                 }
             }
         } # GET_COMP_ROUTINE
 
         if ($comp) {
             if (ref($comp) eq 'CODE') {
                 $log->tracef("[comp][periscomp] invoking arg completion routine");
                 $fres = $comp->(
                     %$extras,
                     word=>$word, ci=>$ci, arg=>$arg, args=>$args{args});
                 return; # from eval
             } elsif (ref($comp) eq 'ARRAY') {
                 # this is deprecated but will be supported for some time
                 $log->tracef("[comp][periscomp] using array specified in arg completion routine: %s", $comp);
                 $fres = complete_array_elem(
                     array=>$comp, word=>$word, ci=>$ci);
                 $static++;
                 return; # from eval
             }
 
             $log->tracef("[comp][periscomp] arg spec's 'completion' property is not a coderef or arrayref");
             if ($args{riap_client} && $args{riap_server_url}) {
                 $log->tracef("[comp][periscomp] trying to perform complete_arg_val request to Riap server");
                 my $res = $args{riap_client}->request(
                     complete_arg_val => $args{riap_server_url},
                     {(uri=>$args{riap_uri}) x !!defined($args{riap_uri}),
                      arg=>$arg, word=>$word, ci=>$ci},
                 );
                 if ($res->[0] != 200) {
                     $log->tracef("[comp][periscomp] Riap request failed (%s), declining", $res);
                     return; # from eval
                 }
                 $fres = $res->[2];
                 return; # from eval
             }
 
             $log->tracef("[comp][periscomp] declining");
             return; # from eval
         }
 
         my $sch = $arg_spec->{schema};
         unless ($sch) {
             $log->tracef("[comp][periscomp] arg spec does not specify schema, declining");
             return; # from eval
         };
 
         # XXX normalize schema if not normalized
 
         $fres = complete_from_schema(schema=>$sch, word=>$word, ci=>$ci);
     };
     $log->debug("[comp][periscomp] completion died: $@") if $@;
     unless ($fres) {
         $log->tracef("[comp][periscomp] no completion from metadata possible, declining");
         goto RETURN_RES;
     }
 
     $fres = hashify_answer($fres);
     $fres->{static} //= $static && $word eq '' ? 1:0;
   RETURN_RES:
     $log->tracef("[comp][periscomp] leaving complete_arg_val, result=%s", $fres);
     $fres;
 }
 
 gen_modified_sub(
     output_name  => 'complete_arg_elem',
     install_sub  => 0,
     base_name    => 'complete_arg_val',
     summary      => 'Given argument name and function metadata, '.
         'complete array element',
     add_args     => {
         index => {
             summary => 'Index of element to complete',
             schema  => [int => min => 0],
         },
     },
 );
 sub complete_arg_elem {
     require Data::Sah::Normalize;
 
     my %args = @_;
 
     my $fres;
 
     $log->tracef("[comp][periscomp] entering complete_arg_elem, arg=<%s>, index=<%d>",
                  $args{arg}, $args{index});
 
     my $extras = $args{extras} // {};
 
     my $ourextras = {arg=>$args{arg}, args=>$args{args}};
 
     my $meta = $args{meta} or do {
         $log->tracef("[comp][periscomp] meta is not supplied, declining");
         goto RETURN_RES;
     };
     my $arg  = $args{arg} or do {
         $log->tracef("[comp][periscomp] arg is not supplied, declining");
         goto RETURN_RES;
     };
     defined(my $index = $args{index}) or do {
         $log->tracef("[comp][periscomp] index is not supplied, declining");
         goto RETURN_RES;
     };
     my $ci   = $args{ci} // $Complete::OPT_CI;
     my $word = $args{word} // '';
 
     # XXX reject if meta's v is not 1.1
 
     my $args_prop = $meta->{args} // {};
     my $arg_spec = $args_prop->{$arg} or do {
         $log->tracef("[comp][periscomp] arg '$arg' is not specified in meta, declining");
         goto RETURN_RES;
     };
 
     my $static;
     eval { # completion sub can die, etc.
 
         my $elcomp;
       GET_ELCOMP_ROUTINE:
         {
             $elcomp = $arg_spec->{element_completion};
             if ($elcomp) {
                 $log->tracef("[comp][periscomp] using arg element completion routine from 'element_completion' property");
                 last GET_ELCOMP_ROUTINE;
             }
             my $xelcomp = $arg_spec->{'x.element_completion'};
             if ($xelcomp) {
                require Module::Path::More;
                 my $mod = "Perinci::Sub::XCompletion::$xelcomp->[0]";
                 if (Module::Path::More::module_path(module=>$mod)) {
                     $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                     my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                     require $mod_pm;
                     my $fref = \&{"$mod\::gen_completion"};
                     $elcomp = $fref->(%{ $xelcomp->[1] });
                 }
                 if ($elcomp) {
                     $log->tracef("[comp][periscomp] using arg element completion routine from 'x.element_completion' attribute");
                     last GET_ELCOMP_ROUTINE;
                 }
             }
             my $ent = $arg_spec->{'x.schema.element_entity'};
             if ($ent) {
                 require Module::Path::More;
                 my $mod = "Perinci::Sub::ArgEntity::$ent";
                 if (Module::Path::More::module_path(module=>$mod)) {
                     $log->tracef("[comp][periscomp] loading module %s ...", $mod);
                     my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
                     require $mod_pm;
                     if (defined &{"$mod\::complete_arg_val"}) {
                         $log->tracef("[comp][periscomp] using arg element completion routine from complete_arg_val() from %s", $mod);
                         $elcomp = \&{"$mod\::complete_arg_val"};
                         last GET_ELCOMP_ROUTINE;
                     }
                 }
             }
         } # GET_ELCOMP_ROUTINE
 
         $ourextras->{index} = $index;
         if ($elcomp) {
             if (ref($elcomp) eq 'CODE') {
                 $log->tracef("[comp][periscomp] invoking arg element completion routine");
                 $fres = $elcomp->(
                     %$extras,
                     %$ourextras,
                     word=>$word, ci=>$ci);
                 return; # from eval
             } elsif (ref($elcomp) eq 'ARRAY') {
                 $log->tracef("[comp][periscomp] using array specified in arg element completion routine: %s", $elcomp);
                 $fres = complete_array_elem(
                     array=>$elcomp, word=>$word, ci=>$ci);
                 $static = $word eq '';
             }
 
             $log->tracef("[comp][periscomp] arg spec's 'element_completion' property is not a coderef or ".
                              "arrayref");
             if ($args{riap_client} && $args{riap_server_url}) {
                 $log->tracef("[comp][periscomp] trying to perform complete_arg_elem request to Riap server");
                 my $res = $args{riap_client}->request(
                     complete_arg_elem => $args{riap_server_url},
                     {(uri=>$args{riap_uri}) x !!defined($args{riap_uri}),
                      arg=>$arg, args=>$args{args}, word=>$word, ci=>$ci,
                      index=>$index},
                 );
                 if ($res->[0] != 200) {
                     $log->tracef("[comp][periscomp] Riap request failed (%s), declining", $res);
                     return; # from eval
                 }
                 $fres = $res->[2];
                 return; # from eval
             }
 
             $log->tracef("[comp][periscomp] declining");
             return; # from eval
         }
 
         my $sch = $arg_spec->{schema};
         unless ($sch) {
             $log->tracef("[comp][periscomp] arg spec does not specify schema, declining");
             return; # from eval
         };
 
         # XXX normalize if not normalized
 
         my ($type, $cs) = @{ $sch };
         if ($type ne 'array') {
             $log->tracef("[comp][periscomp] can't complete element for non-array");
             return; # from eval
         }
 
         unless ($cs->{of}) {
             $log->tracef("[comp][periscomp] schema does not specify 'of' clause, declining");
             return; # from eval
         }
 
         # normalize subschema because normalize_schema (as of 0.01) currently
         # does not do it yet
         my $elsch = Data::Sah::Normalize::normalize_schema($cs->{of});
 
         $fres = complete_from_schema(schema=>$elsch, word=>$word, ci=>$ci);
     };
     $log->debug("[comp][periscomp] completion died: $@") if $@;
     unless ($fres) {
         $log->tracef("[comp][periscomp] no completion from metadata possible, declining");
         goto RETURN_RES;
     }
 
     $fres = hashify_answer($fres);
     $fres->{static} //= $static && $word eq '' ? 1:0;
   RETURN_RES:
     $log->tracef("[comp][periscomp] leaving complete_arg_elem, result=%s", $fres);
     $fres;
 }
 
 $SPEC{complete_cli_arg} = {
     v => 1.1,
     summary => 'Complete command-line argument using Rinci function metadata',
     description => <<'_',
 
 This routine uses `Perinci::Sub::GetArgs::Argv` to generate `Getopt::Long`
 specification from arguments list in Rinci function metadata and common options.
 Then, it will use `Complete::Getopt::Long` to complete option names, option
 values, as well as arguments.
 
 _
     args => {
         meta => {
             summary => 'Rinci function metadata',
             schema => 'hash*',
             req => 1,
         },
         words => {
             summary => 'Command-line arguments',
             schema => ['array*' => {of=>'str*'}],
             req => 1,
         },
         cword => {
             summary => 'On which argument cursor is located (zero-based)',
             schema => 'int*',
             req => 1,
         },
         completion => {
             summary => 'Supply custom completion routine',
             description => <<'_',
 
 If supplied, instead of the default completion routine, this code will be called
 instead. Will receive all arguments that `Complete::Getopt::Long` will pass, and
 additionally:
 
 * `arg` (str, the name of function argument)
 * `args` (hash, the function arguments formed so far)
 * `index` (int, if completing argument element value)
 
 _
             schema => 'code*',
         },
         per_arg_json => {
             summary => 'Will be passed to Perinci::Sub::GetArgs::Argv',
             schema  => 'bool',
         },
         per_arg_yaml => {
             summary => 'Will be passed to Perinci::Sub::GetArgs::Argv',
             schema  => 'bool',
         },
         common_opts => {
             summary => 'Common options',
             description => <<'_',
 
 A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
 option specification), `handler` (Getopt::Long handler). Will be passed to
 `get_args_from_argv()`. Example:
 
     {
         help => {
             getopt  => 'help|h|?',
             handler => sub { ... },
             summary => 'Display help and exit',
         },
         version => {
             getopt  => 'version|v',
             handler => sub { ... },
             summary => 'Display version and exit',
         },
     }
 
 _
             schema => ['hash*'],
         },
         extras => {
             summary => 'Add extra arguments to completion routine',
             schema  => 'hash',
             description => <<'_',
 
 The keys from this `extras` hash will be merged into the final `%args` passed to
 completion routines. Note that standard keys like `word`, `cword`, `ci`, and so
 on as described in the function description will not be overwritten by this.
 
 _
         },
         func_arg_starts_at => {
             schema  => 'int*',
             default => 0,
             description => <<'_',
 
 This is a (temporary?) workaround for Perinci::CmdLine. In an application with
 subcommands (e.g. `cmd --verbose subcmd arg0 arg1 ...`), then `words` will still
 contain the subcommand name. Positional function arguments then start at 1 not
 0. This option allows offsetting function arguments.
 
 _
         },
         %common_args_riap,
     },
     result_naked => 1,
     result => {
         schema => 'hash*',
         description => <<'_',
 
 You can use `format_completion` function in `Complete::Bash` module to format
 the result of this function for bash.
 
 _
     },
 };
 sub complete_cli_arg {
     require Complete::Getopt::Long;
     require Perinci::Sub::GetArgs::Argv;
 
     my %args   = @_;
     my $meta   = $args{meta} or die "Please specify meta";
     my $words  = $args{words} or die "Please specify words";
     my $cword  = $args{cword}; defined($cword) or die "Please specify cword";
     my $copts  = $args{common_opts} // {};
     my $comp   = $args{completion};
     my $extras = {
         %{ $args{extras} // {} },
         words => $args{words},
         cword => $args{cword},
     };
 
     my $fname = __PACKAGE__ . "::complete_cli_arg"; # XXX use __SUB__
     my $fres;
 
     my $word   = $words->[$cword];
     my $args_prop = $meta->{args} // {};
 
     $log->tracef('[comp][periscomp] entering %s(), words=%s, cword=%d, word=<%s>',
                  $fname, $words, $cword, $word);
 
     my $genres = Perinci::Sub::GetArgs::Argv::gen_getopt_long_spec_from_meta(
         meta         => $meta,
         common_opts  => $copts,
         per_arg_json => $args{per_arg_json},
         per_arg_yaml => $args{per_arg_yaml},
         ignore_converted_code => 1,
     );
     die "Can't generate getopt spec from meta: $genres->[0] - $genres->[1]"
         unless $genres->[0] == 200;
     my $gospec = $genres->[2];
     my $specmeta = $genres->[3]{'func.specmeta'};
 
     my $gares = Perinci::Sub::GetArgs::Argv::get_args_from_argv(
         argv   => [@$words],
         meta   => $meta,
         strict => 0,
     );
 
     my $copts_by_ospec = {};
     for (keys %$copts) { $copts_by_ospec->{$copts->{$_}{getopt}}=$copts->{$_} }
 
     my $compgl_comp = sub {
         $log->tracef("[comp][periscomp] entering completion routine (that we supply to Complete::Getopt::Long)");
         my %cargs = @_;
         my $type  = $cargs{type};
         my $ospec = $cargs{ospec} // '';
         my $word  = $cargs{word};
         my $ci    = $cargs{ci} // $Complete::OPT_CI;
 
         my $fres;
 
         my %rargs = (
             riap_server_url => $args{riap_server_url},
             riap_uri        => $args{riap_uri},
             riap_client     => $args{riap_client},
         );
 
         if (my $sm = $specmeta->{$ospec}) {
             $cargs{type} = 'optval';
             if ($sm->{arg}) {
                 $log->tracef("[comp][periscomp] completing option value for a known function argument, arg=<%s>, ospec=<%s>", $sm->{arg}, $ospec);
                 $cargs{arg} = $sm->{arg};
                 my $arg_spec = $args_prop->{$sm->{arg}} or goto RETURN_RES;
                 if ($comp) {
                     $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                     my $compres;
                     eval { $compres = $comp->(%cargs) };
                     $log->debug("[comp][periscomp] completion died: $@") if $@;
                     $log->tracef("[comp][periscomp] result from 'completion' routine: %s", $compres);
                     if ($compres) {
                         $fres = $compres;
                         goto RETURN_RES;
                     }
                 }
                 if ($ospec =~ /\@$/) {
                     $fres = complete_arg_elem(
                         meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
                         word=>$word, index=>$cargs{nth}, # XXX correct index
                         extras=>$extras, %rargs);
                     goto RETURN_RES;
                 } else {
                     $fres = complete_arg_val(
                         meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
                         word=>$word, extras=>$extras, %rargs);
                     goto RETURN_RES;
                 }
             } else {
                 $log->tracef("[comp][periscomp] completing option value for a common option, ospec=<%s>", $ospec);
                 $cargs{arg}  = undef;
                 my $codata = $copts_by_ospec->{$ospec};
                 if ($comp) {
                     $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                     my $res;
                     eval { $res = $comp->(%cargs) };
                     $log->debug("[comp][periscomp] completion died: $@") if $@;
                     if ($res) {
                         $fres = $res;
                         goto RETURN_RES;
                     }
                 }
                 if ($codata->{completion}) {
                     $cargs{arg}  = undef;
                     $log->tracef("[comp][periscomp] completing with common option's 'completion' property");
                     my $res;
                     eval { $res = $codata->{completion}->(%cargs) };
                     $log->debug("[comp][periscomp] completion died: $@") if $@;
                     if ($res) {
                         $fres = $res;
                         goto RETURN_RES;
                     }
                 }
                 if ($codata->{schema}) {
                     require Data::Sah::Normalize;
                     my $nsch = Data::Sah::Normalize::normalize_schema(
                         $codata->{schema});
                     $log->tracef("[comp][periscomp] completing with common option's schema");
                     $fres = complete_from_schema(
                         schema => $nsch, word=>$word, ci=>$ci);
                     goto RETURN_RES;
                 }
                 goto RETURN_RES;
             }
         } elsif ($type eq 'arg') {
             $log->tracef("[comp][periscomp] completing argument #%d", $cargs{argpos});
             $cargs{type} = 'arg';
 
             my $pos = $cargs{argpos};
             my $fasa = $args{func_arg_starts_at} // 0;
 
             # find if there is a non-greedy argument with the exact position
             for my $an (keys %$args_prop) {
                 my $arg_spec = $args_prop->{$an};
                 next unless !$arg_spec->{greedy} &&
                     defined($arg_spec->{pos}) && $arg_spec->{pos} == $pos - $fasa;
                 $log->tracef("[comp][periscomp] this argument position is for non-greedy function argument <%s>", $an);
                 $cargs{arg} = $an;
                 if ($comp) {
                     $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                     my $res;
                     eval { $res = $comp->(%cargs) };
                     $log->debug("[comp][periscomp] completion died: $@") if $@;
                     if ($res) {
                         $fres = $res;
                         goto RETURN_RES;
                     }
                 }
                 $fres = complete_arg_val(
                     meta=>$meta, arg=>$an, args=>$gares->[2],
                     word=>$word, extras=>$extras, %rargs);
                 goto RETURN_RES;
             }
 
             # find if there is a greedy argument which takes elements at that
             # position
             for my $an (sort {
                 ($args_prop->{$b}{pos} // 9999) <=> ($args_prop->{$a}{pos} // 9999)
             } keys %$args_prop) {
                 my $arg_spec = $args_prop->{$an};
                 next unless $arg_spec->{greedy} &&
                     defined($arg_spec->{pos}) && $arg_spec->{pos} <= $pos - $fasa;
                 my $index = $pos - $fasa - $arg_spec->{pos};
                 $cargs{arg} = $an;
                 $cargs{index} = $index;
                 $log->tracef("[comp][periscomp] this position is for greedy function argument <%s>'s element[%d]", $an, $index);
                 if ($comp) {
                     $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                     my $res;
                     eval { $res = $comp->(%cargs) };
                     $log->debug("[comp][periscomp] completion died: $@") if $@;
                     if ($res) {
                         $fres = $res;
                         goto RETURN_RES;
                     }
                 }
                 $fres = complete_arg_elem(
                     meta=>$meta, arg=>$an, args=>$gares->[2],
                     word=>$word, index=>$index, extras=>$extras, %rargs);
                 goto RETURN_RES;
             }
 
             $log->tracef("[comp][periscomp] there is no matching function argument at this position");
             if ($comp) {
                 $log->tracef("[comp][periscomp] invoking routine supplied from 'completion' argument");
                 my $res;
                 eval { $res = $comp->(%cargs) };
                 $log->debug("[comp][periscomp] completion died: $@") if $@;
                 if ($res) {
                     $fres = $res;
                     goto RETURN_RES;
                 }
             }
             goto RETURN_RES;
         } else {
             $log->tracef("[comp][periscomp] completing option value for an unknown/ambiguous option, declining ...");
             # decline because there's nothing in Rinci metadata that can aid us
             goto RETURN_RES;
         }
       RETURN_RES:
         $log->tracef("[comp][periscomp] leaving completion routine (that we supply to Complete::Getopt::Long)");
         $fres;
     }; # completion routine
 
     $fres = Complete::Getopt::Long::complete_cli_arg(
         getopt_spec => $gospec,
         words       => $words,
         cword       => $cword,
         completion  => $compgl_comp,
         extras      => $extras,
     );
 
   RETURN_RES:
     $log->tracef('[comp][periscomp] leaving %s(), result=%s',
                  $fname, $fres);
     $fres;
 }
 
 1;
 # ABSTRACT: Complete command-line argument using Rinci metadata
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::Complete - Complete command-line argument using Rinci metadata
 
 =head1 VERSION
 
 This document describes version 0.80 of Perinci::Sub::Complete (from Perl distribution Perinci-Sub-Complete), released on 2015-08-11.
 
 =head1 SYNOPSIS
 
 See L<Perinci::CmdLine> or L<Perinci::CmdLine::Lite> or L<App::riap> which use
 this module.
 
 =head1 DESCRIPTION
 
 =head1 FUNCTIONS
 
 
 =head2 complete_arg_elem(%args) -> array
 
 {en_US Given argument name and function metadata, complete array element}.
 
 {en_US 
 Will attempt to complete using the completion routine specified in the argument
 specification (the C<completion> property, or in the case of C<complete_arg_elem>
 function, the C<element_completion> property), or if that is not specified, from
 argument's schema using C<complete_from_schema>.
 
 Completion routine will get C<%args>, with the following keys:
 
 =over
 
 =item * C<word> (str, the word to be completed)
 
 =item * C<ci> (bool, whether string matching should be case-insensitive)
 
 =item * C<arg> (str, the argument name which value is currently being completed)
 
 =item * C<index (int, only for the>complete_arg_elem` function, the index in the
 argument array that is currently being completed, starts from 0)
 
 =item * C<args> (hash, the argument hash to the function, so far)
 
 =back
 
 as well as extra keys from C<extras> (but these won't overwrite the above
 standard keys).
 
 Completion routine should return a completion answer structure (described in
 C<Complete>) which is either a hash or an array. The simplest form of answer is
 just to return an array of strings. Completion routine can also return undef to
 express declination.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<arg>* => I<str>
 
 {en_US Argument name}.
 
 =item * B<args> => I<hash>
 
 {en_US Collected arguments so far, will be passed to completion routines}.
 
 =item * B<ci> => I<bool>
 
 {en_US Whether to be case-insensitive}.
 
 =item * B<extras> => I<hash>
 
 {en_US Add extra arguments to completion routine}.
 
 {en_US 
 The keys from this C<extras> hash will be merged into the final C<%args> passed to
 completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
 on as described in the function description will not be overwritten by this.
 }
 
 =item * B<index> => I<int>
 
 {en_US Index of element to complete}.
 
 =item * B<meta>* => I<hash>
 
 {en_US Rinci function metadata, must be normalized}.
 
 =item * B<riap_client> => I<obj>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 When the argument spec in the Rinci metadata contains C<completion> key, this
 means there is custom completion code for that argument. However, if retrieved
 from a remote server, sometimes the C<completion> key no longer contains the code
 (it has been cleansed into a string). Moreover, the completion code needs to run
 on the server.
 
 If supplied this argument and te C<riap_server_url> argument, the function will
 try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
 the function will just give up/decline completing.
 }
 
 =item * B<riap_server_url> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<riap_uri> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<word> => I<str> (default: "")
 
 {en_US Word to be completed}.
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_arg_val(%args) -> array
 
 {en_US Given argument name and function metadata, complete value}.
 
 {en_US 
 Will attempt to complete using the completion routine specified in the argument
 specification (the C<completion> property, or in the case of C<complete_arg_elem>
 function, the C<element_completion> property), or if that is not specified, from
 argument's schema using C<complete_from_schema>.
 
 Completion routine will get C<%args>, with the following keys:
 
 =over
 
 =item * C<word> (str, the word to be completed)
 
 =item * C<ci> (bool, whether string matching should be case-insensitive)
 
 =item * C<arg> (str, the argument name which value is currently being completed)
 
 =item * C<index (int, only for the>complete_arg_elem` function, the index in the
 argument array that is currently being completed, starts from 0)
 
 =item * C<args> (hash, the argument hash to the function, so far)
 
 =back
 
 as well as extra keys from C<extras> (but these won't overwrite the above
 standard keys).
 
 Completion routine should return a completion answer structure (described in
 C<Complete>) which is either a hash or an array. The simplest form of answer is
 just to return an array of strings. Completion routine can also return undef to
 express declination.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<arg>* => I<str>
 
 {en_US Argument name}.
 
 =item * B<args> => I<hash>
 
 {en_US Collected arguments so far, will be passed to completion routines}.
 
 =item * B<ci> => I<bool>
 
 {en_US Whether to be case-insensitive}.
 
 =item * B<extras> => I<hash>
 
 {en_US Add extra arguments to completion routine}.
 
 {en_US 
 The keys from this C<extras> hash will be merged into the final C<%args> passed to
 completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
 on as described in the function description will not be overwritten by this.
 }
 
 =item * B<meta>* => I<hash>
 
 {en_US Rinci function metadata, must be normalized}.
 
 =item * B<riap_client> => I<obj>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 When the argument spec in the Rinci metadata contains C<completion> key, this
 means there is custom completion code for that argument. However, if retrieved
 from a remote server, sometimes the C<completion> key no longer contains the code
 (it has been cleansed into a string). Moreover, the completion code needs to run
 on the server.
 
 If supplied this argument and te C<riap_server_url> argument, the function will
 try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
 the function will just give up/decline completing.
 }
 
 =item * B<riap_server_url> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<riap_uri> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<word> => I<str> (default: "")
 
 {en_US Word to be completed}.
 
 =back
 
 Return value:  (array)
 
 
 =head2 complete_cli_arg(%args) -> hash
 
 {en_US Complete command-line argument using Rinci function metadata}.
 
 {en_US 
 This routine uses C<Perinci::Sub::GetArgs::Argv> to generate C<Getopt::Long>
 specification from arguments list in Rinci function metadata and common options.
 Then, it will use C<Complete::Getopt::Long> to complete option names, option
 values, as well as arguments.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<common_opts> => I<hash>
 
 {en_US Common options}.
 
 {en_US 
 A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
 option specification), C<handler> (Getopt::Long handler). Will be passed to
 C<get_args_from_argv()>. Example:
 
  {
      help => {
          getopt  => 'help|h|?',
          handler => sub { ... },
          summary => 'Display help and exit',
      },
      version => {
          getopt  => 'version|v',
          handler => sub { ... },
          summary => 'Display version and exit',
      },
  }
 
 }
 
 =item * B<completion> => I<code>
 
 {en_US Supply custom completion routine}.
 
 {en_US 
 If supplied, instead of the default completion routine, this code will be called
 instead. Will receive all arguments that C<Complete::Getopt::Long> will pass, and
 additionally:
 
 =over
 
 =item * C<arg> (str, the name of function argument)
 
 =item * C<args> (hash, the function arguments formed so far)
 
 =item * C<index> (int, if completing argument element value)
 }
 
 =back
 
 =item * B<cword>* => I<int>
 
 {en_US On which argument cursor is located (zero-based)}.
 
 =item * B<extras> => I<hash>
 
 {en_US Add extra arguments to completion routine}.
 
 {en_US 
 The keys from this C<extras> hash will be merged into the final C<%args> passed to
 completion routines. Note that standard keys like C<word>, C<cword>, C<ci>, and so
 on as described in the function description will not be overwritten by this.
 }
 
 =item * B<func_arg_starts_at> => I<int> (default: 0)
 
 {en_US 
 This is a (temporary?) workaround for Perinci::CmdLine. In an application with
 subcommands (e.g. C<cmd --verbose subcmd arg0 arg1 ...>), then C<words> will still
 contain the subcommand name. Positional function arguments then start at 1 not
 0. This option allows offsetting function arguments.
 }
 
 =item * B<meta>* => I<hash>
 
 {en_US Rinci function metadata}.
 
 =item * B<per_arg_json> => I<bool>
 
 {en_US Will be passed to Perinci::Sub::GetArgs::Argv}.
 
 =item * B<per_arg_yaml> => I<bool>
 
 {en_US Will be passed to Perinci::Sub::GetArgs::Argv}.
 
 =item * B<riap_client> => I<obj>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 When the argument spec in the Rinci metadata contains C<completion> key, this
 means there is custom completion code for that argument. However, if retrieved
 from a remote server, sometimes the C<completion> key no longer contains the code
 (it has been cleansed into a string). Moreover, the completion code needs to run
 on the server.
 
 If supplied this argument and te C<riap_server_url> argument, the function will
 try to request to the server (via Riap request C<complete_arg_val>). Otherwise,
 the function will just give up/decline completing.
 }
 
 =item * B<riap_server_url> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<riap_uri> => I<str>
 
 {en_US Optional, to perform complete_arg_val to the server}.
 
 {en_US 
 See the C<riap_client> argument.
 }
 
 =item * B<words>* => I<array[str]>
 
 {en_US Command-line arguments}.
 
 =back
 
 Return value:  (hash)
 
 
 {en_US 
 You can use C<format_completion> function in C<Complete::Bash> module to format
 the result of this function for bash.
 }
 
 
 =head2 complete_from_schema(%args) -> [status, msg, result, meta]
 
 {en_US Complete a value from schema}.
 
 {en_US 
 Employ some heuristics to complete a value from Sah schema. For example, if
 schema is C<< [str =E<gt> in =E<gt> [qw/new open resolved rejected/]] >>, then we can
 complete from the C<in> clause. Or for something like C<< [int =E<gt> between =E<gt> [1,
 20]] >> we can complete using values from 1 to 20.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<ci> => I<bool>
 
 =item * B<schema>* => I<any>
 
 {en_US Must be normalized}.
 
 =item * B<word>* => I<str> (default: "")
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (any)
 
 =for Pod::Coverage ^(.+)$
 
 =head1 SEE ALSO
 
 L<Complete>, L<Complete::Getopt::Long>
 
 L<Perinci::CmdLine>, L<Perinci::CmdLine::Lite>, L<App::riap>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Complete>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Complete>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Complete>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/GetArgs/Argv.pm ###
 package Perinci::Sub::GetArgs::Argv;
 
 our $DATE = '2015-08-19'; # DATE
 our $VERSION = '0.69'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 #use Log::Any '$log';
 
 use Data::Sah::Normalize qw(normalize_schema);
 use Getopt::Long::Negate::EN qw(negations_for_option);
 use Getopt::Long::Util qw(parse_getopt_long_opt_spec);
 use List::Util qw(first);
 use Perinci::Sub::GetArgs::Array qw(get_args_from_array);
 use Perinci::Sub::Util qw(err);
 
 use Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        gen_getopt_long_spec_from_meta
                        get_args_from_argv
                );
 
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'Get subroutine arguments from command line arguments (@ARGV)',
 };
 
 my $re_simple_scalar = qr/^(str|num|int|float|bool|buf|re|date|duration)$/;
 
 # retun ($success?, $errmsg, $res)
 sub _parse_json {
     my $str = shift;
 
     state $json = do {
         require JSON::PP;
         JSON::PP->new->allow_nonref;
     };
 
     # to rid of those JSON::PP::Boolean objects which currently choke
     # Data::Sah-generated validator code. in the future Data::Sah can be
     # modified to handle those, or we use a fork of JSON::PP which doesn't
     # produce those in the first place (probably only when performance is
     # critical).
     state $cleanser = do {
         if (eval { require Data::Clean::FromJSON; 1 }) {
             Data::Clean::FromJSON->get_cleanser;
         } else {
             undef;
         }
     };
 
     my $res;
     eval { $res = $json->decode($str); $cleanser->clean_in_place($res) if $cleanser };
     my $e = $@;
     return (!$e, $e, $res);
 }
 
 sub _parse_yaml {
     no warnings 'once';
 
     state $yaml_xs_available = do {
         if (eval { require YAML::XS; 1 }) {
             1;
         } else {
             require YAML::Old;
             0;
         }
     };
 
     my $str = shift;
 
     #local $YAML::Syck::ImplicitTyping = 1;
     my $res;
     eval {
         if ($yaml_xs_available) {
             $res = YAML::XS::Load($str);
         } else {
             # YAML::Old is too strict, it requires "--- " header and newline
             # ending
             $str = "--- $str" unless $str =~ /\A--- /;
             $str .= "\n" unless $str =~ /\n\z/;
             $res = YAML::Old::Load($str);
         }
     };
     my $e = $@;
     return (!$e, $e, $res);
 }
 
 sub _arg2opt {
     my $opt = shift;
     $opt =~ s/[^A-Za-z0-9-]+/-/g; # foo.bar_baz becomes --foo-bar-baz
     $opt;
 }
 
 # return one or more triplets of Getopt::Long option spec, its parsed structure,
 # and extra stuffs. we do this to avoid having to call
 # parse_getopt_long_opt_spec().
 sub _opt2ospec {
     my ($opt, $schema, $arg_spec) = @_;
     my $type = $schema->[0];
     my $cs   = $schema->[1];
     my $is_array_of_simple_scalar = $type eq 'array' &&
         $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
     if ($is_array_of_simple_scalar && $arg_spec && $arg_spec->{'x.name.is_plural'}) {
         if ($arg_spec->{'x.name.singular'}) {
             $opt = $arg_spec->{'x.name.singular'};
         } else {
             require Lingua::EN::PluralToSingular;
             $opt = Lingua::EN::PluralToSingular::to_singular($opt);
         }
     }
     if ($type eq 'bool') {
         if (length($opt) == 1 || $cs->{is}) {
             # single-letter option like -b doesn't get --nob.
             # [bool=>{is=>1}] also means it's a flag and should not get
             # --nofoo.
             return ($opt, {opts=>[$opt]});
         } else {
             my @res;
             my @negs = negations_for_option($opt);
             push @res, $opt, {opts=>[$opt]}, {is_neg=>0, neg_opts=>\@negs};
             for (@negs) {
                 push @res, $_, {opts=>[$_]}, {is_neg=>1, pos_opts=>[$opt]};
             }
             return @res;
         }
     } elsif ($type eq 'buf') {
         return (
             "$opt=s", {opts=>[$opt], desttype=>"", type=>"s"}, undef,
             "$opt-base64=s", {opts=>["$opt-base64"], desttype=>"", type=>"s"}, {is_base64=>1},
         );
     } else {
         my $t = ($type eq 'int' ? 'i' : $type eq 'float' ? 'f' :
                      $is_array_of_simple_scalar ? 's@' : 's');
         return ("$opt=$t", {opts=>[$opt], desttype=>"", type=>$t});
     }
 }
 
 sub _args2opts {
     my %args = @_;
 
     my $argprefix        = $args{argprefix};
     my $parent_args      = $args{parent_args};
     my $meta             = $args{meta};
     my $seen_opts        = $args{seen_opts};
     my $seen_common_opts = $args{seen_common_opts};
     my $seen_func_opts   = $args{seen_func_opts};
     my $rargs            = $args{rargs};
     my $go_spec          = $args{go_spec};
     my $specmeta         = $args{specmeta};
 
     my $args_prop = $meta->{args} // {};
 
     for my $arg (keys %$args_prop) {
         my $fqarg    = "$argprefix$arg";
         my $arg_spec = $args_prop->{$arg};
         my $sch      = $arg_spec->{schema} // ['any', {}];
         my $type     = $sch->[0] // '';
         my $cs       = $sch->[1] // {};
 
         # XXX normalization of 'of' clause should've been handled by sah itself
         if ($type eq 'array' && $cs->{of}) {
             $cs->{of} = normalize_schema($cs->{of});
         }
         my $opt = _arg2opt($fqarg);
         if ($seen_opts->{$opt}) {
             my $i = 1;
             my $opt2;
             while (1) {
                 $opt2 = "$opt-arg" . ($i > 1 ? $i : '');
                 last unless $seen_opts->{$opt2};
                 $i++;
             }
             $opt = $opt2;
         }
 
         my $is_simple_scalar = $type =~ $re_simple_scalar;
         my $is_array_of_simple_scalar = $type eq 'array' &&
             $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
 
         my $stash = {};
 
         # why we use coderefs here? due to Getopt::Long's behavior. when
         # @ARGV=qw() and go_spec is ('foo=s' => \$opts{foo}) then %opts will
         # become (foo=>undef). but if go_spec is ('foo=s' => sub { $opts{foo} =
         # $_[1] }) then %opts will become (), which is what we prefer, so we can
         # later differentiate "unspecified" (exists($opts{foo}) == false) and
         # "specified as undef" (exists($opts{foo}) == true but
         # defined($opts{foo}) == false).
 
         my $handler = sub {
             my ($val, $val_set);
 
             # how many times have been called for this argument?
             my $num_called = ++$stash->{called}{$arg};
 
             # hashify rargs till the end of the handler scope if it happens to
             # be an array (this is the case when we want to fill values using
             # element_meta).
             my $rargs = do {
                 if (ref($rargs) eq 'ARRAY') {
                     $rargs->[$num_called-1] //= {};
                     $rargs->[$num_called-1];
                 } else {
                     $rargs;
                 }
             };
 
             if ($is_array_of_simple_scalar) {
                 $rargs->{$arg} //= [];
                 $val_set = 1; $val = $_[1];
                 push @{ $rargs->{$arg} }, $val;
             } elsif ($is_simple_scalar) {
                 $val_set = 1; $val = $_[1];
                 $rargs->{$arg} = $val;
             } else {
                 {
                     my ($success, $e, $decoded);
                     ($success, $e, $decoded) = _parse_json($_[1]);
                     if ($success) {
                         $val_set = 1; $val = $decoded;
                         $rargs->{$arg} = $val;
                         last;
                     }
                     ($success, $e, $decoded) = _parse_yaml($_[1]);
                     if ($success) {
                         $val_set = 1; $val = $decoded;
                         $rargs->{$arg} = $val;
                         last;
                     }
                     die "Invalid YAML/JSON in arg '$fqarg'";
                 }
             }
             if ($val_set && $arg_spec->{cmdline_on_getopt}) {
                 $arg_spec->{cmdline_on_getopt}->(
                     arg=>$arg, fqarg=>$fqarg, value=>$val, args=>$rargs,
                     opt=>$opt,
                 );
             }
         }; # handler
 
         my @triplets = _opt2ospec($opt, $sch, $arg_spec);
         my $aliases_processed;
         while (my ($ospec, $parsed, $extra) = splice @triplets, 0, 3) {
             $extra //= {};
             if ($extra->{is_neg}) {
                 $go_spec->{$ospec} = sub { $handler->($_[0], 0) };
             } elsif (defined $extra->{is_neg}) {
                 $go_spec->{$ospec} = sub { $handler->($_[0], 1) };
             } elsif ($extra->{is_base64}) {
                 $go_spec->{$ospec} = sub {
                     require MIME::Base64;
                     my $decoded = MIME::Base64::decode($_[1]);
                     $handler->($_[0], $decoded);
                 };
             } else {
                 $go_spec->{$ospec} = $handler;
             }
 
             $specmeta->{$ospec} = {arg=>$arg, fqarg=>$fqarg, parsed=>$parsed, %$extra};
             for (@{ $parsed->{opts} }) {
                 $seen_opts->{$_}++; $seen_func_opts->{$_} = $fqarg;
             }
 
             if ($parent_args->{per_arg_json} && $type !~ $re_simple_scalar) {
                 my $jopt = "$opt-json";
                 if ($seen_opts->{$jopt}) {
                     warn "Clash of option: $jopt, not added";
                 } else {
                     my $jospec = "$jopt=s";
                     my $parsed = {type=>"s", opts=>[$jopt]};
                     $go_spec->{$jospec} = sub {
                         my ($success, $e, $decoded);
                         ($success, $e, $decoded) = _parse_json($_[1]);
                         if ($success) {
                             $rargs->{$arg} = $decoded;
                         } else {
                             die "Invalid JSON in option --$jopt: $_[1]: $e";
                         }
                     };
                     $specmeta->{$jospec} = {arg=>$arg, fqarg=>$fqarg, is_json=>1, parsed=>$parsed, %$extra};
                     $seen_opts->{$jopt}++; $seen_func_opts->{$jopt} = $fqarg;
                 }
             }
             if ($parent_args->{per_arg_yaml} && $type !~ $re_simple_scalar) {
                 my $yopt = "$opt-yaml";
                 if ($seen_opts->{$yopt}) {
                     warn "Clash of option: $yopt, not added";
                 } else {
                     my $yospec = "$yopt=s";
                     my $parsed = {type=>"s", opts=>[$yopt]};
                     $go_spec->{$yospec} = sub {
                         my ($success, $e, $decoded);
                         ($success, $e, $decoded) = _parse_yaml($_[1]);
                         if ($success) {
                             $rargs->{$arg} = $decoded;
                         } else {
                             die "Invalid YAML in option --$yopt: $_[1]: $e";
                         }
                     };
                     $specmeta->{$yospec} = {arg=>$arg, fqarg=>$fqarg, is_yaml=>1, parsed=>$parsed, %$extra};
                     $seen_opts->{$yopt}++; $seen_func_opts->{$yopt} = $fqarg;
                 }
             }
 
             # parse argv_aliases
             if ($arg_spec->{cmdline_aliases} && !$aliases_processed++) {
                 for my $al (keys %{$arg_spec->{cmdline_aliases}}) {
                     my $alspec = $arg_spec->{cmdline_aliases}{$al};
                     my $alsch = $alspec->{schema} //
                         $alspec->{is_flag} ? [bool=>{req=>1,is=>1}] : $sch;
                     my $altype = $alsch->[0];
                     my $alopt = _arg2opt("$argprefix$al");
                     if ($seen_opts->{$alopt}) {
                         warn "Clash of cmdline_alias option $al";
                         next;
                     }
                     my $alcode = $alspec->{code};
                     my $alospec;
                     my $parsed;
                     if ($alcode && $alsch->[0] eq 'bool') {
                         # bool --alias doesn't get --noalias if has code
                         $alospec = $alopt; # instead of "$alopt!"
                         $parsed = {opts=>[$alopt]};
                     } else {
                         ($alospec, $parsed) = _opt2ospec($alopt, $alsch);
                     }
 
                     if ($alcode) {
                         if ($alcode eq 'CODE') {
                             if ($parent_args->{ignore_converted_code}) {
                                 $alcode = sub {};
                             } else {
                                 return [
                                     501,
                                     join("",
                                          "Code in cmdline_aliases for arg $fqarg ",
                                          "got converted into string, probably ",
                                          "because of JSON/YAML transport"),
                                 ];
                             }
                         }
                         # alias handler
                         $go_spec->{$alospec} = sub {
 
                             # do the same like in arg handler
                             my $num_called = ++$stash->{called}{$arg};
                             my $rargs = do {
                                 if (ref($rargs) eq 'ARRAY') {
                                     $rargs->[$num_called-1] //= {};
                                     $rargs->[$num_called-1];
                                 } else {
                                     $rargs;
                                 }
                             };
 
                             $alcode->($rargs, $_[1]);
                         };
                     } else {
                         $go_spec->{$alospec} = $handler;
                     }
                     $specmeta->{$alospec} = {
                         alias     => $al,
                         is_alias  => 1,
                         alias_for => $ospec,
                         arg       => $arg,
                         fqarg     => $fqarg,
                         is_code   => $alcode ? 1:0,
                         parsed    => $parsed,
                         %$extra,
                     };
                     push @{$specmeta->{$ospec}{($alcode ? '':'non').'code_aliases'}},
                         $alospec;
                     $seen_opts->{$alopt}++; $seen_func_opts->{$alopt} = $fqarg;
                 }
             } # cmdline_aliases
 
             # submetadata
             if ($arg_spec->{meta}) {
                 $rargs->{$arg} = {};
                 my $res = _args2opts(
                     %args,
                     argprefix => "$argprefix$arg\::",
                     meta      => $arg_spec->{meta},
                     rargs     => $rargs->{$arg},
                 );
                 return $res if $res;
             }
 
             # element submetadata
             if ($arg_spec->{element_meta}) {
                 $rargs->{$arg} = [];
                 my $res = _args2opts(
                     %args,
                     argprefix => "$argprefix$arg\::",
                     meta      => $arg_spec->{element_meta},
                     rargs     => $rargs->{$arg},
                 );
                 return $res if $res;
             }
         } # for ospec triplet
 
     } # for arg
 
     undef;
 }
 
 $SPEC{gen_getopt_long_spec_from_meta} = {
     v           => 1.1,
     summary     => 'Generate Getopt::Long spec from Rinci function metadata',
     description => <<'_',
 
 This routine will produce a `Getopt::Long` specification from Rinci function
 metadata, as well as some more data structure in the result metadata to help
 producing a command-line help/usage message.
 
 Function arguments will be mapped to command-line options with the same name,
 with non-alphanumeric characters changed to `-` (`-` is preferred over `_`
 because it lets user avoid pressing Shift on popular keyboards). For example:
 `file_size` becomes `file-size`, `file_size.max` becomes `file-size-max`. If
 function argument option name clashes with command-line option or another
 existing option, it will be renamed to `NAME-arg` (or `NAME-arg2` and so on).
 For example: `help` will become `help-arg` (if `common_opts` contains `help`,
 that is).
 
 Each command-line alias (`cmdline_aliases` property) in the argument
 specification will also be added as command-line option, except if it clashes
 with an existing option, in which case this function will warn and skip adding
 the alias. For more information about `cmdline_aliases`, see `Rinci::function`.
 
 For arguments with type of `bool`, Getopt::Long will by default also
 automatically recognize `--noNAME` or `--no-NAME` in addition to `--name`. So
 this function will also check those names for clashes.
 
 For arguments with type array of simple scalar, `--NAME` can be specified more
 than once to append to the array.
 
 If `per_arg_json` setting is active, and argument's schema is not a "required
 simple scalar" (e.g. an array, or a nullable string), then `--NAME-json` will
 also be added to let users input undef (through `--NAME-json null`) or a
 non-scalar value (e.g. `--NAME-json '[1,2,3]'`). If this name conflicts with
 another existing option, a warning will be displayed and the option will not be
 added.
 
 If `per_arg_yaml` setting is active, and argument's schema is not a "required
 simple scalar" (e.g. an array, or a nullable string), then `--NAME-yaml` will
 also be added to let users input undef (through `--NAME-yaml '~'`) or a
 non-scalar value (e.g. `--NAME-yaml '[foo, bar]'`). If this name conflicts with
 another existing option, a warning will be displayed and the option will not be
 added. YAML can express a larger set of values, e.g. binary data, circular
 references, etc.
 
 Will produce a hash (Getopt::Long spec), with `func.specmeta`, `func.opts`,
 `func.common_opts`, `func.func_opts` that contain extra information
 (`func.specmeta` is a hash of getopt spec name and a hash of extra information
 while `func.*opts` lists all used option names).
 
 _
     args => {
         meta => {
             summary => 'Rinci function metadata',
             schema  => 'hash*',
             req     => 1,
         },
         meta_is_normalized => {
             schema => 'bool*',
         },
         args => {
             summary => 'Reference to hash which will store the result',
             schema  => 'hash*',
         },
         common_opts => {
             summary => 'Common options',
             description => <<'_',
 
 A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
 option specification), `handler` (Getopt::Long handler). Will be passed to
 `get_args_from_argv()`. Example:
 
     {
         help => {
             getopt  => 'help|h|?',
             handler => sub { ... },
             summary => 'Display help and exit',
         },
         version => {
             getopt  => 'version|v',
             handler => sub { ... },
             summary => 'Display version and exit',
         },
     }
 
 _
             schema => ['hash*'],
         },
         per_arg_json => {
             summary => 'Whether to add --NAME-json for non-simple arguments',
             schema  => 'bool',
             default => 0,
             description => <<'_',
 
 Will also interpret command-line arguments as JSON if assigned to function
 arguments, if arguments' schema is not simple scalar.
 
 _
         },
         per_arg_yaml => {
             summary => 'Whether to add --NAME-yaml for non-simple arguments',
             schema  => 'bool',
             default => 0,
             description => <<'_',
 
 Will also interpret command-line arguments as YAML if assigned to function
 arguments, if arguments' schema is not simple scalar.
 
 _
         },
         ignore_converted_code => {
             summary => 'Whether to ignore coderefs converted to string',
             schema => 'bool',
             default => 0,
             description => <<'_',
 
 Across network through JSON encoding, coderef in metadata (e.g. in
 `cmdline_aliases` property) usually gets converted to string `CODE`. In some
 cases, like for tab completion, this is pretty harmless so you can turn this
 option on. For example, in the case of `cmdline_aliases`, the effect is just
 that command-line aliases code are not getting executed, but this is usually
 okay.
 
 _
         },
     },
 };
 sub gen_getopt_long_spec_from_meta {
     my %fargs = @_;
 
     my $meta       = $fargs{meta} or return [400, "Please specify meta"];
     unless ($fargs{meta_is_normalized}) {
         require Perinci::Sub::Normalize;
         $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
     }
     my $co           = $fargs{common_opts} // {};
     my $per_arg_yaml = $fargs{per_arg_yaml} // 0;
     my $per_arg_json = $fargs{per_arg_json} // 0;
     my $ignore_converted_code = $fargs{ignore_converted_code};
     my $rargs        = $fargs{args} // {};
 
     my %go_spec;
     my %specmeta; # key = option spec, val = hash of extra info
     my %seen_opts;
     my %seen_common_opts;
     my %seen_func_opts;
 
     for my $k (keys %$co) {
         my $v = $co->{$k};
         my $ospec   = $v->{getopt};
         my $handler = $v->{handler};
         my $res = parse_getopt_long_opt_spec($ospec)
             or return [400, "Can't parse common opt spec '$ospec'"];
         $go_spec{$ospec} = $handler;
         $specmeta{$ospec} = {common_opt=>$k, arg=>undef, parsed=>$res};
         for (@{ $res->{opts} }) {
             return [412, "Clash of common opt '$_'"] if $seen_opts{$_};
             $seen_opts{$_}++; $seen_common_opts{$_} = $ospec;
             if ($res->{is_neg}) {
                 $seen_opts{"no$_"}++ ; $seen_common_opts{"no$_"}  = $ospec;
                 $seen_opts{"no-$_"}++; $seen_common_opts{"no-$_"} = $ospec;
             }
         }
     }
 
     my $res = _args2opts(
         argprefix        => "",
         parent_args      => \%fargs,
         meta             => $meta,
         seen_opts        => \%seen_opts,
         seen_common_opts => \%seen_common_opts,
         seen_func_opts   => \%seen_func_opts,
         rargs            => $rargs,
         go_spec          => \%go_spec,
         specmeta         => \%specmeta,
     );
     return $res if $res;
 
     my $opts        = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_opts)];
     my $common_opts = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_common_opts)];
     my $func_opts   = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_func_opts)];
     my $opts_by_common = {};
     for my $k (keys %$co) {
         my $v = $co->{$k};
         my $ospec = $v->{getopt};
         my @opts;
         for (keys %seen_common_opts) {
             next unless $seen_common_opts{$_} eq $ospec;
             push @opts, (length($_)>1 ? "--$_":"-$_");
         }
         $opts_by_common->{$ospec} = [sort @opts];
     }
 
     my $opts_by_arg = {};
     for (keys %seen_func_opts) {
         my $fqarg = $seen_func_opts{$_};
         push @{ $opts_by_arg->{$fqarg} }, length($_)>1 ? "--$_":"-$_";
     }
     for (keys %$opts_by_arg) {
         $opts_by_arg->{$_} = [sort @{ $opts_by_arg->{$_} }];
     }
 
     [200, "OK", \%go_spec,
      {
          "func.specmeta"       => \%specmeta,
          "func.opts"           => $opts,
          "func.common_opts"    => $common_opts,
          "func.func_opts"      => $func_opts,
          "func.opts_by_arg"    => $opts_by_arg,
          "func.opts_by_common" => $opts_by_common,
      }];
 }
 
 $SPEC{get_args_from_argv} = {
     v => 1.1,
     summary => 'Get subroutine arguments (%args) from command-line arguments '.
         '(@ARGV)',
     description => <<'_',
 
 Using information in Rinci function metadata's `args` property, parse command
 line arguments `@argv` into hash `%args`, suitable for passing into subroutines.
 
 Currently uses Getopt::Long's GetOptions to do the parsing.
 
 As with GetOptions, this function modifies its `argv` argument, so you might
 want to copy the original `argv` first (or pass a copy instead) if you want to
 preserve the original.
 
 See also: gen_getopt_long_spec_from_meta() which is the routine that generates
 the specification.
 
 _
     args => {
         argv => {
             schema => ['array*' => {
                 of => 'str*',
             }],
             description => 'If not specified, defaults to @ARGV',
         },
         args => {
             summary => 'Specify input args, with some arguments preset',
             schema  => ['hash'],
         },
         meta => {
             schema => ['hash*' => {}],
             req => 1,
         },
         meta_is_normalized => {
             summary => 'Can be set to 1 if your metadata is normalized, '.
                 'to avoid duplicate effort',
             schema => 'bool',
             default => 0,
         },
         strict => {
             schema => ['bool' => {default=>1}],
             summary => 'Strict mode',
             description => <<'_',
 
 If set to 0, will still return parsed argv even if there are parsing errors
 (reported by Getopt::Long). If set to 1 (the default), will die upon error.
 
 Normally you would want to use strict mode, for more error checking. Setting off
 strict is used by, for example, Perinci::Sub::Complete during completion where
 the command-line might still be incomplete.
 
 Should probably be named `ignore_errors`. :-)
 
 _
         },
         per_arg_yaml => {
             schema => ['bool' => {default=>0}],
             summary => 'Whether to recognize --ARGNAME-yaml',
             description => <<'_',
 
 This is useful for example if you want to specify a value which is not
 expressible from the command-line, like 'undef'.
 
     % script.pl --name-yaml '~'
 
 See also: per_arg_json. You should enable just one instead of turning on both.
 
 _
         },
         per_arg_json => {
             schema => ['bool' => {default=>0}],
             summary => 'Whether to recognize --ARGNAME-json',
             description => <<'_',
 
 This is useful for example if you want to specify a value which is not
 expressible from the command-line, like 'undef'.
 
     % script.pl --name-json 'null'
 
 But every other string will need to be quoted:
 
     % script.pl --name-json '"foo"'
 
 See also: per_arg_yaml. You should enable just one instead of turning on both.
 
 _
         },
         common_opts => {
             summary => 'Common options',
             description => <<'_',
 
 A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
 option specification), `handler` (Getopt::Long handler). Will be passed to
 `get_args_from_argv()`. Example:
 
     {
         help => {
             getopt  => 'help|h|?',
             handler => sub { ... },
             summary => 'Display help and exit',
         },
         version => {
             getopt  => 'version|v',
             handler => sub { ... },
             summary => 'Display version and exit',
         },
     }
 
 _
             schema => ['hash*'],
         },
         allow_extra_elems => {
             schema => ['bool' => {default=>0}],
             summary => 'Allow extra/unassigned elements in argv',
             description => <<'_',
 
 If set to 1, then if there are array elements unassigned to one of the
 arguments, instead of generating an error, this function will just ignore them.
 
 This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
 
 _
         },
         on_missing_required_args => {
             schema => 'code',
             summary => 'Execute code when there is missing required args',
             description => <<'_',
 
 This can be used to give a chance to supply argument value from other sources if
 not specified by command-line options. Perinci::CmdLine, for example, uses this
 hook to supply value from STDIN or file contents (if argument has `cmdline_src`
 specification key set).
 
 This hook will be called for each missing argument. It will be supplied hash
 arguments: (arg => $the_missing_argument_name, args =>
 $the_resulting_args_so_far, spec => $the_arg_spec).
 
 The hook can return true if it succeeds in making the missing situation
 resolved. In this case, this function will not report the argument as missing.
 
 _
         },
         ignore_converted_code => {
             summary => 'Whether to ignore coderefs converted to string',
             schema => 'bool',
             default => 0,
             description => <<'_',
 
 Across network through JSON encoding, coderef in metadata (e.g. in
 `cmdline_aliases` property) usually gets converted to string `CODE`. In some
 cases, like for tab completion, this is harmless so you can turn this option on.
 
 _
         },
     },
     result => {
         description => <<'_',
 
 Error codes:
 
 * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
 
 * 500 - failure in GetOptions, meaning argv is not valid according to metadata
   specification (only if 'strict' mode is enabled).
 
 * 501 - coderef in cmdline_aliases got converted into a string, probably because
   the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
 
 _
     },
 };
 sub get_args_from_argv {
     require Getopt::Long;
 
     my %fargs = @_;
     my $argv       = $fargs{argv} // \@ARGV;
     my $meta       = $fargs{meta} or return [400, "Please specify meta"];
     unless ($fargs{meta_is_normalized}) {
         require Perinci::Sub::Normalize;
         $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
     }
     my $strict            = $fargs{strict} // 1;
     my $common_opts       = $fargs{common_opts} // {};
     my $per_arg_yaml      = $fargs{per_arg_yaml} // 0;
     my $per_arg_json      = $fargs{per_arg_json} // 0;
     my $allow_extra_elems = $fargs{allow_extra_elems} // 0;
     my $on_missing        = $fargs{on_missing_required_args};
     my $ignore_converted_code = $fargs{ignore_converted_code};
     #$log->tracef("-> get_args_from_argv(), argv=%s", $argv);
 
     # to store the resulting args
     my $rargs = $fargs{args} // {};
 
     # 1. first we generate Getopt::Long spec
     my $genres = gen_getopt_long_spec_from_meta(
         meta => $meta, meta_is_normalized => 1,
         args => $rargs,
         common_opts  => $common_opts,
         per_arg_json => $per_arg_json,
         per_arg_yaml => $per_arg_yaml,
         ignore_converted_code => $ignore_converted_code,
     );
     return err($genres->[0], "Can't generate Getopt::Long spec", $genres)
         if $genres->[0] != 200;
     my $go_spec = $genres->[2];
 
     # 2. then we run GetOptions to fill $rargs from command-line opts
     #$log->tracef("GetOptions spec: %s", \@go_spec);
     {
         local $SIG{__WARN__} = sub{} if !$strict;
         my $old_go_conf = Getopt::Long::Configure(
             $strict ? "no_pass_through" : "pass_through",
             "no_ignore_case", "permute", "bundling", "no_getopt_compat");
         my $res = Getopt::Long::GetOptionsFromArray($argv, %$go_spec);
         Getopt::Long::Configure($old_go_conf);
         unless ($res) {
             return [500, "GetOptions failed"] if $strict;
         }
     }
 
     # 3. then we try to fill $rargs from remaining command-line arguments (for
     # args which have 'pos' spec specified)
 
     my $args_prop = $meta->{args};
 
     if (@$argv) {
         my $res = get_args_from_array(
             array=>$argv, meta => $meta,
             meta_is_normalized => 1,
             allow_extra_elems => $allow_extra_elems,
         );
         if ($res->[0] != 200 && $strict) {
             return err(500, "Get args from array failed", $res);
         } elsif ($strict && $res->[0] != 200) {
             return err("Can't get args from argv", $res);
         } elsif ($res->[0] == 200) {
             my $pos_args = $res->[2];
             for my $name (keys %$pos_args) {
                 my $arg_spec = $args_prop->{$name};
                 my $val      = $pos_args->{$name};
                 if (exists $rargs->{$name}) {
                     return [400, "You specified option --$name but also ".
                                 "argument #".$arg_spec->{pos}] if $strict;
                 }
                 my $type = $arg_spec->{schema}[0];
                 my $cs   = $arg_spec->{schema}[1];
                 my $is_simple_scalar = $type =~ $re_simple_scalar;
                 my $is_array_of_simple_scalar = $type eq 'array' &&
                     $cs->{of} && $cs->{of}[0] =~ $re_simple_scalar;
 
                 if ($arg_spec->{greedy} && ref($val) eq 'ARRAY' &&
                         !$is_array_of_simple_scalar) {
                     my $i = 0;
                     for (@$val) {
                       TRY_PARSING_AS_JSON_YAML:
                         {
                             my ($success, $e, $decoded);
                             if ($per_arg_json) {
                                 ($success, $e, $decoded) = _parse_json($_);
                                 if ($success) {
                                     $_ = $decoded;
                                     last TRY_PARSING_AS_JSON_YAML;
                                 } else {
                                     warn "Failed trying to parse argv #$i as JSON: $e";
                                 }
                             }
                             if ($per_arg_yaml) {
                                 ($success, $e, $decoded) = _parse_yaml($_);
                                 if ($success) {
                                     $_ = $decoded;
                                     last TRY_PARSING_AS_JSON_YAML;
                                 } else {
                                     warn "Failed trying to parse argv #$i as YAML: $e";
                                 }
                             }
                         }
                         $i++;
                     }
                 }
                 if (!$arg_spec->{greedy} && !$is_simple_scalar) {
                   TRY_PARSING_AS_JSON_YAML:
                     {
                         my ($success, $e, $decoded);
                         if ($per_arg_json) {
                             ($success, $e, $decoded) = _parse_json($val);
                             if ($success) {
                                 $val = $decoded;
                                 last TRY_PARSING_AS_JSON_YAML;
                             } else {
                                 warn "Failed trying to parse argv #$arg_spec->{pos} as JSON: $e";
                             }
                         }
                         if ($per_arg_yaml) {
                             ($success, $e, $decoded) = _parse_yaml($val);
                             if ($success) {
                                 $val = $decoded;
                                 last TRY_PARSING_AS_JSON_YAML;
                             } else {
                                 warn "Failed trying to parse argv #$arg_spec->{pos} as YAML: $e";
                             }
                         }
                     }
                 }
                 $rargs->{$name} = $val;
                 # we still call cmdline_on_getopt for this
                 if ($arg_spec->{cmdline_on_getopt}) {
                     if ($arg_spec->{greedy}) {
                         $arg_spec->{cmdline_on_getopt}->(
                             arg=>$name, fqarg=>$name, value=>$_, args=>$rargs,
                             opt=>undef, # this marks that value is retrieved from cmdline arg
                         ) for @$val;
                     } else {
                         $arg_spec->{cmdline_on_getopt}->(
                             arg=>$name, fqarg=>$name, value=>$val, args=>$rargs,
                             opt=>undef, # this marks that value is retrieved from cmdline arg
                         );
                     }
                 }
             }
         }
     }
 
     # 4. check missing required args
 
     my %missing_args;
     for my $arg (keys %$args_prop) {
         my $arg_spec = $args_prop->{$arg};
         if (!exists($rargs->{$arg})) {
             next unless $arg_spec->{req};
             # give a chance to hook to set missing arg
             if ($on_missing) {
                 next if $on_missing->(arg=>$arg, args=>$rargs, spec=>$arg_spec);
             }
             next if exists $rargs->{$arg};
             $missing_args{$arg} = 1;
         }
     }
 
     # 5. check 'deps', currently we only support 'arg' dep type
     {
         last unless $strict;
 
         for my $arg (keys %$args_prop) {
             my $arg_spec = $args_prop->{$arg};
             next unless exists $rargs->{$arg};
             next unless $arg_spec->{deps};
             my $dep_arg = $arg_spec->{deps}{arg};
             next unless $dep_arg;
             return [400, "You specify '$arg', but don't specify '$dep_arg' ".
                         "(upon which '$arg' depends)"]
                 unless exists $rargs->{$dep_arg};
         }
     }
 
     #$log->tracef("<- get_args_from_argv(), args=%s, remaining argv=%s",
     #             $rargs, $argv);
     [200, "OK", $rargs, {
         "func.missing_args" => [sort keys %missing_args],
         "func.gen_getopt_long_spec_result" => $genres,
     }];
 }
 
 1;
 # ABSTRACT: Get subroutine arguments from command line arguments (@ARGV)
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::GetArgs::Argv - Get subroutine arguments from command line arguments (@ARGV)
 
 =head1 VERSION
 
 This document describes version 0.69 of Perinci::Sub::GetArgs::Argv (from Perl distribution Perinci-Sub-GetArgs-Argv), released on 2015-08-19.
 
 =head1 SYNOPSIS
 
  use Perinci::Sub::GetArgs::Argv;
 
  my $res = get_args_from_argv(argv=>\@ARGV, meta=>$meta, ...);
 
 =head1 DESCRIPTION
 
 This module provides C<get_args_from_argv()>, which parses command line
 arguments (C<@ARGV>) into subroutine arguments (C<%args>). This module is used
 by L<Perinci::CmdLine>. For explanation on how command-line options are
 processed, see Perinci::CmdLine's documentation.
 
 =head1 FUNCTIONS
 
 
 =head2 gen_getopt_long_spec_from_meta(%args) -> [status, msg, result, meta]
 
 {en_US Generate Getopt::Long spec from Rinci function metadata}.
 
 {en_US 
 This routine will produce a C<Getopt::Long> specification from Rinci function
 metadata, as well as some more data structure in the result metadata to help
 producing a command-line help/usage message.
 
 Function arguments will be mapped to command-line options with the same name,
 with non-alphanumeric characters changed to C<-> (C<-> is preferred over C<_>
 because it lets user avoid pressing Shift on popular keyboards). For example:
 C<file_size> becomes C<file-size>, C<file_size.max> becomes C<file-size-max>. If
 function argument option name clashes with command-line option or another
 existing option, it will be renamed to C<NAME-arg> (or C<NAME-arg2> and so on).
 For example: C<help> will become C<help-arg> (if C<common_opts> contains C<help>,
 that is).
 
 Each command-line alias (C<cmdline_aliases> property) in the argument
 specification will also be added as command-line option, except if it clashes
 with an existing option, in which case this function will warn and skip adding
 the alias. For more information about C<cmdline_aliases>, see C<Rinci::function>.
 
 For arguments with type of C<bool>, Getopt::Long will by default also
 automatically recognize C<--noNAME> or C<--no-NAME> in addition to C<--name>. So
 this function will also check those names for clashes.
 
 For arguments with type array of simple scalar, C<--NAME> can be specified more
 than once to append to the array.
 
 If C<per_arg_json> setting is active, and argument's schema is not a "required
 simple scalar" (e.g. an array, or a nullable string), then C<--NAME-json> will
 also be added to let users input undef (through C<--NAME-json null>) or a
 non-scalar value (e.g. C<--NAME-json '[1,2,3]'>). If this name conflicts with
 another existing option, a warning will be displayed and the option will not be
 added.
 
 If C<per_arg_yaml> setting is active, and argument's schema is not a "required
 simple scalar" (e.g. an array, or a nullable string), then C<--NAME-yaml> will
 also be added to let users input undef (through C<--NAME-yaml '~'>) or a
 non-scalar value (e.g. C<--NAME-yaml '[foo, bar]'>). If this name conflicts with
 another existing option, a warning will be displayed and the option will not be
 added. YAML can express a larger set of values, e.g. binary data, circular
 references, etc.
 
 Will produce a hash (Getopt::Long spec), with C<func.specmeta>, C<func.opts>,
 C<func.common_opts>, C<func.func_opts> that contain extra information
 (C<func.specmeta> is a hash of getopt spec name and a hash of extra information
 while C<func.*opts> lists all used option names).
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<args> => I<hash>
 
 {en_US Reference to hash which will store the result}.
 
 =item * B<common_opts> => I<hash>
 
 {en_US Common options}.
 
 {en_US 
 A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
 option specification), C<handler> (Getopt::Long handler). Will be passed to
 C<get_args_from_argv()>. Example:
 
  {
      help => {
          getopt  => 'help|h|?',
          handler => sub { ... },
          summary => 'Display help and exit',
      },
      version => {
          getopt  => 'version|v',
          handler => sub { ... },
          summary => 'Display version and exit',
      },
  }
 
 }
 
 =item * B<ignore_converted_code> => I<bool> (default: 0)
 
 {en_US Whether to ignore coderefs converted to string}.
 
 {en_US 
 Across network through JSON encoding, coderef in metadata (e.g. in
 C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
 cases, like for tab completion, this is pretty harmless so you can turn this
 option on. For example, in the case of C<cmdline_aliases>, the effect is just
 that command-line aliases code are not getting executed, but this is usually
 okay.
 }
 
 =item * B<meta>* => I<hash>
 
 {en_US Rinci function metadata}.
 
 =item * B<meta_is_normalized> => I<bool>
 
 =item * B<per_arg_json> => I<bool> (default: 0)
 
 {en_US Whether to add --NAME-json for non-simple arguments}.
 
 {en_US 
 Will also interpret command-line arguments as JSON if assigned to function
 arguments, if arguments' schema is not simple scalar.
 }
 
 =item * B<per_arg_yaml> => I<bool> (default: 0)
 
 {en_US Whether to add --NAME-yaml for non-simple arguments}.
 
 {en_US 
 Will also interpret command-line arguments as YAML if assigned to function
 arguments, if arguments' schema is not simple scalar.
 }
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (any)
 
 
 =head2 get_args_from_argv(%args) -> [status, msg, result, meta]
 
 {en_US Get subroutine arguments (%args) from command-line arguments (@ARGV)}.
 
 {en_US 
 Using information in Rinci function metadata's C<args> property, parse command
 line arguments C<@argv> into hash C<%args>, suitable for passing into subroutines.
 
 Currently uses Getopt::Long's GetOptions to do the parsing.
 
 As with GetOptions, this function modifies its C<argv> argument, so you might
 want to copy the original C<argv> first (or pass a copy instead) if you want to
 preserve the original.
 
 See also: gen_getopt_long_spec_from_meta() which is the routine that generates
 the specification.
 }
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<allow_extra_elems> => I<bool> (default: 0)
 
 {en_US Allow extra/unassigned elements in argv}.
 
 {en_US 
 If set to 1, then if there are array elements unassigned to one of the
 arguments, instead of generating an error, this function will just ignore them.
 
 This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
 }
 
 =item * B<args> => I<hash>
 
 {en_US Specify input args, with some arguments preset}.
 
 =item * B<argv> => I<array[str]>
 
 {en_US If not specified, defaults to @ARGV}
 
 =item * B<common_opts> => I<hash>
 
 {en_US Common options}.
 
 {en_US 
 A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
 option specification), C<handler> (Getopt::Long handler). Will be passed to
 C<get_args_from_argv()>. Example:
 
  {
      help => {
          getopt  => 'help|h|?',
          handler => sub { ... },
          summary => 'Display help and exit',
      },
      version => {
          getopt  => 'version|v',
          handler => sub { ... },
          summary => 'Display version and exit',
      },
  }
 
 }
 
 =item * B<ignore_converted_code> => I<bool> (default: 0)
 
 {en_US Whether to ignore coderefs converted to string}.
 
 {en_US 
 Across network through JSON encoding, coderef in metadata (e.g. in
 C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
 cases, like for tab completion, this is harmless so you can turn this option on.
 }
 
 =item * B<meta>* => I<hash>
 
 =item * B<meta_is_normalized> => I<bool> (default: 0)
 
 {en_US Can be set to 1 if your metadata is normalized, to avoid duplicate effort}.
 
 =item * B<on_missing_required_args> => I<code>
 
 {en_US Execute code when there is missing required args}.
 
 {en_US 
 This can be used to give a chance to supply argument value from other sources if
 not specified by command-line options. Perinci::CmdLine, for example, uses this
 hook to supply value from STDIN or file contents (if argument has C<cmdline_src>
 specification key set).
 
 This hook will be called for each missing argument. It will be supplied hash
 arguments: (arg => $the_missing_argument_name, args =>
 $the_resulting_args_so_far, spec => $the_arg_spec).
 
 The hook can return true if it succeeds in making the missing situation
 resolved. In this case, this function will not report the argument as missing.
 }
 
 =item * B<per_arg_json> => I<bool> (default: 0)
 
 {en_US Whether to recognize --ARGNAME-json}.
 
 {en_US 
 This is useful for example if you want to specify a value which is not
 expressible from the command-line, like 'undef'.
 
  % script.pl --name-json 'null'
 
 But every other string will need to be quoted:
 
  % script.pl --name-json '"foo"'
 
 See also: per_arg_yaml. You should enable just one instead of turning on both.
 }
 
 =item * B<per_arg_yaml> => I<bool> (default: 0)
 
 {en_US Whether to recognize --ARGNAME-yaml}.
 
 {en_US 
 This is useful for example if you want to specify a value which is not
 expressible from the command-line, like 'undef'.
 
  % script.pl --name-yaml '~'
 
 See also: per_arg_json. You should enable just one instead of turning on both.
 }
 
 =item * B<strict> => I<bool> (default: 1)
 
 {en_US Strict mode}.
 
 {en_US 
 If set to 0, will still return parsed argv even if there are parsing errors
 (reported by Getopt::Long). If set to 1 (the default), will die upon error.
 
 Normally you would want to use strict mode, for more error checking. Setting off
 strict is used by, for example, Perinci::Sub::Complete during completion where
 the command-line might still be incomplete.
 
 Should probably be named C<ignore_errors>. :-)
 }
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (any)
 
 
 {en_US 
 Error codes:
 
 =over
 
 =item * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
 
 =item * 500 - failure in GetOptions, meaning argv is not valid according to metadata
 specification (only if 'strict' mode is enabled).
 
 =item * 501 - coderef in cmdline_aliases got converted into a string, probably because
 the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
 }
 
 =back
 
 =head1 FAQ
 
 =head1 SEE ALSO
 
 L<Perinci>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-GetArgs-Argv>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-GetArgs-Argv>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-GetArgs-Argv>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/GetArgs/Array.pm ###
 package Perinci::Sub::GetArgs::Array;
 
 use 5.010001;
 use strict;
 use warnings;
 #use Log::Any '$log';
 
 use Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(get_args_from_array);
 
 our $VERSION = '0.14'; # VERSION
 
 our %SPEC;
 
 $SPEC{get_args_from_array} = {
     v => 1.1,
     summary => 'Get subroutine arguments (%args) from array',
     description => <<'_',
 
 Using information in metadata's `args` property (particularly the `pos` and
 `greedy` arg type clauses), extract arguments from an array into a hash
 `\%args`, suitable for passing into subs.
 
 Example:
 
     my $meta = {
         v => 1.1,
         summary => 'Multiply 2 numbers (a & b)',
         args => {
             a => {schema=>'num*', pos=>0},
             b => {schema=>'num*', pos=>1},
         }
     }
 
 then `get_args_from_array(array=>[2, 3], meta=>$meta)` will produce:
 
     [200, "OK", {a=>2, b=>3}]
 
 _
     args => {
         array => {
             schema => ['array*' => {}],
             req => 1,
             description => <<'_',
 
 NOTE: array will be modified/emptied (elements will be taken from the array as
 they are put into the resulting args). Copy your array first if you want to
 preserve its content.
 
 _
         },
         meta => {
             schema => ['hash*' => {}],
             req => 1,
         },
         meta_is_normalized => {
             summary => 'Can be set to 1 if your metadata is normalized, '.
                 'to avoid duplicate effort',
             schema => 'bool',
             default => 0,
         },
         allow_extra_elems => {
             schema => ['bool' => {default=>0}],
             summary => 'Allow extra/unassigned elements in array',
             description => <<'_',
 
 If set to 1, then if there are array elements unassigned to one of the arguments
 (due to missing `pos`, for example), instead of generating an error, the
 function will just ignore them.
 
 _
         },
     },
 };
 sub get_args_from_array {
     my %fargs = @_;
     my $ary  = $fargs{array} or return [400, "Please specify array"];
     my $meta = $fargs{meta} or return [400, "Please specify meta"];
     unless ($fargs{meta_is_normalized}) {
         require Perinci::Sub::Normalize;
         $meta = Perinci::Sub::Normalize::normalize_function_metadata(
             $meta);
     }
     my $allow_extra_elems = $fargs{allow_extra_elems} // 0;
 
     my $rargs = {};
 
     my $args_p = $meta->{args} // {};
     for my $i (reverse 0..@$ary-1) {
         #$log->tracef("i=$i");
         while (my ($a, $as) = each %$args_p) {
             my $o = $as->{pos};
             if (defined($o) && $o == $i) {
                 if ($as->{greedy}) {
                     my $type = $as->{schema}[0];
                     my @elems = splice(@$ary, $i);
                     if ($type eq 'array') {
                         $rargs->{$a} = \@elems;
                     } else {
                         $rargs->{$a} = join " ", @elems;
                     }
                     #$log->tracef("assign %s to arg->{$a}", $rargs->{$a});
                 } else {
                     $rargs->{$a} = splice(@$ary, $i, 1);
                     #$log->tracef("assign %s to arg->{$a}", $rargs->{$a});
                 }
             }
         }
     }
 
     return [400, "There are extra, unassigned elements in array: [".
                 join(", ", @$ary)."]"] if @$ary && !$allow_extra_elems;
 
     [200, "OK", $rargs];
 }
 
 1;
 #ABSTRACT: Get subroutine arguments from array
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::GetArgs::Array - Get subroutine arguments from array
 
 =head1 VERSION
 
 This document describes version 0.14 of Perinci::Sub::GetArgs::Array (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2014-07-08.
 
 =head1 SYNOPSIS
 
  use Perinci::Sub::GetArgs::Array;
 
  my $res = get_args_from_array(array=>\@ary, meta=>$meta, ...);
 
 =head1 DESCRIPTION
 
 This module provides get_args_from_array(). This module is used by, among
 others, L<Perinci::Sub::GetArgs::Argv>.
 
 =head1 FUNCTIONS
 
 
 =head2 get_args_from_array(%args) -> [status, msg, result, meta]
 
 Get subroutine arguments (%args) from array.
 
 Using information in metadata's C<args> property (particularly the C<pos> and
 C<greedy> arg type clauses), extract arguments from an array into a hash
 C<\%args>, suitable for passing into subs.
 
 Example:
 
     my $meta = {
         v => 1.1,
         summary => 'Multiply 2 numbers (a & b)',
         args => {
             a => {schema=>'num*', pos=>0},
             b => {schema=>'num*', pos=>1},
         }
     }
 
 then C<get_args_from_array(array=>[2, 3], meta=>$meta)> will produce:
 
     [200, "OK", {a=>2, b=>3}]
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<allow_extra_elems> => I<bool> (default: 0)
 
 Allow extra/unassigned elements in array.
 
 If set to 1, then if there are array elements unassigned to one of the arguments
 (due to missing C<pos>, for example), instead of generating an error, the
 function will just ignore them.
 
 =item * B<array>* => I<array>
 
 NOTE: array will be modified/emptied (elements will be taken from the array as
 they are put into the resulting args). Copy your array first if you want to
 preserve its content.
 
 =item * B<meta>* => I<hash>
 
 =item * B<meta_is_normalized> => I<bool> (default: 0)
 
 Can be set to 1 if your metadata is normalized, to avoid duplicate effort.
 
 =back
 
 Return value:
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 =head1 TODO
 
 I am not particularly happy with the duplication of functionality between this
 and the 'args_as' handler in L<Perinci::Sub::Wrapper>. But the later is a code
 to generate code, so I guess it's not so bad for now.
 
 =head1 SEE ALSO
 
 L<Perinci>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-GetArgs-Array>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-GetArgs-Array>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-GetArgs-Array>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 Steven Haryanto <stevenharyanto@gmail.com>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by Steven Haryanto.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/Normalize.pm ###
 package Perinci::Sub::Normalize;
 
 our $DATE = '2015-04-24'; # DATE
 our $VERSION = '0.11'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        normalize_function_metadata
                );
 
 use Sah::Schema::Rinci;
 my $sch = $Sah::Schema::Rinci::SCHEMAS{rinci_function}
     or die "BUG: Rinci schema structure changed (1)";
 my $sch_proplist = $sch->[1]{_prop}
     or die "BUG: Rinci schema structure changed (2)";
 
 sub _normalize{
     my ($meta, $ver, $opts, $proplist, $nmeta, $prefix, $modprefix) = @_;
 
     my $opt_aup = $opts->{allow_unknown_properties};
     my $opt_nss = $opts->{normalize_sah_schemas};
     my $opt_rip = $opts->{remove_internal_properties};
 
     if (defined $ver) {
         defined($meta->{v}) && $meta->{v} eq $ver
             or die "$prefix: Metadata version must be $ver";
     }
 
   KEY:
     for my $k (keys %$meta) {
         die "Invalid prop/attr syntax '$k', must be word/dotted-word only"
             unless $k =~ /\A(\w+)(?:\.(\w+(?:\.\w+)*))?(?:\((\w+)\))?\z/;
 
         my ($prop, $attr);
         if (defined $3) {
             $prop = $1;
             $attr = defined($2) ? "$2.alt.lang.$3" : "alt.lang.$3";
         } else {
             $prop = $1;
             $attr = $2;
         }
 
         my $nk = "$prop" . (defined($attr) ? ".$attr" : "");
 
         # strip property/attr started with _
         if ($prop =~ /\A_/ || defined($attr) && $attr =~ /\A_|\._/) {
             unless ($opt_rip) {
                 $nmeta->{$nk} = $meta->{$k};
             }
             next KEY;
         }
 
         my $prop_proplist = $proplist->{$prop};
 
         # try to load module that declare new props first
         if (!$opt_aup && !$prop_proplist) {
             $modprefix //= $prefix;
             my $mod = "Perinci/Sub/Property$modprefix/$prop.pm";
             eval { require $mod };
             # hide technical error message from require()
             if ($@) {
                 die "Unknown property '$prefix/$prop' (and couldn't ".
                     "load property module '$mod'): $@" if $@;
             }
             $prop_proplist = $proplist->{$prop};
         }
         die "Unknown property '$prefix/$prop'"
             unless $opt_aup || $prop_proplist;
 
         if ($prop_proplist && $prop_proplist->{_prop}) {
             die "Property '$prefix/$prop' must be a hash"
                 unless ref($meta->{$k}) eq 'HASH';
             $nmeta->{$nk} = {};
             _normalize(
                 $meta->{$k},
                 $prop_proplist->{_ver},
                 $opts,
                 $prop_proplist->{_prop},
                 $nmeta->{$nk},
                 "$prefix/$prop",
             );
         } elsif ($prop_proplist && $prop_proplist->{_elem_prop}) {
             die "Property '$prefix/$prop' must be an array"
                 unless ref($meta->{$k}) eq 'ARRAY';
             $nmeta->{$nk} = [];
             my $i = 0;
             for (@{ $meta->{$k} }) {
                 my $href = {};
                 if (ref($_) eq 'HASH') {
                     _normalize(
                         $_,
                         $prop_proplist->{_ver},
                         $opts,
                         $prop_proplist->{_elem_prop},
                         $href,
                         "$prefix/$prop/$i",
                     );
                     push @{ $nmeta->{$nk} }, $href;
                 } else {
                     push @{ $nmeta->{$nk} }, $_;
                 }
                 $i++;
             }
         } elsif ($prop_proplist && $prop_proplist->{_value_prop}) {
             die "Property '$prefix/$prop' must be a hash"
                 unless ref($meta->{$k}) eq 'HASH';
             $nmeta->{$nk} = {};
             for (keys %{ $meta->{$k} }) {
                 $nmeta->{$nk}{$_} = {};
                 die "Property '$prefix/$prop/$_' must be a hash"
                     unless ref($meta->{$k}{$_}) eq 'HASH';
                 _normalize(
                     $meta->{$k}{$_},
                     $prop_proplist->{_ver},
                     $opts,
                     $prop_proplist->{_value_prop},
                     $nmeta->{$nk}{$_},
                     "$prefix/$prop/$_",
                     ($prop eq 'args' ? "$prefix/arg" : undef),
                 );
             }
         } else {
             if ($k eq 'schema' && $opt_nss) { # XXX currently hardcoded
                 require Data::Sah::Normalize;
                 $nmeta->{$nk} = Data::Sah::Normalize::normalize_schema(
                     $meta->{$k});
             } else {
                 $nmeta->{$nk} = $meta->{$k};
             }
         }
     }
 
     $nmeta;
 }
 
 sub normalize_function_metadata($;$) {
     my ($meta, $opts) = @_;
 
     $opts //= {};
 
     $opts->{allow_unknown_properties}    //= 0;
     $opts->{normalize_sah_schemas}       //= 1;
     $opts->{remove_internal_properties}  //= 0;
 
     _normalize($meta, 1.1, $opts, $sch_proplist, {}, '');
 }
 
 1;
 # ABSTRACT: Normalize Rinci function metadata
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::Normalize - Normalize Rinci function metadata
 
 =head1 VERSION
 
 This document describes version 0.11 of Perinci::Sub::Normalize (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-24.
 
 =head1 SYNOPSIS
 
  use Perinci::Sub::Normalize qw(normalize_function_metadata);
 
  my $nmeta = normalize_function_metadata($meta);
 
 =head1 FUNCTIONS
 
 =head2 normalize_function_metadata($meta, \%opts) => HASH
 
 Normalize and check L<Rinci> function metadata C<$meta>. Return normalized
 metadata, which is a shallow copy of C<$meta>. Die on error.
 
 Available options:
 
 =over
 
 =item * allow_unknown_properties => BOOL (default: 0)
 
 If set to true, will die if there are unknown properties.
 
 =item * normalize_sah_schemas => BOOL (default: 1)
 
 By default, L<Sah> schemas e.g. in C<result/schema> or C<args/*/schema> property
 is normalized using L<Data::Sah>'s C<normalize_schema>. Set this to 0 if you
 don't want this.
 
 =item * remove_internal_properties => BOOL (default: 0)
 
 If set to 1, all properties and attributes starting with underscore (C<_>) with
 will be stripped. According to L<DefHash> specification, they are ignored and
 usually contain notes/comments/extra information.
 
 =back
 
 =head1 SEE ALSO
 
 L<Rinci::function>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Normalize>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Normalize>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Normalize>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/Util.pm ###
 package Perinci::Sub::Util;
 
 our $DATE = '2015-01-04'; # DATE
 our $VERSION = '0.41'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        err
                        caller
                        gen_modified_sub
                        warn_err
                        die_err
                );
 
 our %SPEC;
 
 $SPEC{':package'} = {
     v => 1.1,
     summary => 'Helper when writing functions',
 };
 
 our $STACK_TRACE;
 our @_c; # to store temporary celler() result
 our $_i; # temporary variable
 sub err {
     require Scalar::Util;
 
     # get information about caller
     my @caller = CORE::caller(1);
     if (!@caller) {
         # probably called from command-line (-e)
         @caller = ("main", "-e", 1, "program");
     }
 
     my ($status, $msg, $meta, $prev);
 
     for (@_) {
         my $ref = ref($_);
         if ($ref eq 'ARRAY') { $prev = $_ }
         elsif ($ref eq 'HASH') { $meta = $_ }
         elsif (!$ref) {
             if (Scalar::Util::looks_like_number($_)) {
                 $status = $_;
             } else {
                 $msg = $_;
             }
         }
     }
 
     $status //= 500;
     $msg  //= "$caller[3] failed";
     $meta //= {};
     $meta->{prev} //= $prev if $prev;
 
     # put information on who produced this error and where/when
     if (!$meta->{logs}) {
 
         # should we produce a stack trace?
         my $stack_trace;
         {
             no warnings;
             # we use Carp::Always as a sign that user wants stack traces
             last unless $STACK_TRACE // $INC{"Carp/Always.pm"};
             # stack trace is already there in previous result's log
             last if $prev && ref($prev->[3]) eq 'HASH' &&
                 ref($prev->[3]{logs}) eq 'ARRAY' &&
                     ref($prev->[3]{logs}[0]) eq 'HASH' &&
                         $prev->[3]{logs}[0]{stack_trace};
             $stack_trace = [];
             $_i = 1;
             while (1) {
                 {
                     package DB;
                     @_c = CORE::caller($_i);
                     if (@_c) {
                         $_c[4] = [@DB::args];
                     }
                 }
                 last unless @_c;
                 push @$stack_trace, [@_c];
                 $_i++;
             }
         }
         push @{ $meta->{logs} }, {
             type    => 'create',
             time    => time(),
             package => $caller[0],
             file    => $caller[1],
             line    => $caller[2],
             func    => $caller[3],
             ( stack_trace => $stack_trace ) x !!$stack_trace,
         };
     }
 
     #die;
     [$status, $msg, undef, $meta];
 }
 
 sub caller {
     my $n0 = shift;
     my $n  = $n0 // 0;
 
     my $pkg = $Perinci::Sub::Wrapper::default_wrapped_package //
         'Perinci::Sub::Wrapped';
 
     my @r;
     my $i =  0;
     my $j = -1;
     while ($i <= $n+1) { # +1 for this sub itself
         $j++;
         @r = CORE::caller($j);
         last unless @r;
         if ($r[0] eq $pkg && $r[1] =~ /^\(eval /) {
             next;
         }
         $i++;
     }
 
     return unless @r;
     return defined($n0) ? @r : $r[0];
 }
 
 $SPEC{gen_modified_sub} = {
     v => 1.1,
     summary => 'Generate modified metadata (and subroutine) based on another',
     description => <<'_',
 
 Often you'll want to create another sub (and its metadata) based on another, but
 with some modifications, e.g. add/remove/rename some arguments, change summary,
 add/remove some properties, and so on.
 
 Instead of cloning the Rinci metadata and modify it manually yourself, this
 routine provides some shortcuts.
 
 You can specify base sub/metadata using `base_name` (string, subroutine name,
 either qualified or not) or `base_code` (coderef) + `base_meta` (hash).
 
 _
     args => {
         base_name => {
             summary => 'Subroutine name (either qualified or not)',
             schema => 'str*',
             description => <<'_',
 
 If not qualified with package name, will be searched in the caller's package.
 Rinci metadata will be searched in `%SPEC` package variable.
 
 Alternatively, you can also specify `base_code` and `base_meta`.
 
 _
         },
         base_code => {
             summary => 'Base subroutine code',
             schema  => 'code*',
             description => <<'_',
 
 If you specify this, you'll also need to specify `base_meta`.
 
 Alternatively, you can specify `base_name` instead, to let this routine search
 the base subroutine from existing Perl package.
 
 _
         },
         base_meta => {
             summary => 'Base Rinci metadata',
             schema  => 'hash*', # XXX defhash/rifunc
         },
         output_name => {
             summary => 'Where to install the modified sub',
             schema  => 'str*',
             description => <<'_',
 
 Subroutine will be put in the specified name. If the name is not qualified with
 package name, will use caller's package. If no `output_code` is specified, the
 base subroutine reference will be assigned here.
 
 Note that this argument is optional.
 
 _
         },
         output_code => {
             summary => 'Code for the modified sub',
             schema  => 'code*',
             description => <<'_',
 
 If not specified will use `base_code` (which will then be required).
 
 _
         },
         summary => {
             summary => 'Summary for the mod subroutine',
             schema  => 'str*',
         },
         description => {
             summary => 'Description for the mod subroutine',
             schema  => 'str*',
         },
         remove_args => {
             summary => 'List of arguments to remove',
             schema  => 'array*',
         },
         add_args => {
             summary => 'Arguments to add',
             schema  => 'hash*',
         },
         replace_args => {
             summary => 'Arguments to add',
             schema  => 'hash*',
         },
         rename_args => {
             summary => 'Arguments to rename',
             schema  => 'hash*',
         },
         modify_args => {
             summary => 'Arguments to modify',
             description => <<'_',
 
 For each argument you can specify a coderef. The coderef will receive the
 argument ($arg_spec) and is expected to modify the argument specification.
 
 _
             schema  => 'hash*',
         },
         modify_meta => {
             summary => 'Specify code to modify metadata',
             schema  => 'code*',
             description => <<'_',
 
 Code will be called with arguments ($meta) where $meta is the cloned Rinci
 metadata.
 
 _
         },
         install_sub => {
             schema  => 'bool',
             default => 1,
         },
     },
     result => {
         schema => ['hash*' => {
             keys => {
                 code => ['code*'],
                 meta => ['hash*'], # XXX defhash/risub
             },
         }],
     },
 };
 sub gen_modified_sub {
     require Function::Fallback::CoreOrPP;
 
     my %args = @_;
 
     # get base code/meta
     my ($base_code, $base_meta);
     if ($args{base_name}) {
         my ($pkg, $leaf);
         if ($args{base_name} =~ /(.+)::(.+)/) {
             ($pkg, $leaf) = ($1, $2);
         } else {
             $pkg  = CORE::caller();
             $leaf = $args{base_name};
         }
         no strict 'refs';
         $base_code = \&{"$pkg\::$leaf"};
         $base_meta = ${"$pkg\::SPEC"}{$leaf};
         die "Can't find Rinci metadata for $pkg\::$leaf" unless $base_meta;
     } elsif ($args{base_meta}) {
         $base_meta = $args{base_meta};
         $base_code = $args{base_code}
             or die "Please specify base_code";
     } else {
         die "Please specify base_name or base_code+base_meta";
     }
 
     my $output_meta = Function::Fallback::CoreOrPP::clone($base_meta);
     my $output_code = $args{output_code} // $base_code;
 
     # modify metadata
     for (qw/summary description/) {
         $output_meta->{$_} = $args{$_} if $args{$_};
     }
     if ($args{remove_args}) {
         delete $output_meta->{args}{$_} for @{ $args{remove_args} };
     }
     if ($args{add_args}) {
         for my $k (keys %{ $args{add_args} }) {
             my $v = $args{add_args}{$k};
             die "Can't add arg '$k' in mod sub: already exists"
                 if $output_meta->{args}{$k};
             $output_meta->{args}{$k} = $v;
         }
     }
     if ($args{replace_args}) {
         for my $k (keys %{ $args{replace_args} }) {
             my $v = $args{replace_args}{$k};
             die "Can't replace arg '$k' in mod sub: doesn't exist"
                 unless $output_meta->{args}{$k};
             $output_meta->{args}{$k} = $v;
         }
     }
     if ($args{rename_args}) {
         for my $old (keys %{ $args{rename_args} }) {
             my $new = $args{rename_args}{$old};
             my $as = $output_meta->{args}{$old};
             die "Can't rename arg '$old' in mod sub: doesn't exist" unless $as;
             die "Can't rename arg '$old'->'$new' in mod sub: ".
                 "new name already exist" if $output_meta->{args}{$new};
             $output_meta->{args}{$new} = $as;
             delete $output_meta->{args}{$old};
         }
     }
     if ($args{modify_args}) {
         for (keys %{ $args{modify_args} }) {
             $args{modify_args}{$_}->($output_meta->{args}{$_});
         }
     }
     if ($args{modify_meta}) {
         $args{modify_meta}->($output_meta);
     }
 
     # install
     if ($args{output_name}) {
         my ($pkg, $leaf);
         if ($args{output_name} =~ /(.+)::(.+)/) {
             ($pkg, $leaf) = ($1, $2);
         } else {
             $pkg  = CORE::caller();
             $leaf = $args{output_name};
         }
         no strict 'refs';
         no warnings 'redefine';
         *{"$pkg\::$leaf"}       = $output_code if $args{install_sub} // 1;
         ${"$pkg\::SPEC"}{$leaf} = $output_meta;
     }
 
     [200, "OK", {code=>$output_code, meta=>$output_meta}];
 }
 
 # TODO: for simpler cases (e.g. only remove some arguments, or preset some
 # arguments), create more convenient helper, e.g.
 #
 # gen_curried_sub('list_users', {is_suspended=>1}, ?'list_suspended_users'); # equivalent to remove args => ['is_suspended'] and create a wrapper that calls list_users with is_suspended=>1
 
 sub warn_err {
     require Carp;
 
     my $res = err(@_);
     Carp::carp("ERROR $res->[0]: $res->[1]");
 }
 
 sub die_err {
     require Carp;
 
     my $res = err(@_);
     Carp::croak("ERROR $res->[0]: $res->[1]");
 }
 
 1;
 # ABSTRACT: Helper when writing functions
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::Util - Helper when writing functions
 
 =head1 VERSION
 
 This document describes version 0.41 of Perinci::Sub::Util (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-01-04.
 
 =head1 SYNOPSIS
 
 Example for err() and caller():
 
  use Perinci::Sub::Util qw(err caller);
 
  sub foo {
      my %args = @_;
      my $res;
 
      my $caller = caller();
 
      $res = bar(...);
      return err($err, 500, "Can't foo") if $res->[0] != 200;
 
      [200, "OK"];
  }
 
 Example for gen_modified_sub():
 
  use Perinci::Sub::Util qw(gen_modified_sub);
 
  $SPEC{list_users} = {
      v => 1.1,
      args => {
          search => {},
          is_suspended => {},
      },
  };
  sub list_users { ... }
 
  gen_modified_sub(
      output_name => 'list_suspended_users',
      base_name   => 'list_users',
      remove_args => ['is_suspended'],
      output_code => sub {
          list_users(@_, is_suspended=>1);
      },
  );
 
 Example for die_err() and warn_err():
 
  use Perinci::Sub::Util qw(warn_err die_err);
  warn_err(403, "Forbidden");
  die_err(403, "Forbidden");
 
 =head1 FUNCTIONS
 
 =head2 caller([ $n ])
 
 Just like Perl's builtin caller(), except that this one will ignore wrapper code
 in the call stack. You should use this if your code is potentially wrapped. See
 L<Perinci::Sub::Wrapper> for more details.
 
 =head2 err(...) => ARRAY
 
 Experimental.
 
 Generate an enveloped error response (see L<Rinci::function>). Can accept
 arguments in an unordered fashion, by utilizing the fact that status codes are
 always integers, messages are strings, result metadata are hashes, and previous
 error responses are arrays. Error responses also seldom contain actual result.
 Status code defaults to 500, status message will default to "FUNC failed". This
 function will also fill the information in the C<logs> result metadata.
 
 Examples:
 
  err();    # => [500, "FUNC failed", undef, {...}];
  err(404); # => [404, "FUNC failed", undef, {...}];
  err(404, "Not found"); # => [404, "Not found", ...]
  err("Not found", 404); # => [404, "Not found", ...]; # order doesn't matter
  err([404, "Prev error"]); # => [500, "FUNC failed", undef,
                            #     {logs=>[...], prev=>[404, "Prev error"]}]
 
 Will put C<stack_trace> in logs only if C<Carp::Always> module is loaded.
 
 =head2 warn_err(...)
 
 This is a shortcut for:
 
  $res = err(...);
  warn "ERROR $res->[0]: $res->[1]";
 
 =head2 die_err(...)
 
 This is a shortcut for:
 
  $res = err(...);
  die "ERROR $res->[0]: $res->[1]";
 
 
 =head2 gen_modified_sub(%args) -> [status, msg, result, meta]
 
 Generate modified metadata (and subroutine) based on another.
 
 Often you'll want to create another sub (and its metadata) based on another, but
 with some modifications, e.g. add/remove/rename some arguments, change summary,
 add/remove some properties, and so on.
 
 Instead of cloning the Rinci metadata and modify it manually yourself, this
 routine provides some shortcuts.
 
 You can specify base sub/metadata using C<base_name> (string, subroutine name,
 either qualified or not) or C<base_code> (coderef) + C<base_meta> (hash).
 
 Arguments ('*' denotes required arguments):
 
 =over 4
 
 =item * B<add_args> => I<hash>
 
 Arguments to add.
 
 =item * B<base_code> => I<code>
 
 Base subroutine code.
 
 If you specify this, you'll also need to specify C<base_meta>.
 
 Alternatively, you can specify C<base_name> instead, to let this routine search
 the base subroutine from existing Perl package.
 
 =item * B<base_meta> => I<hash>
 
 Base Rinci metadata.
 
 =item * B<base_name> => I<str>
 
 Subroutine name (either qualified or not).
 
 If not qualified with package name, will be searched in the caller's package.
 Rinci metadata will be searched in C<%SPEC> package variable.
 
 Alternatively, you can also specify C<base_code> and C<base_meta>.
 
 =item * B<description> => I<str>
 
 Description for the mod subroutine.
 
 =item * B<install_sub> => I<bool> (default: 1)
 
 =item * B<modify_args> => I<hash>
 
 Arguments to modify.
 
 For each argument you can specify a coderef. The coderef will receive the
 argument ($arg_spec) and is expected to modify the argument specification.
 
 =item * B<modify_meta> => I<code>
 
 Specify code to modify metadata.
 
 Code will be called with arguments ($meta) where $meta is the cloned Rinci
 metadata.
 
 =item * B<output_code> => I<code>
 
 Code for the modified sub.
 
 If not specified will use C<base_code> (which will then be required).
 
 =item * B<output_name> => I<str>
 
 Where to install the modified sub.
 
 Subroutine will be put in the specified name. If the name is not qualified with
 package name, will use caller's package. If no C<output_code> is specified, the
 base subroutine reference will be assigned here.
 
 Note that this argument is optional.
 
 =item * B<remove_args> => I<array>
 
 List of arguments to remove.
 
 =item * B<rename_args> => I<hash>
 
 Arguments to rename.
 
 =item * B<replace_args> => I<hash>
 
 Arguments to add.
 
 =item * B<summary> => I<str>
 
 Summary for the mod subroutine.
 
 =back
 
 Returns an enveloped result (an array).
 
 First element (status) is an integer containing HTTP status code
 (200 means OK, 4xx caller error, 5xx function error). Second element
 (msg) is a string containing error message, or 'OK' if status is
 200. Third element (result) is optional, the actual result. Fourth
 element (meta) is called result metadata and is optional, a hash
 that contains extra information.
 
 Return value:  (hash)
 =head1 FAQ
 
 =head2 What if I want to put result ($res->[2]) into my result with err()?
 
 You can do something like this:
 
  my $err = err(...) if ERROR_CONDITION;
  $err->[2] = SOME_RESULT;
  return $err;
 
 =head1 SEE ALSO
 
 L<Perinci>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/Util/ResObj.pm ###
 package Perinci::Sub::Util::ResObj;
 
 our $DATE = '2015-01-04'; # DATE
 our $VERSION = '0.41'; # VERSION
 
 use Carp;
 use overload
     q("") => sub {
         my $res = shift; "ERROR $err->[0]: $err->[1]\n" . Carp::longmess();
     };
 
 1;
 # ABSTRACT: An object that represents enveloped response suitable for die()-ing
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::Util::ResObj - An object that represents enveloped response suitable for die()-ing
 
 =head1 VERSION
 
 This document describes version 0.41 of Perinci::Sub::Util::ResObj (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-01-04.
 
 =head1 SYNOPSIS
 
 Currently unused. See L<Perinci::Sub::Util>'s C<warn_err> and C<die_err>
 instead.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Perinci/Sub/Util/Sort.pm ###
 package Perinci::Sub::Util::Sort;
 
 our $DATE = '2015-01-04'; # DATE
 our $VERSION = '0.41'; # VERSION
 
 use 5.010;
 use strict;
 use warnings;
 
 require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        sort_args
                );
 
 our %SPEC;
 
 sub sort_args {
     my $args = shift;
     sort {
         (($args->{$a}{pos} // 9999) <=> ($args->{$b}{pos} // 9999)) ||
             $a cmp $b
         } keys %$args;
 }
 
 1;
 # ABSTRACT: Sort routines
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Perinci::Sub::Util::Sort - Sort routines
 
 =head1 VERSION
 
 This document describes version 0.41 of Perinci::Sub::Util::Sort (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-01-04.
 
 =head1 SYNOPSIS
 
  use Perinci::Sub::Util::Sort qw(sort_args);
 
  my $meta = {
      v => 1.1,
      args => {
          a1 => { pos=>0 },
          a2 => { pos=>1 },
          opt1 => {},
          opt2 => {},
      },
  };
  my @args = sort_args($meta->{args}); # ('a1','a2','opt1','opt2')
 
 =head1 FUNCTIONS
 
 =head2 sort_args(\%args) => LIST
 
 Sort argument in args property by pos, then by name.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Util>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/sharyanto/perl-Perinci-Sub-Util>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Util>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Rinci.pm ###
 package Rinci;
 
 our $VERSION = '1.1.77'; # VERSION
 
 1;
 # ABSTRACT: Language-neutral metadata for your code
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Rinci - Language-neutral metadata for your code
 
 =head1 VERSION
 
 This document describes version 1.1.77 of Rinci (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-05-01.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Rinci>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Rinci>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Rinci>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Sah.pm ###
 package Sah;
 
 our $VERSION = '0.9.37'; # VERSION
 
 1;
 # ABSTRACT: Schema for data structures (specification)
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Sah - Schema for data structures (specification)
 
 =head1 VERSION
 
 This document describes version 0.9.37 of Sah (from Perl distribution Sah), released on 2015-06-11.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Sah>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Sah>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Sah/Schema/DefHash.pm ###
 package Sah::Schema::DefHash;
 
 use 5.010001;
 use strict;
 use warnings;
 
 our $VERSION = '1.0.10'; # VERSION
 our $DATE = '2015-04-24'; # DATE
 
 our %SCHEMAS;
 
 $SCHEMAS{defhash} = [hash => {
     # tmp
     _prop => {
         v => {},
         defhash_v => {},
         name => {},
         caption => {},
         summary => {},
         description => {},
         tags => {},
         default_lang => {},
         x => {},
     },
 
     keys => {
 
         v         => ['float*', default=>1],
 
         defhash_v => ['int*', default=>1],
 
         name      => [
             'str*',
             'clset&' => [
                 {
                     match             => qr/\A\w+\z/,
                     'match.err_level' => 'warn',
                     'match.err_msg'   => 'should be a word',
                 },
                 {
                     max_len             => 32,
                     'max_len.err_level' => 'warn',
                     'max_len.err_msg'   => 'should be short',
                 },
             ],
         ],
 
         caption   => [
             'str*',
         ],
 
         summary   => [
             'str',
             'clset&' => [
                 {
                     max_len             => 72,
                     'max_len.err_level' => 'warn',
                     'max_len.err_msg'   => 'should be short',
                 },
                 {
                     'match'           => qr/\n/,
                     'match.op'        => 'not',
                     'match.err_level' => 'warn',
                     'match.err_msg'   => 'should only be a single-line text',
                 },
             ],
         ],
 
         description => [
             'str',
         ],
 
         tags => [
             'array',
             of => [
                 'any*',
                 of => [
                     'str*',
                     'hash*', # XXX defhash, but this is circular
                 ],
             ],
         ],
 
         default_lang => [
             'str*', # XXX check format, e.g. 'en' or 'en_US'
         ],
 
         x => [
             'any',
         ],
     },
     'keys.restrict' => 0,
     'allowed_keys_re' => qr/\A\w+(\.\w+)*\z/,
 }];
 
 $SCHEMAS{defhash_v1} = [defhash => {
     keys => {
         defhash_v => ['int*', is=>1],
     },
 }];
 
 # XXX check known attributes (.alt, etc)
 # XXX check alt.XXX format (e.g. must be alt\.(lang\.\w+|env_lang\.\w+)
 # XXX *.alt.*.X should also be of the same type (e.g. description.alt.lang.foo
 
 1;
 # ABSTRACT: Sah schemas to validate DefHash
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Sah::Schema::DefHash - Sah schemas to validate DefHash
 
 =head1 VERSION
 
 This document describes version 1.0.10 of Sah::Schema::DefHash (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-04-24.
 
 =head1 SYNOPSIS
 
  # schemas are put in the %SCHEMAS package variable
 
 =head1 DESCRIPTION
 
 This module contains L<Sah> schemas to validate L<DefHash>.
 
 =head1 SCHEMAS
 
 =over
 
 =item * defhash
 
 =item * defhash_v1
 
 =back
 
 =head1 SEE ALSO
 
 L<Sah>, L<Data::Sah>
 
 L<DefHash>
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/DefHash>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-DefHash>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=DefHash>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Sah/Schema/Rinci.pm ###
 package Sah::Schema::Rinci;
 
 our $DATE = '2015-05-01'; # DATE
 our $VERSION = '1.1.77'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 our %SCHEMAS;
 
 my %dh_props = (
     v => {},
     defhash_v => {},
     name => {},
     caption => {},
     summary => {},
     description => {},
     tags => {},
     default_lang => {},
     x => {},
 );
 
 $SCHEMAS{rinci} = [hash => {
     # tmp
     _ver => 1.1, # this has the effect of version checking
     _prop => {
         %dh_props,
 
         entity_v => {},
         entity_date => {},
         links => {
             _elem_prop => {
                 %dh_props,
 
                 url => {},
             },
         },
     },
 }];
 
 $SCHEMAS{rinci_function} = [hash => {
     # tmp
     _ver => 1.1,
     _prop => {
         %dh_props,
 
         # from common rinci metadata
         entity_v => {},
         entity_date => {},
         links => {},
 
         is_func => {},
         is_meth => {},
         is_class_meth => {},
         args => {
             _value_prop => {
                 %dh_props,
 
                 # common rinci metadata
                 links => {},
 
                 schema => {},
                 filters => {},
                 default => {},
                 req => {},
                 pos => {},
                 greedy => {},
                 partial => {},
                 stream => {},
                 is_password => {},
                 cmdline_aliases => {
                     _value_prop => {
                         summary => {},
                         description => {},
                         schema => {},
                         code => {},
                         is_flag => {},
                     },
                 },
                 cmdline_on_getopt => {},
                 cmdline_prompt => {},
                 completion => {},
                 element_completion => {},
                 cmdline_src => {},
                 meta => 'fix',
                 element_meta => 'fix',
                 deps => {
                     _keys => {
                         arg => {},
                         all => {},
                         any => {},
                         none => {},
                     },
                 },
             },
         },
         args_as => {},
         args_rels => {},
         result => {
             _prop => {
                 %dh_props,
 
                 schema => {},
                 statuses => {
                     _value_prop => {
                         # from defhash
                         summary => {},
                         description => {},
                         schema => {},
                     },
                 },
                 partial => {},
                 stream => {},
             },
         },
         result_naked => {},
         examples => {
             _elem_prop => {
                 %dh_props,
 
                 args => {},
                 argv => {},
                 src => {},
                 src_plang => {},
                 status => {},
                 result => {},
                 test => {},
             },
         },
         features => {
             _keys => {
                 reverse => {},
                 tx => {},
                 dry_run => {},
                 pure => {},
                 immutable => {},
                 idempotent => {},
                 check_arg => {},
             },
         },
         deps => {
             _keys => {
                 all => {},
                 any => {},
                 none => {},
                 env => {},
                 prog => {},
                 pkg => {},
                 func => {},
                 code => {},
                 tmp_dir => {},
                 trash_dir => {},
             },
         },
     },
 }];
 $SCHEMAS{rinci_function}[1]{_prop}{args}{_value_prop}{meta} =
     $SCHEMAS{rinci_function}[1];
 $SCHEMAS{rinci_function}[1]{_prop}{args}{_value_prop}{element_meta} =
     $SCHEMAS{rinci_function}[1];
 
 # rinci_package
 # rinci_variable
 
 $SCHEMAS{rinci_resmeta} = [hash => {
     # tmp
     _ver => 1.1,
     _prop => {
         %dh_props,
 
         perm_err => {},
         func => {}, # XXX func.*
         cmdline => {}, # XXX cmdline.*
         logs => {},
         prev => {},
         results => {},
         part_start => {},
         part_len => {},
         len => {},
         stream => {},
     },
 }];
 
 # list of known special arguments: -dry_run, -action, -tx_action,
 # -res_part_start, -res_part_len, -arg_part_start, -arg_part_len
 
 1;
 # ABSTRACT: Sah schemas for Rinci metadata
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Sah::Schema::Rinci - Sah schemas for Rinci metadata
 
 =head1 VERSION
 
 This document describes version 1.1.77 of Sah::Schema::Rinci (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-05-01.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Rinci>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Rinci>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Rinci>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### Sah/Schema/Sah.pm ###
 package Sah::Schema::Sah;
 
 use 5.010;
 use strict;
 use warnings;
 
 our $VERSION = '0.9.37'; # VERSION
 our $DATE = '2015-06-11'; # DATE
 
 our %SCHEMAS;
 
 $SCHEMAS{sah_type_name} = ['str' => {
     match => '\A[A-Za-z][A-Za-z0-9_]*(::[A-Za-z][A-Za-z0-9_]*)*\z',
 }];
 
 $SCHEMAS{sah_str_schema} = ['str' => {
     match => '\A[A-Za-z][A-Za-z0-9_]*(::[A-Za-z][A-Za-z0-9_]*)*\*?\z',
 }];
 
 $SCHEMAS{sah_clause_name} = undef; # TODO
 
 $SCHEMAS{sah_clause_set} = [defhash => {
     # tmp
     _prop => {
         # from defhash
         v => {},
         defhash_v => {},
         name => {},
         summary => {},
         description => {},
         tags => {},
         default_lang => {},
         x => {},
 
         # incomplete
         clause => {
         },
         clset => {
         },
     },
 }];
 
 # XXX sah_num_clause_set (based on sah_clause_set)
 # XXX sah_
 
 $SCHEMAS{sah_extras} = [defhash => {
     _prop => {
         def => {},
     },
 }];
 
 $SCHEMAS{sah_array_schema} = ['array' => {
     elems => [
         'sah_type_name',
         'sah_clause_set',
         'sah_extras',
     ],
     min_len => 1,
 }];
 
 $SCHEMAS{sah_schema} = [any => {
     of => [
         'sah_str_schema',
         'sah_array_schema',
     ],
 }];
 
 1;
 # ABSTRACT: Sah schemas for Sah schema
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 Sah::Schema::Sah - Sah schemas for Sah schema
 
 =head1 VERSION
 
 This document describes version 0.9.37 of Sah::Schema::Sah (from Perl distribution Sah), released on 2015-06-11.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/Sah>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-Sah>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
 
 __END__
 
 # commented temporarily, unfinished refactoring
 sub schemas {
     my $re_var_nameU   = '(?:[A-Za-z_][A-Za-z0-9_]*)'; # U = unanchored
     my $re_func_name   = '\A(?:'.$re_var_nameU.'::)*'.$re_var_nameU.'+\z';
     my $reu_var_name   = '(?:[A-Za-z_][A-Za-z0-9_]*)';
     my $re_clause_name = '\A(?:[a-z_][a-z0-9_]*)\z'; # no uppercase
     my $re_cattr_name  = '\A(?:'.$re_var_nameU.'\.)*'.$re_var_nameU.'+\z';
     my $re_clause_key  = ''; # XXX ':ATTR' or 'NAME' or 'NAME:ATTR'
 
     # R = has req=>1
     my $clause_setR = ['hash' => {
         keys_regex => $re_clause_key,
     }];
 
     my $str_schemaR = ['str*' => {
 
         # TODO: is_sah_str_shortcut
         #if => [not_match => $re_type_name, isa_sah_str_shortcut=>1],
 
         # for now, we don't support string shortcuts
         match => $re_type_name,
     }];
 
     # TODO: is_expr
 
     my $array_schemaR = ['array*' => {
         min_len    => 1,
         # the first clause set checks the type
         {
             elems => [$str_schemaR],
         },
 
         # the second clause set checks the clause set
         {
             # first we discard the type first
             prefilters => ['array_slice($_, 1)'],
             deps       => [
                 # no clause sets, e.g. ['int']
                 [[array => {len=>1}],
                  'any'], # do nothing, succeed
 
                 # a single clause set, flattened in the array, but there are odd
                 # number of elements, e.g. ['int', min=>1, 'max']
                 [[array => {elems=>['str*'], check=>'array_len($_) % 2 != 0'}],
                  ['any', fail=>1,
                   err_msg=>'Odd number of elements in clause set']],
 
                 # a single clause set, flattened in the array, with even number
                 # of elements, e.g. ['int', min=>1, max=>10]
                 [[array => {elems=>['str*']}],
                  $clause_setR],
 
                 # otherwise, all elements must be a clause set
                  ['any',
                   [array => {of => $clause_setR}]],
             ] # END deps
         },
 
     }];
 
     # predeclare
     my $hash_schemaR = ['hash*' => undef];
 
     my $schema => ['any' => {
         of   => [qw/str array hash/],
         deps => [
             ['str*'   => $str_schemaR],
             ['array*' => $array_schemaR],
             ['hash*'  => $hash_schemaR],
         ],
     }];
 
     my $defR = ['hash*' => {
         keys_of   => ['str*' => {,
                                  # remove optional '?' suffix
                                  prefilters => [q(replace('[?]\z', '', $_))],
                                  match      => $re_type_name,
                              }],
         values_of => $schema,
     }];
### String/LineNumber.pm ###
 package String::LineNumber;
 
 our $DATE = '2014-12-10'; # DATE
 our $VERSION = '0.01'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        linenum
                );
 
 sub linenum {
     my ($str, $opts) = @_;
     $opts //= {};
     $opts->{width}      //= 4;
     $opts->{zeropad}    //= 0;
     $opts->{skip_empty} //= 1;
 
     my $i = 0;
     $str =~ s/^(([\t ]*\S)?.*)/
         sprintf(join("",
                      "%",
                      ($opts->{zeropad} && !($opts->{skip_empty}
                                                 && !defined($2)) ? "0" : ""),
                      $opts->{width}, "s",
                      "|%s"),
                 ++$i && $opts->{skip_empty} && !defined($2) ? "" : $i,
                 $1)/meg;
 
     $str;
 }
 
 1;
 # ABSTRACT: Give line number to each line of string
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 String::LineNumber - Give line number to each line of string
 
 =head1 VERSION
 
 This document describes version 0.01 of String::LineNumber (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2014-12-10.
 
 =head1 FUNCTIONS
 
 =head2 linenum($str, \%opts) => STR
 
 Add line numbers. For example:
 
      1|line1
      2|line2
       |
      4|line4
 
 Known options:
 
 =over 4
 
 =item * width => INT (default: 4)
 
 =item * zeropad => BOOL (default: 0)
 
 If turned on, will output something like:
 
   0001|line1
   0002|line2
       |
   0004|line4
 
 =item * skip_empty => BOOL (default: 1)
 
 If set to false, keep printing line number even if line is empty:
 
      1|line1
      2|line2
      3|
      4|line4
 
 =back
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/String-LineNumber>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-String-LineNumber>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-LineNumber>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### String/PerlQuote.pm ###
 package String::PerlQuote;
 
 our $DATE = '2014-12-10'; # DATE
 our $VERSION = '0.01'; # VERSION
 
 use 5.010001;
 use strict;
 use warnings;
 
 use Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        single_quote
                        double_quote
                );
 
 # BEGIN COPY PASTE FROM Data::Dump
 my %esc = (
     "\a" => "\\a",
     "\b" => "\\b",
     "\t" => "\\t",
     "\n" => "\\n",
     "\f" => "\\f",
     "\r" => "\\r",
     "\e" => "\\e",
 );
 
 # put a string value in double quotes
 sub double_quote {
   local($_) = $_[0];
   # If there are many '"' we might want to use qq() instead
   s/([\\\"\@\$])/\\$1/g;
   return qq("$_") unless /[^\040-\176]/;  # fast exit
 
   s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
 
   # no need for 3 digits in escape for these
   s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
 
   s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
   s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
 
   return qq("$_");
 }
 # END COPY PASTE FROM Data::Dump
 
 sub single_quote {
   local($_) = $_[0];
   s/([\\'])/\\$1/g;
   return qq('$_');
 }
 1;
 # ABSTRACT: Quote a string like Perl does
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 String::PerlQuote - Quote a string like Perl does
 
 =head1 VERSION
 
 This document describes version 0.01 of String::PerlQuote (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2014-12-10.
 
 =head1 FUNCTIONS
 
 =head2 double_quote($str) => STR
 
 Quote or encode C<$str> to the Perl double quote (C<">) literal representation
 of the string. Example:
 
  say double_quote("a");        # => "a"     (with the quotes)
  say double_quote("a\n");      # => "a\n"
  say double_quote('"');        # => "\""
  say double_quote('$foo');     # => "\$foo"
 
 This code is taken from C<quote()> in L<Data::Dump>. Maybe I didn't look more
 closely, but I couldn't a module that provides a function to do something like
 this. L<String::Escape>, for example, provides C<qqbackslash> but it does not
 escape C<$>.
 
 =head2 single_quote($str) => STR
 
 Like C<double_quote> but will produce a Perl single quote literal representation
 instead of the double quote ones. In single quotes, only literal backslash C<\>
 and single quote character C<'> are escaped, the rest are displayed as-is, so
 the result might span multiple lines or contain other non-printable characters.
 
  say single_quote("Mom's");    # => 'Mom\'s' (with the quotes)
  say single_quote("a\\");      # => 'a\\"
  say single_quote('"');        # => '"'
  say single_quote("\$foo");    # => '$foo'
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/String-PerlQuote>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-String-PerlQuote>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-PerlQuote>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2014 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
### String/Wildcard/Bash.pm ###
 package String::Wildcard::Bash;
 
 use 5.010001;
 use strict;
 use warnings;
 
 our $VERSION = '0.02'; # VERSION
 
 use Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT_OK = qw(
                        contains_wildcard
                );
 
 # note: order is important here, brace encloses the other
 my $re1 =
     qr(
           # non-escaped brace expression, with at least one comma
           (?P<brace>
               (?<!\\)(?:\\\\)*\{
               (?:           \\\\ | \\\{ | \\\} | [^\\\{\}] )*
               (?:, (?:  \\\\ | \\\{ | \\\} | [^\\\{\}] )* )+
               (?<!\\)(?:\\\\)*\}
           )
       |
           # non-escaped brace expression, to catch * or ? or [...] inside so
           # they don't go to below pattern, because bash doesn't consider them
           # wildcards, e.g. '/{et?,us*}' expands to '/etc /usr', but '/{et?}'
           # doesn't expand at all to /etc.
           (?P<braceno>
               (?<!\\)(?:\\\\)*\{
               (?:           \\\\ | \\\{ | \\\} | [^\\\{\}] )*
               (?<!\\)(?:\\\\)*\}
           )
       |
           (?P<class>
               # non-empty, non-escaped character class
               (?<!\\)(?:\\\\)*\[
               (?:  \\\\ | \\\[ | \\\] | [^\\\[\]] )+
               (?<!\\)(?:\\\\)*\]
           )
       |
           (?P<joker>
               # non-escaped * and ?
               (?<!\\)(?:\\\\)*[*?]
           )
       )ox;
 
 sub contains_wildcard {
     my $str = shift;
 
     while ($str =~ /$re1/go) {
         my %m = %+;
         return 1 if $m{brace} || $m{class} || $m{joker};
     }
     0;
 }
 
 1;
 # ABSTRACT: Bash wildcard string routines
 
 __END__
 
 =pod
 
 =encoding UTF-8
 
 =head1 NAME
 
 String::Wildcard::Bash - Bash wildcard string routines
 
 =head1 VERSION
 
 This document describes version 0.02 of String::Wildcard::Bash (from Perl distribution Perinci-CmdLine-Any-Lumped version 0.09), released on 2015-01-03.
 
 =head1 SYNOPSIS
 
     use String::Wildcard::Bash qw(contains_wildcard);
 
     say 1 if contains_wildcard(""));      # -> 0
     say 1 if contains_wildcard("ab*"));   # -> 1
     say 1 if contains_wildcard("ab\\*")); # -> 0
 
 =head1 DESCRIPTION
 
 =for Pod::Coverage ^(qqquote)$
 
 =head1 FUNCTIONS
 
 =head2 contains_wildcard($str) => bool
 
 Return true if C<$str> contains wildcard pattern. Wildcard patterns include C<*>
 (meaning zero or more characters), C<?> (exactly one character), C<[...]>
 (character class), C<{...,}> (brace expansion). Can handle escaped/backslash
 (e.g. C<foo\*> does not contain wildcard, it's C<foo> followed by a literal
 asterisk C<*>).
 
 Aside from wildcard, bash does other types of expansions/substitutions too, but
 these are not considered wildcard. These include tilde expansion (e.g. C<~>
 becomes C</home/alice>), parameter and variable expansion (e.g. C<$0> and
 C<$HOME>), arithmetic expression (e.g. C<$[1+2]>), history (C<!>), and so on.
 
 Although this module has 'Bash' in its name, this set of wildcards should be
 applicable to other Unix shells. Haven't checked completely though.
 
 =head1 SEE ALSO
 
 L<Regexp::Wildcards> to convert a string with wildcard pattern to equivalent
 regexp pattern. Can handle Unix wildcards as well as SQL and DOS/Win32. As of
 this writing (v1.05), it does not handle character class (C<[...]>) and
 interprets brace expansion differently than bash.
 
 Other C<String::Wildcard::*> modules.
 
 =head1 HOMEPAGE
 
 Please visit the project's homepage at L<https://metacpan.org/release/String-Wildcard-Bash>.
 
 =head1 SOURCE
 
 Source repository is at L<https://github.com/perlancar/perl-String-Wildcard-Bash>.
 
 =head1 BUGS
 
 Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=String-Wildcard-Bash>
 
 When submitting a bug or request, please include a test-file or a
 patch to an existing test-file that illustrates the bug or desired
 feature.
 
 =head1 AUTHOR
 
 perlancar <perlancar@cpan.org>
 
 =head1 COPYRIGHT AND LICENSE
 
 This software is copyright (c) 2015 by perlancar@cpan.org.
 
 This is free software; you can redistribute it and/or modify it under
 the same terms as the Perl 5 programming language system itself.
 
 =cut
