#!perl
# BEGIN DATAPACK CODE
{
my $toc;
my $data_linepos = 1;
unshift @INC, sub {
$toc ||= do {
my $fh = \*DATA;
my $header_line;
my $header_found;
while (1) {
my $header_line = <$fh>;
defined($header_line)
or die "Unexpected end of data section while reading header line";
chomp($header_line);
if ($header_line eq 'Data::Section::Seekable v1') {
$header_found++;
last;
}
}
die "Can't find header 'Data::Section::Seekable v1'"
unless $header_found;
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;
# 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;
\%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 + $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.120
# on Fri Nov 29 13:50:02 2019. You probably should not manually edit this file.
# NO_PERINCI_CMDLINE_SCRIPT
# PERINCI_CMDLINE_COMPLETER_SCRIPT: {program_name=>"ppgrep",read_config=>0,read_env=>0,skip_format=>1,subcommands=>undef,url=>"/App/ppgrep/ppgrep"}
# FRAGMENT id=shcompgen-hint completer=1 for=ppgrep
our $DATE = '2019-11-29'; # DATE
our $VERSION = '0.033'; # VERSION
# PODNAME: _ppgrep
# ABSTRACT: Completer script for ppgrep
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 = {program_name=>"ppgrep",read_config=>0,read_env=>0,skip_format=>1,subcommands=>undef,url=>"/App/ppgrep/ppgrep"};
my $meta = {_orig_args_as=>undef,_orig_result_naked=>undef,args=>{count=>{cmdline_aliases=>{c=>{}},schema=>["true",{req=>1},{}],summary=>"Suppress normal output; instead print a count of matching processes",tags=>["category:display"]},euid=>{cmdline_aliases=>{u=>{}},schema=>["array",{of=>"str*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes whose effective user ID is listed. Either the numerical or symbolical value may be used.",tags=>["category:filtering"]},exact=>{cmdline_aliases=>{x=>{}},schema=>["true",{req=>1},{}],summary=>"Only match processes whose names (or command line if -f is specified) exactly match the pattern",tags=>["category:filtering"]},full=>{cmdline_aliases=>{f=>{}},schema=>["true",{req=>1},{}],summary=>"The pattern is normally only matched against the process name. When -f is set, the full command line is used.",tags=>["category:filtering"]},group=>{cmdline_aliases=>{G=>{}},schema=>["array",{of=>"str*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes whose real group ID is listed. Either the numerical or symbolical value may be used.",tags=>["category:filtering"]},inverse=>{cmdline_aliases=>{v=>{}},schema=>["true",{req=>1},{}],summary=>"Negates the matching",tags=>["category:filtering"]},list_full=>{cmdline_aliases=>{a=>{}},schema=>["true",{req=>1},{}],summary=>"List the full command line as well as the process ID",tags=>["category:display"]},list_name=>{cmdline_aliases=>{l=>{}},schema=>["true",{req=>1},{}],summary=>"List the process name as well as the process ID",tags=>["category:display"]},pattern=>{pos=>0,schema=>["str",{req=>1},{}],summary=>"Only match processes whose name/cmdline match the pattern",tags=>["category:filtering"]},pgroup=>{cmdline_aliases=>{g=>{}},schema=>["array",{of=>"uint*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes in the process group IDs listed",tags=>["category:filtering"]},session=>{cmdline_aliases=>{s=>{}},schema=>["array",{of=>"uint*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes whose process session ID is listed",tags=>["category:filtering"]},terminal=>{cmdline_aliases=>{t=>{}},schema=>["array",{of=>"str*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes whose controlling terminal is listed. The terminal name should be specified without the \"/dev/\" prefix.",tags=>["category:filtering"]},uid=>{cmdline_aliases=>{U=>{}},schema=>["array",{of=>"str*",req=>1,"x.perl.coerce_rules"=>["From_str::comma_sep"]},{}],summary=>"Only match processes whose user ID is listed. Either the numerical or symbolical value may be used.",tags=>["category:filtering"]}},args_as=>"hash",description=>"\nThis utility is similar to <prog:pgrep> except that we only look at our\ndescendants (parent, parent's parent, and so on up to PID 1).\n\n",entity_date=>undef,entity_v=>undef,links=>["prog:pgrep"],result_naked=>0,summary=>"Look up parents' processes based on name and other attributes",v=>1.1};
my $sc_metas = {};
my $copts = {help=>{getopt=>"help|h|?",handler=>sub{package Perinci::CmdLine::Base;use warnings;use strict;no feature;use feature ':5.10';my($go, $val, $r) = @_;$$r{'action'} = 'help';$$r{'skip_parse_subcommand_argv'} = 1},order=>0,summary=>"Display help message and exit",usage=>"--help (or -h, -?)"},version=>{getopt=>"version|v",handler=>sub{package Perinci::CmdLine::Base;use warnings;use strict;no feature;use feature ':5.10';my($go, $val, $r) = @_;$$r{'action'} = 'version';$$r{'skip_parse_subcommand_argv'} = 1},summary=>"Display program's version and exit",usage=>"--version (or -v)"}};
my $r = {};
# get words
my $shell;
my ($words, $cword);
if ($ENV{COMP_LINE}) { $shell = "bash"; require Complete::Bash; require Encode; ($words,$cword) = @{ Complete::Bash::parse_cmdline() }; ($words,$cword) = @{ Complete::Bash::join_wordbreak_words($words,$cword) }; $words = [map {Encode::decode("UTF-8", $_)} @$words]; }
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', 'no_getopt_compat', 'gnu_compat');
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
_ppgrep - Completer script for ppgrep
=head1 VERSION
This document describes version 0.033 of Perinci::CmdLine::Base (from Perl distribution App-ppgrep), released on 2019-11-29.
=head1 HOMEPAGE
Please visit the project's homepage at L<https://metacpan.org/release/App-ppgrep>.
=head1 SOURCE
Source repository is at L<https://github.com/perlancar/perl-App-ppgrep>.
=head1 BUGS
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=App-ppgrep>
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) 2019 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/Bash.pm,6376,41548,1;193
Complete/Common.pm,47951,6507,2;1443
Complete/Env.pm,54482,5656,3;1639
Complete/File.pm,60163,14154,4;1897
Complete/Getopt/Long.pm,74349,33893,5;2358
Complete/Path.pm,108267,13757,6;3289
Complete/Tcsh.pm,122049,6638,7;3706
Complete/Util.pm,128712,38793,8;3949
Data/Clean.pm,167527,16397,9;5256
Data/Clean/ForJSON.pm,183954,8992,10;5811
Data/Clean/FromJSON.pm,192977,3100,11;6104
Data/Dmp.pm,196097,12330,12;6228
Data/ModeMerge.pm,208453,26971,13;6614
Data/ModeMerge/Config.pm,235457,14454,14;7399
Data/ModeMerge/Mode/ADD.pm,249946,2657,15;7923
Data/ModeMerge/Mode/Base.pm,252639,22041,16;8043
Data/ModeMerge/Mode/CONCAT.pm,274718,1741,17;8716
Data/ModeMerge/Mode/DELETE.pm,276497,2738,18;8795
Data/ModeMerge/Mode/KEEP.pm,279271,2463,19;8925
Data/ModeMerge/Mode/NORMAL.pm,281772,2800,20;9044
Data/ModeMerge/Mode/SUBTRACT.pm,284612,3373,21;9188
Data/Sah/Normalize.pm,288015,9038,22;9331
Data/Sah/Resolve.pm,297081,7505,23;9605
Data/Sah/Util/Type.pm,304616,9456,24;9844
Function/Fallback/CoreOrPP.pm,314110,4838,25;10144
Getopt/Long/Negate/EN.pm,318981,5332,26;10335
Getopt/Long/Util.pm,324341,15221,27;10484
Lingua/EN/PluralToSingular.pm,339600,14259,28;11055
Log/ger.pm,353878,9776,29;11802
Log/ger/Format.pm,363680,1185,30;12101
Log/ger/Format/None.pm,364896,951,31;12170
Log/ger/Heavy.pm,365872,18292,32;12228
Log/ger/Layout.pm,384190,1144,33;12648
Log/ger/Output.pm,385360,1250,34;12714
Log/ger/Output/Array.pm,386642,1294,35;12789
Log/ger/Output/ArrayML.pm,387970,1563,36;12868
Log/ger/Output/Null.pm,389564,954,37;12952
Log/ger/Output/String.pm,390551,1983,38;13010
Log/ger/Plugin.pm,392560,1930,39;13108
Log/ger/Plugin/MultilevelLog.pm,394530,2144,40;13219
Log/ger/Util.pm,396698,9269,41;13319
Mo.pm,405981,591,42;13629
Mo/Golf.pm,406591,8174,43;13633
Mo/Inline.pm,414786,3471,44;13869
Mo/Moose.pm,418277,533,45;14010
Mo/Mouse.pm,418830,563,46;14015
Mo/build.pm,419413,248,47;14020
Mo/builder.pm,419683,338,48;14024
Mo/chain.pm,420041,216,49;14028
Mo/coerce.pm,420278,330,50;14032
Mo/default.pm,420630,435,51;14036
Mo/exporter.pm,421088,176,52;14040
Mo/import.pm,421285,185,53;14044
Mo/importer.pm,421493,207,54;14048
Mo/is.pm,421717,228,55;14052
Mo/nonlazy.pm,421967,129,56;14056
Mo/option.pm,422117,259,57;14060
Mo/required.pm,422399,340,58;14064
Mo/xs.pm,422756,256,59;14068
Module/Installed/Tiny.pm,423045,6725,60;14072
Perinci/Sub/Complete.pm,429802,67662,61;14295
Perinci/Sub/GetArgs/Argv.pm,497500,55172,62;16159
Perinci/Sub/GetArgs/Array.pm,552709,7479,63;17647
Perinci/Sub/Normalize.pm,560221,7303,64;17907
Perinci/Sub/Util.pm,567552,21083,65;18142
Perinci/Sub/Util/Args.pm,588668,6274,66;18903
Perinci/Sub/Util/ResObj.pm,594977,1545,67;19157
Perinci/Sub/Util/Sort.pm,596555,1957,68;19218
Regexp/Stringify.pm,598540,5418,69;19309
Sah/Schema/rinci/function_meta.pm,604000,5179,70;19506
Sah/Schema/rinci/meta.pm,609212,1842,71;19693
Sah/Schema/rinci/result_meta.pm,611094,1825,72;19778
Sah/SchemaR/rinci/function_meta.pm,612962,6027,73;19856
Sah/SchemaR/rinci/meta.pm,619023,2929,74;19914
Sah/SchemaR/rinci/result_meta.pm,621993,2277,75;19972
Sah/Schemas/Rinci.pm,624299,1280,76;20030
String/LineNumber.pm,625608,2512,77;20086
String/PerlQuote.pm,628148,3383,78;20204
String/Wildcard/Bash.pm,631563,8895,79;20329
YAML/Old.pm,640478,3321,80;20643
YAML/Old/Dumper.pm,643826,17730,81;20760
YAML/Old/Dumper/Base.pm,661588,3735,82;21337
YAML/Old/Error.pm,665349,5985,83;21448
YAML/Old/Loader.pm,671361,25286,84;21639
YAML/Old/Loader/Base.pm,696679,1235,85;22410
YAML/Old/Marshall.pm,697943,934,86;22447
YAML/Old/Mo.pm,698900,3416,87;22494
YAML/Old/Node.pm,702341,4692,88;22574
YAML/Old/Tag.pm,707057,240,89;22792
YAML/Old/Types.pm,707323,6708,90;22811
### Clone/PP.pm ###
#package Clone::PP;
#
#use 5.006;
#use strict;
#use warnings;
#use vars qw($VERSION @EXPORT_OK);
#use Exporter;
#
#$VERSION = 1.07;
#
#@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/Bash.pm ###
#package Complete::Bash;
#
#our $DATE = '2019-08-20'; # DATE
#our $VERSION = '0.330'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# point
# parse_cmdline
# join_wordbreak_words
# format_completion
# );
#
#our %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'Completion routines for bash shell',
#};
#
#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{point} = {
# v => 1.1,
# summary => 'Return line with point marked by a marker',
# description => <<'_',
#
#This is a utility function useful for testing/debugging. `parse_cmdline()`
#expects a command-line and a cursor position (`$line`, `$point`). This routine
#expects `$line` with a marker character (by default it's the caret, `^`) and
#return (`$line`, `$point`) to feed to `parse_cmdline()`.
#
#Example:
#
# point("^foo") # => ("foo", 0)
# point("fo^o") # => ("foo", 2)
#
#_
# args_as => 'array',
# args => {
# cmdline => {
# summary => 'Command-line which contains a marker character',
# schema => 'str*',
# pos => 0,
# },
# marker => {
# summary => 'Marker character',
# schema => ['str*', len=>1],
# default => '^',
# pos => 1,
# },
# },
# result_naked => 1,
#};
#sub point {
# my ($line, $marker) = @_;
# $marker //= '^';
#
# my $point = index($line, $marker);
# die "BUG: No marker '$marker' in line <$line>" unless $point >= 0;
# $line =~ s/\Q$marker\E//;
# ($line, $point);
#}
#
#$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; this comparison is made against
#bash versions 4.2-4.3):
#
#1) quotes and backslashes are stripped (bash's `COMP_WORDS` contains all the
# quotes and backslashes);
#
#2) quoted phrase that contains spaces, or phrase that contains escaped spaces is
# parsed as a single word. For example:
#
# command "First argument" Second\ argument
#
# bash would split it as (represented as Perl):
#
# ["command", "\"First", "argument\"", "Second\\", "argument"]
#
# which is not very convenient. We parse it into:
#
# ["command", "First argument", "Second argument"]
#
#3) 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.
#
#4) tildes (`~`) are expanded with user's home directory except for the current
# word (bash does not perform tilde expansion for `COMP_WORDS`);
#
#Caveats:
#
#* Like bash, we group non-whitespace word-breaking characters into its own word.
# By default `COMP_WORDBREAKS` is:
#
# "'@><=;|&(:
#
# So if raw command-line is:
#
# command --foo=bar http://example.com:80 mail@example.org Foo::Bar
#
# then the parse result will be:
#
# ["command", "--foo", "=", "bar", "http", ":", "//example.com", ":", "80", "Foo", "::", "Bar"]
#
# which is annoying sometimes. But we follow bash here so we can more easily
# accept input from a joined `COMP_WORDS` if we write completion bash functions,
# e.g. (in the example, `foo` is a Perl script):
#
# _foo ()
# {
# local words=(${COMP_CWORDS[@]})
# # add things to words, etc
# local point=... # calculate the new point
# COMPREPLY=( `COMP_LINE="foo ${words[@]}" COMP_POINT=$point foo` )
# }
#
# To avoid these word-breaking characters to be split/grouped, we can escape
# them with backslash or quote them, e.g.:
#
# command "http://example.com:80" Foo\:\:Bar
#
# which bash will parse as:
#
# ["command", "\"http://example.com:80\"", "Foo\\:\\:Bar"]
#
# and we parse as:
#
# ["command", "http://example.com:80", "Foo::Bar"]
#
#* Due to the way bash parses the command line (see above), the two below are
# equivalent:
#
# % cmd --foo=bar
# % cmd --foo = bar
#
#Because they both expand to `['--foo', '=', 'bar']`. But obviously
#<pm: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,
# },
# opts => {
# summary => 'Options',
# schema => 'hash*',
# description => <<'_',
#
#Optional. Known options:
#
#* `truncate_current_word` (bool). If set to 1, will truncate current word to the
# position of cursor, for example (`^` marks the position of cursor):
# `--vers^oo` to `--vers` instead of `--versoo`. This is more convenient when
# doing tab completion.
#
#_
# schema => 'hash*',
# pos => 2,
# },
# },
# 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, roughly 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, $opts) = @_;
#
# $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;
#
# log_trace "[compbash] line=<$line> point=<$point>"
# if $ENV{COMPLETE_BASH_TRACE};
#
# my @words;
# my $cword;
# my $pos = 0;
# my $pos_min_ws = 0;
# my $after_ws = 1; # XXX what does this variable mean?
# 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
# ([\@><=|&\(:]+) | # 10) non-whitespace word-breaking characters
# \s+
# )!
# $pos += length($1);
# #say "D: \$1=<$1> \$2=<$3> \$3=<$3> \$4=<$4> \$5=<$5> \$6=<$6> \$7=<$7> \$8=<$8> \$9=<$9> \$10=<$10>";
# #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;
# }
# #say "D:is_cur_word=$is_cur_word";
# $chunk =
# $2 ? _add_double_quoted($3, $is_cur_word) :
# $5 ? _add_single_quoted($6) :
# _add_unquoted($8, $is_cur_word, $after_ws);
# if ($opts && $opts->{truncate_current_word} &&
# $is_cur_word && $pos > $point) {
# $chunk = substr(
# $chunk, 0, length($chunk)-($pos_min_ws-$point));
# #say "D:truncating current word to <$chunk>";
# }
# 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 ($10) {
# # non-whitespace word-breaking characters
# push @words, $10;
# $after_ws = 1;
# } else {
# # whitespace
# $after_ws = 1;
# }
# !egx;
#
# $cword //= @words;
# $words[$cword] //= '';
#
# log_trace "[compbash] words=%s, cword=%s", \@words, $cword
# if $ENV{COMPLETE_BASH_TRACE};
#
# [\@words, $cword];
#}
#
#$SPEC{join_wordbreak_words} = {
# v => 1.1,
# summary => 'Post-process parse_cmdline() result by joining some words',
# description => <<'_',
#
#`parse_cmdline()`, like bash, splits some characters that are considered as
#word-breaking characters:
#
# "'@><=;|&(:
#
#So if command-line is:
#
# command -MData::Dump bob@example.org
#
#then they will be parsed as:
#
# ["command", "-MData", "::", "Dump", "bob", '@', "example.org"]
#
#Normally in Perl applications, we want `:`, `@` to be part of word. So this
#routine will convert the above into:
#
# ["command", "-MData::Dump", 'bob@example.org']
#
#_
#};
#sub join_wordbreak_words {
# my ($words, $cword) = @_;
# my $new_words = [];
# my $i = -1;
# while (++$i < @$words) {
# my $w = $words->[$i];
# if ($w =~ /\A[\@=:]+\z/) {
# if (@$new_words and $#$new_words != $cword) {
# $new_words->[-1] .= $w;
# $cword-- if $cword >= $i || $cword >= @$new_words;
# } else {
# push @$new_words, $w;
# }
# if ($i+1 < @$words) {
# $i++;
# $new_words->[-1] .= $words->[$i];
# $cword-- if $cword >= $i || $cword >= @$new_words;
# }
# } else {
# push @$new_words, $w;
# }
# }
# [$new_words, $cword];
#}
#
#sub _terminal_width {
# # XXX need to cache?
# if (eval { require Term::Size; 1 }) {
# my ($cols, undef) = Term::Size::chars(*STDOUT{IO});
# $cols // 80;
# } else {
# $ENV{COLUMNS} // 80;
# }
#}
#
## given terminal width & number of columns, calculate column width
#sub _column_width {
# my ($terminal_width, $num_columns) = @_;
# if (defined $num_columns && $num_columns > 0) {
# int( ($terminal_width - ($num_columns-1)*2) / $num_columns ) - 1;
# } else {
# undef;
# }
#}
#
## given terminal width & column width, calculate number of columns
#sub _num_columns {
# my ($terminal_width, $column_width) = @_;
# my $n = int( ($terminal_width+2) / ($column_width+2) );
# $n >= 1 ? $n : 1;
#}
#
#$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 => {
# summary => 'Specify options',
# schema=>'hash*',
# pos=>1,
# description => <<'_',
#
#Known options:
#
#* word
#
# A workaround. String. For now, see source code for more details.
#
#* show_summaries
#
# Whether to show item's summaries. Boolean, default is from
# COMPLETE_BASH_SHOW_SUMMARIES environment variable or 1.
#
# An answer item contain summary, which is a short description about the item,
# e.g.:
#
# [{word=>"-a" , summary=>"Show hidden files"},
# {word=>"-l" , summary=>"Show details"},
# {word=>"--sort", summary=>"Specify sort order"}],
#
# When summaries are not shown, user will just be seeing something like:
#
# -a
# -l
# --sort
#
# But when summaries are shown, user will see:
#
# -a -- Show hidden files
# -l -- Show details
# --sort -- Specify sort order
#
# which is quite helpful.
#
#_
#
# },
# },
# 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 $words = $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};
#
# # we keep the original words (before formatted with summaries) when we want
# # to use fzf instead of passing to bash directly
# my @words;
# my @summaries;
# my @res;
# my $has_summary;
#
# my $code_return_message = sub {
# # display a message instead of list of words. we send " " (ASCII space)
# # which bash does not display, so we can display a line of message while
# # the user does not get the message as the completion. I've also tried
# # \000 to \037 instead of space (\040) but nothing works better.
# my $msg = shift;
# if ($msg =~ /\A /) {
# $msg =~ s/\A +//;
# $msg = " (empty message)" unless length $msg;
# }
# return (sprintf("%-"._terminal_width()."s", $msg), " ");
# };
#
# FORMAT_MESSAGE:
# # display a message instead of list of words. we send " " (ASCII space)
# # which bash does not display, so we can display a line of message while the
# # user does not get the message as the completion. I've also tried \000 to
# # \037 instead of space (\040) but nothing works better.
# if (defined $hcomp->{message}) {
# @res = $code_return_message->($hcomp->{message});
# goto RETURN_RES;
# }
#
# WORKAROUND_PREVENT_BASH_FROM_INSERTING_SPACE:
# if (defined($path_sep) && @$words == 1) {
# my $re = qr/\Q$path_sep\E\z/;
# my $word;
# if (ref($words->[0]) eq 'HASH') {
# $words = [$words->[0], {word=>"$words->[0] "}] if
# $words->[0]{word} =~ $re;
# } else {
# $words = [$words->[0], "$words->[0] "]
# if $words->[0] =~ $re;
# }
# }
#
# WORKAROUND_WITH_WORDBREAKS:
# # this is a workaround. since bash breaks words using characters in
# # $COMP_WORDBREAKS, which by default is "'@><=;|&(: this presents a problem
# # we often encounter: if we want to provide with a list of strings
# # containing say ':', 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).
# if (defined($opts->{word})) {
# if ($opts->{word} =~ s/(.+[\@><=;|&\(:])//) {
# my $prefix = $1;
# for (@$words) {
# if (ref($_) eq 'HASH') {
# $_->{word} =~ s/\A\Q$prefix\E//i;
# } else {
# s/\A\Q$prefix\E//i;
# }
# }
# }
# }
#
# ESCAPE_WORDS:
# for my $entry (@$words) {
# my $word = ref($entry) eq 'HASH' ? $entry->{word} : $entry;
# my $summary = (ref($entry) eq 'HASH' ? $entry->{summary} : undef) // '';
# 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 @words, $word;
# push @summaries, $summary;
# $has_summary = 1 if length $summary;
# }
#
# my $summary_align = $ENV{COMPLETE_BASH_SUMMARY_ALIGN} // 'left';
# my $max_columns = $ENV{COMPLETE_BASH_MAX_COLUMNS} // 0;
# my $terminal_width = _terminal_width();
# my $column_width = _column_width($terminal_width, $max_columns);
#
# #warn "terminal_width=$terminal_width, column_width=".($column_width // 'undef')."\n";
#
# FORMAT_SUMMARIES: {
# @res = @words;
# last if @words <= 1;
# last unless $has_summary;
# last unless $opts->{show_summaries} //
# $ENV{COMPLETE_BASH_SHOW_SUMMARIES} // 1;
# my $max_entry_width = 8;
# my $max_summ_width = 0;
# for (0..$#words) {
# $max_entry_width = length $words[$_]
# if $max_entry_width < length $words[$_];
# $max_summ_width = length $summaries[$_]
# if $max_summ_width < length $summaries[$_];
# }
# #warn "max_entry_width=$max_entry_width, max_summ_width=$max_summ_width\n";
# if ($summary_align eq 'right') {
# # if we are aligning summary to the right, we want to fill column
# # width width
# if ($max_columns <= 0) {
# $max_columns = _num_columns(
# $terminal_width, ($max_entry_width + 2 + $max_summ_width));
# }
# $column_width = _column_width($terminal_width, $max_columns);
# my $new_max_summ_width = $column_width - 2 - $max_entry_width;
# $max_summ_width = $new_max_summ_width
# if $max_summ_width < $new_max_summ_width;
# #warn "max_columns=$max_columns, column_width=$column_width, max_summ_width=$max_summ_width\n";
# }
#
# for (0..$#words) {
# my $summary = $summaries[$_];
# if (length $summary) {
# $res[$_] = sprintf(
# "%-${max_entry_width}s |%".
# ($summary_align eq 'right' ? $max_summ_width : '')."s",
# $words[$_], $summary);
# }
# }
# } # FORMAT_SUMMARIES
#
# MAX_COLUMNS: {
# last unless $max_columns > 0;
# my $max_entry_width = 0;
# for (@res) {
# $max_entry_width = length if $max_entry_width < length;
# }
# last if $max_entry_width >= $column_width;
# for (@res) {
# $_ .= " " x ($column_width - length) if $column_width > length;
# }
# }
#
# PASS_TO_FZF: {
# last unless $ENV{COMPLETE_BASH_FZF};
# my $items = $ENV{COMPLETE_BASH_FZF_ITEMS} // 100;
# last unless @words >= $items;
#
# require File::Which;
# unless (File::Which::which("fzf")) {
# #@res = $code_return_message->("Cannot find fzf to filter ".
# # scalar(@words)." items");
# goto RETURN_RES;
# }
#
# require IPC::Open2;
# local *CHLD_OUT;
# local *CHLD_IN;
# my $pid = IPC::Open2::open2(
# \*CHLD_OUT, \*CHLD_IN, "fzf", "-m", "-d:", "--with-nth=2..")
# or do {
# @res = $code_return_message->("Cannot open fzf to filter ".
# scalar(@words)." items");
# goto RETURN_RES;
# };
#
# print CHLD_IN map { "$_:$res[$_]\n" } 0..$#res;
# close CHLD_IN;
#
# my @res_words;
# while (<CHLD_OUT>) {
# my ($index) = /\A([0-9]+)\:/ or next;
# push @res_words, $words[$index];
# }
# if (@res_words) {
# @res = join(" ", @res_words);
# } else {
# @res = ();
# }
# waitpid($pid, 0);
# }
#
# RETURN_RES:
# #use Data::Dump; warn Data::Dump::dump(\@res);
# if ($as eq 'array') {
# return \@res;
# } else {
# return join("", map {($_, "\n")} @res);
# }
#}
#
#1;
## ABSTRACT: Completion routines for bash shell
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::Bash - Completion routines for bash shell
#
#=head1 VERSION
#
#This document describes version 0.330 of Complete::Bash (from Perl distribution Complete-Bash), released on 2019-08-20.
#
#=head1 DESCRIPTION
#
#This module provides routines related to tab completion in bash shell.
#
#=head2 About programmable completion in bash
#
#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 (C<-C>) including, from 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
#
#=head2 About the routines in this module
#
#First of all, C<parse_cmdline()> is the function to parse raw command-line (such
#as what you get from bash in C<COMP_LINE> environment variable) into words. This
#makes it easy for the other functions to generate completion answer. See the
#documentation for that function for more details.
#
#C<format_completion()> is what you use to format completion answer structure for
#bash.
#
#=head1 FUNCTIONS
#
#
#=head2 format_completion
#
#Usage:
#
# 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
#
#This function is not exported by default, but exportable.
#
#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>
#
#Specify options.
#
#Known options:
#
#=over
#
#=item * word
#
#A workaround. String. For now, see source code for more details.
#
#=item * show_summaries
#
#Whether to show item's summaries. Boolean, default is from
#COMPLETE_BASH_SHOW_SUMMARIES environment variable or 1.
#
#An answer item contain summary, which is a short description about the item,
#e.g.:
#
# [{word=>"-a" , summary=>"Show hidden files"},
# {word=>"-l" , summary=>"Show details"},
# {word=>"--sort", summary=>"Specify sort order"}],
#
#When summaries are not shown, user will just be seeing something like:
#
# -a
# -l
# --sort
#
#But when summaries are shown, user will see:
#
# -a -- Show hidden files
# -l -- Show details
# --sort -- Specify sort order
#
#which is quite helpful.
#
#=back
#
#=back
#
#Return value: Formatted string (or array, if `as` is set to `array`) (str|array)
#
#
#
#=head2 join_wordbreak_words
#
#Usage:
#
# join_wordbreak_words() -> [status, msg, payload, meta]
#
#Post-process parse_cmdline() result by joining some words.
#
#C<parse_cmdline()>, like bash, splits some characters that are considered as
#word-breaking characters:
#
# "'@><=;|&(:
#
#So if command-line is:
#
# command -MData::Dump bob@example.org
#
#then they will be parsed as:
#
# ["command", "-MData", "::", "Dump", "bob", '@', "example.org"]
#
#Normally in Perl applications, we want C<:>, C<@> to be part of word. So this
#routine will convert the above into:
#
# ["command", "-MData::Dump", 'bob@example.org']
#
#This function is not exported by default, but exportable.
#
#No arguments.
#
#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 (payload) 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 parse_cmdline
#
#Usage:
#
# parse_cmdline($cmdline, $point, $opts) -> array
#
#Parse shell command-line for processing by completion routines.
#
#This function basically converts C<COMP_LINE> (str) and C<COMP_POINT> (int) into
#something like (but not exactly the same as) C<COMP_WORDS> (array) and
#C<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; this comparison is made against
#bash versions 4.2-4.3):
#
#1) quotes and backslashes are stripped (bash's C<COMP_WORDS> contains all the
# quotes and backslashes);
#
#2) quoted phrase that contains spaces, or phrase that contains escaped spaces is
# parsed as a single word. For example:
#
# command "First argument" Second\ argument
#
# bash would split it as (represented as Perl):
#
# ["command", "\"First", "argument\"", "Second\\", "argument"]
#
# which is not very convenient. We parse it into:
#
# ["command", "First argument", "Second argument"]
#
#3) variables are substituted with their values from environment variables except
# for the current word (C<COMP_WORDS[COMP_CWORD]>) (bash does not perform
# variable substitution for C<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.
#
#4) tildes (C<~>) are expanded with user's home directory except for the current
# word (bash does not perform tilde expansion for C<COMP_WORDS>);
#
#Caveats:
#
#=over
#
#=item * Like bash, we group non-whitespace word-breaking characters into its own word.
#By default C<COMP_WORDBREAKS> is:
#
#"'@><=;|&(:
#
#So if raw command-line is:
#
#command --foo=bar http://example.com:80 mail@example.org Foo::Bar
#
#then the parse result will be:
#
#["command", "--foo", "=", "bar", "http", ":", "//example.com", ":", "80", "Foo", "::", "Bar"]
#
#which is annoying sometimes. But we follow bash here so we can more easily
#accept input from a joined C<COMP_WORDS> if we write completion bash functions,
#e.g. (in the example, C<foo> is a Perl script):
#
#I<foo ()
#{
# local words=(${COMP>CWORDS[@]})
# # add things to words, etc
# local point=... # calculate the new point
# COMPREPLY=( C<COMP_LINE="foo ${words[@]}" COMP_POINT=$point foo> )
#}
#
#To avoid these word-breaking characters to be split/grouped, we can escape
#them with backslash or quote them, e.g.:
#
#command "http://example.com:80" Foo\:\:Bar
#
#which bash will parse as:
#
#["command", "\"http://example.com:80\"", "Foo\:\:Bar"]
#
#and we parse as:
#
#["command", "http://example.com:80", "Foo::Bar"]
#
#=item * Due to the way bash parses the command line (see above), the two below are
#equivalent:
#
#% cmd --foo=bar
#% cmd --foo = bar
#
#=back
#
#Because they both expand to C<['--foo', '=', 'bar']>. But obviously
#L<Getopt::Long> does not regard the two as equivalent.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$cmdline> => I<str>
#
#Command-line, defaults to COMP_LINE environment.
#
#=item * B<$opts> => I<hash>
#
#Options.
#
#Optional. Known options:
#
#=over
#
#=item * C<truncate_current_word> (bool). If set to 1, will truncate current word to the
#position of cursor, for example (C<^> marks the position of cursor):
#C<--vers^oo> to C<--vers> instead of C<--versoo>. This is more convenient when
#doing tab completion.
#
#=back
#
#=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, roughly 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 point
#
#Usage:
#
# point($cmdline, $marker) -> any
#
#Return line with point marked by a marker.
#
#This is a utility function useful for testing/debugging. C<parse_cmdline()>
#expects a command-line and a cursor position (C<$line>, C<$point>). This routine
#expects C<$line> with a marker character (by default it's the caret, C<^>) and
#return (C<$line>, C<$point>) to feed to C<parse_cmdline()>.
#
#Example:
#
# point("^foo") # => ("foo", 0)
# point("fo^o") # => ("foo", 2)
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$cmdline> => I<str>
#
#Command-line which contains a marker character.
#
#=item * B<$marker> => I<str> (default: "^")
#
#Marker character.
#
#=back
#
#Return value: (any)
#
#=head1 ENVIRONMENT
#
#=head2 COMPLETE_BASH_FZF
#
#Bool. Whether to pass large completion answer to fzf instead of directly passing
#it to bash and letting bash page it with a simpler more-like internal pager. By
#default, large is defined as having at least 100 items (same bash's
#C<completion-query-items> setting). This can be configured via
#L</COMPLETE_BASH_FZF_ITEMS>.
#
#=head2 COMPLETE_BASH_FZF_ITEMS
#
#Uint. Default 100. The minimum number of items to trigger passing completion
#answer to fzf. See also: L</COMPLETE_BASH_FZF>.
#
#=head2 COMPLETE_BASH_MAX_COLUMNS
#
#Uint.
#
#Bash will show completion entries in one or several columns, depending on the
#terminal width and the length of the entries (much like a standard non-long
#`ls`). If you prefer completion entries to be shown in a single column no matter
#how wide your terminal is, or how short the entries are, you can set the value
#of this variable to 1. If you prefer a maximum of two columns, set to 2, and so
#on. L</format_completion> will pad the entries with sufficient spaces to limit
#the number of columns.
#
#=head2 COMPLETE_BASH_SHOW_SUMMARIES
#
#Bool. Will set the default for C<show_summaries> option in
#L</format_completion>.
#
#=head2 COMPLETE_BASH_SUMMARY_ALIGN
#
#String. Either C<left> (the default) or C<right>.
#
#The C<left> align looks something like this:
#
# --bar Summary about the bar option
# --baz Summary about the baz option
# --foo Summary about the foo option
# --schapen Summary about the schapen option
#
#The C<right> align will make the completion answer look like what you see in the
#B<fish> shell:
#
# --bar Summary about the bar option
# --baz Summary about the baz option
# --foo Summary about the foo option
# --schapen Summary about the schapen option
#
#=head2 COMPLETE_BASH_TRACE
#
#Bool. If set to true, will produce more log statements to L<Log::ger>.
#
#=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 SEE ALSO
#
#L<Complete>, the convention that this module follows.
#
#Some higher-level modules that use this module (so you don't have to use this
#module directly): L<Getopt::Long::Complete> (via L<Complete::Getopt::Long>),
#L<Getopt::Long::Subcommand>, L<Perinci::CmdLine> (via
#L<Perinci::Sub::Complete>).
#
#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 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2016, 2015, 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/Common.pm ###
#package Complete::Common;
#
#our $DATE = '2016-01-07'; # DATE
#our $VERSION = '0.22'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# %arg_word
# );
#
#our %EXPORT_TAGS = (
# all => \@EXPORT_OK
#);
#
#our %arg_word = (
# word => {
# summary => 'Word to complete',
# schema => ['str', default=>''],
# pos=>0,
# req=>1,
# },
#);
#
#our $OPT_CI = ($ENV{COMPLETE_OPT_CI} // 1) ? 1:0;
#our $OPT_WORD_MODE = ($ENV{COMPLETE_OPT_WORD_MODE} // 1) ? 1:0;
#our $OPT_CHAR_MODE = ($ENV{COMPLETE_OPT_CHAR_MODE} // 1) ? 1:0;
#our $OPT_FUZZY = ($ENV{COMPLETE_OPT_FUZZY} // 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_DIG_LEAF = ($ENV{COMPLETE_OPT_DIG_LEAF} // 1) ? 1:0;
#
#1;
## ABSTRACT: Common stuffs for completion routines
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::Common - Common stuffs for completion routines
#
#=head1 VERSION
#
#This document describes version 0.22 of Complete::Common (from Perl distribution Complete-Common), released on 2016-01-07.
#
#=head1 DESCRIPTION
#
#This module defines some common arguments and settings. C<Complete::*> modules
#should use the default from these settings, to make it convenient for users to
#change some behaviors globally.
#
#The defaults are optimized for convenience and laziness for user typing and
#might change from release to release.
#
#=head2 C<$Complete::Common::OPT_CI> => bool (default: from COMPLETE_OPT_CI or 1)
#
#If set to 1, matching is done case-insensitively.
#
#In bash/readline, this is akin to setting C<completion-ignore-case>.
#
#=head2 C<$Complete::Common::OPT_WORD_MODE> => bool (default: from COMPLETE_OPT_WORD_MODE or 1)
#
#If set to 1, enable word-mode matching.
#
#Word mode matching is normally only done when exact matching fails to return any
#candidate. To give you an idea of how word-mode matching works, you can run
#Emacs and try its completion of filenames (C<C-x C-f>) or function names
#(C<M-x>). Basically, each string is split into words and matching is tried for
#all available word even non-adjacent ones. For example, if you have C<dua-d> and
#the choices are (C<dua-tiga>, C<dua-empat>, C<dua-lima-delapan>) then
#C<dua-lima-delapan> will match because C<d> matches C<delapan> even though the
#word is not adjacent. This is convenient when you have strings that are several
#or many words long: you can just type the starting letters of some of the words
#instead of just the starting letters of the whole string (which might need to be
#quite long before producing a unique match).
#
#=head2 C<$Complete::Common::OPT_CHAR_MODE> => bool (default: from COMPLETE_OPT_CHAR_MODE or 1)
#
#If set to 1, enable character-mode matching.
#
#This mode is like word-mode matching, except it works on a
#character-by-character basis. Basically, it will match if a word contains any
#letters of the string in the correct order. For example, C<ap> will match C<ap>,
#C<amp>, C<slap>, or C<cramp> (but will not match C<pa> or C<pram>).
#
#Character-mode matching is normally only done when exact matching and word-mode
#fail to return any candidate.
#
#=head2 C<$Complete::Common::OPT_FUZZY> => int (default: from COMPLETE_OPT_FUZZY or 1)
#
#Enable fuzzy matching (matching even though there are some spelling mistakes).
#The greater the number, the greater the tolerance. To disable fuzzy matching,
#set to 0.
#
#Fuzzy matching is normally only done when exact matching, word-mode, and
#char-mode matching fail to return any candidate.
#
#=head2 C<$Complete::Common::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::File>,
#L<Complete::Module>, or L<Complete::Riap>) respect this setting.
#
#=head2 C<$Complete::Common::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::File>,
#L<Complete::Module>, or L<Complete::Riap>) respect this setting.
#
#=head2 C<$Complete::Common::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::Common::OPT_CI>.
#
#=head2 COMPLETE_OPT_FUZZY => int
#
#Set default for C<$Complete::Common::OPT_FUZZY>.
#
#=head2 COMPLETE_OPT_WORD_MODE => bool
#
#Set default for C<$Complete::Common::OPT_WORD_MODE>.
#
#=head2 COMPLETE_OPT_MAP_CASE => bool
#
#Set default for C<$Complete::Common::OPT_MAP_CASE>.
#
#=head2 COMPLETE_OPT_EXP_IM_PATH => bool
#
#Set default for C<$Complete::Common::OPT_EXP_IM_PATH>.
#
#=head2 COMPLETE_OPT_DIG_LEAF => bool
#
#Set default for C<$Complete::Common::OPT_DIG_LEAF>.
#
#=head1 SEE ALSO
#
#L<Complete>
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Complete-Common>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Complete-Common>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Common>
#
#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) 2016 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/Env.pm ###
#package Complete::Env;
#
#our $DATE = '2017-12-31'; # DATE
#our $VERSION = '0.400'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Complete::Common qw(:all);
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# complete_env
# complete_env_elem
# complete_path_env_elem
# );
#
#our %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'Completion routines related to environment variables',
#};
#
#$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 => {
# %arg_word,
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_env {
# require Complete::Util;
#
# my %args = @_;
# my $word = $args{word} // "";
# if ($word =~ /^\$/) {
# Complete::Util::complete_array_elem(
# word=>$word, array=>[map {"\$$_"} keys %ENV],
# );
# } else {
# Complete::Util::complete_array_elem(
# word=>$word, array=>[keys %ENV],
# );
# }
#}
#
#$SPEC{complete_env_elem} = {
# v => 1.1,
# summary => 'Complete from elements of an environment variable',
# description => <<'_',
#
#An environment variable like PATH contains colon- (or, on Windows, semicolon-)
#separated elements. This routine complete from the elements of such variable.
#
#_
# args => {
# %arg_word,
# env => {
# summary => 'Name of environment variable to use',
# schema => 'str*',
# req => 1,
# pos => 1,
# },
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_env_elem {
# require Complete::Util;
#
# my %args = @_;
# my $word = $args{word} // "";
# my $env = $args{env};
# my @elems;
# if ($^O eq 'MSWin32') {
# @elems = split /;/, ($ENV{$env} // '');
# } else {
# @elems = split /:/, ($ENV{$env} // '');
# }
# Complete::Util::complete_array_elem(
# word=>$word, array=>\@elems,
# );
#}
#
#$SPEC{complete_path_env_elem} = {
# v => 1.1,
# summary => 'Complete from elements of PATH environment variable',
# description => <<'_',
#
#PATH environment variable contains colon- (or, on Windows, semicolon-) separated
#elements. This routine complete from those elements.
#
#_
# args => {
# %arg_word,
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_path_env_elem {
# my %args = @_;
# complete_env_elem(word => $args{word}, env => 'PATH');
#}
#
#1;
## ABSTRACT: Completion routines related to environment variables
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::Env - Completion routines related to environment variables
#
#=head1 VERSION
#
#This document describes version 0.400 of Complete::Env (from Perl distribution Complete-Env), released on 2017-12-31.
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#
#=head2 complete_env
#
#Usage:
#
# complete_env(%args) -> array
#
#Complete from environment variables.
#
#On Windows, environment variable names are all converted to uppercase. You can
#use case-insensitive option (C<ci>) to match against original casing.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#=head2 complete_env_elem
#
#Usage:
#
# complete_env_elem(%args) -> array
#
#Complete from elements of an environment variable.
#
#An environment variable like PATH contains colon- (or, on Windows, semicolon-)
#separated elements. This routine complete from the elements of such variable.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<env>* => I<str>
#
#Name of environment variable to use.
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#=head2 complete_path_env_elem
#
#Usage:
#
# complete_path_env_elem(%args) -> array
#
#Complete from elements of PATH environment variable.
#
#PATH environment variable contains colon- (or, on Windows, semicolon-) separated
#elements. This routine complete from those elements.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Complete-Env>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Complete-Env>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Env>
#
#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 SEE ALSO
#
#L<Complete>
#
#Other C<Complete::*> modules.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017, 2016, 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/File.pm ###
#package Complete::File;
#
#our $DATE = '2017-07-14'; # DATE
#our $VERSION = '0.43'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Complete::Common qw(:all);
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# complete_file
# complete_dir
# );
#
#our %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'Completion routines related to files',
#};
#
#$SPEC{complete_file} = {
# v => 1.1,
# summary => 'Complete file and directory from local filesystem',
# args => {
# %arg_word,
# 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*']}],
# tags => ['category:filtering'],
# },
# 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*',
# tags => ['category:filtering'],
# },
# exclude_dir => {
# schema => 'bool*',
# description => <<'_',
#
#This is also an alternative to specifying full `filter`. Set this to true if you
#do not want directories.
#
#If you only want directories, take a look at `complete_dir()`.
#
#_
# tags => ['category:filtering'],
# },
# file_ext_filter => {
# schema => ['any*', of=>['re*', ['array*',of=>'str*']]],
# description => <<'_',
#
#This is also an alternative to specifying full `filter` or `file_regex_filter`.
#You can set this to a regex or a set of extensions to accept. Note that like in
#`file_regex_filter`, directories of any name is also still allowed.
#
#_
# tags => ['category:filtering'],
# },
# 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 Encode;
# require File::Glob;
#
# my %args = @_;
# my $word = $args{word} // "";
# my $handle_tilde = $args{handle_tilde} // 1;
# my $allow_dot = $args{allow_dot} // 1;
#
# # 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::bsd_glob($1); # glob will expand ~foo to /home/foo
# return [] unless @dir;
# $starting_path = Encode::decode('UTF-8', $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, Encode::decode('UTF-8', $_);
# }
# \@res;
# };
#
# # prepare filter_func
#
# # from the filter option
# my $filter;
# if ($args{filter} && !ref($args{filter})) {
# my @seqs = split /\s*\|\s*/, $args{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 ($args{filter} && ref($args{filter}) eq 'CODE') {
# $filter = $args{filter};
# }
#
# # from the file_regex_filter option
# my $filter_fregex;
# if ($args{file_regex_filter}) {
# $filter_fregex = sub {
# my $name = shift;
# return 1 if -d $name;
# return 0 unless -f _;
# return 1 if $name =~ $args{file_regex_filter};
# 0;
# };
# }
#
# # from the file_ext_filter option
# my $filter_fext;
# if ($args{file_ext_filter} && ref $args{file_ext_filter} eq 'Regexp') {
# $filter_fext = sub {
# my $name = shift;
# return 1 if -d $name;
# return 0 unless -f _;
# my $ext = $name =~ /\.(\w+)\z/ ? $1 : '';
# return 1 if $ext =~ $args{file_ext_filter};
# 0;
# };
# } elsif ($args{file_ext_filter} && ref $args{file_ext_filter} eq 'ARRAY') {
# $filter_fext = sub {
# my $name = shift;
# return 1 if -d $name;
# return 0 unless -f _;
# my $ext = $name =~ /\.(\w+)\z/ ? $1 : '';
# if ($Complete::Common::OPT_CI) {
# $ext = lc($ext);
# for my $e (@{ $args{file_ext_filter} }) {
# return 1 if $ext eq lc($e);
# }
# } else {
# for my $e (@{ $args{file_ext_filter} }) {
# return 1 if $ext eq $e;
# }
# }
# 0;
# };
# }
#
# # from _dir (used by complete_dir)
# my $filter_dir;
# if ($args{_dir}) {
# $filter_dir = sub { return 0 unless (-d $_[0]); 1 };
# }
#
# # from exclude_dir option
# my $filter_xdir;
# if ($args{exclude_dir}) {
# $filter_xdir = sub { return 0 if (-d $_[0]); 1 };
# }
#
# # final filter sub
# my $final_filter = sub {
# my $name = shift;
# if ($filter_dir) { return 0 unless $filter_dir->($name) }
# if ($filter_xdir) { return 0 unless $filter_xdir->($name) }
# if ($filter) { return 0 unless $filter->($name) }
# if ($filter_fregex) { return 0 unless $filter_fregex->($name) }
# if ($filter_fext) { return 0 unless $filter_fext->($name) }
# 1;
# };
#
# Complete::Path::complete_path(
# word => $word,
# list_func => $list,
# is_dir_func => sub { -d $_[0] },
# filter_func => $final_filter,
# starting_path => $starting_path,
# result_prefix => $result_prefix,
# );
#}
#
#$SPEC{complete_dir} = do {
# my $spec = {%{ $SPEC{complete_file} }}; # shallow copy
#
# $spec->{summary} = 'Complete directory from local filesystem '.
# '(wrapper for complete_dir() that only picks directories)';
# $spec->{args} = { %{$spec->{args}} }; # shallow copy of args
# delete $spec->{args}{file_regex_filter};
# delete $spec->{args}{file_ext_filter};
# delete $spec->{args}{exclude_dir};
#
# $spec;
#};
#sub complete_dir {
# my %args = @_;
#
# complete_file(%args, _dir=>1);
#}
#
#1;
## ABSTRACT: Completion routines related to files
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::File - Completion routines related to files
#
#=head1 VERSION
#
#This document describes version 0.43 of Complete::File (from Perl distribution Complete-File), released on 2017-07-14.
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#
#=head2 complete_dir
#
#Usage:
#
# complete_dir(%args) -> array
#
#Complete directory from local filesystem (wrapper for complete_dir() that only picks directories).
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<allow_dot> => I<bool> (default: 1)
#
#If turned off, will not allow "." or ".." in path.
#
#This is most useful when combined with C<starting_path> option to prevent user
#going up/outside the starting path.
#
#=item * B<filter> => I<str|code>
#
#Only return items matching this filter.
#
#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<starting_path> => I<str> (default: ".")
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#=head2 complete_file
#
#Usage:
#
# complete_file(%args) -> array
#
#Complete file and directory from local filesystem.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<allow_dot> => I<bool> (default: 1)
#
#If turned off, will not allow "." or ".." in path.
#
#This is most useful when combined with C<starting_path> option to prevent user
#going up/outside the starting path.
#
#=item * B<exclude_dir> => I<bool>
#
#This is also an alternative to specifying full C<filter>. Set this to true if you
#do not want directories.
#
#If you only want directories, take a look at C<complete_dir()>.
#
#=item * B<file_ext_filter> => I<re|array[str]>
#
#This is also an alternative to specifying full C<filter> or C<file_regex_filter>.
#You can set this to a regex or a set of extensions to accept. Note that like in
#C<file_regex_filter>, directories of any name is also still allowed.
#
#=item * B<file_regex_filter> => I<re>
#
#Filter shortcut for file regex.
#
#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>
#
#Only return items matching this filter.
#
#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<starting_path> => I<str> (default: ".")
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Complete-File>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Complete-File>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-File>
#
#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 SEE ALSO
#
#L<Complete>
#
#Other C<Complete::*> modules.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017, 2016, 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 = '2019-06-26'; # DATE
#our $VERSION = '0.471'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# complete_cli_arg
# );
#
#our %SPEC;
#
#sub _default_completion {
# require Complete::Env;
# require Complete::File;
# require Complete::Util;
#
# 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');
# {
# my $compres = Complete::Env::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_elem(
# 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::File::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::File::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 <pm: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 <pm: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 <pm: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_elem(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 <pm: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 <pm: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 <pm: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'";
# next if $res->{is_arg};
# $res->{min_vals} //= $res->{type} ? 1 : 0;
# $res->{max_vals} //= $res->{type} || $res->{opttype} ? 1:0;
# for my $o0 (@{ $res->{opts} }) {
# my @ary = $res->{is_neg} && length($o0) > 1 ?
# ([$o0, 0], ["no$o0",1], ["no-$o0",1]) : ([$o0,0]);
# for my $elem (@ary) {
# my $o = $elem->[0];
# my $is_neg = $elem->[1];
# my $k = length($o)==1 ||
# (!$bundling && $res->{dash_prefix} eq '-') ?
# "-$o" : "--$o";
# $opts{$k} = {
# name => $k,
# ospec => $ospec, # key to getopt specification
# parsed => $res,
# is_neg => $is_neg,
# };
# }
# }
# }
# my @optnames = sort keys %opts;
#
# my $code_get_summary = sub {
# # currently we only extract summaries from Rinci metadata and
# # Perinci::CmdLine object
# return unless $extras;
# my $ggls_res = $extras->{ggls_res};
# return unless $ggls_res;
# my $cmdline = $extras->{cmdline};
# return unless $cmdline;
# my $r = $extras->{r};
# return unless $r;
#
# my $optname = shift;
# my $ospec = $opts{$optname}{ospec};
# return unless $ospec; # shouldn't happen
# my $specmeta = $ggls_res->[3]{'func.specmeta'};
# my $ospecmeta = $specmeta->{$ospec};
#
# if ($ospecmeta->{is_alias}) {
# my $real_ospecmeta = $specmeta->{ $ospecmeta->{alias_for} };
# my $real_opt = $real_ospecmeta->{parsed}{opts}[0];
# $real_opt = length($real_opt) == 1 ? "-$real_opt" : "--$real_opt";
# return "Alias for $real_opt";
# }
#
# if (defined(my $coptname = $ospecmeta->{common_opt})) {
# # it's a common Perinci::CmdLine option
# my $coptspec = $cmdline->{common_opts}{$coptname};
# #use DD; dd $coptspec;
# return unless $coptspec;
#
# my $summ;
# # XXX translate
# if ($opts{$optname}{is_neg}) {
# $summ = $coptspec->{"summary.alt.bool.not"};
# return $summ if defined $summ;
# my $pos_opt = $ospecmeta->{pos_opts}[0];
# $pos_opt = length($pos_opt) == 1 ? "-$pos_opt" : "--$pos_opt";
# return "The opposite of $pos_opt";
# } else {
# $summ = $coptspec->{"summary.alt.bool.yes"};
# return $summ if defined $summ;
# $summ = $coptspec->{"summary"};
# return $summ if defined $summ;
# }
# } else {
# # it's option from function argument
# my $arg = $ospecmeta->{arg};
# my $argspec = $extras->{r}{meta}{args}{$arg};
# #use DD; dd $argspec;
#
# my $summ;
# # XXX translate
# #use DD; dd {optname=>$optname, ospecmeta=>$ospecmeta};
# if ($ospecmeta->{is_neg}) {
# $summ = $argspec->{"summary.alt.bool.not"};
# return $summ if defined $summ;
# my $pos_opt = $ospecmeta->{pos_opts}[0];
# $pos_opt = length($pos_opt) == 1 ? "-$pos_opt" : "--$pos_opt";
# return "The opposite of $pos_opt";
# } else {
# $summ = $argspec->{"summary.alt.bool.yes"};
# return $summ if defined $summ;
# $summ = $argspec->{"summary"};
# return $summ if defined $summ;
# }
# }
#
# return;
# };
#
# my %seen_opts;
#
# # for each word (each element in this array), 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.
# #
# # each element is a hash. if hash contains 'optname' key then it expects an
# # option name. if hash contains 'optval' key then it expects an option
# # value.
# #
# # 'short_only' means that the word is not to be completed with long option
# # name, only (bundle of) one-letter option names.
#
# 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-/) {
#
# # check if it is a (bundle) of short option names
# SHORT_OPTS:
# {
# # it's not a known short option
# last unless $opts{"-".substr($word,1,1)};
#
# # not a bundle, regard as only a single short option name
# last unless $bundling;
#
# # expand bundle
# my $j = $i;
# my $rest = substr($word, 1);
# my @inswords;
# my $encounter_equal_sign;
# EXPAND:
# while (1) {
# $rest =~ s/(.)// or last;
# my $opt = "-$1";
# my $opthash = $opts{$opt};
# unless ($opthash) {
# # we encounter an unknown option, doubt that this is a
# # bundle of short option name, it could be someone
# # typing --long as -long
# @inswords = ();
# $expects[$i]{short_only} = 0;
# $rest = $word;
# last EXPAND;
# }
# if ($opthash->{parsed}{max_vals}) {
# # stop after an option that requires value
# _mark_seen(\%seen_opts, $opt, \%opts);
#
# if ($i == $j) {
# $words[$i] = $opt;
# } else {
# push @inswords, $opt;
# $j++;
# }
#
# my $expand;
# if (length $rest) {
# $expand++;
# # complete -Sfoo^ is completing option value
# $expects[$j > $i ? $j+1 : $j+2]{do_complete_optname} = 0;
# $expects[$j > $i ? $j+1 : $j+2]{optval} = $opt;
# } else {
# # complete -S^ as [-S] to add space
# $expects[$j > $i ? $j-1 : $j]{optname} = $opt;
# $expects[$j > $i ? $j-1 : $j]{comp_result} = [
# substr($word, 0, length($word)-length($rest))];
# }
#
# if ($rest =~ s/\A=//) {
# $encounter_equal_sign++;
# }
#
# if ($expand) {
# push @inswords, "=", $rest;
# $j+=2;
# }
# last EXPAND;
# }
# # continue splitting
# _mark_seen(\%seen_opts, $opt, \%opts);
# if ($i == $j) {
# $words[$i] = $opt;
# } else {
# push @inswords, $opt;
# }
# $j++;
# }
#
# #use DD; print "D:inswords: "; dd \@inswords;
#
# my $prefix = $encounter_equal_sign ? '' :
# substr($word, 0, length($word)-length($rest));
# splice @words, $i+1, 0, @inswords;
# for (0..@inswords) {
# $expects[$i+$_]{prefix} = $prefix;
# $expects[$i+$_]{word} = $rest;
# }
# $cword += @inswords;
# $i += @inswords;
# $word = $words[$i];
# $expects[$i]{short_only} //= 1;
# } # SHORT_OPTS
#
# # 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 }
# }
#
# for (1 .. $min_vals) {
# $i++;
# last WORD if $i >= @words;
# $expects[$i]{optval} = $opt;
# $expects[$i]{nth} = $nth;
# push @{ $parsed_opts{$opt} }, $words[$i];
# }
# 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;
# push @{ $parsed_opts{$opt} }, $words[$i+$_];
# }
# } 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++;
# }
# }
#
# my $exp = $expects[$cword];
# my $word = $exp->{word} // $words[$cword];
#
# #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;
# #use DD; print "D:exp: "; dd $exp;
# #use DD; say "D:word:<$word>";
#
# my @answers;
#
# # complete option names
# {
# last if $word =~ /\A[^-]/;
# last unless exists $exp->{optname};
# last if defined($exp->{do_complete_optname}) &&
# !$exp->{do_complete_optname};
# if ($exp->{comp_result}) {
# push @answers, $exp->{comp_result};
# last;
# }
# #say "D:completing option names";
# my $opt = $exp->{optname};
# my @o;
# my @osumms;
# my $o_has_summaries;
# for my $optname (@optnames) {
# my $repeatable = 0;
# next if $exp->{short_only} && $optname =~ /\A--/;
# if ($seen_opts{$optname}) {
# my $opthash = $opts{$optname};
# 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{$optname} && !$repeatable && (
# # long option has been specified
# (!$opt || $opt ne $optname) ||
# # 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 = $optname; $o =~ s/\A-//;
# push @o, "$exp->{prefix}$o";
# } else {
# push @o, $optname;
# }
# my $summ = $code_get_summary->($optname) // '';
# if (length $summ) {
# $o_has_summaries = 1;
# push @osumms, $summ;
# } else {
# push @osumms, '';
# }
# }
# #use DD; dd \@o;
# #use DD; dd \@osumms;
# my $compres = Complete::Util::complete_array_elem(
# array => \@o, word => $word,
# (summaries => \@osumms) x !!$o_has_summaries,
# );
# #$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});
# #say "D:completing option value";
# my $opt = $exp->{optval};
# my $opthash; $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);
# Complete::Util::modify_answer(answer=>$compres, prefix=>$exp->{prefix})
# if defined $exp->{prefix};
# #$log->tracef('[comp][compgl] adding result from routine: %s', $compres);
# }
# if (!$compres || !$comp) {
# $compres = _default_completion(%compargs);
# Complete::Util::modify_answer(answer=>$compres, prefix=>$exp->{prefix})
# if defined $exp->{prefix};
# #$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; $compres = $comp->(%compargs) if $comp;
# 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.471 of Complete::Getopt::Long (from Perl distribution Complete-Getopt-Long), released on 2019-06-26.
#
#=head1 SYNOPSIS
#
#See L<Getopt::Long::Complete> for an easy way to use this module.
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#
#=head2 complete_cli_arg
#
#Usage:
#
# 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 L<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 L<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.
#
#This function is not exported by default, but exportable.
#
#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 L<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_elem(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 L<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 L<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 L<Complete::Bash> module to format
#the result of this function for bash.
#
#=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 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 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2017, 2016, 2015, 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/Path.pm ###
#package Complete::Path;
#
#our $DATE = '2017-07-03'; # DATE
#our $VERSION = '0.24'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Complete::Common qw(:all);
#
#our $COMPLETE_PATH_TRACE = $ENV{COMPLETE_PATH_TRACE} // 0;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# complete_path
# );
#
#sub _dig_leaf {
# my ($p, $list_func, $is_dir_func, $filter_func, $path_sep) = @_;
# my $num_dirs;
# my $listres = $list_func->($p, '', 0);
# return $p unless ref($listres) eq 'ARRAY' && @$listres;
# my @candidates;
# L1:
# for my $e (@$listres) {
# my $p2 = $p =~ m!\Q$path_sep\E\z! ? "$p$e" : "$p$path_sep$e";
# {
# local $_ = $p2; # convenience for filter func
# next L1 if $filter_func && !$filter_func->($p2);
# }
# push @candidates, $p2;
# }
# return $p unless @candidates == 1;
# my $p2 = $candidates[0];
# my $is_dir;
# if ($p2 =~ 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, $filter_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::File::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 => {
# %arg_word,
# 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::File`).
#
#_
# },
# 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 => '/',
# },
# #result_prefix => {
# # summary => 'Prefix each result with this string',
# # schema => 'str*',
# #},
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_path {
# require Complete::Util;
#
# 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 $result_prefix = $args{result_prefix};
# my $starting_path = $args{starting_path} // '';
#
# my $ci = $Complete::Common::OPT_CI;
# my $word_mode = $Complete::Common::OPT_WORD_MODE;
# my $fuzzy = $Complete::Common::OPT_FUZZY;
# my $map_case = $Complete::Common::OPT_MAP_CASE;
# my $exp_im_path = $Complete::Common::OPT_EXP_IM_PATH;
# my $dig_leaf = $Complete::Common::OPT_DIG_LEAF;
#
# 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 $intdir_with_path_sep = "$intdir$path_sep";
# 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;
# #use DD; say "D: list res=", DD::dump($listres);
# my $matches = Complete::Util::complete_array_elem(
# word => $intdir, array => $listres,
# );
# my $exact_matches = [grep {
# $_ eq $intdir || $_ eq $intdir_with_path_sep
# } @$matches];
# #use Data::Dmp; say "D: word=<$intdir>, matches=", dmp($matches), ", exact_matches=", dmp($exact_matches);
#
# # when doing exp_im_path, check if we have a single exact match. in
# # that case, don't use all the candidates because that can be
# # annoying, e.g. you have 'a/foo' and 'and/food', you won't be able
# # to complete 'a/f' because bash (e.g.) will always cut the answer
# # to 'a' because the candidates are 'a/foo' and 'and/foo' (it will
# # use the shortest common string which is 'a').
# #say "D: num_exact_matches: ", scalar @$exact_matches;
# if (!$exp_im_path || @$exact_matches == 1) {
# $matches = $exact_matches;
# }
#
# for (@$matches) {
# 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 $matches = Complete::Util::complete_array_elem(
# word => $leaf, array => $listres,
# );
# #use DD; dd $matches;
#
# L1:
# for my $e (@$matches) {
# my $p = $dir =~ $re_ends_with_path_sep ?
# "$dir$e" : "$dir$path_sep$e";
# #say "D:p=$p";
# {
# 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) {
# {
# my $p2 = _dig_leaf($p, $list_func, $is_dir_func, $filter_func, $path_sep);
# last if $p2 eq $p;
# $p = $p2;
# #say "D:p=$p (dig_leaf)";
#
# # 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.24 of Complete::Path (from Perl distribution Complete-Path), released on 2017-07-03.
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#
#=head2 complete_path
#
#Usage:
#
# complete_path(%args) -> array
#
#Complete path.
#
#Complete path, for anything path-like. Meant to be used as backend for other
#functions like C<Complete::File::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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<filter_func> => I<code>
#
#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>
#
#Function to check whether a path is a "dir".
#
#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::File>).
#
#=item * B<list_func>* => I<code>
#
#Function to list the content of intermediate "dirs".
#
#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<path_sep> => I<str> (default: "/")
#
#=item * B<starting_path>* => I<str> (default: "")
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#=head1 ENVIRONMENT
#
#=head2 COMPLETE_PATH_TRACE => bool
#
#If set to true, will produce more log statements for debugging.
#
#=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 SEE ALSO
#
#L<Complete>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017, 2016, 2015, 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/Tcsh.pm ###
#package Complete::Tcsh;
#
#our $DATE = '2015-09-09'; # DATE
#our $VERSION = '0.02'; # 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{':package'} = {
# v => 1.1,
# summary => 'Completion module for tcsh shell',
#};
#
#$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 => {
# completion => {
# summary => 'Completion answer structure',
# description => <<'_',
#
#Either an array or hash, as described in `Complete`.
#
#_
# schema=>['any*' => of => ['hash*', 'array*']],
# req=>1,
# pos=>0,
# },
# },
# 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.02 of Complete::Tcsh (from Perl distribution Complete-Tcsh), released on 2015-09-09.
#
#=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($completion) -> str|array
#
#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<completion>* => I<hash|array>
#
#Completion answer structure.
#
#Either an array or hash, as described in C<Complete>.
#
#=back
#
#Return value: Formatted string (or array, if `as` is set to `array`) (str|array)
#
#
#=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: 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.
#
#=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) 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/Util.pm ###
#package Complete::Util;
#
#our $DATE = '2019-07-23'; # DATE
#our $VERSION = '0.603'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#use Complete::Common qw(:all);
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# hashify_answer
# arrayify_answer
# combine_answers
# modify_answer
# ununiquify_answer
# complete_array_elem
# complete_hash_key
# complete_comma_sep
# );
#
#our %SPEC;
#
#our $COMPLETE_UTIL_TRACE = $ENV{COMPLETE_UTIL_TRACE} // 0;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'General completion routine',
# description => <<'_',
#
#This package provides some generic completion routines that follow the
#<pm:Complete> convention. (If you are looking for bash/shell tab completion
#routines, take a look at the See Also section.) The main routine is
#`complete_array_elem` which tries to complete a word using choices from elements
#of supplied array. For example:
#
# complete_array_elem(word => "a", array => ["apple", "apricot", "banana"]);
#
#The routine will first try a simple substring prefix matching. If that fails,
#will try some other methods like word-mode, character-mode, or fuzzy matching.
#These methods can be disabled using settings.
#
#There are other utility routines e.g. for converting completion answer structure
#from hash to array/array to hash, combine or modify answer, etc. These routines
#are usually used by the other more specific or higher-level completion modules.
#
#_
#};
#
#$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,
# },
# },
# args_as => 'array',
# 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,
# },
# },
# args_as => 'array',
# result_naked => 1,
# result => {
# schema => 'array*',
# },
#};
#sub arrayify_answer {
# my $ans = shift;
# if (ref($ans) eq 'HASH') {
# $ans = $ans->{words};
# }
# $ans;
#}
#
#sub __min(@) {
# my $m = $_[0];
# for (@_) {
# $m = $_ if $_ < $m;
# }
# $m;
#}
#
#our $code_editdist;
#our $editdist_flex;
#
## straight copy of Wikipedia's "Levenshtein Distance"
#sub __editdist {
# my @a = split //, shift;
# my @b = split //, shift;
#
# # There is an extra row and column in the matrix. This is the distance from
# # the empty string to a substring of the target.
# my @d;
# $d[$_][0] = $_ for 0 .. @a;
# $d[0][$_] = $_ for 0 .. @b;
#
# for my $i (1 .. @a) {
# for my $j (1 .. @b) {
# $d[$i][$j] = (
# $a[$i-1] eq $b[$j-1]
# ? $d[$i-1][$j-1]
# : 1 + __min(
# $d[$i-1][$j],
# $d[$i][$j-1],
# $d[$i-1][$j-1]
# )
# );
# }
# }
#
# $d[@a][@b];
#}
#
#my %complete_array_elem_args = (
# %arg_word,
# array => {
# schema => ['array*'=>{of=>'str*'}],
# req => 1,
# pos => 1,
# slurpy => 1,
# },
# summaries => {
# schema => ['array*'=>{of=>'str*'}],
# },
# exclude => {
# schema => ['array*'],
# },
# replace_map => {
# schema => ['hash*', each_value=>['array*', of=>'str*']],
# description => <<'_',
#
#You can supply correction entries in this option. An example is when array if
#`['mount','unmount']` and `umount` is a popular "typo" for `unmount`. When
#someone already types `um` it cannot be completed into anything (even the
#current fuzzy mode will return *both* so it cannot complete immediately).
#
#One solution is to add replace_map `{'unmount'=>['umount']}`. This way, `umount`
#will be regarded the same as `unmount` and when user types `um` it can be
#completed unambiguously into `unmount`.
#
#_
# tags => ['experimental'],
# },
#);
#
#$SPEC{complete_array_elem} = {
# v => 1.1,
# summary => 'Complete from array',
# description => <<'_',
#
#Try to find completion from an array of strings. Will attempt several methods,
#from the cheapest and most discriminating to the most expensive and least
#discriminating.
#
#First method is normal/exact string prefix matching (either case-sensitive or
#insensitive depending on the `$Complete::Common::OPT_CI` variable or the
#`COMPLETE_OPT_CI` environment variable). If at least one match is found, return
#result. Else, proceed to the next method.
#
#Word-mode matching (can be disabled by setting
#`$Complete::Common::OPT_WORD_MODE` or `COMPLETE_OPT_WORD_MODE` environment
#varialbe to false). Word-mode matching is described in <pm:Complete::Common>. If
#at least one match is found, return result. Else, proceed to the next method.
#
#Prefix char-mode matching (can be disabled by settings
#`$Complete::Common::OPT_CHAR_MODE` or `COMPLETE_OPT_CHAR_MODE` environment
#variable to false). Prefix char-mode matching is just like char-mode matching
#(see next paragraph) except the first character must match. If at least one
#match is found, return result. Else, proceed to the next method.
#
#Char-mode matching (can be disabled by settings
#`$Complete::Common::OPT_CHAR_MODE` or `COMPLETE_OPT_CHAR_MODE` environment
#variable to false). Char-mode matching is described in <pm:Complete::Common>. If
#at least one match is found, return result. Else, proceed to the next method.
#
#Fuzzy matching (can be disabled by setting `$Complete::Common::OPT_FUZZY` or
#`COMPLETE_OPT_FUZZY` to false). Fuzzy matching is described in
#<pm:Complete::Common>. If at least one match is found, return result. Else,
#return empty string.
#
#Will sort the resulting completion list, so you don't have to presort the array.
#
#_
# args => {
# %complete_array_elem_args,
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_array_elem {
# my %args = @_;
#
# my $array0 = $args{array} or die "Please specify array";
# my $summaries = $args{summaries};
# my $word = $args{word} // "";
#
# my $ci = $Complete::Common::OPT_CI;
# my $map_case = $Complete::Common::OPT_MAP_CASE;
# my $word_mode = $Complete::Common::OPT_WORD_MODE;
# my $char_mode = $Complete::Common::OPT_CHAR_MODE;
# my $fuzzy = $Complete::Common::OPT_FUZZY;
#
# log_trace("[computil] entering complete_array_elem(), word=<%s>", $word)
# if $COMPLETE_UTIL_TRACE;
#
# my $res;
#
# unless (@$array0) {
# $res = []; goto RETURN_RES;
# }
#
# # normalize
# my $wordn = $ci ? uc($word) : $word; $wordn =~ s/_/-/g if $map_case;
#
# my $excluden;
# if ($args{exclude}) {
# $excluden = {};
# for my $el (@{$args{exclude}}) {
# my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
# $excluden->{$eln} //= 1;
# }
# }
#
# my $rmapn;
# my $rev_rmapn; # to replace back to the original words back in the result
# if (my $rmap = $args{replace_map}) {
# $rmapn = {};
# $rev_rmapn = {};
# for my $k (keys %$rmap) {
# my $kn = $ci ? uc($k) : $k; $kn =~ s/_/-/g if $map_case;
# my @vn;
# for my $v (@{ $rmap->{$k} }) {
# my $vn = $ci ? uc($v) : $v; $vn =~ s/_/-/g if $map_case;
# push @vn, $vn;
# $rev_rmapn->{$vn} //= $k;
# }
# $rmapn->{$kn} = \@vn;
# }
# }
#
# my @words; # the answer
# my @wordsumms; # summaries for each item in @words
# my @array ; # original array + rmap entries
# my @arrayn; # case- & map-case-normalized form of $array + rmap entries
# my @arraysumms; # summaries for each item in @array (or @arrayn)
#
# # normal string prefix matching. we also fill @array & @arrayn here (which
# # will be used again in word-mode, fuzzy, and char-mode matching) so we
# # don't have to calculate again.
# log_trace("[computil] Trying normal string-prefix matching ...") if $COMPLETE_UTIL_TRACE;
# for my $i (0..$#{$array0}) {
# my $el = $array0->[$i];
# my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
# next if $excluden && $excluden->{$eln};
# push @array , $el;
# push @arrayn, $eln;
# push @arraysumms, $summaries->[$i] if $summaries;
# if (0==index($eln, $wordn)) {
# push @words, $el;
# push @wordsumms, $summaries->[$i] if $summaries;
# }
# if ($rmapn && $rmapn->{$eln}) {
# for my $vn (@{ $rmapn->{$eln} }) {
# push @array , $el;
# push @arrayn, $vn;
# # we add the normalized form, because we'll just revert it back
# # to the original word in the final result
# if (0==index($vn, $wordn)) {
# push @words, $vn;
# push @wordsumms, $summaries->[$i] if $summaries;
# }
# }
# }
# }
# log_trace("[computil] Result from normal string-prefix matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
#
# # word-mode matching
# {
# last unless $word_mode && !@words;
# my @split_wordn = $wordn =~ /(\w+)/g;
# unshift @split_wordn, '' if $wordn =~ /\A\W/;
# last unless @split_wordn > 1;
# my $re = '\A';
# for my $i (0..$#split_wordn) {
# $re .= '(?:\W+\w+)*\W+' if $i;
# $re .= quotemeta($split_wordn[$i]).'\w*';
# }
# $re = qr/$re/;
# log_trace("[computil] Trying word-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
#
# for my $i (0..$#array) {
# my $match;
# {
# if ($arrayn[$i] =~ $re) {
# $match++;
# last;
# }
# # try splitting CamelCase into Camel-Case
# my $tmp = $array[$i];
# if ($tmp =~ s/([a-z0-9_])([A-Z])/$1-$2/g) {
# $tmp = uc($tmp) if $ci; $tmp =~ s/_/-/g if $map_case; # normalize again
# if ($tmp =~ $re) {
# $match++;
# last;
# }
# }
# }
# next unless $match;
# push @words, $array[$i];
# push @wordsumms, $arraysumms[$i] if $summaries;
# }
# log_trace("[computil] Result from word-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
# }
#
# # prefix char-mode matching
# if ($char_mode && !@words && length($wordn) && length($wordn) <= 7) {
# my $re = join(".*", map {quotemeta} split(//, $wordn));
# $re = qr/\A$re/;
# log_trace("[computil] Trying prefix char-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
# for my $i (0..$#array) {
# if ($arrayn[$i] =~ $re) {
# push @words, $array[$i];
# push @wordsumms, $arraysumms[$i] if $summaries;
# }
# }
# log_trace("[computil] Result from prefix char-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
# }
#
# # char-mode matching
# if ($char_mode && !@words && length($wordn) && length($wordn) <= 7) {
# my $re = join(".*", map {quotemeta} split(//, $wordn));
# $re = qr/$re/;
# log_trace("[computil] Trying char-mode matching (re=%s) ...", $re) if $COMPLETE_UTIL_TRACE;
# for my $i (0..$#array) {
# if ($arrayn[$i] =~ $re) {
# push @words, $array[$i];
# push @wordsumms, $arraysumms[$i] if $summaries;
# }
# }
# log_trace("[computil] Result from char-mode matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
# }
#
# # fuzzy matching
# if ($fuzzy && !@words) {
# log_trace("[computil] Trying fuzzy matching ...") if $COMPLETE_UTIL_TRACE;
# $code_editdist //= do {
# my $env = $ENV{COMPLETE_UTIL_LEVENSHTEIN} // '';
# if ($env eq 'xs') {
# require Text::Levenshtein::XS;
# $editdist_flex = 0;
# \&Text::Levenshtein::XS::distance;
# } elsif ($env eq 'flexible') {
# require Text::Levenshtein::Flexible;
# $editdist_flex = 1;
# \&Text::Levenshtein::Flexible::levenshtein_l;
# } elsif ($env eq 'pp') {
# $editdist_flex = 0;
# \&__editdist;
# } elsif (eval { require Text::Levenshtein::Flexible; 1 }) {
# $editdist_flex = 1;
# \&Text::Levenshtein::Flexible::levenshtein_l;
# } else {
# $editdist_flex = 0;
# \&__editdist;
# }
# };
#
# my $factor = 1.3;
# my $x = -1;
# my $y = 1;
#
# # note: we cannot use Text::Levenshtein::Flexible::levenshtein_l_all()
# # because we perform distance calculation on the normalized array but we
# # want to get the original array elements
#
# my %editdists;
# ELEM:
# for my $i (0..$#array) {
# my $eln = $arrayn[$i];
#
# for my $l (length($wordn)-$y .. length($wordn)+$y) {
# next if $l <= 0;
# my $chopped = substr($eln, 0, $l);
# my $maxd = __min(
# __min(length($chopped), length($word))/$factor,
# $fuzzy,
# );
# my $d;
# unless (defined $editdists{$chopped}) {
# if ($editdist_flex) {
# $d = $code_editdist->($wordn, $chopped, $maxd);
# next ELEM unless defined $d;
# } else {
# $d = $code_editdist->($wordn, $chopped);
# }
# $editdists{$chopped} = $d;
# } else {
# $d = $editdists{$chopped};
# }
# #say "D: d($word,$chopped)=$d (maxd=$maxd)";
# next unless $d <= $maxd;
# push @words, $array[$i];
# push @wordsumms, $arraysumms[$i] if $summaries;
# next ELEM;
# }
# }
# log_trace("[computil] Result from fuzzy matching: %s", \@words) if @words && $COMPLETE_UTIL_TRACE;
# }
#
# # replace back the words from replace_map
# if ($rmapn && @words) {
# my @wordsn;
# for my $el (@words) {
# my $eln = $ci ? uc($el) : $el; $eln =~ s/_/-/g if $map_case;
# push @wordsn, $eln;
# }
# for my $i (0..$#words) {
# if (my $w = $rev_rmapn->{$wordsn[$i]}) {
# $words[$i] = $w;
# }
# }
# }
#
# # sort results and insert summaries
# $res = [
# map {
# $summaries ?
# {word=>$words[$_], summary=>$wordsumms[$_]} :
# $words[$_]
# }
# sort {
# $ci ?
# lc($words[$a]) cmp lc($words[$b]) :
# $words[$a] cmp $words[$b] }
# 0 .. $#words
# ];
#
# RETURN_RES:
# log_trace("[computil] leaving complete_array_elem(), res=%s", $res)
# if $COMPLETE_UTIL_TRACE;
# $res;
#}
#
#$SPEC{complete_hash_key} = {
# v => 1.1,
# summary => 'Complete from hash keys',
# args => {
# %arg_word,
# hash => { schema=>['hash*'=>{}], req=>1 },
# summaries => { schema=>['hash*'=>{}] },
# summaries_from_hash_values => { schema=>'true*' },
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
# args_rels => {
# choose_one => ['summaries', 'summaries_from_hash_values'],
# },
#};
#sub complete_hash_key {
# my %args = @_;
# my $hash = $args{hash} or die "Please specify hash";
# my $word = $args{word} // "";
# my $summaries = $args{summaries};
# my $summaries_from_hash_values = $args{summaries_from_hash_values};
#
# my @keys = keys %$hash;
# my @summaries;
# my $has_summary;
# if ($summaries) {
# $has_summary++;
# for (@keys) { push @summaries, $summaries->{$_} }
# } elsif ($summaries_from_hash_values) {
# $has_summary++;
# for (@keys) { push @summaries, $hash->{$_} }
# }
#
# complete_array_elem(
# word=>$word, array=>\@keys,
# (summaries=>\@summaries) x !!$has_summary,
# );
#}
#
#my %complete_comma_sep_args = (
# %complete_array_elem_args,
# sep => {
# schema => 'str*',
# default => ',',
# },
# uniq => {
# summary => 'Whether list should contain unique elements',
# description => <<'_',
#
#When this option is set to true, if the formed list in the current word already
#contains an element, the element will not be offered again as completion answer.
#For example, if `elems` is `[1,2,3,4]` and `word` is `2,3,` then without `uniq`
#set to true the completion answer is:
#
# 2,3,1
# 2,3,2
# 2,3,3
# 2,3,4
#
#but with `uniq` set to true, the completion answer becomes:
#
# 2,3,1
# 2,3,4
#
#See also the `remaining` option for a more general mechanism of offering fewer
#elements.
#
#_
# schema => ['bool*', is=>1],
# },
# remaining => {
# schema => ['code*'],
# summary => 'What elements should remain for completion',
# description => <<'_',
#
#This is a more general mechanism if the `uniq` option does not suffice. Suppose
#you are offering completion for sorting fields. The elements are field names as
#well as field names prefixed with dash (`-`) to mean sorting with a reverse
#order. So for example `elems` is `["name","-name","age","-age"]`. When current
#word is `name`, it doesn't make sense to offer `name` nor `-name` again as the
#next sorting field. So we can set `remaining` to this code:
#
# sub {
# my ($seen_elems, $elems) = @_;
#
# my %seen;
# for (@$seen_elems) {
# (my $nodash = $_) =~ s/^-//;
# $seen{$nodash}++;
# }
#
# my @remaining;
# for (@$elems) {
# (my $nodash = $_) =~ s/^-//;
# push @remaining, $_ unless $seen{$nodash};
# }
#
# \@remaining;
# }
#
#As you can see above, the code is given `$seen_elems` and `$elems` as arguments
#and is expected to return remaining elements to offer.
#
#_
# tags => ['hidden-cli'],
# },
#);
#$complete_comma_sep_args{elems} = delete $complete_comma_sep_args{array};
#
#$SPEC{complete_comma_sep} = {
# v => 1.1,
# summary => 'Complete a comma-separated list string',
# args => {
# %complete_comma_sep_args,
# },
# result_naked => 1,
# result => {
# schema => 'array',
# },
#};
#sub complete_comma_sep {
# my %args = @_;
# my $word = delete $args{word} // "";
# my $sep = delete $args{sep} // ',';
# my $elems = delete $args{elems} or die "Please specify elems";
# my $uniq = delete $args{uniq};
# my $remaining = delete $args{remaining};
#
# my $ci = $Complete::Common::OPT_CI;
#
# my @mentioned_elems = split /\Q$sep\E/, $word, -1;
# my $cae_word = @mentioned_elems ? pop(@mentioned_elems) : '';
#
# my $remaining_elems;
# if ($remaining) {
# $remaining_elems = $remaining->(\@mentioned_elems, $elems);
# } elsif ($uniq) {
# my %mem;
# $remaining_elems = [];
# for (@mentioned_elems) {
# if ($ci) { $mem{lc $_}++ } else { $mem{$_}++ }
# }
# for (@$elems) {
# push @$remaining_elems, $_ unless ($ci ? $mem{lc $_} : $mem{$_});
# }
# } else {
# $remaining_elems = $elems;
# }
#
# my $cae_res = complete_array_elem(
# %args,
# word => $cae_word,
# array => $remaining_elems,
# );
#
# my $prefix = join($sep, @mentioned_elems);
# $prefix .= $sep if @mentioned_elems;
# $cae_res = [map { "$prefix$_" } @$cae_res];
#
# # add trailing comma for convenience, where appropriate
# {
# last unless @$cae_res == 1;
# last if @$remaining_elems <= 1;
# $cae_res->[0] .= $sep;
# }
# $cae_res;
#}
#
#$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 <prog: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),
# complete_module(word=>$word),
# );
#
#But 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->{$_};
# }
# }
# }
# }
#
# $encounter_hash ? $final : $final->{words};
#}
#
#$SPEC{modify_answer} = {
# v => 1.1,
# summary => 'Modify answer (add prefix/suffix, etc)',
# args => {
# answer => {
# schema => ['any*', of=>['hash*','array*']], # XXX answer_t
# req => 1,
# pos => 0,
# },
# suffix => {
# schema => 'str*',
# },
# prefix => {
# schema => 'str*',
# },
# },
# result_naked => 1,
# result => {
# schema => 'undef',
# },
#};
#sub modify_answer {
# my %args = @_;
#
# my $answer = $args{answer};
# my $words = ref($answer) eq 'HASH' ? $answer->{words} : $answer;
#
# if (defined(my $prefix = $args{prefix})) {
# $_ = "$prefix$_" for @$words;
# }
# if (defined(my $suffix = $args{suffix})) {
# $_ = "$_$suffix" for @$words;
# }
# undef;
#}
#
#$SPEC{ununiquify_answer} = {
# v => 1.1,
# summary => 'If answer contains only one item, make it two',
# description => <<'_',
#
#For example, if answer is `["a"]`, then will make answer become `["a","a "]`.
#This will prevent shell from automatically adding space.
#
#_
# args => {
# answer => {
# schema => ['any*', of=>['hash*','array*']], # XXX answer_t
# req => 1,
# pos => 0,
# },
# },
# result_naked => 1,
# result => {
# schema => 'undef',
# },
#};
#sub ununiquify_answer {
# my %args = @_;
#
# my $answer = $args{answer};
# my $words = ref($answer) eq 'HASH' ? $answer->{words} : $answer;
#
# if (@$words == 1) {
# push @$words, "$words->[0] ";
# }
# undef;
#}
#
#1;
## ABSTRACT: General completion routine
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::Util - General completion routine
#
#=head1 VERSION
#
#This document describes version 0.603 of Complete::Util (from Perl distribution Complete-Util), released on 2019-07-23.
#
#=head1 DESCRIPTION
#
#
#This package provides some generic completion routines that follow the
#L<Complete> convention. (If you are looking for bash/shell tab completion
#routines, take a look at the See Also section.) The main routine is
#C<complete_array_elem> which tries to complete a word using choices from elements
#of supplied array. For example:
#
# complete_array_elem(word => "a", array => ["apple", "apricot", "banana"]);
#
#The routine will first try a simple substring prefix matching. If that fails,
#will try some other methods like word-mode, character-mode, or fuzzy matching.
#These methods can be disabled using settings.
#
#There are other utility routines e.g. for converting completion answer structure
#from hash to array/array to hash, combine or modify answer, etc. These routines
#are usually used by the other more specific or higher-level completion modules.
#
#=head1 FUNCTIONS
#
#
#=head2 arrayify_answer
#
#Usage:
#
# arrayify_answer($arg) -> array
#
#Make sure we return completion answer in array form.
#
#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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$arg>* => I<array|hash>
#
#=back
#
#Return value: (array)
#
#
#
#=head2 combine_answers
#
#Usage:
#
# combine_answers($answers, ...) -> hash
#
#Given two or more answers, combine them into one.
#
#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 L<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),
# complete_module(word=>$word),
# );
#
#But 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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$answers>* => I<array[hash|array]>
#
#=back
#
#Return value: (hash)
#
#
#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
#
#Usage:
#
# complete_array_elem(%args) -> array
#
#Complete from array.
#
#Try to find completion from an array of strings. Will attempt several methods,
#from the cheapest and most discriminating to the most expensive and least
#discriminating.
#
#First method is normal/exact string prefix matching (either case-sensitive or
#insensitive depending on the C<$Complete::Common::OPT_CI> variable or the
#C<COMPLETE_OPT_CI> environment variable). If at least one match is found, return
#result. Else, proceed to the next method.
#
#Word-mode matching (can be disabled by setting
#C<$Complete::Common::OPT_WORD_MODE> or C<COMPLETE_OPT_WORD_MODE> environment
#varialbe to false). Word-mode matching is described in L<Complete::Common>. If
#at least one match is found, return result. Else, proceed to the next method.
#
#Prefix char-mode matching (can be disabled by settings
#C<$Complete::Common::OPT_CHAR_MODE> or C<COMPLETE_OPT_CHAR_MODE> environment
#variable to false). Prefix char-mode matching is just like char-mode matching
#(see next paragraph) except the first character must match. If at least one
#match is found, return result. Else, proceed to the next method.
#
#Char-mode matching (can be disabled by settings
#C<$Complete::Common::OPT_CHAR_MODE> or C<COMPLETE_OPT_CHAR_MODE> environment
#variable to false). Char-mode matching is described in L<Complete::Common>. If
#at least one match is found, return result. Else, proceed to the next method.
#
#Fuzzy matching (can be disabled by setting C<$Complete::Common::OPT_FUZZY> or
#C<COMPLETE_OPT_FUZZY> to false). Fuzzy matching is described in
#L<Complete::Common>. If at least one match is found, return result. Else,
#return empty string.
#
#Will sort the resulting completion list, so you don't have to presort the array.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<array>* => I<array[str]>
#
#=item * B<exclude> => I<array>
#
#=item * B<replace_map> => I<hash>
#
#You can supply correction entries in this option. An example is when array if
#C<['mount','unmount']> and C<umount> is a popular "typo" for C<unmount>. When
#someone already types C<um> it cannot be completed into anything (even the
#current fuzzy mode will return I<both> so it cannot complete immediately).
#
#One solution is to add replace_map C<< {'unmount'=E<gt>['umount']} >>. This way, C<umount>
#will be regarded the same as C<unmount> and when user types C<um> it can be
#completed unambiguously into C<unmount>.
#
#=item * B<summaries> => I<array[str]>
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 complete_comma_sep
#
#Usage:
#
# complete_comma_sep(%args) -> array
#
#Complete a comma-separated list string.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<elems>* => I<array[str]>
#
#=item * B<exclude> => I<array>
#
#=item * B<remaining> => I<code>
#
#What elements should remain for completion.
#
#This is a more general mechanism if the C<uniq> option does not suffice. Suppose
#you are offering completion for sorting fields. The elements are field names as
#well as field names prefixed with dash (C<->) to mean sorting with a reverse
#order. So for example C<elems> is C<["name","-name","age","-age"]>. When current
#word is C<name>, it doesn't make sense to offer C<name> nor C<-name> again as the
#next sorting field. So we can set C<remaining> to this code:
#
# sub {
# my ($seen_elems, $elems) = @_;
#
# my %seen;
# for (@$seen_elems) {
# (my $nodash = $_) =~ s/^-//;
# $seen{$nodash}++;
# }
#
# my @remaining;
# for (@$elems) {
# (my $nodash = $_) =~ s/^-//;
# push @remaining, $_ unless $seen{$nodash};
# }
#
# \@remaining;
# }
#
#As you can see above, the code is given C<$seen_elems> and C<$elems> as arguments
#and is expected to return remaining elements to offer.
#
#=item * B<replace_map> => I<hash>
#
#You can supply correction entries in this option. An example is when array if
#C<['mount','unmount']> and C<umount> is a popular "typo" for C<unmount>. When
#someone already types C<um> it cannot be completed into anything (even the
#current fuzzy mode will return I<both> so it cannot complete immediately).
#
#One solution is to add replace_map C<< {'unmount'=E<gt>['umount']} >>. This way, C<umount>
#will be regarded the same as C<unmount> and when user types C<um> it can be
#completed unambiguously into C<unmount>.
#
#=item * B<sep> => I<str> (default: ",")
#
#=item * B<summaries> => I<array[str]>
#
#=item * B<uniq> => I<bool>
#
#Whether list should contain unique elements.
#
#When this option is set to true, if the formed list in the current word already
#contains an element, the element will not be offered again as completion answer.
#For example, if C<elems> is C<[1,2,3,4]> and C<word> is C<2,3,> then without C<uniq>
#set to true the completion answer is:
#
# 2,3,1
# 2,3,2
# 2,3,3
# 2,3,4
#
#but with C<uniq> set to true, the completion answer becomes:
#
# 2,3,1
# 2,3,4
#
#See also the C<remaining> option for a more general mechanism of offering fewer
#elements.
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 complete_hash_key
#
#Usage:
#
# complete_hash_key(%args) -> array
#
#Complete from hash keys.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<hash>* => I<hash>
#
#=item * B<summaries> => I<hash>
#
#=item * B<summaries_from_hash_values> => I<true>
#
#=item * B<word>* => I<str> (default: "")
#
#Word to complete.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 hashify_answer
#
#Usage:
#
# hashify_answer($arg, $meta) -> hash
#
#Make sure we return completion answer in hash form.
#
#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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$arg>* => I<array|hash>
#
#=item * B<$meta> => I<hash>
#
#Metadata (extra keys) for the hash.
#
#=back
#
#Return value: (hash)
#
#
#
#=head2 modify_answer
#
#Usage:
#
# modify_answer(%args) -> undef
#
#Modify answer (add prefix/suffix, etc).
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<answer>* => I<hash|array>
#
#=item * B<prefix> => I<str>
#
#=item * B<suffix> => I<str>
#
#=back
#
#Return value: (undef)
#
#
#
#=head2 ununiquify_answer
#
#Usage:
#
# ununiquify_answer(%args) -> undef
#
#If answer contains only one item, make it two.
#
#For example, if answer is C<["a"]>, then will make answer become C<["a","a "]>.
#This will prevent shell from automatically adding space.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<answer>* => I<hash|array>
#
#=back
#
#Return value: (undef)
#
#=head1 FAQ
#
#=head2 Why is fuzzy matching slow?
#
#Example:
#
# use Benchmark qw(timethis);
# use Complete::Util qw(complete_array_elem);
#
# # turn off the other non-exact matching methods
# $Complete::Common::OPT_CI = 0;
# $Complete::Common::OPT_WORD_MODE = 0;
# $Complete::Common::OPT_CHAR_MODE = 0;
#
# my @ary = ("aaa".."zzy"); # 17575 elems
# timethis(20, sub { complete_array_elem(array=>\@ary, word=>"zzz") });
#
#results in:
#
# timethis 20: 7 wallclock secs ( 6.82 usr + 0.00 sys = 6.82 CPU) @ 2.93/s (n=20)
#
#Answer: fuzzy matching is slower than exact matching due to having to calculate
#Levenshtein distance. But if you find fuzzy matching too slow using the default
#pure-perl implementation, you might want to install
#L<Text::Levenshtein::Flexible> (an optional prereq) to speed up fuzzy matching.
#After Text::Levenshtein::Flexible is installed:
#
# timethis 20: 1 wallclock secs ( 1.04 usr + 0.00 sys = 1.04 CPU) @ 19.23/s (n=20)
#
#=head1 ENVIRONMENT
#
#=head2 COMPLETE_UTIL_TRACE => bool
#
#If set to true, will display more log statements for debugging.
#
#=head2 COMPLETE_UTIL_LEVENSHTEIN => str ('pp'|'xs'|'flexible')
#
#Can be used to force which Levenshtein distance implementation to use. C<pp>
#means the included PP implementation, which is the slowest (1-2 orders of
#magnitude slower than XS implementations), C<xs> which means
#L<Text::Levenshtein::XS>, or C<flexible> which means
#L<Text::Levenshtein::Flexible> (performs best).
#
#If this is not set, the default is to use Text::Levenshtein::Flexible when it's
#available, then fallback to the included PP implementation.
#
#=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 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.
#
#L<Bencher::Scenarios::CompleteUtil>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2017, 2016, 2015, 2014, 2013 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.pm ###
#package Data::Clean;
#
#our $DATE = '2019-09-08'; # DATE
#our $VERSION = '0.505'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#sub new {
# my ($class, %opts) = @_;
# my $self = bless {_opts=>\%opts}, $class;
# log_trace("Cleanser options: %s", \%opts);
#
# my $cd = $self->_generate_cleanser_code;
# for my $mod (keys %{ $cd->{modules} }) {
# (my $mod_pm = "$mod.pm") =~ s!::!/!g;
# require $mod_pm;
# }
# $self->{_cd} = $cd;
# $self->{_code} = eval $cd->{src};
# {
# last unless $cd->{clone_func} =~ /(.+)::(.+)/;
# (my $mod_pm = "$1.pm") =~ s!::!/!g;
# require $mod_pm;
# }
# die "Can't generate code: $@" if $@;
#
# $self;
#}
#
#sub command_call_method {
# my ($self, $cd, $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, $cd, $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, $cd, $args) = @_;
# return "{{var}} = {{var}} ? 1:0; \$ref = ''";
#}
#
#sub command_deref_scalar_one_or_zero {
# my ($self, $cd, $args) = @_;
# return "{{var}} = \${ {{var}} } ? 1:0; \$ref = ''";
#}
#
#sub command_deref_scalar {
# my ($self, $cd, $args) = @_;
# return '{{var}} = ${ {{var}} }; $ref = ref({{var}})';
#}
#
#sub command_stringify {
# my ($self, $cd, $args) = @_;
# return '{{var}} = "{{var}}"; $ref = ""';
#}
#
#sub command_replace_with_ref {
# my ($self, $cd, $args) = @_;
# return '{{var}} = $ref; $ref = ""';
#}
#
#sub command_replace_with_str {
# require String::PerlQuote;
#
# my ($self, $cd, $args) = @_;
# return "{{var}} = ".String::PerlQuote::double_quote($args->[0]).'; $ref=""';
#}
#
#sub command_unbless {
# my ($self, $cd, $args) = @_;
#
# return join(
# "",
# 'my $reftype = Scalar::Util::reftype({{var}}); ',
# '{{var}} = $reftype eq "HASH" ? {%{ {{var}} }} :',
# ' $reftype eq "ARRAY" ? [@{ {{var}} }] :',
# ' $reftype eq "SCALAR" ? \(my $copy = ${ {{var}} }) :',
# ' $reftype eq "CODE" ? sub { goto &{ {{var}} } } :',
# '(die "Cannot unbless object with type $ref")',
# );
#}
#
#sub command_clone {
# my ($self, $cd, $args) = @_;
#
# my $limit = $args->[0] // 1;
# return join(
# "",
# "if (++\$ctr_circ <= $limit) { ",
# "{{var}} = $cd->{clone_func}({{var}}); redo ",
# "} else { ",
# "{{var}} = 'CIRCULAR'; \$ref = '' }",
# );
#}
#
#sub command_unbless_ffc_inlined {
# my ($self, $cd, $args) = @_;
#
# # code taken from Function::Fallback::CoreOrPP 0.07
# $cd->{subs}{unbless} //= <<'EOC';
# 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";
# }
#EOC
#
# "{{var}} = \$sub_unbless->({{var}}); \$ref = ref({{var}})";
#}
#
## test
#sub command_die {
# my ($self, $cd, $args) = @_;
# return "die";
#}
#
#sub _generate_cleanser_code {
# my $self = shift;
# my $opts = $self->{_opts};
#
# # compilation data, a structure that will be passed around between routines
# # during the generation of cleanser code.
# my $cd = {
# modules => {}, # key = module name, val = version
# clone_func => $self->{_opts}{'!clone_func'},
# code => '',
# subs => {},
# };
#
# $cd->{modules}{'Scalar::Util'} //= 0;
#
# if (!$cd->{clone_func}) {
# $cd->{clone_func} = 'Clone::PP::clone';
# }
# {
# last unless $cd->{clone_func} =~ /(.+)::(.+)/;
# $cd->{modules}{$1} //= 0;
# }
#
# 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 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($cd, \@args);
# #$add_stmt->('stmt', 'say "ref=$ref, " . {{var}}'); # DEBUG
# $add_new_if->('$ref && $refs{ {{var}} }++', $act);
# }
#
# # 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($cd, \@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($cd, \@args));
# }
#
# # recurse array and hash
# if ($opts->{'!recurse_obj'}) {
# $add_stmt->('stmt', 'my $reftype=Scalar::Util::reftype({{var}})//""');
# $add_new_if->('$reftype eq "ARRAY"', '$process_array->({{var}})');
# $add_if->('$reftype eq "HASH"' , '$process_hash->({{var}})');
# } else {
# $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($cd, \@args));
# }
#
# push @code, 'sub {'."\n";
#
# for (sort keys %{$cd->{subs}}) {
# push @code, "state \$sub_$_ = sub { ".$cd->{subs}{$_}." };\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_trace("Cleanser code:\n%s",
# $ENV{LINENUM} // 1 ?
# String::LineNumber::linenum($code) : $code);
# }
#
# $cd->{src} = $code;
#
# $cd;
#}
#
#sub clean_in_place {
# my ($self, $data) = @_;
#
# $self->{_code}->($data);
#}
#
#sub clone_and_clean {
# no strict 'refs';
#
# my ($self, $data) = @_;
# my $clone = &{$self->{_cd}{clone_func}}($data);
# $self->clean_in_place($clone);
#}
#
#1;
## ABSTRACT: Clean data structure
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Clean - Clean data structure
#
#=head1 VERSION
#
#This document describes version 0.505 of Data::Clean (from Perl distribution Data-Clean), released on 2019-09-08.
#
#=head1 SYNOPSIS
#
# use Data::Clean;
#
# my $cleanser = Data::Clean->new(
# # specify how to deal with specific classes
# 'DateTime' => [call_method => 'epoch'], # replace object with its epoch
# 'Time::Moment' => [call_method => 'epoch'], # replace object with its epoch
# 'Regexp' => ['stringify'], # replace $obj with "$obj"
#
# # specify how to deal with all scalar refs
# SCALAR => ['deref_scalar'], # replace \1 with 1
#
# # specify how to deal with circular reference
# -circular => ['clone'],
#
# # specify how to deal with all other kinds of objects
# -obj => ['unbless'],
# );
#
# # to get cleansed data
# my $cleansed_data = $cleanser->clone_and_clean($data);
#
# # to replace original data with cleansed one
# $cleanser->clean_in_place($data);
#
#=head1 DESCRIPTION
#
#This class can be used to process a data structure by replacing some forms of
#data items with other forms. One of the main uses is to clean "unsafe" data,
#e.g. clean a data structure so it can be encoded to JSON (see
#L<Data::Clean::ForJSON>, which is a thin wrapper over this class).
#
#As can be seen from the example, you specify a list of transformations to be
#done, and then this class will generate an appropriate Perl code to do the
#cleansing. This class is faster than the other ways of processing, e.g.
#L<Data::Rmap> (see L<Bencher::Scenarios::DataCleansing> for some benchmarks).
#
#=for Pod::Coverage ^(command_.+)$
#
#=head1 METHODS
#
#=head2 new(%opts) => $obj
#
#Create a new instance.
#
#Options specify what to do with certain category of data. Option keys are either
#reference types (like C<HASH>, C<ARRAY>, C<SCALAR>) or class names (like
#C<Foo::Bar>), or C<-obj> (to match all kinds of objects, a.k.a. blessed
#references), C<-circular> (to match circular references), C<-ref> (to refer to
#any kind of 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' >>.
#
#Option keys that start with C<!> are special:
#
#=over
#
#=item * !recurse_obj (bool)
#
#Can be set to true to to recurse into objects if they are hash- or array-based.
#By default objects are not recursed into. Note that if you enable this option,
#object options (like C<Foo::Bar> or C<-obj>) won't work for hash- and
#array-based objects because they will be recursed instead.
#
#=item * !clone_func (str)
#
#Set fully qualified name of clone function to use. The default is to use
#C<Clone::PP::clone>.
#
#The clone module (all but the last part of the C<!clone_func> value) will
#automatically be loaded using C<require()>.
#
#=back
#
#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' => STR]
#
#This will call a method named I<STR> and use its return as the replacement. For
#example: C<< DateTime->from_epoch(epoch=>1000) >> when processed with C<<
#[call_method => 'epoch'] >> will become 1000.
#
#=item * ['call_func', STR]
#
#This will call a function named I<STR> with value as argument and use its return
#as the replacement.
#
#=item * ['one_or_zero']
#
#This will perform C<< $val ? 1:0 >>.
#
#=item * ['deref_scalar_one_or_zero']
#
#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 I<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>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Clean>.
#
#=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>
#
#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 SEE ALSO
#
#Related modules: L<Data::Rmap>, L<Hash::Sanitize>, L<Data::Walk>.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2017, 2016 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/ForJSON.pm ###
#package Data::Clean::ForJSON;
#
#our $DATE = '2019-11-26'; # DATE
#our $VERSION = '0.395'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use parent qw(Data::Clean);
#use vars qw($creating_singleton);
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# clean_json_in_place
# clone_and_clean_json
# );
#
#sub new {
# my ($class, %opts) = @_;
#
# if (!%opts && !$creating_singleton) {
# warn "You are creating a new ".__PACKAGE__." object without customizing options. ".
# "You probably want to call get_cleanser() yet to get a singleton instead?";
# }
#
# $opts{DateTime} //= [call_method => 'epoch'];
# $opts{'Time::Moment'} //= [call_method => 'epoch'];
# $opts{'Math::BigInt'} //= [call_method => 'bstr'];
# $opts{Regexp} //= ['stringify'];
# $opts{version} //= ['stringify'];
#
# $opts{SCALAR} //= ['deref_scalar'];
# $opts{-ref} //= ['replace_with_ref'];
# $opts{-circular} //= ['clone'];
# $opts{-obj} //= ['unbless'];
#
# $opts{'!recurse_obj'} //= 1;
# $class->SUPER::new(%opts);
#}
#
#sub get_cleanser {
# my $class = shift;
# local $creating_singleton = 1;
# state $singleton = $class->new;
# $singleton;
#}
#
#sub clean_json_in_place {
# __PACKAGE__->get_cleanser->clean_in_place(@_);
#}
#
#sub clone_and_clean_json {
# __PACKAGE__->get_cleanser->clone_and_clean(@_);
#}
#
#1;
## ABSTRACT: Clean data so it is safe to output to JSON
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Clean::ForJSON - Clean data so it is safe to output to JSON
#
#=head1 VERSION
#
#This document describes version 0.395 of Data::Clean::ForJSON (from Perl distribution Data-Clean-ForJSON), released on 2019-11-26.
#
#=head1 SYNOPSIS
#
# use Data::Clean::ForJSON;
# my $cleanser = Data::Clean::ForJSON->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)"}'
#
#Functional shortcuts:
#
# use Data::Clean::ForJSON qw(clean_json_in_place clone_and_clean_json);
#
# # equivalent to Data::Clean::ForJSON->get_cleanser->clean_in_place($data)
# clean_json_in_place($data);
#
# # equivalent to Data::Clean::ForJSON->get_cleanser->clone_and_clean($data)
# $cleaned = clone_and_clean_json($data);
#
#=head1 DESCRIPTION
#
#This class cleans data from anything that might be problematic when encoding to
#JSON. This includes coderefs, globs, and so on. Here's what it will do by
#default:
#
#=over
#
#=item * Change DateTime and Time::Moment object to its epoch value
#
#=item * Change Regexp and version object to its string value
#
#=item * Change scalar references (e.g. \1) to its scalar value (e.g. 1)
#
#=item * Change other references (non-hash, non-array) to its ref() value (e.g. "GLOB", "CODE")
#
#=item * Clone circular references
#
#With a default limit of 1, meaning that if a reference is first seen again for
#the first time, it will be cloned. But if it is seen again for the second time,
#it will be replaced with "CIRCULAR".
#
#To change the default limit, customize your cleanser object:
#
# $cleanser = Data::Clean::ForJSON->new(
# -circular => ["clone", 4],
# );
#
#or you can perform other action for circular references, see L<Data::Clean> for
#more details.
#
#=item * Unbless other types of objects
#
#=back
#
#Cleaning recurses into objects.
#
#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::ger> at trace level. You can see it, e.g. using
#L<Log::ger::Output::Screen>:
#
# % LOG_CLEANSER_CODE=1 perl -MLog::ger::Output=Screen -MLog::ger::Level::trace -MData::Clean::ForJSON \
# -e'$c=Data::Clean::ForJSON->new; ...'
#
#=head1 FUNCTIONS
#
#None of the functions are exported by default.
#
#=head2 clean_json_in_place($data)
#
#A shortcut for:
#
# Data::Clean::ForJSON->get_cleanser->clean_in_place($data)
#
#=head2 clone_and_clean_json($data) => $cleaned
#
#A shortcut for:
#
# $cleaned = Data::Clean::ForJSON->get_cleanser->clone_and_clean($data)
#
#=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() => $obj
#
#Create a new instance.
#
#=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 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::ForJSON object repeatedly, as the constructor
#generates the cleanser code first using eval(). A short benchmark (run on my
#slow Atom netbook):
#
# % bench -MData::Clean::ForJSON -b'$c=Data::Clean::ForJSON->new' \
# 'Data::Clean::ForJSON->new->clone_and_clean([1..100])' \
# '$c->clone_and_clean([1..100])'
# Benchmarking sub { Data::Clean::ForJSON->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::ForJSON->new(-circular => 0);
#
#Benchmark:
#
# $ perl -MData::Clean::ForJSON -MBench -E '
# $data = [[1],[2],[3],[4],[5]];
# bench {
# circ => sub { state $c = Data::Clean::ForJSON->new; $c->clone_and_clean($data) },
# nocirc => sub { state $c = Data::Clean::ForJSON->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.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 ENVIRONMENT
#
#=head2 LOG_CLEANSER_CODE
#
#Bool. Can be set to true to log cleanser code using L<Log::ger> at C<trace>
#level.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-ForJSON>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Clean-ForJSON>.
#
#=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-ForJSON>
#
#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 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::ForJSON, 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).
#
#Some benchmarks in L<Bencher::Scenarios::DataCleansing>. You can see that
#Data::Clean::ForJSON can be several times faster than, say, Data::Rmap.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 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/FromJSON.pm ###
#package Data::Clean::FromJSON;
#
#our $DATE = '2019-11-26'; # DATE
#our $VERSION = '0.395'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use parent qw(Data::Clean);
#use vars qw($creating_singleton);
#
#sub new {
# my ($class, %opts) = @_;
# if (!%opts && !$creating_singleton) {
# warn "You are creating a new ".__PACKAGE__." object without customizing options. ".
# "You probably want to call get_cleanser() yet to get a singleton instead?";
# }
#
# $opts{"JSON::PP::Boolean"} //= ['deref_scalar_one_or_zero'];
#
# $class->SUPER::new(%opts);
#}
#
#sub get_cleanser {
# my $class = shift;
# local $creating_singleton = 1;
# state $singleton = $class->new;
# $singleton;
#}
#
#1;
## ABSTRACT: Clean data from JSON decoder
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Clean::FromJSON - Clean data from JSON decoder
#
#=head1 VERSION
#
#This document describes version 0.395 of Data::Clean::FromJSON (from Perl distribution Data-Clean-ForJSON), released on 2019-11-26.
#
#=head1 SYNOPSIS
#
# use Data::Clean::FromJSON;
# use JSON;
# my $cleanser = Data::Clean::FromJSON->get_cleanser;
# my $data = JSON->new->decode('[true]'); # -> [bless(do{\(my $o=1)},"JSON::XS::Boolean")]
# my $cleaned = $cleanser->clean_in_place($data); # -> [1]
#
#=head1 DESCRIPTION
#
#This class can "clean" data that comes from a JSON encoder. Currently what it
#does is:
#
#=over
#
#=item * Convert boolean objects to simple Perl values
#
#=back
#
#=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() => $obj
#
#=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 FAQ
#
#=head2 Why am I getting 'Modification of a read-only value attempted at lib/Data/Clean.pm line xxx'?
#
#[2013-10-15 ] This is also from Data::Clone::clone() when it encounters
#JSON::{PP,XS}::Boolean objects. You can use clean_in_place() instead of
#clone_and_clean(), or clone your data using other cloner like L<Sereal>.
#
#=head1 ENVIRONMENT
#
#LOG_CLEANSER_CODE
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Clean-ForJSON>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Clean-ForJSON>.
#
#=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-ForJSON>
#
#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) 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 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/Dmp.pm ###
#package Data::Dmp;
#
#our $DATE = '2017-01-30'; # DATE
#our $VERSION = '0.23'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Scalar::Util qw(looks_like_number blessed reftype refaddr);
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT = qw(dd dmp);
#
## for when dealing with circular refs
#our %_seen_refaddrs;
#our %_subscripts;
#our @_fixups;
#
#our $OPT_PERL_VERSION = "5.010";
#our $OPT_REMOVE_PRAGMAS = 0;
#our $OPT_DEPARSE = 1;
#our $OPT_STRINGIFY_NUMBERS = 0;
#
## 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 _dump_code {
# my $code = shift;
#
# state $deparse = do {
# require B::Deparse;
# B::Deparse->new("-l"); # -i option doesn't have any effect?
# };
#
# my $res = $deparse->coderef2text($code);
#
# my ($res_before_first_line, $res_after_first_line) =
# $res =~ /(.+?)^(#line .+)/ms;
#
# if ($OPT_REMOVE_PRAGMAS) {
# $res_before_first_line = "{";
# } elsif ($OPT_PERL_VERSION < 5.016) {
# # older perls' feature.pm doesn't yet support q{no feature ':all';}
# # so we replace it with q{no feature}.
# $res_before_first_line =~ s/no feature ':all';/no feature;/m;
# }
# $res_after_first_line =~ s/^#line .+//gm;
#
# $res = "sub" . $res_before_first_line . $res_after_first_line;
# $res =~ s/^\s+//gm;
# $res =~ s/\n+//g;
# $res =~ s/;\}\z/}/;
# $res;
#}
#
#sub _quote_key {
# $_[0] =~ /\A-?[A-Za-z_][A-Za-z0-9_]*\z/ ||
# $_[0] =~ /\A-?[1-9][0-9]{0,8}\z/ ? $_[0] : _double_quote($_[0]);
#}
#
#sub _dump {
# my ($val, $subscript) = @_;
#
# my $ref = ref($val);
# if ($ref eq '') {
# if (!defined($val)) {
# return "undef";
# } elsif (looks_like_number($val) && !$OPT_STRINGIFY_NUMBERS &&
# # perl does several normalizations to number literal, e.g.
# # "+1" becomes 1, 0123 is octal literal, etc. make sure we
# # only leave out quote when the number is not normalized
# $val eq $val+0 &&
# # perl also doesn't recognize Inf and NaN as numeric
# # literals (ref: perldata) so these unquoted literals will
# # choke under 'use strict "subs"
# $val !~ /\A-?(?:inf(?:inity)?|nan)\z/i
# ) {
# return $val;
# } else {
# return _double_quote($val);
# }
# }
# my $refaddr = refaddr($val);
# $_subscripts{$refaddr} //= $subscript;
# if ($_seen_refaddrs{$refaddr}++) {
# push @_fixups, "\$a->$subscript=\$a",
# ($_subscripts{$refaddr} ? "->$_subscripts{$refaddr}" : ""), ";";
# return "'fix'";
# }
#
# my $class;
#
# if ($ref eq 'Regexp' || $ref eq 'REGEXP') {
# require Regexp::Stringify;
# return Regexp::Stringify::stringify_regexp(
# regexp=>$val, with_qr=>1, plver=>$OPT_PERL_VERSION);
# }
#
# if (blessed $val) {
# $class = $ref;
# $ref = reftype($val);
# }
#
# my $res;
# if ($ref eq 'ARRAY') {
# $res = "[";
# my $i = 0;
# for (@$val) {
# $res .= "," if $i;
# $res .= _dump($_, "$subscript\[$i]");
# $i++;
# }
# $res .= "]";
# } elsif ($ref eq 'HASH') {
# $res = "{";
# my $i = 0;
# for (sort keys %$val) {
# $res .= "," if $i++;
# my $k = _quote_key($_);
# my $v = _dump($val->{$_}, "$subscript\{$k}");
# $res .= "$k=>$v";
# }
# $res .= "}";
# } elsif ($ref eq 'SCALAR') {
# $res = "\\"._dump($$val, $subscript);
# } elsif ($ref eq 'REF') {
# $res = "\\"._dump($$val, $subscript);
# } elsif ($ref eq 'CODE') {
# $res = $OPT_DEPARSE ? _dump_code($val) : 'sub{"DUMMY"}';
# } else {
# die "Sorry, I can't dump $val (ref=$ref) yet";
# }
#
# $res = "bless($res,"._double_quote($class).")" if defined($class);
# $res;
#}
#
#our $_is_dd;
#sub _dd_or_dmp {
# local %_seen_refaddrs;
# local %_subscripts;
# local @_fixups;
#
# my $res;
# if (@_ > 1) {
# $res = "(" . join(",", map {_dump($_, '')} @_) . ")";
# } else {
# $res = _dump($_[0], '');
# }
# if (@_fixups) {
# $res = "do{my\$a=$res;" . join("", @_fixups) . "\$a}";
# }
#
# if ($_is_dd) {
# say $res;
# return wantarray() || @_ > 1 ? @_ : $_[0];
# } else {
# return $res;
# }
#}
#
#sub dd { local $_is_dd=1; _dd_or_dmp(@_) } # goto &sub doesn't work here
#sub dmp { goto &_dd_or_dmp }
#
#1;
## ABSTRACT: Dump Perl data structures as Perl code
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Dmp - Dump Perl data structures as Perl code
#
#=head1 VERSION
#
#This document describes version 0.23 of Data::Dmp (from Perl distribution Data-Dmp), released on 2017-01-30.
#
#=head1 SYNOPSIS
#
# use Data::Dmp; # exports dd() and dmp()
# dd [1, 2, 3]; # prints "[1,2,3]"
# $a = dmp({a => 1}); # -> "{a=>1}"
#
#=head1 DESCRIPTION
#
#Data::Dmp is a Perl dumper like L<Data::Dumper>. It's compact (only about 175
#lines of code long), starts fast and does not use any non-core modules except
#L<Regexp::Stringify> when dumping regexes. It produces compact single-line
#output (similar to L<Data::Dumper::Concise>). It roughly has the same speed as
#Data::Dumper (usually a bit faster for smaller structures) and faster than
#L<Data::Dump>, but does not offer the various formatting options. It supports
#dumping objects, regexes, circular structures, coderefs. Its code is first based
#on L<Data::Dump>: I removed all the parts that I don't need, particularly the
#pretty formatting stuffs) and added some features that I need like proper regex
#dumping and coderef deparsing.
#
#=head1 SETTINGS
#
#=head2 $Data::Dmp::OPT_PERL_VERSION => str (default: 5.010)
#
#Set target Perl version. If you set this to, say C<5.010>, then the dumped code
#will keep compatibility with Perl 5.10.0. This is used in the following ways:
#
#=over
#
#=item * passed to L<Regexp::Stringify>
#
#=item * when dumping code references
#
#For example, in perls earlier than 5.016, feature.pm does not understand:
#
# no feature ':all';
#
#so we replace it with:
#
# no feature;
#
#=back
#
#=head2 $Data::Dmp::OPT_REMOVE_PRAGMAS => bool (default: 0)
#
#If set to 1, then pragmas at the start of coderef dump will be removed. Coderef
#dump is produced by L<B::Deparse> and is of the form like:
#
# sub { use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; $a <=> $b }
#
#If you want to dump short coderefs, the pragmas might be distracting. You can
#turn turn on this option which will make the above dump become:
#
# sub { $a <=> $b }
#
#Note that without the pragmas, the dump might be incorrect.
#
#=head2 $Data::Dmp::OPT_DEPARSE => bool (default: 1)
#
#Can be set to 0 to skip deparsing code. Coderefs will be dumped as
#C<sub{"DUMMY"}> instead, like in Data::Dump.
#
#=head2 $Data::Dmp::OPT_STRINGIFY_NUMBERS => bool (default: 0)
#
#If set to true, will dump numbers as quoted string, e.g. 123 as "123" instead of
#123. This might be helpful if you want to compute the hash of or get a canonical
#representation of data structure.
#
#=head1 BENCHMARKS
#
# [1..10]:
# Rate Data::Dump Data::Dumper Data::Dmp
# Data::Dump 30417+-55/s -- -66.2% -74.0%
# Data::Dumper 89888+-79/s 195.52+-0.6% -- -23.1%
# Data::Dmp 116890+-160/s 284.29+-0.87% 30.04+-0.21% --
#
# [1..100]:
# Rate Data::Dump Data::Dmp Data::Dumper
# Data::Dump 3712.3+-7.9/s -- -73.9% -74.9%
# Data::Dmp 14211.3+-4.9/s 282.82+-0.82% -- -3.8%
# Data::Dumper 14771+-28/s 297.9+-1.1% 3.94+-0.2% --
#
# Some mixed structure:
# Rate Data::Dump Data::Dmp Data::Dumper
# Data::Dump 8764+-16/s -- -67.6% -80.1%
# Data::Dmp 27016+-36/s 208.28+-0.7% -- -38.6%
# Data::Dumper 43995+-13/s 402.02+-0.95% 62.85+-0.22% --
#
#=head1 FUNCTIONS
#
#=head2 dd($data, ...) => $data ...
#
#Exported by default. Like C<Data::Dump>'s C<dd> (a.k.a. C<dump>), print one or
#more data to STDOUT. Unlike C<Data::Dump>'s C<dd>, it I<always> prints and
#return I<the original data> (like L<XXX>), making it convenient to insert into
#expressions. This also removes ambiguity and saves one C<wantarray()> call.
#
#=head2 dmp($data, ...) => $str
#
#Exported by default. Return dump result as string. Unlike C<Data::Dump>'s C<dd>
#(a.k.a. C<dump>), it I<never> prints and only return the data.
#
#=head1 FAQ
#
#=head2 When to use Data::Dmp? How does it compare to other dumper modules?
#
#Data::Dmp might be suitable for you if you want a relatively fast pure-Perl data
#structure dumper to eval-able Perl code. It produces compact, single-line Perl
#code but offers little/no formatting options. Data::Dmp and Data::Dump module
#family usually produce Perl code that is "more eval-able", e.g. it can recreate
#circular structure.
#
#L<Data::Dump> produces visually nicer output (some alignment, use of range
#operator to shorten lists, use of base64 for binary data, etc) but no built-in
#option to produce compact/single-line output. It's more suitable for debugging.
#It's also relatively slow. I usually use its variant, L<Data::Dump::Color>, for
#console debugging.
#
#L<Data::Dumper> is a core module, offers a lot of formatting options (like
#disabling hash key sorting, setting verboseness/indent level, and so on) but you
#usually have to configure it quite a bit before it does exactly like you want
#(that's why there are modules on CPAN that are just wrapping Data::Dumper with
#some configuration, like L<Data::Dumper::Concise> et al). It does not support
#dumping Perl code that can recreate circular structures.
#
#Of course, dumping to eval-able Perl code is slow (not to mention the cost of
#re-loading the code back to in-memory data, via eval-ing) compared to dumping to
#JSON, YAML, Sereal, or other format. So you need to decide first whether this is
#the appropriate route you want to take. (But note that there is also
#L<Data::Dumper::Limited> and L<Data::Undump> which uses a format similar to
#Data::Dumper but lets you load the serialized data without eval-ing them, thus
#achieving the speed comparable to JSON::XS).
#
#=head2 Is the output guaranteed to be single line dump?
#
#No. Some things can still produce multiline dump, e.g. newline in regular
#expression.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Dmp>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Dmp>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Dmp>
#
#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 SEE ALSO
#
#L<Data::Dump> and other variations/derivate works in Data::Dump::*.
#
#L<Data::Dumper> and its variants.
#
#L<Data::Printer>.
#
#L<YAML>, L<JSON>, L<Storable>, L<Sereal>, and other serialization formats.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017 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/ModeMerge.pm ###
#package Data::ModeMerge;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Mo qw(build default);
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT = qw(mode_merge);
#
#sub mode_merge {
# my ($l, $r, $config_vars) = @_;
# my $mm = __PACKAGE__->new(config => $config_vars);
# $mm->merge($l, $r);
#}
#
#has config => (is => "rw");
#
## hash of modename => handler
#has modes => (is => 'rw', default => sub { {} });
#
#has combine_rules => (is => 'rw');
#
## merging process state
#has path => (is => "rw", default => sub { [] });
#has errors => (is => "rw", default => sub { [] });
#has mem => (is => "rw", default => sub { {} }); # for handling circular refs. {key=>{res=>[...], todo=>[sub1, ...]}, ...}
#has cur_mem_key => (is => "rw"); # for handling circular refs. instead of passing around this as argument, we put it here.
#
#sub _in($$) {
# state $load_dmp = do { require Data::Dmp };
# my ($self, $needle, $haystack) = @_;
# return 0 unless defined($needle);
# my $r1 = ref($needle);
# my $f1 = $r1 ? Data::Dmp::dmp($needle) : undef;
# for (@$haystack) {
# my $r2 = ref($_);
# next if $r1 xor $r2;
# return 1 if $r2 && $f1 eq Data::Dmp::dmp($_);
# return 1 if !$r2 && $needle eq $_;
# }
# 0;
#}
#
#sub BUILD {
# require Data::ModeMerge::Config;
#
# my ($self, $args) = @_;
#
# if ($self->config) {
# # some sanity checks
# my $is_hashref = ref($self->config) eq 'HASH';
# die "config must be a hashref or a Data::ModeMerge::Config" unless
# $is_hashref || UNIVERSAL::isa($self->config, "Data::ModeMerge::Config");
# $self->config(Data::ModeMerge::Config->new(%{ $self->config })) if $is_hashref;
# } else {
# $self->config(Data::ModeMerge::Config->new);
# }
#
# for (qw(NORMAL KEEP ADD CONCAT SUBTRACT DELETE)) {
# $self->register_mode($_);
# }
#
# if (!$self->combine_rules) {
# $self->combine_rules({
# # "left + right" => [which mode to use, which mode after merge]
# 'ADD+ADD' => ['ADD' , 'ADD' ],
# #'ADD+CONCAT' => undef,
# 'ADD+DELETE' => ['DELETE' , 'DELETE'],
# #'ADD+KEEP' => undef,
# 'ADD+NORMAL' => ['NORMAL' , 'NORMAL'],
# 'ADD+SUBTRACT' => ['SUBTRACT', 'ADD' ],
#
# #'CONCAT+ADD' => undef,
# 'CONCAT+CONCAT' => ['CONCAT' , 'CONCAT'],
# 'CONCAT+DELETE' => ['DELETE' , 'DELETE'],
# #'CONCAT+KEEP' => undef,
# 'CONCAT+NORMAL' => ['NORMAL' , 'NORMAL'],
# #'CONCAT+SUBTRACT' => undef,
#
# 'DELETE+ADD' => ['NORMAL' , 'ADD' ],
# 'DELETE+CONCAT' => ['NORMAL' , 'CONCAT' ],
# 'DELETE+DELETE' => ['DELETE' , 'DELETE' ],
# 'DELETE+KEEP' => ['NORMAL' , 'KEEP' ],
# 'DELETE+NORMAL' => ['NORMAL' , 'NORMAL' ],
# 'DELETE+SUBTRACT' => ['NORMAL' , 'SUBTRACT'],
#
# 'KEEP+ADD' => ['KEEP', 'KEEP'],
# 'KEEP+CONCAT' => ['KEEP', 'KEEP'],
# 'KEEP+DELETE' => ['KEEP', 'KEEP'],
# 'KEEP+KEEP' => ['KEEP', 'KEEP'],
# 'KEEP+NORMAL' => ['KEEP', 'KEEP'],
# 'KEEP+SUBTRACT' => ['KEEP', 'KEEP'],
#
# 'NORMAL+ADD' => ['ADD' , 'NORMAL'],
# 'NORMAL+CONCAT' => ['CONCAT' , 'NORMAL'],
# 'NORMAL+DELETE' => ['DELETE' , 'NORMAL'],
# 'NORMAL+KEEP' => ['NORMAL' , 'KEEP' ],
# 'NORMAL+NORMAL' => ['NORMAL' , 'NORMAL'],
# 'NORMAL+SUBTRACT' => ['SUBTRACT', 'NORMAL'],
#
# 'SUBTRACT+ADD' => ['SUBTRACT', 'SUBTRACT'],
# #'SUBTRACT+CONCAT' => undef,
# 'SUBTRACT+DELETE' => ['DELETE' , 'DELETE' ],
# #'SUBTRACT+KEEP' => undef,
# 'SUBTRACT+NORMAL' => ['NORMAL' , 'NORMAL' ],
# 'SUBTRACT+SUBTRACT' => ['ADD' , 'SUBTRACT'],
# });
# }
#}
#
#sub push_error {
# my ($self, $errmsg) = @_;
# push @{ $self->errors }, [[@{ $self->path }], $errmsg];
# return;
#}
#
#sub register_mode {
# my ($self, $name0) = @_;
# my $obj;
# if (ref($name0)) {
# my $obj = $name0;
# } elsif ($name0 =~ /^\w+(::\w+)+$/) {
# eval "require $name0; \$obj = $name0->new";
# die "Can't load module $name0: $@" if $@;
# } elsif ($name0 =~ /^\w+$/) {
# my $modname = "Data::ModeMerge::Mode::$name0";
# eval "require $modname; \$obj = $modname->new";
# die "Can't load module $modname: $@" if $@;
# } else {
# die "Invalid mode name $name0";
# }
# my $name = $obj->name;
# die "Mode $name already registered" if $self->modes->{$name};
# $obj->merger($self);
# $self->modes->{$name} = $obj;
#}
#
#sub check_prefix {
# my ($self, $hash_key) = @_;
# die "Hash key not a string" if ref($hash_key);
# my $dis = $self->config->disable_modes;
# if (defined($dis) && ref($dis) ne 'ARRAY') {
# $self->push_error("Invalid config value `disable_modes`: must be an array");
# return;
# }
# for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
# grep { !$dis || !$self->_in($_->name, $dis) }
# values %{ $self->modes }) {
# if ($mh->check_prefix($hash_key)) {
# return $mh->name;
# }
# }
# return;
#}
#
#sub check_prefix_on_hash {
# my ($self, $hash) = @_;
# die "Not a hash" unless ref($hash) eq 'HASH';
# my $res = 0;
# for (keys %$hash) {
# do { $res++; last } if $self->check_prefix($_);
# }
# $res;
#}
#
#sub add_prefix {
# my ($self, $hash_key, $mode) = @_;
# die "Hash key not a string" if ref($hash_key);
# my $dis = $self->config->disable_modes;
# if (defined($dis) && ref($dis) ne 'ARRAY') {
# die "Invalid config value `disable_modes`: must be an array";
# }
# if ($dis && $self->_in($mode, $dis)) {
# $self->push_error("Can't add prefix for currently disabled mode `$mode`");
# return $hash_key;
# }
# my $mh = $self->modes->{$mode} or die "Unknown mode: $mode";
# $mh->add_prefix($hash_key);
#}
#
#sub remove_prefix {
# my ($self, $hash_key) = @_;
# die "Hash key not a string" if ref($hash_key);
# my $dis = $self->config->disable_modes;
# if (defined($dis) && ref($dis) ne 'ARRAY') {
# die "Invalid config value `disable_modes`: must be an array";
# }
# for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
# grep { !$dis || !$self->_in($_->name, $dis) }
# values %{ $self->modes }) {
# if ($mh->check_prefix($hash_key)) {
# my $r = $mh->remove_prefix($hash_key);
# if (wantarray) { return ($r, $mh->name) }
# else { return $r }
# }
# }
# if (wantarray) { return ($hash_key, $self->config->default_mode) }
# else { return $hash_key }
#}
#
#sub remove_prefix_on_hash {
# my ($self, $hash) = @_;
# die "Not a hash" unless ref($hash) eq 'HASH';
# for (keys %$hash) {
# my $old = $_;
# $_ = $self->remove_prefix($_);
# next unless $old ne $_;
# die "Conflict when removing prefix on hash: $old -> $_ but $_ already exists"
# if exists $hash->{$_};
# $hash->{$_} = $hash->{$old};
# delete $hash->{$old};
# }
# $hash;
#}
#
#sub merge {
# my ($self, $l, $r) = @_;
# $self->path([]);
# $self->errors([]);
# $self->mem({});
# $self->cur_mem_key(undef);
# my ($key, $res, $backup) = $self->_merge(undef, $l, $r);
# {
# success => !@{ $self->errors },
# error => (@{ $self->errors } ?
# join(", ",
# map { sprintf("/%s: %s", join("/", @{ $_->[0] }), $_->[1]) }
# @{ $self->errors }) : ''),
# result => $res,
# backup => $backup,
# };
#}
#
## handle circular refs: process todo's
#sub _process_todo {
# my ($self) = @_;
# if ($self->cur_mem_key) {
# for my $mk (keys %{ $self->mem }) {
# my $res = $self->mem->{$mk}{res};
# if (defined($res) && @{ $self->mem->{$mk}{todo} }) {
# #print "DEBUG: processing todo for mem<$mk>\n";
# for (@{ $self->mem->{$mk}{todo} }) {
# $_->(@$res);
# return if @{ $self->errors };
# }
# $self->mem->{$mk}{todo} = [];
# }
# }
# }
#}
#
#sub _merge {
# my ($self, $key, $l, $r, $mode) = @_;
# my $c = $self->config;
# $mode //= $c->default_mode;
#
# my $mh = $self->modes->{$mode};
# die "Can't find handler for mode $mode" unless $mh;
#
# # determine which merge method we will call
# my $rl = ref($l);
# my $rr = ref($r);
# my $tl = $rl eq 'HASH' ? 'HASH' : $rl eq 'ARRAY' ? 'ARRAY' : $rl eq 'CODE' ? 'CODE' : !$rl ? 'SCALAR' : '';
# my $tr = $rr eq 'HASH' ? 'HASH' : $rr eq 'ARRAY' ? 'ARRAY' : $rr eq 'CODE' ? 'CODE' : !$rr ? 'SCALAR' : '';
# if (!$tl) { $self->push_error("Unknown type in left side: $rl"); return }
# if (!$tr) { $self->push_error("Unknown type in right side: $rr"); return }
# if (!$c->allow_create_array && $tl ne 'ARRAY' && $tr eq 'ARRAY') {
# $self->push_error("Not allowed to create array"); return;
# }
# if (!$c->allow_create_hash && $tl ne 'HASH' && $tr eq 'HASH') {
# $self->push_error("Not allowed to create hash"); return;
# }
# if (!$c->allow_destroy_array && $tl eq 'ARRAY' && $tr ne 'ARRAY') {
# $self->push_error("Not allowed to destroy array"); return;
# }
# if (!$c->allow_destroy_hash && $tl eq 'HASH' && $tr ne 'HASH') {
# $self->push_error("Not allowed to destroy hash"); return;
# }
# my $meth = "merge_${tl}_${tr}";
# if (!$mh->can($meth)) { $self->push_error("No merge method found for $tl + $tr (mode $mode)"); return }
#
# #$self->_process_todo;
# # handle circular refs: add to todo if necessary
# my $memkey;
# if ($rl || $rr) {
# $memkey = sprintf "%s%s %s%s %s %s",
# (defined($l) ? ($rl ? 2 : 1) : 0),
# (defined($l) ? "$l" : ''),
# (defined($r) ? ($rr ? 2 : 1) : 0),
# (defined($r) ? "$r" : ''),
# $mode,
# $self->config;
# #print "DEBUG: number of keys in mem = ".scalar(keys %{ $self->mem })."\n";
# #print "DEBUG: mem keys = \n".join("", map { " $_\n" } keys %{ $self->mem }) if keys %{ $self->mem };
# #print "DEBUG: calculating memkey = <$memkey>\n";
# }
# if ($memkey) {
# if (exists $self->mem->{$memkey}) {
# $self->_process_todo;
# if (defined $self->mem->{$memkey}{res}) {
# #print "DEBUG: already calculated, using cached result\n";
# return @{ $self->mem->{$memkey}{res} };
# } else {
# #print "DEBUG: detecting circular\n";
# return ($key, undef, undef, 1);
# }
# } else {
# $self->mem->{$memkey} = {res=>undef, todo=>[]};
# $self->cur_mem_key($memkey);
# #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";
# my ($newkey, $res, $backup) = $mh->$meth($key, $l, $r);
# #print "DEBUG: setting res for mem<$memkey>\n";
# $self->mem->{$memkey}{res} = [$newkey, $res, $backup];
# $self->_process_todo;
# return ($newkey, $res, $backup);
# }
# } else {
# $self->_process_todo;
# #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";
# return $mh->$meth($key, $l, $r);
# }
#}
#
## returns 1 if a is included in b (e.g. [user => "jajang"] in included in [user
## => jajang => "quota"], but [user => "paijo"] is not)
#sub _path_is_included {
# my ($self, $p1, $p2) = @_;
# my $res = 1;
# for my $i (0..@$p1-1) {
# do { $res = 0; last } if !defined($p2->[$i]) || $p1->[$i] ne $p2->[$i];
# }
# #print "_path_is_included([".join(", ", @$p1)."], [".join(", ", @$p2)."])? $res\n";
# $res;
#}
#
#1;
## ABSTRACT: Merge two nested data structures, with merging modes and options
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge - Merge two nested data structures, with merging modes and options
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
# my $hash1 = { a=>1, c=>1, d=>{ da =>[1]} };
# my $hash2 = { a=>2, "-c"=>2, d=>{"+da"=>[2]} };
#
#
# # if you want Data::ModeMerge to behave like many other merging
# # modules (e.g. Hash::Merge or Data::Merger), turn off modes
# # (prefix) parsing and options key parsing.
#
# my $mm = Data::ModeMerge->new(config => {parse_prefix=>0, options_key=>undef});
# my $res = $mm->merge($hash1, $hash2);
# die $res->{error} if $res->{error};
# # $res->{result} -> { a=>2, c=>1, "-c"=>2, d=>{da=>[1], "+da"=>[2]} }
#
#
# # otherwise Data::ModeMerge will parse prefix as well as options
# # key
#
# my $res = $mm->merge($hash1, $hash2);
# die $res->{error} if $res->{error};
# # $res->{result} -> { a=>2, c=>-1, d=>{da=>[1,2]} }
#
# $res = $merge({ a =>1, { a2 =>1, ""=>{parse_prefix=>0}},
# {".a"=>2, {".a2"=>2 }});
# # $res->{result} -> { a=>12, {a2=>1, ".a2"=>2} }, parse_prefix is turned off in just the subhash
#
#
# # procedural interface
#
# my $res = mode_merge($hash1, $hash2, {allow_destroy_hash=>0});
#
#=head1 DESCRIPTION
#
#There are already several modules on CPAN to do recursive data
#structure merging, like L<Data::Merger> and
#L<Hash::Merge>. C<Data::ModeMerge> differs in that it offers merging
#"modes" and "options". It provides greater flexibility on what the
#result of a merge between two data should/can be. This module may or
#may not be what you need.
#
#One application of this module is in handling configuration. Often
#there are multiple levels of configuration, e.g. in your typical Unix
#command-line program there are system-wide config file in /etc,
#per-user config file under ~/, and command-line options. It's
#convenient programatically to load each of those in a hash and then
#merge system-wide hash with the per-user hash, and then merge the
#result with the command-line hash to get the a single hash as the
#final configuration. Your program can from there on deal with this
#just one hash instead of three.
#
#In a typical merging process between two hashes (left-side and
#right-side), when there is a conflicting key, then the right-side key
#will override the left-side. This is usually the desired behaviour in
#our said program as the system-wide config is there to provide
#defaults, and the per-user config (and the command-line arguments)
#allow a user to override those defaults.
#
#But suppose that the user wants to I<unset> a certain configuration
#setting that is defined by the system-wide config? She can't do that
#unless she edits the system-wide config (in which she might need admin
#rights), or the program allows the user to disregard the system-wide
#config. The latter is usually what's implemented by many Unix
#programs, e.g. the C<-noconfig> command-line option in C<mplayer>. But
#this has two drawbacks: a slightly added complexity in the program
#(need to provide a special, extra comand-line option) and the user
#loses all the default settings in the system-wide config. What she
#needed in the first place was to just unset I<a single setting> (a
#single key-value pair of the hash).
#
#L<Data::ModeMerge> comes to the rescue. It provides a so-called
#C<DELETE mode>.
#
# mode_merge({foo=>1, bar=>2}, {"!foo"=>undef, bar=>3, baz=>1});
#
#will result ini:
#
# {bar=>3, baz=>1}
#
#The C<!> prefix tells Data::ModeMerge to do a DELETE mode merging. So
#the final result will lack the C<foo> key.
#
#On the other hand, what if the system admin wants to I<protect> a
#certain configuration setting from being overriden by the user or the
#command-line? This is useful in a hosting or other retrictive
#environment where we want to limit users' freedom to some levels. This
#is possible via the KEEP mode merging.
#
# mode_merge({"^bar"=>2, "^baz"=>1}, {bar=>3, "!baz"=>0, qux=>7});
#
#will result in:
#
# {"^bar"=>2, "^baz"=>1, qux=>7}
#
#effectively protecting C<bar> and C<baz> from being
#overriden/deleted/etc.
#
#Aside from the two mentioned modes, there are also a few others
#available by default: ADD (prefix C<+>), CONCAT (prefix C<.>),
#SUBTRACT (prefix C<->), as well as the plain ol' NORMAL/override
#(optional prefix C<*>).
#
#You can add other modes by writing a mode handler module.
#
#You can change the default prefixes for each mode if you want. You can
#disable each mode individually.
#
#You can default to always using a certain mode, like the NORMAL mode,
#and ignore all the prefixes, in which case Data::ModeMerge will behave
#like most other merge modules.
#
#There are a few other options like whether or not the right side is
#allowed a "change the structure" of the left side (e.g. replacing a
#scalar with an array/hash, destroying an existing array/hash with
#scalar), maximum length of scalar/array/hash, etc.
#
#You can change default mode, prefixes, disable/enable modes, etc on a
#per-hash basis using the so-called B<options key>. See the B<OPTIONS
#KEY> section for more details.
#
#This module can handle (though not all possible cases)
#circular/recursive references.
#
#=for Pod::Coverage ^(BUILD)$
#
#=head1 MERGING PREFIXES AND YOUR DATA
#
#Merging with this module means you need to be careful when your hash
#keys might contain one of the mode prefixes characters by accident,
#because it will trigger the wrong merge mode and moreover the prefix
#characters will be B<stripped> from the final result (unless you
#configure the module not to do so).
#
#A rather common case is when you have regexes in your hash
#keys. Regexes often begins with C<^>, which coincidentally is a prefix
#for the KEEP mode. Or perhaps you have dot filenames as hash keys,
#where it clashes with the CONCAT mode. Or perhaps shell wildcards,
#where C<*> is also used as the prefix for NORMAL mode.
#
#To avoid clashes, you can either:
#
#=over 4
#
#=item * exclude the keys using
#C<exclude_merge>/C<include_merge>/C<exclude_parse>/C<include_parse>
#config settings
#
#=item * turn off some modes which you don't want via the
#C<disable_modes> config
#
#=item * change the prefix for that mode so that it doesn't clash with
#your data via the C<set_prefix> config
#
#=item * disable prefix parsing altogether via setting C<parse_prefix>
#config to 0
#
#=back
#
#You can do this via the configuration, or on a per-hash basis, using
#the options key.
#
#See L<Data::ModeMerge::Config> for more details on configuration.
#
#=head1 OPTIONS KEY
#
#Aside from merging mode prefixes, you also need to watch out if your
#hash contains a "" (empty string) key, because by default this is the
#key used for options key.
#
#Options key are used to specify configuration on a per-hash basis.
#
#If your hash keys might contain "" keys which are not meant to be an
#options key, you can either:
#
#=over 4
#
#=item * change the name of the key for options key, via setting
#C<options_key> config to another string.
#
#=item * turn off options key mechanism,
#by setting C<options_key> config to undef.
#
#=back
#
#See L<Data::ModeMerge::Config> for more details about options key.
#
#=head1 MERGING MODES
#
#=head2 NORMAL (optional '*' prefix on left/right side)
#
# mode_merge({ a =>11, b=>12}, { b =>22, c=>23}); # {a=>11, b=>22, c=>23}
# mode_merge({"*a"=>11, b=>12}, {"*b"=>22, c=>23}); # {a=>11, b=>22, c=>23}
#
#=head2 ADD ('+' prefix on the right side)
#
# mode_merge({i=>3}, {"+i"=>4, "+j"=>1}); # {i=>7, j=>1}
# mode_merge({a=>[1]}, {"+a"=>[2, 3]}); # {a=>[1, 2, 3]}
#
#Additive merge on hashes will be treated like a normal merge.
#
#=head2 CONCAT ('.' prefix on the right side)
#
# mode_merge({i=>3}, {".i"=>4, ".j"=>1}); # {i=>34, j=>1}
#
#Concative merge on arrays will be treated like additive merge.
#
#=head2 SUBTRACT ('-' prefix on the right side)
#
# mode_merge({i=>3}, {"-i"=>4}); # {i=>-1}
# mode_merge({a=>["a","b","c"]}, {"-a"=>["b"]}); # {a=>["a","c"]}
#
#Subtractive merge on hashes behaves like a normal merge, except that
#each key on the right-side hash without any prefix will be assumed to
#have a DELETE prefix, i.e.:
#
# mode_merge({h=>{a=>1, b=>1}}, {-h=>{a=>2, "+b"=>2, c=>2}})
#
#is equivalent to:
#
# mode_merge({h=>{a=>1, b=>1}}, {h=>{"!a"=>2, "+b"=>2, "!c"=>2}})
#
#and will merge to become:
#
# {h=>{b=>3}}
#
#=head2 DELETE ('!' prefix on the right side)
#
# mode_merge({x=>WHATEVER}, {"!x"=>WHATEVER}); # {}
#
#=head2 KEEP ('^' prefix on the left/right side)
#
#If you add '^' prefix on the left side, it will be protected from
#being replaced/deleted/etc.
#
# mode_merge({'^x'=>WHATEVER1}, {"x"=>WHATEVER2}); # {x=>WHATEVER1}
#
#For hashes, KEEP mode means that all keys on the left side will not be
#replaced/modified/deleted, *but* you can still add more keys from the
#right side hash.
#
# mode_merge({a=>1, b=>2, c=>3},
# {a=>4, '^c'=>1, d=>5},
# {default_mode=>'KEEP'});
# # {a=>1, b=>2, c=>3, d=>5}
#
#Multiple prefixes on the right side is allowed, where the merging will
#be done by precedence level (highest first):
#
# mode_merge({a=>[1,2]}, {'-a'=>[1], '+a'=>[10]}); # {a=>[2,10]}
#
#but not on the left side:
#
# mode_merge({a=>1, '^a'=>2}, {a=>3}); # error!
#
#Precedence levels (from highest to lowest):
#
# KEEP
# NORMAL
# SUBTRACT
# CONCAT ADD
# DELETE
#
#=head1 CREATING AND USING YOUR OWN MODE
#
#Let's say you want to add a mode named C<FOO>. It will have the prefix
#'?'.
#
#Create the mode handler class,
#e.g. C<Data::ModeMerge::Mode::FOO>. It's probably best to subclass
#from L<Data::ModeMerge::Mode::Base>. The class must implement name(),
#precedence_level(), default_prefix(), default_prefix_re(), and
#merge_{SCALAR,ARRAY,HASH}_{SCALAR,ARRAY,HASH}(). For more details, see
#the source code of Base.pm and one of the mode handlers
#(e.g. NORMAL.pm).
#
#To use the mode, register it:
#
# my $mm = Data::ModeMerge->new;
# $mm->register_mode('FOO');
#
#This will require C<Data::ModeMerge::Mode::FOO>. After that, define
#the operations against other modes:
#
# # if there's FOO on the left and NORMAL on the right, what mode
# # should the merge be done in (FOO), and what the mode should be
# # after the merge? (NORMAL)
# $mm->combine_rules->{"FOO+NORMAL"} = ["FOO", "NORMAL"];
#
# # we don't define FOO+ADD
#
# $mm->combine_rules->{"FOO+KEEP"} = ["KEEP", "KEEP"];
#
# # and so on
#
#=head1 FUNCTIONS
#
#=head2 mode_merge($l, $r[, $config_vars])
#
#A non-OO wrapper for merge() method. Exported by default. See C<merge>
#method for more details.
#
#=head1 ATTRIBUTES
#
#=head2 config
#
#A hashref for config. See L<Data::ModeMerge::Config>.
#
#=head2 modes
#
#=head2 combine_rules
#
#=head2 path
#
#=head2 errors
#
#=head2 mem
#
#=head2 cur_mem_key
#
#=head1 METHODS
#
#For typical usage, you only need merge().
#
#=head2 push_error($errmsg)
#
#Used by mode handlers to push error when doing merge. End users
#normally should not need this.
#
#=head2 register_mode($name_or_package_or_obj)
#
#Register a mode. Will die if mode with the same name already exists.
#
#=head2 check_prefix($hash_key)
#
#Check whether hash key has prefix for certain mode. Return the name of
#the mode, or undef if no prefix is detected.
#
#=head2 check_prefix_on_hash($hash)
#
#This is like C<check_prefix> but performed on every key of the
#specified hash. Return true if any of the key contain a merge prefix.
#
#=head2 add_prefix($hash_key, $mode)
#
#Return hash key with added prefix with specified mode. Log merge error
#if mode is unknown or is disabled.
#
#=head2 remove_prefix($hash_key)
#
#Return hash key will any prefix removed.
#
#=head2 remove_prefix_on_hash($hash)
#
#This is like C<remove_prefix> but performed on every key of the
#specified hash. Return the same hash but with prefixes removed.
#
#=head2 merge($l, $r)
#
#Merge two nested data structures. Returns the result hash: {
#success=>0|1, error=>'...', result=>..., backup=>... }. The 'error'
#key is set to contain an error message if there is an error. The merge
#result is in the 'result' key. The 'backup' key contains replaced
#elements from the original hash/array.
#
#=head1 FAQ
#
#=head2 What is this module good for? Why would I want to use this module instead of the other hash merge modules?
#
#If you just need to (deeply) merge two hashes, chances are you do not
#need this module. Use, for example, L<Hash::Merge>, which is also
#flexible enough because it allows you to set merging behaviour for
#merging different types (e.g. SCALAR vs ARRAY).
#
#You might need this module if your data is recursive/self-referencing
#(which, last time I checked, is not handled well by Hash::Merge), or
#if you want to be able to merge differently (i.e. apply different
#merging B<modes>) according to different prefixes on the key, or
#through special key. In other words, you specify merging modes from
#inside the hash itself.
#
#I originally wrote Data::ModeMerge this for L<Data::Schema> and
#L<Config::Tree>. I want to reuse the "parent" schema (or
#configuration) in more ways other than just override conflicting
#keys. I also want to be able to allow the parent to protect certain
#keys from being overriden. I found these two features lacking in all
#merging modules that I've evaluated prior to writing Data::ModeMerge.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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 SEE ALSO
#
#L<Data::ModeMerge::Config>
#
#Other merging modules on CPAN: L<Data::Merger> (from Data-Utilities),
#L<Hash::Merge>, L<Hash::Merge::Simple>
#
#L<Data::Schema> and L<Config::Tree> (among others, two modules which
#use Data::ModeMerge)
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2016 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/ModeMerge/Config.pm ###
#package Data::ModeMerge::Config;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use Mo qw(build default);
#
#has recurse_hash => (is => 'rw', default => sub{1});
#has recurse_array => (is => 'rw', default => sub{0});
#has parse_prefix => (is => 'rw', default => sub{1});
#has wanted_path => (is => 'rw');
#has default_mode => (is => 'rw', default => sub{'NORMAL'});
#has disable_modes => (is => 'rw');
#has allow_create_array => (is => 'rw', default => sub{1});
#has allow_create_hash => (is => 'rw', default => sub{1});
#has allow_destroy_array => (is => 'rw', default => sub{1});
#has allow_destroy_hash => (is => 'rw', default => sub{1});
#has exclude_parse => (is => 'rw');
#has exclude_parse_regex => (is => 'rw');
#has include_parse => (is => 'rw');
#has include_parse_regex => (is => 'rw');
#has exclude_merge => (is => 'rw');
#has exclude_merge_regex => (is => 'rw');
#has include_merge => (is => 'rw');
#has include_merge_regex => (is => 'rw');
#has set_prefix => (is => 'rw');
#has readd_prefix => (is => 'rw', default => sub{1});
#has premerge_pair_filter => (is => 'rw');
#has options_key => (is => 'rw', default => sub{''});
#has allow_override => (is => 'rw');
#has disallow_override => (is => 'rw');
#
## list of config settings only available in merger-object's config
## (not in options key)
#sub _config_config {
# state $a = [qw/
# wanted_path
# options_key
# allow_override
# disallow_override
# /];
#}
#
## list of config settings available in options key
#sub _config_ok {
# state $a = [qw/
# recurse_hash
# recurse_array
# parse_prefix
# default_mode
# disable_modes
# allow_create_array
# allow_create_hash
# allow_destroy_array
# allow_destroy_hash
# exclude_parse
# exclude_parse_regex
# include_parse
# include_parse_regex
# exclude_merge
# exclude_merge_regex
# include_merge
# include_merge_regex
# set_prefix
# readd_prefix
# premerge_pair_filter
# /];
#}
#
#1;
## ABSTRACT: Data::ModeMerge configuration
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Config - Data::ModeMerge configuration
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Config (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# # getting configuration
# if ($mm->config->allow_extra_hash_keys) { ... }
#
# # setting configuration
# $mm->config->max_warnings(100);
#
#=head1 DESCRIPTION
#
#Configuration variables for Data::ModeMerge.
#
#=head1 ATTRIBUTES
#
#=head2 recurse_hash => BOOL
#
#Context: config, options key
#
#Default: 1
#
#Whether to recursively merge hash. When 1, each key-value pair between
#2 hashes will be recursively merged. Otherwise, the right-side hash
#will just replace the left-side.
#
#Options key will not be parsed under recurse_hash=0.
#
#Example:
#
# mode_merge({h=>{a=>1}}, {h=>{b=>1}} ); # {h=>{a=>1, b=>1}}
# mode_merge({h=>{a=>1}}, {h=>{b=>1}}, {recurse_hash=>0}); # {h=>{b=>1}}
#
#=head2 recurse_array => BOOL
#
#Context: config, options key
#
#Default: 0
#
#Whether to recursively merge array. When 1, each element is
#recursively merged. Otherwise, the right-side array will just replace
#the left-side.
#
#Example:
#
# mode_merge([1, 1], [4] ); # [4, 1]
# mode_merge([1, 1], [4], {recurse_array=>0}); # [2]
#
#=head2 parse_prefix => BOOL
#
#Context: config, options key
#
#Default: 1
#
#Whether to parse merge prefix in hash keys. If set to 0, merging
#behaviour is similar to most other nested merge modules.
#
# mode_merge({a=>1}, {"+a"=>2} ); # {a=>3}
# mode_merge({a=>1}, {"+a"=>2}, {parse_prefix=>0}); # {a=>1, "+a"=>2}
#
#=head2 wanted_path => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#If set, merging is only done to the specified "branch". Useful to save
#time/storage when merging large hash "trees" while you only want a
#certain branch of the trees (e.g. resolving just a config variable
#from several config hashes).
#
#Example:
#
# mode_merge(
# {
# user => {
# jajang => { quota => 100, admin => 1 },
# paijo => { quota => 50, admin => 0 },
# kuya => { quota => 150, admin => 0 },
# },
# groups => [qw/admin staff/],
# },
# {
# user => {
# jajang => { quota => 1000 },
# }
# }
# );
#
#With wanted_path unset, the result would be:
#
# {
# user => {
# jajang => { quota => 1000, admin => 1 },
# paijo => { quota => 50, admin => 0 },
# kuya => { quota => 150, admin => 0 },
# }
# groups => [qw/admin staff/],
# }
#
#With wanted_path set to ["user", "jajang", "quota"] (in other words,
#you're saying that you'll be disregarding other branches), the result
#would be:
#
# {
# user => {
# jajang => { quota => 1000, admin => undef },
# }
# }
#
#=head2 default_mode => 'NORMAL' | 'ADD' | 'CONCAT' | 'SUBTRACT' | 'DELETE' | 'KEEP' | ...
#
#Context: config, options key
#
#Default: NORMAL
#
#Example:
#
# mode_merge(3, 4 ); # 4
# mode_merge(3, 4, {default_mode => "ADD"}); # 7
#
#=head2 disable_modes => ARRAYREF
#
#Context: config, options key
#
#Default: []
#
#List of modes to ignore the prefixes of.
#
#Example:
#
# mode_merge({add=>1, del=>2, concat=>3},
# {add=>2, "!del"=>0, .concat=>4},
# {disable_modes=>[qw/CONCAT/]});
# # {add=>3, concat=>3, .concat=>4}
#
#See also: C<parse_prefix> which if set to 0 will in effect disable all
#modes except the default mode.
#
#=head2 allow_create_array => BOOL
#
#Context: config, options key
#
#Default: 1
#
#If enabled, then array creation will be allowed (from something
#non-array, like a hash/scalar). Setting to 0 is useful if you want to
#avoid the merge to "change the structure" of the left side.
#
#Example:
#
# mode_merge(1, [1,2] ); # success, result=[1,2]
# mode_merge(1, [1,2], {allow_create_array=>0}); # failed, can't create array
#
#=head2 allow_create_hash => BOOL
#
#Context: config, options key
#
#Default: 1
#
#If enabled, then hash creation will be allowed (from something
#non-hash, like array/scalar). Setting to 0 is useful if you want to
#avoid the merge to "change the structure" of the left side.
#
#Example:
#
# mode_merge(1, {a=>1} ); # success, result={a=>1}
# mode_merge(1, {a=>1}, {allow_create_hash=>0}); # failed, can't create hash
#
#=head2 allow_destroy_array => BOOL
#
#Context: config, options key
#
#Default: 1
#
#If enabled, then replacing array on the left side with non-array
#(e.g. hash/scalar) on the right side is allowed. Setting to 0 is
#useful if you want to avoid the merge to "change the structure" of the
#left side.
#
#Example:
#
# mode_merge([1,2], {} ); # success, result={}
# mode_merge([1,2], {}, {allow_destroy_array=>0}); # failed, can't destroy array
#
#=head2 allow_destroy_hash => BOOL
#
#Context: config, options key
#
#Default: 1
#
#If enabled, then replacing hash on the left side with non-hash
#(e.g. array/scalar) on the right side is allowed. Setting to 0 is
#useful if you want to avoid the merge to "change the structure" of the
#left side.
#
#Example:
#
# mode_merge({a=>1}, [] ); # success, result=[]
# mode_merge({a=>1}, [], {allow_destroy_hash=>0}); # failed, can't destroy hash
#
#=head2 exclude_parse => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#The list of hash keys that should not be parsed for prefix and merged
#as-is using the default mode.
#
#If C<include_parse> is also mentioned then only keys in
#C<include_parse> and not in C<exclude_parse> will be parsed for
#prefix.
#
#Example:
#
# mode_merge({a=>1, b=>2}, {"+a"=>3, "+b"=>4}, {exclude_parse=>["+b"]}); # {a=>4, b=>2, "+b"=>4}
#
#=head2 exclude_parse_regex => REGEX
#
#Context: config, options key
#
#Default: undef
#
#Just like C<exclude_parse> but using regex instead of list.
#
#=head2 include_parse => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#If specified, then only hash keys listed by this setting will be
#parsed for prefix. The rest of the keys will not be parsed and merged
#as-is using the default mode.
#
#If C<exclude_parse> is also mentioned then only keys in
#C<include_parse> and not in C<exclude_parse> will be parsed for
#prefix.
#
#Example:
#
# mode_merge({a=>1, b=>2, c=>3}, {"+a"=>4, "+b"=>5, "+c"=>6},
# {include_parse=>["+a"]}); # {a=>1, "+a"=>4, b=>7, c=>3, "+c"=>6}
#
#=head2 include_parse_regex => REGEX
#
#Context: config, options key
#
#Default: undef
#
#Just like C<include_parse> but using regex instead of list.
#
#=head2 exclude_merge => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#The list of hash keys on the left side that should not be merged and
#instead copied directly to the result. All merging keys on the right
#side will be ignored.
#
#If C<include_merge> is also mentioned then only keys in
#C<include_merge> and not in C<exclude_merge> will be merged.
#
#Example:
#
# mode_merge({a=>1}, {"+a"=>20, "-a"=>30}, {exclude_merge=>["a"]}); # {a=>1}
#
#=head2 exclude_merge_regex => REGEX
#
#Context: config, options key
#
#Default: undef
#
#Just like C<exclude_merge> but using regex instead of list.
#
#=head2 include_merge => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#If specified, then only hash keys listed by this setting will be
#merged.
#
#If C<exclude_merge> is also mentioned then only keys in
#C<include_merge> and not in C<exclude_merge> will be merged.
#
#Example:
#
# mode_merge({a=>1, b=>2, c=>3}, {"+a"=>40, "+b"=>50, "+c"=>60, "!c"=>70},
# {include_merge=>["a"]}); # {a=>41, b=>2, c=>3}
#
#=head2 include_merge_regex => ARRAYREF
#
#Context: config, options key
#
#Default: undef
#
#Just like C<include_merge> but using regex instead of list.
#
#=head2 set_prefix => HASHREF
#
#Context: config, options key
#
#Default: undef
#
#Temporarily change the prefix character for each mode. Value is
#hashref where each hash key is mode and the value is a new prefix
#string.
#
# mode_merge({a=>1, c=>2}, {'+a'=>10, '.c'=>20}); # {a=>11, c=>220}
# mode_merge({a=>1, c=>2}, {'+a'=>10, '.c'=>20}, {set_prefix=>{ADD=>'.', CONCAT=>'+'}}); # {a=>110, c=>22}
#
#=head2 readd_prefix => BOOL
#
#Context: config, options key
#
#Default: 1
#
#When merging two hashes, the prefixes are first stripped before
#merging. After merging is done, the prefixes by default will be
#re-added. This is done so that modes which are "sticky" (like KEEP)
#can propagate their mode). Setting C<readd_prefix> to 0 will prevent
#their stickiness.
#
# mode_merge({"^a"=>1}, {a=>2}); # {"^a"=>1}
# mode_merge({"^a"=>1}, {a=>2}, {readd_prefix=>0}); # { "a"=>1}
#
#=head2 premerge_pair_filter => CODEREF
#
#Context: config, options key
#
#Default: undef
#
#Pass the key and value of each hash pair to a subroutine before
#merging (and before the keys are stripped for mode prefixes). Will
#push error if there is conflicting key in the hash.
#
#The subroutine should return a list of new key(s) and value(s). If key
#is undef then it means the pair should be discarded. This way, the
#filter is able to add or remove pairs from the hash.
#
# mode_merge({a=>1}, {"+amok"=>2},
# {premerge_pair_filter=>sub{ uc(substr($_[0],0,2)), $_[1]*2 }});
# # {"A"=>6}
#
#=head2 options_key => STR
#
#Context: config
#
#Default: '' (empty string)
#
#If defined, then when merging two hashes, this key will be searched
#first on the left-side and right-side hash. The values will then be
#merged and override (many of) the configuration.
#
#Options key is analogous to Apache's C<.htaccess> mechanism, which
#allows setting configuration on a per-directory (per-hash)
#basis. There's even an C<allow_override> config similar to Apache
#directive of the same name.
#
#If you want to disable processing of options key, set this to undef.
#
#Example:
#
# mode_merge({a=>1, {x=>3}},
# {a=>2, {x=>4}},
# {default_mode=>'ADD'}); # {a=>3, {x=>7}}
# mode_merge({a=>1, {x=>3}},
# {a=>2, {x=>4, ''=>{default_mode=>'CONCAT'}}},
# {default_mode=>'ADD'}); # {a=>3, {x=>34}}
#
#On the above example, C<default_mode> is set to ADD. But in the
#{x=>...} subhash, C<default_mode> is changed to CONCAT by the options
#key.
#
#=head2 allow_override => REGEX
#
#Context: config
#
#Default: undef
#
#If defined, then only config names matching regex will be able to be
#set in options key.
#
#If C<disallow_override> is also set, then only config names matching
#C<allow_override> and not matching C<disallow_override> will be able
#to be set in options key.
#
#=head2 disallow_override => REGEX
#
#Context: config
#
#Default: undef
#
#If defined, then config names matching regex will not be able to be
#set in options key.
#
#For example, if you want to restrict "structural changes" in merging
#while still allowing options key, you can set C<allow_create_hash>,
#C<allow_destroy_hash>, C<allow_create_array>, and
#C<allow_destroy_array> all to 0 and C<disallow_override> to
#C<allow_create|allow_destroy> to forbid overriding via options key.
#
#If C<disallow_override> is also set, then only config names matching
#C<allow_override> and not matching C<disallow_override> will be able
#to be set in options key.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/ADD.pm ###
#package Data::ModeMerge::Mode::ADD;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::NORMAL';
#
#sub name { 'ADD' }
#
#sub precedence_level { 3 }
#
#sub default_prefix { '+' }
#
#sub default_prefix_re { qr/^\+/ }
#
#sub merge_SCALAR_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, ( $l // 0 ) + $r);
#}
#
#sub merge_SCALAR_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add scalar and array");
# return;
#}
#
#sub merge_SCALAR_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add scalar and hash");
# return;
#}
#
#sub merge_ARRAY_SCALAR {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add array and scalar");
# return;
#}
#
#sub merge_ARRAY_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, [ @$l, @$r ]);
#}
#
#sub merge_ARRAY_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add array and hash");
# return;
#}
#
#sub merge_HASH_SCALAR {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add hash and scalar");
# return;
#}
#
#sub merge_HASH_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't add hash and array");
# return;
#}
#
#1;
## ABSTRACT: Handler for Data::ModeMerge ADD merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::ADD - Handler for Data::ModeMerge ADD merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::ADD (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle ADD merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/Base.pm ###
#package Data::ModeMerge::Mode::Base;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#
##use Data::Dmp;
#
##use Log::Any '$log';
#use Mo qw(build default);
#
##use Data::Clone qw/clone/;
#
#has merger => (is => 'rw');
#has prefix => (is => 'rw');
#has prefix_re => (is => 'rw');
#has check_prefix_sub => (is => 'rw');
#has add_prefix_sub => (is => 'rw');
#has remove_prefix_sub => (is => 'rw');
#
#sub name {
# die "Subclass must provide name()";
#}
#
#sub precedence_level {
# die "Subclass must provide precedence_level()";
#}
#
#sub default_prefix {
# die "Subclass must provide default_prefix()";
#}
#
#sub default_prefix_re {
# die "Subclass must provide default_prefix_re()";
#}
#
#sub BUILD {
# my ($self) = @_;
# $self->prefix($self->default_prefix);
# $self->prefix_re($self->default_prefix_re);
#}
#
#sub check_prefix {
# my ($self, $hash_key) = @_;
# if ($self->check_prefix_sub) {
# $self->check_prefix_sub->($hash_key);
# } else {
# $hash_key =~ $self->prefix_re;
# }
#}
#
#sub add_prefix {
# my ($self, $hash_key) = @_;
# if ($self->add_prefix_sub) {
# $self->add_prefix_sub->($hash_key);
# } else {
# $self->prefix . $hash_key;
# }
#}
#
#sub remove_prefix {
# my ($self, $hash_key) = @_;
# if ($self->remove_prefix_sub) {
# $self->remove_prefix_sub->($hash_key);
# } else {
# my $re = $self->prefix_re;
# $hash_key =~ s/$re//;
# $hash_key;
# }
#}
#
#sub merge_ARRAY_ARRAY {
# my ($self, $key, $l, $r) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
# return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_array;
# return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);
#
# my @res;
# my @backup;
# my $la = @$l;
# my $lb = @$r;
# push @{ $mm->path }, -1;
# for my $i (0..($la > $lb ? $la : $lb)-1) {
# #print "DEBUG: merge_A_A: #$i: a->[$i]=".Data::Dumper->new([$l->[$i]])->Indent(0)->Terse(1)->Dump.", b->[$i]=".Data::Dumper->new([$r->[$i]])->Indent(0)->Terse(1)->Dump."\n";
# $mm->path->[-1] = $i;
# if ($i < $la && $i < $lb) {
# push @backup, $l->[$i];
# my ($subnewkey, $subres, $subbackup, $is_circular) = $mm->_merge($i, $l->[$i], $r->[$i], $c->default_mode);
# last if @{ $mm->errors };
# if ($is_circular) {
# push @res, undef;
# #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";
# push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {
# my ($subnewkey, $subres, $subbackup) = @_;
# #print "DEBUG: Entering todo subroutine (i=$i)\n";
# $res[$i] = $subres;
# }
# } else {
# push @res, $subres;# if defined($newkey); = we allow DELETE on array?
# }
# } elsif ($i < $la) {
# push @res, $l->[$i];
# } else {
# push @res, $r->[$i];
# }
# }
# pop @{ $mm->path };
# ($key, \@res, \@backup);
#}
#
#sub _prefilter_hash {
# my ($self, $h, $desc, $sub) = @_;
# my $mm = $self->merger;
#
# if (ref($sub) ne 'CODE') {
# $mm->push_error("$desc failed: filter must be a coderef");
# return;
# }
#
# my $res = {};
# for (keys %$h) {
# my @r = $sub->($_, $h->{$_});
# while (my ($k, $v) = splice @r, 0, 2) {
# next unless defined $k;
# if (exists $res->{$k}) {
# $mm->push_error("$desc failed; key conflict: ".
# "$_ -> $k, but key $k already exists");
# return;
# }
# $res->{$k} = $v;
# }
# }
#
# $res;
#}
#
## turn {[prefix]key => val, ...} into { key => [MODE, val], ...}, push
## error if there's conflicting key
#sub _gen_left {
# my ($self, $l, $mode, $esub, $ep, $ip, $epr, $ipr) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
#
# #print "DEBUG: Entering _gen_left(".dmp($l).", $mode, ...)\n";
#
# if ($c->premerge_pair_filter) {
# $l = $self->_prefilter_hash($l, "premerge filter left hash",
# $c->premerge_pair_filter);
# return if @{ $mm->errors };
# }
#
# my $hl = {};
# if ($c->parse_prefix) {
# for (keys %$l) {
# my $do_parse = 1;
# $do_parse = 0 if $do_parse && $ep && $mm->_in($_, $ep);
# $do_parse = 0 if $do_parse && $ip && !$mm->_in($_, $ip);
# $do_parse = 0 if $do_parse && $epr && /$epr/;
# $do_parse = 0 if $do_parse && $ipr && !/$ipr/;
#
# if ($do_parse) {
# my $old = $_;
# my $m2;
# ($_, $m2) = $mm->remove_prefix($_);
# next if $esub && !$esub->($_);
# if ($old ne $_ && exists($l->{$_})) {
# $mm->push_error("Conflict when removing prefix on left-side ".
# "hash key: $old -> $_ but $_ already exists");
# return;
# }
# $hl->{$_} = [$m2, $l->{$old}];
# } else {
# next if $esub && !$esub->($_);
# $hl->{$_} = [$mode, $l->{$_}];
# }
# }
# } else {
# for (keys %$l) {
# next if $esub && !$esub->($_);
# $hl->{$_} = [$mode, $l->{$_}];
# }
# }
#
# #print "DEBUG: Leaving _gen_left, result = ".dmp($hl)."\n";
# $hl;
#}
#
## turn {[prefix]key => val, ...} into { key => {MODE=>val, ...}, ...},
## push error if there's conflicting key+MODE
#sub _gen_right {
# my ($self, $r, $mode, $esub, $ep, $ip, $epr, $ipr) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
#
# #print "DEBUG: Entering _gen_right(".dmp($r).", $mode, ...)\n";
#
# if ($c->premerge_pair_filter) {
# $r = $self->_prefilter_hash($r, "premerge filter right hash",
# $c->premerge_pair_filter);
# return if @{ $mm->errors };
# }
#
# my $hr = {};
# if ($c->parse_prefix) {
# for (keys %$r) {
# my $do_parse = 1;
# $do_parse = 0 if $do_parse && $ep && $mm->_in($_, $ep);
# $do_parse = 0 if $do_parse && $ip && !$mm->_in($_, $ip);
# $do_parse = 0 if $do_parse && $epr && /$epr/;
# $do_parse = 0 if $do_parse && $ipr && !/$ipr/;
#
# if ($do_parse) {
# my $old = $_;
# my $m2;
# ($_, $m2) = $mm->remove_prefix($_);
# next if $esub && !$esub->($_);
# if (exists $hr->{$_}{$m2}) {
# $mm->push_error("Conflict when removing prefix on right-side ".
# "hash key: $old($m2) -> $_ ($m2) but $_ ($m2) ".
# "already exists");
# return;
# }
# $hr->{$_}{$m2} = $r->{$old};
# } else {
# next if $esub && !$esub->($_);
# $hr->{$_} = {$mode => $r->{$_}};
# }
# }
# } else {
# for (keys %$r) {
# next if $esub && !$esub->($_);
# $hr->{$_} = {$mode => $r->{$_}}
# }
# }
# #print "DEBUG: Leaving _gen_right, result = ".dmp($hr)."\n";
# $hr;
#}
#
## merge two hashes which have been prepared by _gen_left and
## _gen_right, will result in { key => [final_mode, val], ... }
#sub _merge_gen {
# my ($self, $hl, $hr, $mode, $em, $im, $emr, $imr) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
#
# #print "DEBUG: Entering _merge_gen(".dmp($hl).", ".dmp($hr).", $mode, ...)\n";
#
# my $res = {};
# my $backup = {};
#
# my %k = map {$_=>1} keys(%$hl), keys(%$hr);
# push @{ $mm->path }, "";
# K:
# for my $k (keys %k) {
# my @o;
# $mm->path->[-1] = $k;
# my $do_merge = 1;
# $do_merge = 0 if $do_merge && $em && $mm->_in($k, $em);
# $do_merge = 0 if $do_merge && $im && !$mm->_in($k, $im);
# $do_merge = 0 if $do_merge && $emr && $k =~ /$emr/;
# $do_merge = 0 if $do_merge && $imr && $k !~ /$imr/;
#
# if (!$do_merge) {
# $res->{$k} = $hl->{$k} if $hl->{$k};
# next K;
# }
#
# $backup->{$k} = $hl->{$k}[1] if $hl->{$k} && $hr->{$k};
# if ($hl->{$k}) {
# push @o, $hl->{$k};
# }
# if ($hr->{$k}) {
# my %m = map {$_=>$mm->modes->{$_}->precedence_level} keys %{ $hr->{$k} };
# #print "DEBUG: \\%m=".Data::Dumper->new([\%m])->Indent(0)->Terse(1)->Dump."\n";
# push @o, map { [$_, $hr->{$k}{$_}] } sort { $m{$b} <=> $m{$a} } keys %m;
# }
# my $final_mode;
# my $is_circular;
# my $v;
# #print "DEBUG: k=$k, o=".Data::Dumper->new([\@o])->Indent(0)->Terse(1)->Dump."\n";
# for my $i (0..$#o) {
# if ($i == 0) {
# my $mh = $mm->modes->{$o[$i][0]};
# if (@o == 1 &&
# (($hl->{$k} && $mh->can("merge_left_only")) ||
# ($hr->{$k} && $mh->can("merge_right_only")))) {
# # there's only left-side or right-side
# my $meth = $hl->{$k} ? "merge_left_only" : "merge_right_only";
# my ($subnewkey, $v, $subbackup, $is_circular, $newmode) = $mh->$meth($k, $o[$i][1]); # XXX handle circular?
# next K unless defined($subnewkey);
# $final_mode = $newmode;
# $v = $res;
# } else {
# $final_mode = $o[$i][0];
# $v = $o[$i][1];
# }
# } else {
# my $m = $mm->combine_rules->{"$final_mode+$o[$i][0]"}
# or do {
# $mm->push_error("Can't merge $final_mode + $o[$i][0]");
# return;
# };
# #print "DEBUG: merge $final_mode+$o[$i][0] = $m->[0], $m->[1]\n";
# my ($subnewkey, $subbackup);
# ($subnewkey, $v, $subbackup, $is_circular) = $mm->_merge($k, $v, $o[$i][1], $m->[0]);
# return if @{ $mm->errors };
# if ($is_circular) {
# if ($i < $#o) {
# $mm->push_error("Can't handle circular at $i of $#o merges (mode $m->[0]): not the last merge");
# return;
# }
# #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";
# push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {
# my ($subnewkey, $subres, $subbackup) = @_;
# #print "DEBUG: Entering todo subroutine (k=$k)\n";
# my $final_mode = $m->[1];
# #XXX return unless defined($subnewkey);
# $res->{$k} = [$m->[1], $subres];
# if ($c->readd_prefix) {
# # XXX if there is a conflict error in
# # _readd_prefix, how to adjust path?
# $self->_readd_prefix($res, $k, $c->default_mode);
# } else {
# $res->{$k} = $res->{$k}[1];
# }
# };
# delete $res->{$k};
# }
# next K unless defined $subnewkey;
# $final_mode = $m->[1];
# }
# }
# $res->{$k} = [$final_mode, $v] unless $is_circular;
# }
# pop @{ $mm->path };
# #print "DEBUG: Leaving _merge_gen, res = ".dmp($res)."\n";
# ($res, $backup);
#}
#
## hh is {key=>[MODE, val], ...} which is the format returned by _merge_gen
#sub _readd_prefix {
# my ($self, $hh, $k, $defmode) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
#
# my $m = $hh->{$k}[0];
# if ($m eq $defmode) {
# $hh->{$k} = $hh->{$k}[1];
# } else {
# my $kp = $mm->modes->{$m}->add_prefix($k);
# if (exists $hh->{$kp}) {
# $mm->push_error("BUG: conflict when re-adding prefix after merge: $kp");
# return;
# }
# $hh->{$kp} = $hh->{$k}[1];
# delete $hh->{$k};
# }
#}
#
#sub merge_HASH_HASH {
# my ($self, $key, $l, $r, $mode) = @_;
# my $mm = $self->merger;
# my $c = $mm->config;
# $mode //= $c->default_mode;
# #print "DEBUG: entering merge_H_H(".dmp($l).", ".dmp($r).", $mode), config=($c)=",dmp($c),"\n";
# #$log->trace("using config($c)");
#
# return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_hash;
# return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);
#
# # STEP 1. MERGE LEFT & RIGHT OPTIONS KEY
# my $config_replaced;
# my $orig_c = $c;
# my $ok = $c->options_key;
# {
# last unless defined $ok;
#
# my $okl = $self->_gen_left ($l, $mode, sub {$_[0] eq $ok});
# return if @{ $mm->errors };
#
# my $okr = $self->_gen_right($r, $mode, sub {$_[0] eq $ok});
# return if @{ $mm->errors };
#
# push @{ $mm->path }, $ok;
# my ($res, $backup);
# {
# local $c->{readd_prefix} = 0;
# ($res, $backup) = $self->_merge_gen($okl, $okr, $mode);
# }
# pop @{ $mm->path };
# return if @{ $mm->errors };
#
# #print "DEBUG: merge options key (".dmp($okl).", ".dmp($okr).") = ".dmp($res)."\n";
#
# $res = $res->{$ok} ? $res->{$ok}[1] : undef;
# if (defined($res) && ref($res) ne 'HASH') {
# $mm->push_error("Invalid options key after merge: value must be hash");
# return;
# }
# last unless keys %$res;
# #$log->tracef("cloning config ...");
# # Data::Clone by default does *not* deep-copy object
# #my $c2 = clone($c);
# my $c2 = bless({ %$c }, ref($c));
#
# for (keys %$res) {
# if ($c->allow_override) {
# my $re = $c->allow_override;
# if (!/$re/) {
# $mm->push_error("Configuration in options key `$_` not allowed by allow_override $re");
# return;
# }
# }
# if ($c->disallow_override) {
# my $re = $c->disallow_override;
# if (/$re/) {
# $mm->push_error("Configuration in options key `$_` not allowed by disallow_override $re");
# return;
# }
# }
# if ($mm->_in($_, $c->_config_config)) {
# $mm->push_error("Configuration not allowed in options key: $_");
# return;
# }
# if ($_ ne $ok && !$mm->_in($_, $c->_config_ok)) {
# $mm->push_error("Unknown configuration in options key: $_");
# return;
# }
# $c2->$_($res->{$_}) unless $_ eq $ok;
# }
# $mm->config($c2);
# $config_replaced++;
# $c = $c2;
# #$log->trace("config now changed to $c2");
# }
#
# my $sp = $c->set_prefix;
# my $saved_prefixes;
# if (defined($sp)) {
# if (ref($sp) ne 'HASH') {
# $mm->push_error("Invalid config value `set_prefix`: must be a hash");
# return;
# }
# $saved_prefixes = {};
# for my $mh (values %{ $mm->modes }) {
# my $n = $mh->name;
# if ($sp->{$n}) {
# $saved_prefixes->{$n} = {
# prefix => $mh->prefix,
# prefix_re => $mh->prefix_re,
# check_prefix_sub => $mh->check_prefix_sub,
# add_prefix_sub => $mh->add_prefix_sub,
# remove_prefix_sub => $mh->remove_prefix_sub,
# };
# $mh->prefix($sp->{$n});
# my $re = quotemeta($sp->{$n});
# $mh->prefix_re(qr/^$re/);
# $mh->check_prefix_sub(undef);
# $mh->add_prefix_sub(undef);
# $mh->remove_prefix_sub(undef);
# }
# }
# }
#
# my $ep = $c->exclude_parse;
# my $ip = $c->include_parse;
# if (defined($ep) && ref($ep) ne 'ARRAY') {
# $mm->push_error("Invalid config value `exclude_parse`: must be an array");
# return;
# }
# if (defined($ip) && ref($ip) ne 'ARRAY') {
# $mm->push_error("Invalid config value `include_parse`: must be an array");
# return;
# }
#
# my $epr = $c->exclude_parse_regex;
# my $ipr = $c->include_parse_regex;
# if (defined($epr)) {
# eval { $epr = qr/$epr/ };
# if ($@) {
# $mm->push_error("Invalid config value `exclude_parse_regex`: invalid regex: $@");
# return;
# }
# }
# if (defined($ipr)) {
# eval { $ipr = qr/$ipr/ };
# if ($@) {
# $mm->push_error("Invalid config value `include_parse_regex`: invalid regex: $@");
# return;
# }
# }
#
# # STEP 2. PREPARE LEFT HASH
# my $hl = $self->_gen_left ($l, $mode, sub {defined($ok) ? $_[0] ne $ok : 1}, $ep, $ip, $epr, $ipr);
# return if @{ $mm->errors };
#
# # STEP 3. PREPARE RIGHT HASH
# my $hr = $self->_gen_right($r, $mode, sub {defined($ok) ? $_[0] ne $ok : 1}, $ep, $ip, $epr, $ipr);
# return if @{ $mm->errors };
#
# #print "DEBUG: hl=".Data::Dumper->new([$hl])->Indent(0)->Terse(1)->Dump."\n";
# #print "DEBUG: hr=".Data::Dumper->new([$hr])->Indent(0)->Terse(1)->Dump."\n";
#
# my $em = $c->exclude_merge;
# my $im = $c->include_merge;
# if (defined($em) && ref($em) ne 'ARRAY') {
# $mm->push_error("Invalid config value `exclude_marge`: must be an array");
# return;
# }
# if (defined($im) && ref($im) ne 'ARRAY') {
# $mm->push_error("Invalid config value `include_merge`: must be an array");
# return;
# }
#
# my $emr = $c->exclude_merge_regex;
# my $imr = $c->include_merge_regex;
# if (defined($emr)) {
# eval { $emr = qr/$emr/ };
# if ($@) {
# $mm->push_error("Invalid config value `exclude_merge_regex`: invalid regex: $@");
# return;
# }
# }
# if (defined($imr)) {
# eval { $imr = qr/$imr/ };
# if ($@) {
# $mm->push_error("Invalid config value `include_merge_regex`: invalid regex: $@");
# return;
# }
# }
#
# # STEP 4. MERGE LEFT & RIGHT
# my ($res, $backup) = $self->_merge_gen($hl, $hr, $mode, $em, $im, $emr, $imr);
# return if @{ $mm->errors };
#
# #print "DEBUG: intermediate res(5) = ".Data::Dumper->new([$res])->Indent(0)->Terse(1)->Dump."\n";
#
# # STEP 5. TURN BACK {key=>[MODE=>val]}, ...} INTO {(prefix)key => val, ...}
# if ($c->readd_prefix) {
# for my $k (keys %$res) {
# $self->_readd_prefix($res, $k, $c->default_mode);
# }
# } else {
# $res->{$_} = $res->{$_}[1] for keys %$res;
# }
#
# if ($saved_prefixes) {
# for (keys %$saved_prefixes) {
# my $mh = $mm->modes->{$_};
# my $s = $saved_prefixes->{$_};
# $mh->prefix($s->{prefix});
# $mh->prefix_re($s->{prefix_re});
# $mh->check_prefix_sub($s->{check_prefix_sub});
# $mh->add_prefix_sub($s->{add_prefix_sub});
# $mh->remove_prefix_sub($s->{remove_prefix_sub});
# }
# }
#
# # restore config
# if ($config_replaced) {
# $mm->config($orig_c);
# #print "DEBUG: Restored config, config=", dmp($mm->config), "\n";
# }
#
# #print "DEBUG: backup = ".Data::Dumper->new([$backup])->Indent(0)->Terse(1)->Dump."\n";
# #print "DEBUG: leaving merge_H_H, result = ".dmp($res)."\n";
# ($key, $res, $backup);
#}
#
#1;
## ABSTRACT: Base class for Data::ModeMerge mode handler
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::Base - Base class for Data::ModeMerge mode handler
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::Base (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the base class for mode type handlers.
#
#=for Pod::Coverage ^(BUILD|merge_.+)$
#
#=head1 ATTRIBUTES
#
#=head2 merger
#
#=head2 prefix
#
#=head2 prefix_re
#
#=head2 check_prefix_sub
#
#=head2 add_prefix_sub
#
#=head2 remove_prefix_sub
#
#=head1 METHODS
#
#=head2 name
#
#Return name of mode. Subclass must override this method.
#
#=head2 precedence_level
#
#Return precedence level, which is a number. The greater the number,
#the higher the precedence. Subclass must override this method.
#
#=head2 default_prefix
#
#Return default prefix. Subclass must override this method.
#
#=head2 default_prefix_re
#
#Return default prefix regex. Subclass must override this method.
#
#=head2 check_prefix($hash_key)
#
#Return true if hash key has prefix for this mode.
#
#=head2 add_prefix($hash_key)
#
#Return hash key with added prefix of this mode.
#
#=head2 remove_prefix($hash_key)
#
#Return hash key with prefix of this mode prefix removed.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/CONCAT.pm ###
#package Data::ModeMerge::Mode::CONCAT;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::ADD';
#
#sub name { 'CONCAT' }
#
#sub precedence_level { 2 }
#
#sub default_prefix { '.' }
#
#sub default_prefix_re { qr/^\./ }
#
#sub merge_SCALAR_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, ($l // "") . $r);
#}
#
#1;
## ABSTRACT: Handler for Data::ModeMerge CONCAT merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::CONCAT - Handler for Data::ModeMerge CONCAT merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::CONCAT (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle CONCAT merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/DELETE.pm ###
#package Data::ModeMerge::Mode::DELETE;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::Base';
#
#sub name { 'DELETE' }
#
#sub precedence_level { 1 }
#
#sub default_prefix { '!' }
#
#sub default_prefix_re { qr/^!/ }
#
## merge_left_only and merge_right_only are a bit different: they are
## called with $l only or $r only instead of both, and should return an
## extra argument $mode, i.e. ($key, $result, $backup, $is_circular,
## $mode)
#sub merge_left_only {
# my ($self, $key, $l) = @_;
# return;
#}
#
#sub merge_right_only {
# my ($self, $key, $r) = @_;
# return;
#}
#
#sub merge_SCALAR_SCALAR {
# return;
#}
#
#sub merge_SCALAR_ARRAY {
# return;
#}
#
#sub merge_SCALAR_HASH {
# return;
#}
#
#sub merge_ARRAY_SCALAR {
# return;
#}
#
#sub merge_ARRAY_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->merger->config->allow_destroy_array or
# $self->merger->push_error("Now allowed to destroy array via DELETE mode");
# return;
#}
#
#sub merge_ARRAY_HASH {
# return;
#}
#
#sub merge_HASH_SCALAR {
# return;
#}
#
#sub merge_HASH_ARRAY {
# return;
#}
#
#sub merge_HASH_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->merger->config->allow_destroy_hash or
# $self->merger->push_error("Now allowed to destroy hash via DELETE mode");
# return;
#}
#
#1;
## ABSTRACT: Handler for Data::ModeMerge DELETE merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::DELETE - Handler for Data::ModeMerge DELETE merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::DELETE (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle DELETE merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/KEEP.pm ###
#package Data::ModeMerge::Mode::KEEP;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::Base';
#
#sub name { 'KEEP' }
#
#sub precedence_level { 6 }
#
#sub default_prefix { '^' }
#
#sub default_prefix_re { qr/^\^/ }
#
#sub merge_SCALAR_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_SCALAR_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_SCALAR_HASH {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_ARRAY_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_ARRAY_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->SUPER::merge_ARRAY_ARRAY($key, $l, $r, 'KEEP');
#};
#
#sub merge_ARRAY_HASH {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_HASH_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_HASH_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, $l);
#}
#
#sub merge_HASH_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->SUPER::merge_HASH_HASH($key, $l, $r, 'KEEP');
#};
#
#1;
## ABSTRACT: Handler for Data::ModeMerge KEEP merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::KEEP - Handler for Data::ModeMerge KEEP merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::KEEP (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle KEEP merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/NORMAL.pm ###
#package Data::ModeMerge::Mode::NORMAL;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::Base';
#
#sub name { 'NORMAL' }
#
#sub precedence_level { 5 }
#
#sub default_prefix { '*' }
#
#sub default_prefix_re { qr/^\*/ }
#
#sub merge_SCALAR_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_SCALAR_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_SCALAR_HASH {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_SCALAR_CODE {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_ARRAY_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_ARRAY_HASH {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_ARRAY_CODE {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_HASH_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_HASH_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_HASH_CODE {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_CODE_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_CODE_ARRAY {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_CODE_HASH {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#sub merge_CODE_CODE {
# my ($self, $key, $l, $r) = @_;
# ($key, $r);
#}
#
#1;
## ABSTRACT: Handler for Data::ModeMerge NORMAL merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::NORMAL - Handler for Data::ModeMerge NORMAL merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::NORMAL (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle NORMAL merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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/ModeMerge/Mode/SUBTRACT.pm ###
#package Data::ModeMerge::Mode::SUBTRACT;
#
#our $DATE = '2016-07-22'; # DATE
#our $VERSION = '0.35'; # VERSION
#
#use 5.010;
#use strict;
#use warnings;
#use Mo qw(build default);
#extends 'Data::ModeMerge::Mode::NORMAL';
#
#sub name { 'SUBTRACT' }
#
#sub precedence_level { 4 }
#
#sub default_prefix { '-' }
#
#sub default_prefix_re { qr/^-/ }
#
#sub merge_SCALAR_SCALAR {
# my ($self, $key, $l, $r) = @_;
# ($key, $l - $r);
#}
#
#sub merge_SCALAR_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract scalar and array");
# return;
#}
#
#sub merge_SCALAR_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract scalar and hash");
# return;
#}
#
#sub merge_ARRAY_SCALAR {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract array and scalar");
# return;
#}
#
#sub merge_ARRAY_ARRAY {
# my ($self, $key, $l, $r) = @_;
# my @res;
# my $mm = $self->merger;
# for (@$l) {
# push @res, $_ unless $mm->_in($_, $r);
# }
# ($key, \@res);
#}
#
#sub merge_ARRAY_HASH {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract array and hash");
# return;
#}
#
#sub merge_HASH_SCALAR {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract hash and scalar");
# return;
#}
#
#sub merge_HASH_ARRAY {
# my ($self, $key, $l, $r) = @_;
# $self->merger->push_error("Can't subtract hash and array");
# return;
#}
#
#sub merge_HASH_HASH {
# my ($self, $key, $l, $r) = @_;
# my $mm = $self->merger;
#
# my %res;
# my $r2 = {};
# for (keys %$r) {
# my $k = $mm->check_prefix($_) ? $_ : $mm->add_prefix($_, 'DELETE');
# if ($k ne $_ && exists($r->{$k})) {
# $mm->push_error("Conflict when adding DELETE prefix on right-side hash key $_ ".
# "for SUBTRACT merge: key $k already exists");
# return;
# }
# $r2->{$k} = $r->{$_};
# }
# $mm->_merge($key, $l, $r2, 'NORMAL');
#}
#
#1;
## ABSTRACT: Handler for Data::ModeMerge SUBTRACT merge mode
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::ModeMerge::Mode::SUBTRACT - Handler for Data::ModeMerge SUBTRACT merge mode
#
#=head1 VERSION
#
#This document describes version 0.35 of Data::ModeMerge::Mode::SUBTRACT (from Perl distribution Data-ModeMerge), released on 2016-07-22.
#
#=head1 SYNOPSIS
#
# use Data::ModeMerge;
#
#=head1 DESCRIPTION
#
#This is the class to handle SUBTRACT merge mode.
#
#=for Pod::Coverage ^merge_.*
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
#
#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) 2016 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 = '2018-09-10'; # DATE
#our $VERSION = '0.050'; # 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.050 of Data::Sah::Normalize (from Perl distribution Data-Sah-Normalize), released on 2018-09-10.
#
#=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 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 SEE ALSO
#
#L<Sah>, L<Data::Sah>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2018, 2015, 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
### Data/Sah/Resolve.pm ###
#package Data::Sah::Resolve;
#
#our $DATE = '2017-04-19'; # DATE
#our $VERSION = '0.007'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(resolve_schema);
#
#sub _resolve {
# my ($opts, $type, $clsets, $seen) = @_;
#
# die "Recursive schema definition: ".join(" -> ", @$seen, $type)
# if grep { $type eq $_ } @$seen;
# push @$seen, $type;
#
# (my $typemod_pm = "Data/Sah/Type/$type.pm") =~ s!::!/!g;
# eval { require $typemod_pm; 1 };
# my $err = $@;
# # already a builtin-type, so just return the schema's type name & clause set
# return [$type, $clsets] unless $err;
# die "Can't check whether $type is a builtin Sah type: $err"
# unless $err =~ /\ACan't locate/;
#
# # not a type, try a schema under Sah::Schema
# my $schmod = "Sah::Schema::$type";
# (my $schmod_pm = "$schmod.pm") =~ s!::!/!g;
# eval { require $schmod_pm; 1 };
# die "Not a known built-in Sah type '$type' (can't locate ".
# "Data::Sah::Type::$type) and not a known schema name '$type' ($@)"
# if $@;
# no strict 'refs';
# my $sch2 = ${"$schmod\::schema"};
# die "BUG: Schema module $schmod doesn't contain \$schema" unless $sch2;
# unshift @$clsets, $sch2->[1];
# _resolve($opts, $sch2->[0], $clsets, $seen);
#}
#
#sub resolve_schema {
# my $opts = ref($_[0]) eq 'HASH' ? shift : {};
# my $sch = shift;
#
# unless ($opts->{schema_is_normalized}) {
# require Data::Sah::Normalize;
# $sch = Data::Sah::Normalize::normalize_schema($sch);
# }
# $opts->{merge_clause_sets} //= 1;
#
# my $seen = [];
# my $res = _resolve($opts, $sch->[0], keys(%{$sch->[1]}) ? [$sch->[1]] : [], $seen);
#
# MERGE:
# {
# last unless $opts->{merge_clause_sets};
# last if @{ $res->[1] } < 2;
#
# my @clsets = (shift @{ $res->[1] });
# for my $clset (@{ $res->[1] }) {
# my $has_merge_mode_keys;
# for (keys %$clset) {
# if (/\Amerge\./) {
# $has_merge_mode_keys = 1;
# last;
# }
# }
# if ($has_merge_mode_keys) {
# state $merger = do {
# require Data::ModeMerge;
# my $mm = Data::ModeMerge->new(config => {
# recurse_array => 1,
# });
# $mm->modes->{NORMAL} ->prefix ('merge.normal.');
# $mm->modes->{NORMAL} ->prefix_re(qr/\Amerge\.normal\./);
# $mm->modes->{ADD} ->prefix ('merge.add.');
# $mm->modes->{ADD} ->prefix_re(qr/\Amerge\.add\./);
# $mm->modes->{CONCAT} ->prefix ('merge.concat.');
# $mm->modes->{CONCAT} ->prefix_re(qr/\Amerge\.concat\./);
# $mm->modes->{SUBTRACT}->prefix ('merge.subtract.');
# $mm->modes->{SUBTRACT}->prefix_re(qr/\Amerge\.subtract\./);
# $mm->modes->{DELETE} ->prefix ('merge.delete.');
# $mm->modes->{DELETE} ->prefix_re(qr/\Amerge\.delete\./);
# $mm->modes->{KEEP} ->prefix ('merge.keep.');
# $mm->modes->{KEEP} ->prefix_re(qr/\Amerge\.keep\./);
# $mm;
# };
# my $merge_res = $merger->merge($clsets[-1], $clset);
# unless ($merge_res->{success}) {
# die "Can't merge clause set: $merge_res->{error}";
# }
# $clsets[-1] = $merge_res->{result};
# } else {
# push @clsets, $clset;
# }
# }
#
# $res->[1] = \@clsets;
# }
#
# $res->[2] = $seen if $opts->{return_intermediates};
#
# $res;
#}
#
#1;
## ABSTRACT: Resolve Sah schema
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Sah::Resolve - Resolve Sah schema
#
#=head1 VERSION
#
#This document describes version 0.007 of Data::Sah::Resolve (from Perl distribution Data-Sah-Resolve), released on 2017-04-19.
#
#=head1 SYNOPSIS
#
# use Data::Sah::Resolve qw(resolve_schema);
#
# my $sch = resolve_schema("int");
# # => ["int", []]
#
# my $sch = resolve_schema("posint*");
# # => ["int", [{min=>1}, {req=>1}]
#
# my $sch = resolve_schema([posint => div_by => 3]);
# # => ["int", {min=>1}, {div_by=>3}]
#
# my $sch = resolve_schema(["posint", "merge.delete.min"=>undef, div_by => 3]);
# # => ["int", {div_by=>3}]
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#=head2 resolve_schema([ \%opts, ] $sch) => sch
#
#Sah schemas can be defined in terms of other schemas. The resolving process
#follows the base schema recursively until it finds a builtin type as the base.
#
#This routine performs the following steps:
#
#=over
#
#=item 1. Normalize the schema
#
#Unless C<schema_is_normalized> option is true, in which case schema is assumed
#to be normalized already.
#
#=item 2. Check if the schema's type is a builtin type
#
#Currently this is done by checking if the module of the name C<<
#Data::Sah::Type::<type> >> is loadable. If it is a builtin type then we are
#done.
#
#=item 3. Check if the schema's type is the name of another schema
#
#This is done by checking if C<< Sah::Schema::<name> >> module exists and is
#loadable. If this is the case then we retrieve the base schema from the
#C<$schema> variable in the C<< Sah::Schema::<name> >> package and repeat the
#process while accumulating and/or merging the clause sets.
#
#=item 4. If schema's type is neither, we die.
#
#=back
#
#Returns C<< [base_type, clause_sets] >>. If C<return_intermediates> option is
#true, then the third elements will be the list of intermediate schema names.
#
#Example 1: C<int>.
#
#First we normalize to C<< ["int",{},{}] >>. The type is C<int> and it is a
#builtin type (L<Data::Sah::Type::int> exists) so the final result is C<< ["int",
#[]] >>.
#
#Example 2: C<posint*>.
#
#First we normalize to C<< ["posint",{req=>1},{}] >>. The type is C<posint> and
#it is the name of another schema (L<Sah::Schema::posint>). We retrieve the
#schema which is C<< ["int", {summary=>"Positive integer (1,2,3,...)", min=>1},
#{}] >>. We now try to resolve C<int> and find that it's a builtin type. So the
#final result is: C<< ["int", [ {req=>1}, {summary=>"Positive integer
#(1,2,3,...)", min=>1} ]] >>.
#
#Known options:
#
#=over
#
#=item * schema_is_normalized => bool (default: 0)
#
#When set to true, function will skip normalizing schema and assume input schema
#is normalized.
#
#=item * merge_clause_sets => bool (default: 1)
#
#=item * return_intermediates => bool
#
#=back
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Resolve>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Sah-Resolve>.
#
#=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-Resolve>
#
#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 SEE ALSO
#
#L<Sah>, L<Data::Sah>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017, 2016 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/Util/Type.pm ###
#package Data::Sah::Util::Type;
#
#our $DATE = '2016-12-09'; # DATE
#our $VERSION = '0.46'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(get_type is_type is_simple is_numeric is_collection is_ref);
#
## XXX absorb and use metadata from Data::Sah::Type::*
#our $type_metas = {
# all => {scalar=>0, numeric=>0, ref=>0},
# any => {scalar=>0, numeric=>0, ref=>0},
# array => {scalar=>0, numeric=>0, ref=>1},
# bool => {scalar=>1, numeric=>0, ref=>0},
# buf => {scalar=>1, numeric=>0, ref=>0},
# cistr => {scalar=>1, numeric=>0, ref=>0},
# code => {scalar=>1, numeric=>0, ref=>1},
# float => {scalar=>1, numeric=>1, ref=>0},
# hash => {scalar=>0, numeric=>0, ref=>1},
# int => {scalar=>1, numeric=>1, ref=>0},
# num => {scalar=>1, numeric=>1, ref=>0},
# obj => {scalar=>1, numeric=>0, ref=>1},
# re => {scalar=>1, numeric=>0, ref=>1, simple=>1},
# str => {scalar=>1, numeric=>0, ref=>0},
# undef => {scalar=>1, numeric=>0, ref=>0},
# date => {scalar=>1, numeric=>0, ref=>0},
# duration => {scalar=>1, numeric=>0, ref=>0},
#};
#
#sub get_type {
# my $sch = shift;
#
# if (ref($sch) eq 'ARRAY') {
# $sch = $sch->[0];
# }
#
# if (defined($sch) && !ref($sch)) {
# $sch =~ s/\*\z//;
# return $sch;
# } else {
# return undef;
# }
#}
#
#sub _normalize {
# require Data::Sah::Normalize;
#
# my ($sch, $opts) = @_;
# return $sch if $opts->{schema_is_normalized};
# return Data::Sah::Normalize::normalize_schema($sch);
#}
#
## for any|all to pass a criteria, we assume that all of the schemas in the 'of'
## clause must also pass (and there must not be '!of', 'of&', or that kind of
## thing.
#sub _handle_any_all {
# my ($sch, $opts, $crit) = @_;
# $sch = _normalize($sch, $opts);
# return 0 if $sch->[1]{'of.op'};
# my $of = $sch->[1]{of};
# return 0 unless $of && ref($of) eq 'ARRAY' && @$of;
# for (@$of) {
# return 0 unless $crit->($_);
# }
# 1;
#}
#
#sub is_type {
# my ($sch, $opts) = @_;
# $opts //= {};
#
# my $type = get_type($sch) or return undef;
# my $tmeta = $type_metas->{$type} or return undef;
# $type;
#}
#
#sub is_simple {
# my ($sch, $opts) = @_;
# $opts //= {};
#
# my $type = get_type($sch) or return undef;
# my $tmeta = $type_metas->{$type} or return undef;
# if ($type eq 'any' || $type eq 'all') {
# return _handle_any_all($sch, $opts, sub { is_simple(shift) });
# }
# return $tmeta->{simple} // ($tmeta->{scalar} && !$tmeta->{ref});
#}
#
#sub is_collection {
# my ($sch, $opts) = @_;
# $opts //= {};
#
# my $type = get_type($sch) or return undef;
# my $tmeta = $type_metas->{$type} or return undef;
# if ($type eq 'any' || $type eq 'all') {
# return _handle_any_all($sch, $opts, sub { is_collection(shift) });
# }
# return !$tmeta->{scalar};
#}
#
#sub is_numeric {
# my ($sch, $opts) = @_;
# $opts //= {};
#
# my $type = get_type($sch) or return undef;
# my $tmeta = $type_metas->{$type} or return undef;
# if ($type eq 'any' || $type eq 'all') {
# return _handle_any_all($sch, $opts, sub { is_numeric(shift) });
# }
# return $tmeta->{numeric};
#}
#
#sub is_ref {
# my ($sch, $opts) = @_;
# $opts //= {};
#
# my $type = get_type($sch) or return undef;
# my $tmeta = $type_metas->{$type} or return undef;
# if ($type eq 'any' || $type eq 'all') {
# return _handle_any_all($sch, $opts, sub { is_ref(shift) });
# }
# return $tmeta->{ref};
#}
#
#1;
## ABSTRACT: Utility functions related to types
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Sah::Util::Type - Utility functions related to types
#
#=head1 VERSION
#
#This document describes version 0.46 of Data::Sah::Util::Type (from Perl distribution Data-Sah-Util-Type), released on 2016-12-09.
#
#=head1 SYNOPSIS
#
# use Data::Sah::Util::Type qw(
# get_type
# is_type
# is_simple is_numeric is_collection is_ref
# );
#
# say get_type("int"); # -> int
# say get_type("int*"); # -> int
# say get_type([int => min=>0]); # -> int
# say get_type("foo"); # -> foo (doesn't check type is known)
#
# say is_type("int*"); # -> 1
# say is_type("foo"); # -> 0
#
# say is_simple("int"); # -> 1
# say is_simple("array"); # -> 0
# say is_simple([any => of => ["float", "str"]); # -> 1
# say is_simple("re"); # -> 1
# say is_simple("foo"); # -> 0
#
# say is_collection("array*"); # -> 1
# say is_collection(["hash", of=>"int"]); # -> 1
# say is_collection("str"); # -> 0
# say is_collection("foo"); # -> 0
#
# say is_ref("code*"); # -> 1
# say is_ref("array"); # -> 1
# say is_ref("str"); # -> 0
# say is_ref("foo"); # -> 0
#
# say is_numeric(["int", min=>0]); # -> 1
# say is_numeric("str"); # -> 0
# say is_numeric("foo"); # -> 0
#
#=head1 DESCRIPTION
#
#This module provides some secondary utility functions related to L<Sah> and
#L<Data::Sah>. It is deliberately distributed separately from the Data-Sah main
#distribution to be differentiated from Data::Sah::Util which contains "primary"
#utilities and is distributed with Data-Sah.
#
#Reference table for simple/collection/ref/numeric criteria of builtin types:
#
# +----------+-----------+---------------+--------+------------+
# | type | is_simple | is_collection | is_ref | is_numeric |
# +----------+-----------+---------------+--------+------------+
# | array | | 1 | 1 | |
# | bool | 1 | | | |
# | buf | 1 | | | |
# | cistr | 1 | | | |
# | code | | | 1 | |
# | date | 1 | | | |
# | duration | 1 | | | |
# | float | 1 | | | 1 |
# | hash | | 1 | 1 | |
# | int | 1 | | | 1 |
# | num | 1 | | | 1 |
# | obj | | | 1 | |
# | re | 1 | | 1 | |
# | str | 1 | | | |
# | undef | 1 | | | |
# +----------+-----------+---------------+--------+------------+
#
#=head1 FUNCTIONS
#
#None exported by default, but they are exportable.
#
#=head2 get_type($sch) => STR
#
#Return type name.
#
#=head2 is_type($sch) => STR
#
#Return type name if type in schema is known, or undef.
#
#=head2 is_simple($sch[, \%opts]) => BOOL
#
#Simple means "scalar" or can be represented as a scalar. This is currently used
#to determine if a builtin type can be specified as an argument or option value
#in command-line.
#
#This includes C<re>, C<bool>, as well as C<date> and C<duration>.
#
#If type is C<all>, then for this routine to be true all of the mentioned types
#must be simple. If type is C<any>, then for this routine to be true at least one
#of the mentioned types must be simple.
#
#Options:
#
#=over
#
#=item * schema_is_normalized => BOOL
#
#=back
#
#=head2 is_collection($sch[, \%opts]) => BOOL
#
#Collection means C<array> or C<hash>.
#
#If type is C<all>, then for this routine to be true all of the mentioned types
#must be collection. If type is C<any>, then for this routine to be true at least
#one of the mentioned types must be collection.
#
#=head2 is_ref($sch[, \%opts]) => BOOL
#
#"Ref" means generally a reference in Perl. But C<date> and C<duration> are not
#regarded as "ref". Regular expression on the other hand is regarded as a ref.
#
#If type is C<all>, then for this routine to be true all of the mentioned types
#must be "ref". If type is C<any>, then for this routine to be true at least one
#of the mentioned types must be "ref".
#
#=head2 is_numeric($sch[, \%opts]) => BOOL
#
#Currently, only C<num>, C<int>, and C<float> are numeric.
#
#If type is C<all>, then for this routine to be true all of the mentioned types
#must be numeric. If type is C<any>, then for this routine to be true at least
#one of the mentioned types must be numeric.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah-Util-Type>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Sah-Util-Type>.
#
#=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-Util-Type>
#
#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 SEE ALSO
#
#L<Data::Sah>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2016 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
### Function/Fallback/CoreOrPP.pm ###
#package Function::Fallback::CoreOrPP;
#
#use 5.010001;
#use strict;
#use warnings;
#
#our $VERSION = '0.08'; # VERSION
#
#our $USE_NONCORE_XS_FIRST = 1;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# clone
# clone_list
# 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 clone_list {
# map { clone($_) } @_;
#}
#
#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} );
# } elsif ($r3 eq 'CODE') {
# return sub { goto &$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.08 of Function::Fallback::CoreOrPP (from Perl distribution Function-Fallback-CoreOrPP), released on 2017-01-14.
#
#=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 clone_list(@data) => @data
#
#A shortcut for:
#
# return map {clone($_)} @data
#
#=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 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/sharyanto/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 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 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017 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 = '2019-04-23'; # DATE
#our $VERSION = '0.060'; # 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 =~ /\Ahas([_-].+)/ ) { return ("hasnt$1") }
# elsif ($word =~ /\Ahave([_-].+)/ ) { return ("havent$1") }
# elsif ($word =~ /\Ahasnt([_-].+)/ ) { return ("has$1") }
# elsif ($word =~ /\Ahavent([_-].+)/ ) { return ("have$1") }
#
# elsif ($word =~ /\Acan([_-].+)/ ) { return ("cant$1") }
# elsif ($word =~ /\Acant([_-].+)/ ) { return ("can$1") }
#
# elsif ($word =~ /\Aenabled([_-].+)/ ) { return ("disabled$1") }
# elsif ($word =~ /\Adisabled([_-].+)/) { return ("enabled$1") }
# elsif ($word =~ /\Aenable([_-].+)/ ) { return ("disable$1") }
# elsif ($word =~ /\Adisable([_-].+)/) { return ("enable$1") }
#
# elsif ($word =~ /\Aallowed([_-].+)/ ) { return ("disallowed$1") }
# elsif ($word =~ /\Adisallowed([_-].+)/) { return ("allowed$1") }
# elsif ($word =~ /\Aallow([_-].+)/ ) { return ("disallow$1") }
# elsif ($word =~ /\Adisallow([_-].+)/) { return ("allow$1") }
#
# elsif ($word =~ /\Ainclude([_-].+)/ ) { return ("exclude$1") }
# elsif ($word =~ /\Aexclude([_-].+)/ ) { return ("include$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.060 of Getopt::Long::Negate::EN (from Perl distribution Getopt-Long-Negate-EN), released on 2019-04-23.
#
#=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('has-foo'); # ('hasnt-foo')
# @negs = negations_for_option('hasnt-foo'); # ('has-foo')
# @negs = negations_for_option('have-foo'); # ('havent-foo')
# @negs = negations_for_option('havent-foo'); # ('have-foo')
#
# @negs = negations_for_option('can-foo'); # ('cant-foo')
# @negs = negations_for_option('cant-foo'); # ('can-foo')
#
# @negs = negations_for_option('enabled-foo'); # ('disabled-foo')
# @negs = negations_for_option('disabled-foo');# ('enabled-foo')
# @negs = negations_for_option('enable-foo'); # ('disable-foo')
# @negs = negations_for_option('disable-foo'); # ('enable-foo')
#
# @negs = negations_for_option('allowed-foo'); # ('disallowed-foo')
# @negs = negations_for_option('disallowed-foo'); # ('allowed-foo')
# @negs = negations_for_option('allow-foo'); # ('disallow-foo')
# @negs = negations_for_option('disallow-foo'); # ('allow-foo')
#
# @negs = negations_for_option('include-foo'); # ('exclude-foo')
# @negs = negations_for_option('exclude-foo'); # ('include-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) 2019, 2016, 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 = '2017-08-10'; # DATE
#our $VERSION = '0.890'; # 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
# gen_getopt_long_spec_from_getopt_std_spec
# );
#
#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:
#
#* `is_arg` (if true, then option specification is the special `<>` for argument
# callback)
#* `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;
# return {is_arg=>1, dash_prefix=>'', opts=>[]}
# if $optspec eq '<>';
# $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 <pm: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";
#
# return "argument" if $parse->{is_arg};
#
# 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*',
# pos => 0,
# cmdline_aliases => {f=>{}},
# },
# string => {
# summary => 'String to be checked',
# schema => 'buf*',
# },
# include_noexec => {
# summary => 'Include scripts that do not have +x mode bit set',
# schema => 'bool*',
# default => 1,
# },
# },
# args_rels => {
# 'req_one' => ['filename', 'string'],
# },
#};
#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 %extrameta;
#
# 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>;
# }
# close $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;
# }
#
# # NOTE: the presence of \s* pattern after ^ causes massive slowdown of
# # the regex when we reach many thousands of lines, so we use split()
#
# #if ($str =~ /^\s*(use|require)\s+(Getopt::Long(?:::Complete)?)(\s|;)/m) {
# # $yesno = 1;
# # $extrameta{'func.module'} = $2;
# # last DETECT;
# #}
#
# for (split /^/, $str) {
# if (/^\s*(use|require)\s+(Getopt::Long(?:::Complete|::Less|::EvenLess)?)(\s|;|$)/) {
# $yesno = 1;
# $extrameta{'func.module'} = $2;
# last DETECT;
# }
# }
#
# $reason = "Can't find any statement requiring Getopt::Long(?::Complete|::Less|::EvenLess)? module";
# } # DETECT
#
# [200, "OK", $yesno, {"func.reason"=>$reason, %extrameta}];
#}
#
#$SPEC{gen_getopt_long_spec_from_getopt_std_spec} = {
# v => 1.1,
# summary => 'Generate Getopt::Long spec from Getopt::Std spec',
# args => {
# spec => {
# summary => 'Getopt::Std spec string',
# schema => 'str*',
# req => 1,
# pos => 0,
# },
# is_getopt => {
# summary => 'Whether to assume spec is for getopt() or getopts()',
# description => <<'_',
#
#By default spec is assumed to be for getopts() instead of getopt(). This means
#that for a spec like `abc:`, `a` and `b` don't take argument while `c` does. But
#if `is_getopt` is true, the meaning of `:` is reversed: `a` and `b` take
#arguments while `c` doesn't.
#
#_
# schema => 'bool',
# },
# },
# result_naked => 1,
# result => {
# schema => 'hash*',
# },
#};
#sub gen_getopt_long_spec_from_getopt_std_spec {
# my %args = @_;
#
# my $is_getopt = $args{is_getopt};
# my $spec = {};
#
# while ($args{spec} =~ /(.)(:?)/g) {
# $spec->{$1 . ($is_getopt ? ($2 ? "" : "=s") : ($2 ? "=s" : ""))} =
# sub {};
# }
#
# $spec;
#}
#
#1;
## 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.890 of Getopt::Long::Util (from Perl distribution Getopt-Long-Util), released on 2017-08-10.
#
#=head1 FUNCTIONS
#
#
#=head2 detect_getopt_long_script
#
#Usage:
#
# 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
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<filename> => I<str>
#
#Path to file to be checked.
#
#=item * B<include_noexec> => I<bool> (default: 1)
#
#Include scripts that do not have +x mode bit set.
#
#=item * B<string> => I<buf>
#
#String to be checked.
#
#=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 gen_getopt_long_spec_from_getopt_std_spec
#
#Usage:
#
# gen_getopt_long_spec_from_getopt_std_spec(%args) -> hash
#
#Generate Getopt::Long spec from Getopt::Std spec.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<is_getopt> => I<bool>
#
#Whether to assume spec is for getopt() or getopts().
#
#By default spec is assumed to be for getopts() instead of getopt(). This means
#that for a spec like C<abc:>, C<a> and C<b> don't take argument while C<c> does. But
#if C<is_getopt> is true, the meaning of C<:> is reversed: C<a> and C<b> take
#arguments while C<c> doesn't.
#
#=item * B<spec>* => I<str>
#
#Getopt::Std spec string.
#
#=back
#
#Return value: (hash)
#
#
#=head2 humanize_getopt_long_opt_spec
#
#Usage:
#
# humanize_getopt_long_opt_spec($optspec) -> str
#
#Convert L<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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$optspec>* => I<str>
#
#=back
#
#Return value: (str)
#
#
#=head2 parse_getopt_long_opt_spec
#
#Usage:
#
# parse_getopt_long_opt_spec($optspec) -> hash
#
#Parse a single Getopt::Long option specification.
#
#Examples:
#
#=over
#
#=item * Example #1:
#
# parse_getopt_long_opt_spec("help|h|?"); # -> { dash_prefix => "", opts => ["help", "h", "?"] }
#
#=item * Example #2:
#
# parse_getopt_long_opt_spec("--foo=s"); # -> { dash_prefix => "--", desttype => "", opts => ["foo"], type => "s" }
#
#=back
#
#Will produce a hash with some keys:
#
#=over
#
#=item * C<is_arg> (if true, then option specification is the special C<< E<lt>E<gt> >> for argument
#callback)
#
#=item * C<opts> (array of option names, in the order specified in the opt spec)
#
#=item * C<type> (string, type name)
#
#=item * C<desttype> (either '', or '@' or '%'),
#
#=item * C<is_neg> (true for C<--opt!>)
#
#=item * C<is_inc> (true for C<--opt+>)
#
#=item * C<min_vals> (int, usually 0 or 1)
#
#=item * C<max_vals> (int, usually 0 or 1 except for option that requires multiple
#values)
#
#=back
#
#Will return undef if it can't parse the string.
#
#This function is not exported by default, but exportable.
#
#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/sharyanto/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 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 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017, 2016, 2015, 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
### Lingua/EN/PluralToSingular.pm ###
#package Lingua::EN::PluralToSingular;
#use warnings;
#use strict;
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw/to_singular is_plural/;
#our $VERSION = '0.21';
#
## 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
# brethren brother
# children child
# corpora corpus
# craftsmen craftsman
# crises crisis
# criteria criterion
# curricula curriculum
# feet foot
# fungi fungus
# geese goose
# genera genus
# gentlemen gentleman
# indices index
# lice louse
# matrices matrix
# memoranda memorandum
# men man
# mice mouse
# monies money
# neuroses neurosis
# nuclei nucleus
# oases oasis
# oxen ox
# pence penny
# people person
# phenomena phenomenon
# quanta quantum
# strata stratum
# teeth tooth
# testes testis
# these this
# theses thesis
# those that
# women woman
#ad-men ad-man
#admen adman
#aircraftmen aircraftman
#airmen airman
#airwomen airwoman
#alaskamen alaskaman
#aldermen alderman
#anchormen anchorman
#ape-men ape-man
#assemblymen assemblyman
#backwoodsmen backwoodsman
#bandsmen bandsman
#barmen barman
#barrow-men barrow-man
#batmen batman
#batsmen batsman
#beggarmen beggarman
#beggarwomen beggarwoman
#behmen behman
#boatmen boatman
#bogeymen bogeyman
#bowmen bowman
#brakemen brakeman
#bushmen bushman
#businessmen businessman
#businesswomen businesswoman
#busmen busman
#byre-men byre-man
#cabmen cabman
#cameramen cameraman
#carmen carman
#cattlemen cattleman
#cavalrymen cavalryman
#cavemen caveman
#chairmen chairman
#chairwomen chairwoman
#chapmen chapman
#charwomen charwoman
#chessmen chessman
#chinamen chinaman
#churchmen churchman
#clansmen clansman
#classmen classman
#clemen cleman
#clergymen clergyman
#coachmen coachman
#coalmen coalman
#cognomen cognoman
#con-men con-man
#congressmen congressman
#congresswomen congresswoman
#councilmen councilman
#councilwomen councilwoman
#countrymen countryman
#countrywomen countrywoman
#cowmen cowman
#cracksmen cracksman
#craftsmen craftsman
#cragsmen cragsman
#crewmen crewman
#cyclamen cyclaman
#dairymen dairyman
#dalesmen dalesman
#doormen doorman
#draftsmen draftsman
#draughtsmen draughtsman
#dustmen dustman
#dutchmen dutchman
#englishmen englishman
#englishwomen englishwoman
#ex-servicemen ex-serviceman
#excisemen exciseman
#fellow-men fellow-man
#ferrymen ferryman
#fieldsmen fieldsman
#firemen fireman
#fishermen fisherman
#flagmen flagman
#footmen footman
#foremen foreman
#forewomen forewoman
#freedmen freedman
#freemen freeman
#frenchmen frenchman
#frenchwomen frenchwoman
#freshmen freshman
#frogmen frogman
#frontiersmen frontiersman
#g-men g-man
#gentlemen gentleman
#gentlewomen gentlewoman
#germen german
#god-men god-man
#gombeen-men gombeen-man
#groundsmen groundsman
#guardsmen guardsman
#gunmen gunman
#handymen handyman
#hangmen hangman
#harmen harman
#he-men he-man
#headmen headman
#helmsmen helmsman
#hemmen hemman
#henchmen henchman
#herdsmen herdsman
#highwaymen highwayman
#horsemen horseman
#horsewomen horsewoman
#housemen houseman
#huntsmen huntsman
#husbandmen husbandman
#hymen hyman
#icemen iceman
#indiamen indiaman
#infantrymen infantryman
#irishmen irishman
#irishwomen irishwoman
#jazzmen jazzman
#journeymen journeyman
#jurymen juryman
#kinmen kinman
#kinsmen kinsman
#kinswomen kinswoman
#klansmen klansman
#landsmen landsman
#laundrymen laundryman
#laundrywomen laundrywoman
#lawmen lawman
#laymen layman
#liegemen liegeman
#liftmen liftman
#linemen lineman
#linesmen linesman
#linkmen linkman
#liverymen liveryman
#lobstermen lobsterman
#longshoremen longshoreman
#lumbermen lumberman
#madmen madman
#madwomen madwoman
#mailmen mailman
#marksmen marksman
#medicine-men medicine-man
#men man
#merchantmen merchantman
#mermen merman
#middlemen middleman
#midshipmen midshipman
#militiamen militiaman
#milkmen milkman
#minutemen minuteman
#motormen motorman
#muffin-men muffin-man
#musclemen muscleman
#needlewomen needlewoman
#newsmen newsman
#newspapermen newspaperman
#newswomen newswoman
#night-watchmen night-watchman
#noblemen nobleman
#nomen noman
#norsemen norseman
#northmen northman
#nurserymen nurseryman
#oarsmen oarsman
#oarswomen oarswoman
#oehmen oehman
#oilmen oilman
#ombudsmen ombudsman
#orangemen orangeman
#pantrymen pantryman
#patrolmen patrolman
#pitchmen pitchman
#pitmen pitman
#placemen placeman
#plainsmen plainsman
#ploughmen ploughman
#pointsmen pointsman
#policemen policeman
#policewomen policewoman
#postmen postman
#potmen potman
#pressmen pressman
#property-men property-man
#quarrymen quarryman
#raftsmen raftsman
#ragmen ragman
#railwaymen railwayman
#repairmen repairman
#riflemen rifleman
#roadmen roadman
#roundsmen roundsman
#salarymen salaryman
#salesmen salesman
#saleswomen saleswoman
#salmen salman
#sandwichmen sandwichman
#schoolmen schoolman
#scotchmen scotchman
#scotchwomen scotchwoman
#scotsmen scotsman
#scotswomen scotswoman
#seamen seaman
#seedsmen seedsman
#servicemen serviceman
#showmen showman
#sidesmen sidesman
#signalmen signalman
#snowmen snowman
#specimen speciman
#spokesmen spokesman
#spokeswomen spokeswoman
#sportsmen sportsman
#stablemen stableman
#stamen staman
#stammen stamman
#statesmen statesman
#steersmen steersman
#supermen superman
#superwomen superwoman
#switchmen switchman
#swordsmen swordsman
#t-men t-man
#tallymen tallyman
#taxmen taxman
#townsmen townsman
#tradesmen tradesman
#trainmen trainman
#trenchermen trencherman
#tribesmen tribesman
#turkmen turkman
#tutankhamen tutankhaman
#underclassmen underclassman
#vestrymen vestryman
#vonallmen vonallman
#washerwomen washerwoman
#watchmen watchman
#watermen waterman
#weathermen weatherman
#welshmen welshman
#women woman
#woodmen woodman
#woodsmen woodsman
#workmen workman
#yachtsmen yachtsman
#yeomen yeoman
#/);
#
## 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/
# 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/
#Aries
#Charles
#Gonzales
#Hades
#Hercules
#Hermes
#Holmes
#Hughes
#Ives
#Jacques
#James
#Keyes
#Mercedes
#Naples
#Oates
#Raines
#Texas
#athletics
#bogus
#bus
#cactus
#cannabis
#caries
#chaos
#citrus
#clothes
#corps
#corpus
#devious
#dias
#facies
#famous
#hippopotamus
#homunculus
#iris
#lens
#mathematics
#metaphysics
#metropolis
#mews
#minus
#miscellaneous
#molasses
#mrs
#narcissus
#news
#octopus
#ourselves
#papyrus
#perhaps
#physics
#platypus
#plus
#previous
#pus
#rabies
#scabies
#sometimes
#stylus
#themselves
#this
#thus
#various
#yes
#nucleus
#synchronous
#/);
#
#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/
#
## Also used
#
## perl -n -e 'print if /oe$/' < /usr/share/dict/words
#
#my @oes = (qw/
#canoes
#does
#foes
#gumshoes
#hoes
#horseshoes
#oboes
#shoes
#snowshoes
#throes
#toes
#/);
#
#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).
#
## Also get a good list using
#
## perl -n -e 'print if /ie$/' < /usr/share/dict/words
#
## There are too many obscure words there though.
#
## Also, I'm deliberately not including "Bernie" and "Bessie" since the
## plurals are rare I think.
#
#my @ies = (qw/
#Aussies
#Valkryies
#aunties
#bogies
#brownies
#calories
#charlies
#coolies
#coteries
#curies
#cuties
#dies
#genies
#goalies
#kilocalories
#lies
#magpies
#menagerie
#movies
#neckties
#pies
#porkpies
#prairies
#quickies
#reveries
#rookies
#sorties
#stogies
#talkies
#ties
#zombies
#/);
#
#my %ies;
#
#@ies{@ies} = (1) x @ies;
#
## Words which end in -se, so that we want the singular to change from
## -ses to -se. This also contains verbs like "deceases", so that they
## don't trigger spell checker errors.
#
#my @ses = (qw/
#automates
#bases
#cases
#causes
#ceases
#closes
#cornflakes
#creases
#databases
#deceases
#flakes
#horses
#increases
#mates
#parses
#purposes
#races
#releases
#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$/;
#
## Plurals ending -i, singular is either -us, -o or something else
## See https://en.wiktionary.org/wiki/Category:English_irregular_plurals_ending_in_%22-i%22
#
## -i to -us
#my @i_to_us = (qw/
#abaci
#abaculi
#acanthi
#acini
#alumni
#anthocauli
#bacilli
#baetuli
#cacti
#calculi
#calli
#catheti
#emboli
#emeriti
#esophagi
#foci
#foeti
#fumuli
#fungi
#gonococci
#hippopotami
#homunculi
#incubi
#loci
#macrofungi
#macronuclei
#naevi
#nuclei
#obeli
#octopi
#oeconomi
#oesophagi
#panni
#periœci
#phocomeli
#phoeti
#platypi
#polypi
#precunei
#radii
#rhombi
#sarcophagi
#solidi
#stimuli
#succubi
#syllabi
#thesauri
#thrombi
#tori
#trophi
#uteri
#viri
#virii
#xiphopagi
#zygomatici
#/);
#
#my %i_to_us;
#@i_to_us{@i_to_us} = (1) x @i_to_us;
#
## -i to -o
#my @i_to_o = (qw/
# alveoli
# ghetti
# manifesti
# ostinati
# pianissimi
# scenarii
# stiletti
# torsi
#/);
#
#my %i_to_o;
#@i_to_o{@i_to_o} = (1) x @i_to_o;
#
## -i to something else
#
#my %i_to_other = (
# improvisatori => 'improvisatore',
# rhinoceri => 'rhinoceros',
# scaloppini => 'scaloppine'
#);
#
## 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$//;
# }
# }
# elsif ($word =~ /i$/) {
# if ($i_to_us{$word}) {
# $singular =~ s/i$/us/;
# }
# elsif ($i_to_o{$word}) {
# $singular =~ s/i$/o/;
# }
# if ($i_to_other{$word}) {
# $singular = $i_to_other{$word};
# }
# }
#
# }
# 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;
### Log/ger.pm ###
#package Log::ger;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
##IFUNBUILT
## use strict 'subs', 'vars';
## use warnings;
##END IFUNBUILT
#
#our $re_addr = qr/\(0x([0-9a-f]+)/o;
#
#our %Levels = (
# fatal => 10,
# error => 20,
# warn => 30,
# info => 40,
# debug => 50,
# trace => 60,
#);
#
#our %Level_Aliases = (
# off => 0,
# warning => 30,
#);
#
#our $Current_Level = 30;
#
#our $Caller_Depth_Offset = 0;
#
## a flag that can be used by null output to skip using formatter
#our $_logger_is_null;
#
#our $_dumper;
#
#our %Global_Hooks;
#
## in Log/ger/Heavy.pm
## our %Default_Hooks = (
#
#our %Package_Targets; # key = package name, value = \%init_args
#our %Per_Package_Hooks; # key = package name, value = { phase => hooks, ... }
#
#our %Hash_Targets; # key = hash address, value = [$hashref, \%init_args]
#our %Per_Hash_Hooks; # key = hash address, value = { phase => hooks, ... }
#
#our %Object_Targets; # key = object address, value = [$obj, \%init_args]
#our %Per_Object_Hooks; # key = object address, value = { phase => hooks, ... }
#
#my $sub0 = sub {0};
#my $sub1 = sub {1};
#my $default_null_routines;
#
#sub install_routines {
# my ($target, $target_arg, $routines, $name_routines) = @_;
#
# if ($name_routines && !defined &subname) {
# if (eval { require Sub::Name; 1 }) {
# *subname = \&Sub::Name::subname;
# } else {
# *subname = sub {};
# }
# }
#
# if ($target eq 'package') {
##IFUNBUILT
## no warnings 'redefine';
##END IFUNBUILT
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# #print "D:installing $name to package $target_arg\n";
# *{"$target_arg\::$name"} = $code;
# subname("$target_arg\::$name", $code) if $name_routines;
# }
# } elsif ($target eq 'object') {
##IFUNBUILT
## no warnings 'redefine';
##END IFUNBUILT
# my $pkg = ref $target_arg;
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_method\z/;
# *{"$pkg\::$name"} = $code;
# subname("$pkg\::$name", $code) if $name_routines;
# }
# } elsif ($target eq 'hash') {
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# $target_arg->{$name} = $code;
# }
# }
#}
#
#sub add_target {
# my ($target, $target_arg, $args, $replace) = @_;
# $replace = 1 unless defined $replace;
#
# if ($target eq 'package') {
# unless ($replace) { return if $Package_Targets{$target_arg} }
# $Package_Targets{$target_arg} = $args;
# } elsif ($target eq 'object') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unless ($replace) { return if $Object_Targets{$addr} }
# $Object_Targets{$addr} = [$target_arg, $args];
# } elsif ($target eq 'hash') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unless ($replace) { return if $Hash_Targets{$addr} }
# $Hash_Targets{$addr} = [$target_arg, $args];
# }
#}
#
#sub _set_default_null_routines {
# $default_null_routines ||= [
# (map {(
# [$sub0, "log_$_", $Levels{$_}, 'log_sub'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "log_is_$_", $Levels{$_}, 'is_sub'],
# [$sub0, $_, $Levels{$_}, 'log_method'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "is_$_", $Levels{$_}, 'is_method'],
# )} keys %Levels),
# ];
#}
#
#sub get_logger {
# my ($package, %args) = @_;
#
# my $caller = caller(0);
# $args{category} = $caller if !defined($args{category});
# my $obj = []; $obj =~ $re_addr;
# my $pkg = "Log::ger::Obj$1"; bless $obj, $pkg;
# add_target(object => $obj, \%args);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(object => $obj, \%args);
# } else {
# # if we haven't added any hooks etc, skip init_target() process and use
# # this preconstructed routines as shortcut, to save startup overhead
# _set_default_null_routines();
# install_routines(object => $obj, $default_null_routines, 0);
# }
# $obj; # XXX add DESTROY to remove from list of targets
#}
#
#sub import {
# my ($package, %args) = @_;
#
# my $caller = caller(0);
# $args{category} = $caller if !defined($args{category});
# add_target(package => $caller, \%args);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(package => $caller, \%args);
# } else {
# # if we haven't added any hooks etc, skip init_target() process and use
# # this preconstructed routines as shortcut, to save startup overhead
# _set_default_null_routines();
# install_routines(package => $caller, $default_null_routines, 0);
# }
#}
#
#1;
## ABSTRACT: A lightweight, flexible logging framework
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger - A lightweight, flexible logging framework
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
#In your module (producer):
#
# package Foo;
# use Log::ger; # will import some logging methods e.g. log_warn, log_error
#
# sub foo {
# ...
# # produce some logs
# log_error "an error occurred: %03d - %s", $errcode, $errmsg;
# ...
# log_debug "http response: %s", $http; # automatic dumping of data
# }
# 1;
#
#In your application (consumer/listener):
#
# use Foo;
# use Log::ger::Output 'Screen';
#
# foo();
#
#=head1 DESCRIPTION
#
#Log::ger is yet another logging framework with the following features:
#
#=over
#
#=item * Separation of producers and consumers/listeners
#
#Like L<Log::Any>, this offers a very easy way for modules to produce some logs
#without having to configure anything. Configuring output, level, etc can be done
#in the application as log consumers/listeners. To read more about this, see the
#documentation of L<Log::Any> or L<Log::ger::Manual> (but nevertheless see
#L<Log::ger::Manual> on why you might prefer Log::ger to Log::Any).
#
#=item * Lightweight and fast
#
#B<Slim distribution.> No non-core dependencies, extra functionalities are
#provided in separate distributions to be pulled as needed.
#
#B<Low startup overhead.> Only ~0.5-1ms. For comparison, L<strict> ~0.2-0.5ms,
#L<warnings> ~2ms, L<Log::Any> 0.15 ~2-3ms, Log::Any 1.049 ~8-10ms,
#L<Log::Log4perl> ~35ms. This is measured on a 2014-2015 PC and before doing any
#output configuration. I strive to make C<use Log::ger;> statement to be roughly
#as light as C<use strict;> or C<use warnings;> so the impact of adding the
#statement is really minimal and you can just add logging without much thought to
#most of your modules. This is important to me because I want logging to be
#pervasive.
#
#To test for yourself, try e.g. with L<bencher-code>:
#
# % bencher-code 'use Log::ger' 'use Log::Any' --startup
#
#B<Fast>. Low null-/stealth-logging overhead, about 1.5x faster than Log::Any, 3x
#faster than Log4perl, 5x faster than L<Log::Fast>, ~40x faster than
#L<Log::Contextual>, and ~100x faster than L<Log::Dispatch>.
#
#For more benchmarks, see L<Bencher::Scenarios::LogGer>.
#
#B<Conditional compilation.> There is a plugin to optimize away unneeded logging
#statements, like assertion/conditional compilation, so they have zero runtime
#performance cost. See L<Log::ger::Plugin::OptAway>.
#
#Being lightweight means the module can be used more universally, from CLI to
#long-running daemons to inside routines with tight loops.
#
#=item * Flexible
#
#B<Customizable levels and routine/method names.> Can be used in a procedural or
#OO style. Log::ger can mimic the interface of L<Log::Any>, L<Log::Contextual>,
#L<Log::Log4perl>, or some other popular logging frameworks, to ease migration or
#adjust with your personal style.
#
#B<Per-package settings.> Each importer package can use its own format/layout,
#output. For example, a module that is migrated from Log::Any uses Log::Any-style
#logging, while another uses native Log::ger style, and yet some other uses block
#formatting like Log::Contextual. This eases code migration and teamwork. Each
#module author can preserve her own logging style, if wanted, and all the modules
#still use the same framework.
#
#B<Dynamic.> Outputs and levels can be changed anytime during run-time and
#logging routines will be updated automatically. This is useful in situation like
#a long-running server application: you can turn on tracing logs temporarily to
#debug problems, then turn them off again, without restarting your server.
#
#B<Interoperability.> There are modules to interop with Log::Any, either consume
#Log::Any logs (see L<Log::Any::Adapter::LogGer>) or produce logs to be consumed
#by Log::Any (see L<Log::ger::Output::LogAny>).
#
#B<Many output modules and plugins.> See C<Log::ger::Output::*>,
#C<Log::ger::Format::*>, C<Log::ger::Layout::*>, C<Log::ger::Plugin::*>. Writing
#an output module in Log::ger is easier than writing a Log::Any::Adapter::*.
#
#=back
#
#For more documentation, start with L<Log::ger::Manual>.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 SEE ALSO
#
#Some other popular logging frameworks: L<Log::Any>, L<Log::Contextual>,
#L<Log::Log4perl>, L<Log::Dispatch>, L<Log::Dispatchouli>.
#
#If you still prefer debugging using the good old C<print()>, there's
#L<Debug::Print>.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Format.pm ###
#package Log::ger::Format;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use parent qw(Log::ger::Plugin);
#
#sub _import_sets_for_current_package { 1 }
#
#1;
## ABSTRACT: Use a format plugin
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Format - Use a format plugin
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
#To set for current package only:
#
# use Log::ger::Format 'Block';
#
#or:
#
# use Log::ger::Format;
# Log::ger::Format->set_for_current_package('Block');
#
#To set globally:
#
# use Log::ger::Format;
# Log::ger::Format->set('Block');
#
#=head1 DESCRIPTION
#
#Note: Since format plugins affect log-producing code, the import syntax defaults
#to setting for current package instead of globally.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 SEE ALSO
#
#L<Log::ger::Layout>
#
#L<Log::ger::Output>
#
#L<Log::ger::Plugin>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Format/None.pm ###
#package Log::ger::Format::None;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#sub get_hooks {
# return {
# create_formatter => [
# __PACKAGE__, 50,
# sub {
# [sub {shift}];
# }],
# };
#}
#
#1;
## ABSTRACT: Perform no formatting on the message
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Format::None - Perform no formatting on the message
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use Log::ger::Format 'None';
#
#=head1 DESCRIPTION
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head1 SEE ALSO
#
#L<Log::ger>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Heavy.pm ###
#package Log::ger::Heavy;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
##IFUNBUILT
## use strict;
## use warnings;
##END IFUNBUILT
#
#package
# Log::ger;
#
##IFUNBUILT
## use vars qw(
## $re_addr
## %Levels
## %Level_Aliases
## $Current_Level
## $_logger_is_null
## $_dumper
## %Global_Hooks
## %Package_Targets
## %Per_Package_Hooks
## %Hash_Targets
## %Per_Hash_Hooks
## %Object_Targets
## %Per_Object_Hooks
## );
##END IFUNBUILT
#
## key = phase, value = [ [key, prio, coderef], ... ]
#our %Default_Hooks = (
# create_formatter => [
# [__PACKAGE__, 90,
# # the default formatter is sprintf-style that dumps data structures
# # arguments as well as undef as '<undef>'.
# sub {
# my %args = @_;
#
# my $formatter = sub {
# return $_[0] if @_ < 2;
# my $fmt = shift;
# my @args;
# for (@_) {
# if (!defined($_)) {
# push @args, '<undef>';
# } elsif (ref $_) {
# require Log::ger::Util unless $_dumper;
# push @args, Log::ger::Util::_dump($_);
# } else {
# push @args, $_;
# }
# }
# sprintf $fmt, @args;
# };
# [$formatter];
# }],
# ],
#
# create_layouter => [],
#
# create_routine_names => [
# [__PACKAGE__, 90,
# # the default names are log_LEVEL() and log_is_LEVEL() for subroutine
# # names, or LEVEL() and is_LEVEL() for method names
# sub {
# my %args = @_;
#
# my $levels = [keys %Levels];
#
# return [{
# log_subs => [map { ["log_$_", $_] } @$levels],
# is_subs => [map { ["log_is_$_", $_] } @$levels],
# # used when installing to hash or object
# log_methods => [map { ["$_", $_] } @$levels],
# is_methods => [map { ["is_$_", $_] } @$levels],
# }, 1];
# }],
# ],
#
# create_log_routine => [
# [__PACKAGE__, 10,
# # the default behavior is to create a null routine for levels that are
# # too high than the global level ($Current_Level). since we run at high
# # priority (10), this block typical output plugins at normal priority
# # (50). this is a convenience so normally a plugin does not have to
# # deal with level checking.
# sub {
# my %args = @_;
# my $level = $args{level};
# if (defined($level) && (
# $Current_Level < $level ||
# # there's only us
# @{ $Global_Hooks{create_log_routine} } == 1)
# ) {
# $_logger_is_null = 1;
# return [sub {0}];
# }
# [undef]; # decline
# }],
# ],
#
# create_logml_routine => [],
#
# create_is_routine => [
# [__PACKAGE__, 90,
# # the default behavior is to compare to global level. normally this
# # behavior suffices. we run at low priority (90) so normal plugins
# # which typically use priority 50 can override us.
# sub {
# my %args = @_;
# my $level = $args{level};
# [sub { $Current_Level >= $level }];
# }],
# ],
#
# before_install_routines => [],
#
# after_install_routines => [],
#);
#
#for my $phase (keys %Default_Hooks) {
# $Global_Hooks{$phase} = [@{ $Default_Hooks{$phase} }];
#}
#
## if flow_control is 1, stops after the first hook that gives non-undef result.
## flow_control can also be a coderef that will be called after each hook with
## ($hook, $hook_res) and can return 1 to mean stop.
#sub run_hooks {
# my ($phase, $hook_args, $flow_control,
# $target, $target_arg) = @_;
# #print "D: running hooks for phase $phase\n";
#
# $Global_Hooks{$phase} or die "Unknown phase '$phase'";
# my @hooks = @{ $Global_Hooks{$phase} };
#
# if ($target eq 'package') {
# unshift @hooks, @{ $Per_Package_Hooks{$target_arg}{$phase} || [] };
# } elsif ($target eq 'hash') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unshift @hooks, @{ $Per_Hash_Hooks{$addr}{$phase} || [] };
# } elsif ($target eq 'object') {
# my ($addr) = "$target_arg" =~ $re_addr;
# unshift @hooks, @{ $Per_Object_Hooks{$addr}{$phase} || [] };
# }
#
# my $res;
# for my $hook (sort {$a->[1] <=> $b->[1]} @hooks) {
# my $hook_res = $hook->[2]->(%$hook_args);
# if (defined $hook_res->[0]) {
# $res = $hook_res->[0];
# #print "D: got result from hook $res\n";
# if (ref $flow_control eq 'CODE') {
# last if $flow_control->($hook, $hook_res);
# } else {
# last if $flow_control;
# }
# }
# last if $hook_res->[1];
# }
# return $res;
#}
#
#sub init_target {
# my ($target, $target_arg, $init_args) = @_;
#
# #print "D:init_target($target, $target_arg, ...)\n";
# my %hook_args = (
# target => $target,
# target_arg => $target_arg,
# init_args => $init_args,
# );
#
# my %formatters;
# run_hooks(
# 'create_formatter', \%hook_args,
# # collect formatters, until a hook instructs to stop
# sub {
# my ($hook, $hook_res) = @_;
# my ($formatter, $flow_control, $fmtname) = @$hook_res;
# $fmtname = 'default' if !defined($fmtname);
# $formatters{$fmtname} ||= $formatter;
# $flow_control;
# },
# $target, $target_arg);
#
# my $layouter =
# run_hooks('create_layouter', \%hook_args, 1, $target, $target_arg);
#
# my $routine_names = {};
# run_hooks(
# 'create_routine_names', \%hook_args,
# # collect routine names, until a hook instructs to stop.
# sub {
# my ($hook, $hook_res) = @_;
# my ($rn, $flow_control) = @$hook_res;
# $rn or return;
# for (keys %$rn) {
# push @{ $routine_names->{$_} }, @{ $rn->{$_} };
# }
# $flow_control;
# },
# $target, $target_arg);
#
# my @routines;
# my $object = $target eq 'object';
#
# CREATE_LOG_ROUTINES:
# {
# my @rn;
# if ($target eq 'package') {
# push @rn, @{ $routine_names->{log_subs} || [] };
# push @rn, @{ $routine_names->{logml_subs} || [] };
# } else {
# push @rn, @{ $routine_names->{log_methods} || [] };
# push @rn, @{ $routine_names->{logml_methods} || [] };
# }
# my $mllogger0;
# for my $rn (@rn) {
# my ($rname, $lname, $fmtname) = @$rn;
# my $lnum; $lnum = $Levels{$lname} if defined $lname;
# my $routine_name_is_ml = !defined($lname);
# $fmtname = 'default' if !defined($fmtname);
#
# my $logger;
# my ($logger0, $logger0_is_ml);
# $_logger_is_null = 0;
# for my $phase (qw/create_logml_routine create_log_routine/) {
# local $hook_args{name} = $rname;
# local $hook_args{level} = $lnum;
# local $hook_args{str_level} = $lname;
# $logger0_is_ml = $phase eq 'create_logml_routine';
# if ($mllogger0) {
# # we reuse the same multilevel logger0 for all log routines,
# # since it can handle different levels
# $logger0 = $mllogger0;
# last;
# }
# $logger0 = run_hooks(
# $phase, \%hook_args, 1, $target, $target_arg)
# or next;
# if ($logger0_is_ml) {
# $mllogger0 = $logger0;
# }
# last;
# }
# # this can happen if there is no create_logml_routine hook but
# # routine name is a logml routine
# unless ($logger0) {
# $_logger_is_null = 1;
# $logger0 = sub {0};
# }
#
# require Log::ger::Util if !$logger0_is_ml && $routine_name_is_ml;
#
# {
# if ($_logger_is_null) {
# # if logger is a null logger (sub {0}) we don't need to
# # format message, layout message, or care about the logger
# # being a subroutine/object
# $logger = $logger0;
# last;
# }
#
# my $formatter = $formatters{$fmtname}
# or die "Formatter named '$fmtname' not available";
# if ($formatter) {
# if ($layouter) {
# if ($logger0_is_ml) {
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; my $lnum=shift; my $lname = Log::ger::Util::string_level($lnum);
# $logger0->($init_args, $lnum, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) };
# } else { $logger = sub { my $lnum=shift; my $lname = Log::ger::Util::string_level($lnum);
# $logger0->($init_args, $lnum, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) }; }
# } else { # routine name not multiple-level
# if ($object) { $logger = sub { shift; $logger0->($init_args, $lnum, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) };
# } else { $logger = sub { $logger0->($init_args, $lnum, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) }; }
# }
# } else { # logger0 not multiple-level
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) };
# } else { $logger = sub { return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) }; }
# } else { # routine name not multiple-level
# if ($object) { $logger = sub { shift; $logger0->($init_args, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) };
# } else { $logger = sub { $logger0->($init_args, $layouter->($formatter->(@_), $init_args, $lnum, $lname)) }; }
# }
# }
# } else { # no layouter
# if ($logger0_is_ml) {
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; my $lnum=shift; $logger0->($init_args, $lnum, $formatter->(@_) ) };
# } else { $logger = sub { my $lnum=shift; $logger0->($init_args, $lnum, $formatter->(@_) ) }; }
# } else { # routine name not multiple-level
# if ($object) { $logger = sub { shift; $logger0->($init_args, $lnum, $formatter->(@_) ) };
# } else { $logger = sub { $logger0->($init_args, $lnum, $formatter->(@_) ) }; }
# }
# } else { # logger0 not multiple-level
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, $formatter->(@_) ) };
# } else { $logger = sub { return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, $formatter->(@_) ) }; }
# } else { # routine name not multiple-level
# if ($object) { $logger = sub { shift; $logger0->($init_args, $formatter->(@_) ) };
# } else { $logger = sub { $logger0->($init_args, $formatter->(@_) ) }; }
# }
# }
# }
# } else { # no formatter
# { # no layouter, just to align
# if ($logger0_is_ml) {
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; my $lnum=shift; $logger0->($init_args, $lnum, @_ ) };
# } else { $logger = sub { my $lnum=shift; $logger0->($init_args, $lnum, @_ ) }; }
# } else { # routine name not multiple-lvl
# if ($object) { $logger = sub { shift; $logger0->($init_args, $lnum, @_ ) };
# } else { $logger = sub { $logger0->($init_args, $lnum, @_ ) }; }
# }
# } else { # logger0 not multiple-level
# if ($routine_name_is_ml) {
# if ($object) { $logger = sub { shift; return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, @_ ) };
# } else { $logger = sub { return 0 if Log::ger::Util::numeric_level(shift) > $Current_Level;
# $logger0->($init_args, @_ ) }; }
# } else {
# if ($object) { $logger = sub { shift; $logger0->($init_args, @_ ) };
# } else { $logger = sub { $logger0->($init_args, @_ ) }; }
# }
# }
# }
# }
# }
# L1:
# my $type = $routine_name_is_ml ?
# ($object ? 'logml_method' : 'logml_sub') :
# ($object ? 'log_method' : 'log_sub');
# push @routines, [$logger, $rname, $lnum, $type];
# }
# }
# CREATE_IS_ROUTINES:
# {
# my @rn;
# my $type;
# if ($target eq 'package') {
# push @rn, @{ $routine_names->{is_subs} || [] };
# $type = 'is_sub';
# } else {
# push @rn, @{ $routine_names->{is_methods} || [] };
# $type = 'is_method';
# }
# for my $rn (@rn) {
# my ($rname, $lname) = @$rn;
# my $lnum = $Levels{$lname};
#
# local $hook_args{name} = $rname;
# local $hook_args{level} = $lnum;
# local $hook_args{str_level} = $lname;
#
# my $code_is =
# run_hooks('create_is_routine', \%hook_args, 1,
# $target, $target_arg);
# next unless $code_is;
# push @routines, [$code_is, $rname, $lnum, $type];
# }
# }
#
# {
# local $hook_args{routines} = \@routines;
# local $hook_args{formatters} = \%formatters;
# local $hook_args{layouter} = $layouter;
# run_hooks('before_install_routines', \%hook_args, 0,
# $target, $target_arg);
# }
#
# install_routines($target, $target_arg, \@routines, 1);
#
# {
# local $hook_args{routines} = \@routines;
# run_hooks('after_install_routines', \%hook_args, 0,
# $target, $target_arg);
# }
#}
#
#1;
## ABSTRACT: The bulk of the implementation of Log::ger
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Heavy - The bulk of the implementation of Log::ger
#
#=head1 VERSION
#
#version 0.028
#
#=head1 DESCRIPTION
#
#This module contains the bulk of the implementation of Log::ger, to keep
#Log::ger superslim.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Layout.pm ###
#package Log::ger::Layout;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use parent qw(Log::ger::Plugin);
#
## we only use one output, so set() should replace all hooks from previously set
## plugin package
#sub _replace_package_regex { qr/\ALog::ger::Layout::/ }
#
#1;
## ABSTRACT: Use a layout plugin
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Layout - Use a layout plugin
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
#To set globally:
#
# use Log::ger::Layout;
# Log::ger::Layout->set('Pattern');
#
#or:
#
# use Log::ger::Layout 'Pattern';
#
#To set for current package only:
#
# use Log::ger::Layout;
# Log::ger::Layout->set_for_current_package('Pattern');
#
#=for Pod::Coverage ^(.+)$
#
#=head1 SEE ALSO
#
#L<Log::ger::Output>
#
#L<Log::ger::Plugin>
#
#L<Log::ger::Format>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Output.pm ###
#package Log::ger::Output;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use parent 'Log::ger::Plugin';
#
## we only use one output, so set() should replace all hooks from previously set
## plugin package
#sub _replace_package_regex { qr/\ALog::ger::Output::/ }
#
#1;
## ABSTRACT: Set logging output
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Output - Set logging output
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
#To set globally:
#
# use Log::ger::Output;
# Log::ger::Output->set(Screen => (
# use_color => 1,
# ...
# );
#
#or:
#
# use Log::ger::Output 'Screen', (
# use_color=>1,
# ...
# );
#
#To set for current package only:
#
# use Log::ger::Output;
# Log::ger::Output->set_for_current_package(Screen => (
# use_color => 1,
# ...
# );
#
#=for Pod::Coverage ^(.+)$
#
#=head1 SEE ALSO
#
#L<Log::ger::Format>
#
#L<Log::ger::Layout>
#
#L<Log::ger::Plugin>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Output/Array.pm ###
#package Log::ger::Output::Array;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#sub get_hooks {
# my %conf = @_;
#
# $conf{array} or die "Please specify array";
#
# return {
# create_log_routine => [
# __PACKAGE__, 50,
# sub {
# my %args = @_;
#
# my $logger = sub {
# my ($ctx, $msg) = @_;
# push @{$conf{array}}, $msg;
# };
# [$logger];
# }],
# };
#}
#
#1;
## ABSTRACT: Log to array
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Output::Array - Log to array
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use Log::ger::Output Array => (
# array => $ary,
# );
#
#=head1 DESCRIPTION
#
#Mainly for testing only.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head2 array => arrayref
#
#Required.
#
#=head1 SEE ALSO
#
#L<Log::ger>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Output/ArrayML.pm ###
#package Log::ger::Output::ArrayML;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#use Log::ger::Util;
#
#sub get_hooks {
# my %conf = @_;
#
# $conf{array} or die "Please specify array";
#
# return {
# create_logml_routine => [
# __PACKAGE__, 50,
# sub {
# my %args = @_;
# my $logger = sub {
# my $level = Log::ger::Util::numeric_level($_[1]);
# return if $level > $Log::ger::Current_Level;
# push @{$conf{array}}, $_[2];
# };
# [$logger];
# }],
# };
#}
#
#1;
## ABSTRACT: Log to array
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Output::ArrayML - Log to array
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use Log::ger::Output ArrayML => (
# array => $ary,
# );
#
#=head1 DESCRIPTION
#
#Mainly for testing only.
#
#This output is just like L<Log::ger::Output::Array> except that it provides a
#C<create_logml_routine> hook instead of C<create_log_routine>.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head2 array => arrayref
#
#Required.
#
#=head1 SEE ALSO
#
#L<Log::ger>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Output/Null.pm ###
#package Log::ger::Output::Null;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#sub get_hooks {
# return {
# create_log_routine => [
# __PACKAGE__, 50,
# sub {
# $Log::ger::_logger_is_null = 1;
# [sub {0}];
# }],
# };
#}
#
#1;
## ABSTRACT: Null output
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Output::Null - Null output
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use Log::ger;
# use Log::ger::Output 'Null';
#
# log_warn "blah...";
#
#=head1 DESCRIPTION
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Output/String.pm ###
#package Log::ger::Output::String;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#sub get_hooks {
# my %conf = @_;
#
# $conf{string} or die "Please specify string";
#
# my $formatter = $conf{formatter};
# my $append_newline = $conf{append_newline};
# $append_newline = 1 unless defined $append_newline;
#
# return {
# create_log_routine => [
# __PACKAGE__, 50,
# sub {
# my %args = @_;
# my $level = $args{level};
# my $logger = sub {
# my $msg = $_[1];
# if ($formatter) {
# $msg = $formatter->($msg);
# }
# ${ $conf{string} } .= $msg;
# ${ $conf{string} } .= "\n"
# unless !$append_newline || $msg =~ /\R\z/;
# };
# [$logger];
# }],
# };
#}
#
#1;
## ABSTRACT: Set output to a string
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Output::String - Set output to a string
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use var '$str';
# use Log::ger::Output 'String' => (
# string => \$str,
# # append_newline => 0, # default is true, to mimic Log::ger::Output::Screen
# );
# use Log::ger;
#
# log_warn "warn ...";
# log_error "debug ...";
#
#C<$str> will contain "warn ...\n".
#
#=head1 DESCRIPTION
#
#For testing only.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head2 string => scalarref
#
#Required.
#
#=head2 formatter => coderef
#
#Optional.
#
#=head2 append_newline => bool (default: 1)
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Plugin.pm ###
#package Log::ger::Plugin;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#use Log::ger::Util;
#
#sub set {
# my $pkg = shift;
#
# my %args;
# if (ref $_[0] eq 'HASH') {
# %args = %{shift()};
# } else {
# %args = (name => shift, conf => {@_});
# }
#
# $args{prefix} ||= $pkg . '::';
# $args{replace_package_regex} = $pkg->_replace_package_regex;
# Log::ger::Util::set_plugin(%args);
#}
#
#sub set_for_current_package {
# my $pkg = shift;
#
# my %args;
# if (ref $_[0] eq 'HASH') {
# %args = %{shift()};
# } else {
# %args = (name => shift, conf => {@_});
# }
#
# my $caller = caller(0);
# $args{target} = 'package';
# $args{target_arg} = $caller;
#
# set($pkg, \%args);
#}
#
#sub _import_sets_for_current_package { 0 }
#
#sub _replace_package_regex { undef }
#
#sub import {
# if (@_ > 1) {
# if ($_[0]->_import_sets_for_current_package) {
# goto &set_for_current_package;
# } else {
# goto &set;
# }
# }
#}
#
#1;
## ABSTRACT: Use a plugin
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Plugin - Use a plugin
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
#To set globally:
#
# use Log::ger::Plugin;
# Log::ger::Plugin->set('OptAway');
#
#or:
#
# use Log::ger::Plugin 'OptAway';
#
#To set for current package only:
#
# use Log::ger::Plugin;
# Log::ger::Plugin->set_for_current_package('OptAway');
#
#=for Pod::Coverage ^(.+)$
#
#=head1 SEE ALSO
#
#L<Log::ger::Format>
#
#L<Log::ger::Layout>
#
#L<Log::ger::Output>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Plugin/MultilevelLog.pm ###
#package Log::ger::Plugin::MultilevelLog;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#use Log::ger::Util;
#
#sub get_hooks {
# my %conf = @_;
#
# return {
# create_routine_names => [
# __PACKAGE__, 50,
# sub {
# return [{
# logml_subs => [[$conf{sub_name} || 'log', undef]],
# logml_methods => [[$conf{method_name} || 'log', undef]],
# }];
# },
# ],
# };
#}
#
#1;
## ABSTRACT: Create a log($LEVEL, ...) subroutine/method
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Plugin::MultilevelLog - Create a log($LEVEL, ...) subroutine/method
#
#=head1 VERSION
#
#version 0.028
#
#=head1 SYNOPSIS
#
# use Log::ger::Plugin MultilevelLog => (
# sub_name => 'log', # optional
# method_name => 'log', # optional
# );
# use Log::ger;
#
#=head1 DESCRIPTION
#
#The default way is to create separate C<log_LEVEL> subroutine (or C<LEVEL>
#methods) for each level, e.g. C<log_trace> subroutine (or C<trace> method),
#C<log_warn> (or C<warn>), and so on. But sometimes you might want a log routine
#that takes $level as the first argument, e.g. instead of:
#
# log_warn('blah ...');
#
#or:
#
# $log->debug('Blah: %s', $data);
#
#you prefer:
#
# log('warn', 'blah ...');
#
#or:
#
# $log->log('debug', 'Blah: %s', $data);
#
#This plugin can create such log routine for you.
#
#Note: the multilevel log is slower because of extra argument and additional
#string level -> numeric level conversion.
#
#Note: the individual separate C<log_LEVEL> subroutines (or C<LEVEL> methods) are
#still installed.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 CONFIGURATION
#
#=head2 sub_name => str (default: "log")
#
#=head2 method_name => str (default: "log")
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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/ger/Util.pm ###
#package Log::ger::Util;
#
#our $DATE = '2019-05-06'; # DATE
#our $VERSION = '0.028'; # VERSION
#
#use strict;
#use warnings;
#
#require Log::ger;
#require Log::ger::Heavy;
#
#sub _dump {
# unless ($Log::ger::_dumper) {
# eval {
# no warnings 'once';
# require Data::Dmp;
# $Data::Dmp::OPT_REMOVE_PRAGMAS = 1;
# 1;
# };
# if ($@) {
# no warnings 'once';
# require Data::Dumper;
# $Log::ger::_dumper = sub {
# local $Data::Dumper::Terse = 1;
# local $Data::Dumper::Indent = 0;
# local $Data::Dumper::Useqq = 1;
# local $Data::Dumper::Deparse = 1;
# local $Data::Dumper::Quotekeys = 0;
# local $Data::Dumper::Sortkeys = 1;
# local $Data::Dumper::Trailingcomma = 1;
# local $Data::Dumper::Useqq = 1; # to show "\034", possible bug in Data::Dumper
# Data::Dumper::Dumper($_[0]);
# };
# } else {
# $Log::ger::_dumper = sub { Data::Dmp::dmp($_[0]) };
# }
# }
# $Log::ger::_dumper->($_[0]);
#}
#
#sub numeric_level {
# my $level = shift;
# return $level if $level =~ /\A\d+\z/;
# return $Log::ger::Levels{$level}
# if defined $Log::ger::Levels{$level};
# return $Log::ger::Level_Aliases{$level}
# if defined $Log::ger::Level_Aliases{$level};
# die "Unknown level '$level'";
#}
#
#sub string_level {
# my $level = shift;
# return $level if defined $Log::ger::Levels{$level};
# $level = $Log::ger::Level_Aliases{$level}
# if defined $Log::ger::Level_Aliases{$level};
# for (keys %Log::ger::Levels) {
# my $v = $Log::ger::Levels{$_};
# return $_ if $v == $level;
# }
# die "Unknown level '$level'";
#}
#
#sub set_level {
# no warnings 'once';
# $Log::ger::Current_Level = numeric_level(shift);
# reinit_all_targets();
#}
#
#sub _action_on_hooks {
# no warnings 'once';
#
# my ($action, $target, $target_arg, $phase) = splice @_, 0, 4;
#
# my $hooks = $Log::ger::Global_Hooks{$phase} or die "Unknown phase '$phase'";
# if ($target eq 'package') {
# $hooks = ($Log::ger::Per_Package_Hooks{$target_arg}{$phase} ||= []);
# } elsif ($target eq 'object') {
# my ($addr) = $target_arg =~ $Log::ger::re_addr;
# $hooks = ($Log::ger::Per_Object_Hooks{$addr}{$phase} ||= []);
# } elsif ($target eq 'hash') {
# my ($addr) = $target_arg =~ $Log::ger::re_addr;
# $hooks = ($Log::ger::Per_Hash_Hooks{$addr}{$phase} ||= []);
# }
#
# if ($action eq 'add') {
# my $hook = shift;
# # XXX remove duplicate key
# # my $key = $hook->[0];
# unshift @$hooks, $hook;
# } elsif ($action eq 'remove') {
# my $code = shift;
# for my $i (reverse 0..$#{$hooks}) {
# splice @$hooks, $i, 1 if $code->($hooks->[$i]);
# }
# } elsif ($action eq 'reset') {
# my $saved = [@$hooks];
# splice @$hooks, 0, scalar(@$hooks),
# @{ $Log::ger::Default_Hooks{$phase} };
# return $saved;
# } elsif ($action eq 'empty') {
# my $saved = [@$hooks];
# splice @$hooks, 0;
# return $saved;
# } elsif ($action eq 'save') {
# return [@$hooks];
# } elsif ($action eq 'restore') {
# my $saved = shift;
# splice @$hooks, 0, scalar(@$hooks), @$saved;
# return $saved;
# }
#}
#
#sub add_hook {
# my ($phase, $hook) = @_;
# _action_on_hooks('add', '', undef, $phase, $hook);
#}
#
#sub add_per_target_hook {
# my ($target, $target_arg, $phase, $hook) = @_;
# _action_on_hooks('add', $target, $target_arg, $phase, $hook);
#}
#
#sub remove_hook {
# my ($phase, $code) = @_;
# _action_on_hooks('remove', '', undef, $phase, $code);
#}
#
#sub remove_per_target_hook {
# my ($target, $target_arg, $phase, $code) = @_;
# _action_on_hooks('remove', $target, $target_arg, $phase, $code);
#}
#
#sub reset_hooks {
# my ($phase) = @_;
# _action_on_hooks('reset', '', undef, $phase);
#}
#
#sub reset_per_target_hooks {
# my ($target, $target_arg, $phase) = @_;
# _action_on_hooks('reset', $target, $target_arg, $phase);
#}
#
#sub empty_hooks {
# my ($phase) = @_;
# _action_on_hooks('empty', '', undef, $phase);
#}
#
#sub empty_per_target_hooks {
# my ($target, $target_arg, $phase) = @_;
# _action_on_hooks('empty', $target, $target_arg, $phase);
#}
#
#sub save_hooks {
# my ($phase) = @_;
# _action_on_hooks('save', '', undef, $phase);
#}
#
#sub save_per_target_hooks {
# my ($target, $target_arg, $phase) = @_;
# _action_on_hooks('save', $target, $target_arg, $phase);
#}
#
#sub restore_hooks {
# my ($phase, $saved) = @_;
# _action_on_hooks('restore', '', undef, $phase, $saved);
#}
#
#sub restore_per_target_hooks {
# my ($target, $target_arg, $phase, $saved) = @_;
# _action_on_hooks('restore', $target, $target_arg, $phase, $saved);
#}
#
#sub reinit_target {
# my ($target, $target_arg) = @_;
#
# # adds target if not already exists
# Log::ger::add_target($target, $target_arg, {}, 0);
#
# if ($target eq 'package') {
# my $init_args = $Log::ger::Package_Targets{$target_arg};
# Log::ger::init_target(package => $target_arg, $init_args);
# } elsif ($target eq 'object') {
# my ($obj_addr) = $target_arg =~ $Log::ger::re_addr
# or die "Invalid object '$target_arg': not a reference";
# my $v = $Log::ger::Object_Targets{$obj_addr}
# or die "Unknown object target '$target_arg'";
# Log::ger::init_target(object => $v->[0], $v->[1]);
# } elsif ($target eq 'hash') {
# my ($hash_addr) = $target_arg =~ $Log::ger::re_addr
# or die "Invalid hashref '$target_arg': not a reference";
# my $v = $Log::ger::Hash_Targets{$hash_addr}
# or die "Unknown hash target '$target_arg'";
# Log::ger::init_target(hash => $v->[0], $v->[1]);
# } else {
# die "Unknown target '$target'";
# }
#}
#
#sub reinit_all_targets {
# for my $pkg (keys %Log::ger::Package_Targets) {
# #print "D:reinit package $pkg\n";
# Log::ger::init_target(
# package => $pkg, $Log::ger::Package_Targets{$pkg});
# }
# for my $k (keys %Log::ger::Object_Targets) {
# my ($obj, $init_args) = @{ $Log::ger::Object_Targets{$k} };
# Log::ger::init_target(object => $obj, $init_args);
# }
# for my $k (keys %Log::ger::Hash_Targets) {
# my ($hash, $init_args) = @{ $Log::ger::Hash_Targets{$k} };
# Log::ger::init_target(hash => $hash, $init_args);
# }
#}
#
#sub set_plugin {
# my %args = @_;
#
# my $hooks;
# if ($args{hooks}) {
# $hooks = $args{hooks};
# } else {
# no strict 'refs';
# my $prefix = $args{prefix} || 'Log::ger::Plugin::';
# my $mod = $args{name};
# $mod = $prefix . $mod unless index($mod, $prefix) == 0;
# (my $mod_pm = "$mod.pm") =~ s!::!/!g;
# require $mod_pm;
# $hooks = &{"$mod\::get_hooks"}(%{ $args{conf} || {} });
# }
#
# {
# last unless $args{replace_package_regex};
# my $all_hooks;
# if (!$args{target}) {
# $all_hooks = \%Log::ger::Global_Hooks;
# } elsif ($args{target} eq 'package') {
# $all_hooks = $Log::ger::Per_Package_Hooks{ $args{target_arg} };
# } elsif ($args{target} eq 'object') {
# my ($addr) = $args{target_arg} =~ $Log::ger::re_addr;
# $all_hooks = $Log::ger::Per_Object_Hooks{$addr};
# } elsif ($args{target} eq 'hash') {
# my ($addr) = $args{target_arg} =~ $Log::ger::re_addr;
# $all_hooks = $Log::ger::Per_Hash_Hooks{$addr};
# }
# last unless $all_hooks;
# for my $phase (keys %$all_hooks) {
# my $hooks = $all_hooks->{$phase};
# for my $i (reverse 0..$#{$hooks}) {
# splice @$hooks, $i, 1
# if $hooks->[$i][0] =~ $args{replace_package_regex};
# }
# }
# }
#
# for my $phase (keys %$hooks) {
# my $hook = $hooks->{$phase};
# if (defined $args{target}) {
# add_per_target_hook(
# $args{target}, $args{target_arg}, $phase, $hook);
# } else {
# add_hook($phase, $hook);
# }
# }
#
# my $reinit = $args{reinit};
# $reinit = 1 unless defined $reinit;
# if ($reinit) {
# if (defined $args{target}) {
# reinit_target($args{target}, $args{target_arg});
# } else {
# reinit_all_targets();
# }
# }
#}
#
#1;
## ABSTRACT: Utility routines for Log::ger
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Log::ger::Util - Utility routines for Log::ger
#
#=head1 VERSION
#
#version 0.028
#
#=head1 DESCRIPTION
#
#This package is created to keep Log::ger as minimalist as possible.
#
#=for Pod::Coverage ^(.+)$
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017 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
### Mo.pm ###
#package Mo;
#$Mo::VERSION = '0.40';
#$VERSION='0.40';
#no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.'::'.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};
### Mo/Golf.pm ###
###
## name: Mo::Golf
## abstract: Module for Compacting Mo Modules
## author: Ingy döt Net <ingy@ingy.net>
## license: perl
## copyright: 2011
## see:
## - Mo
#
#use strict;
#use warnings;
#package Mo::Golf;
#
#our $VERSION='0.40';
#
#use PPI;
#
## This is the mapping of common names to shorter forms that still make some
## sense.
#my %short_names = (
# (
# map {($_, substr($_, 0, 1))}
# qw(
# args builder class default exports features
# generator import is_lazy method MoPKG name
# nonlazy_defaults options reftype self
# )
# ),
# build_subs => 'B',
# old_constructor => 'C',
# caller_pkg => 'P',
#);
#
#my %short_barewords = ( EAGERINIT => q{':E'}, NONLAZY => q{':N'} );
#
#my %hands_off = map {($_,1)} qw'&import *import';
#
#sub import {
# return unless @_ == 2 and $_[1] eq 'golf';
# binmode STDOUT;
# my $text = do { local $/; <> };
# print STDOUT golf( $text );
#};
#
#sub golf {
# my ( $text ) = @_;
#
# my $tree = PPI::Document->new( \$text );
#
# my %finder_subs = _finder_subs();
#
# my @order = qw( comments duplicate_whitespace whitespace trailing_whitespace );
#
# for my $name ( @order ) {
# my $elements = $tree->find( $finder_subs{$name} );
# die $@ if !defined $elements;
# $_->delete for @{ $elements || [] };
# }
#
# $tree->find( $finder_subs{$_} )
# for qw( del_superfluous_concat del_last_semicolon_in_block separate_version shorten_var_names shorten_barewords );
# die $@ if $@;
#
# for my $name ( 'double_semicolon' ) {
# my $elements = $tree->find( $finder_subs{$name} );
# die $@ if !defined $elements;
# $_->delete for @{ $elements || [] };
# }
#
# return $tree->serialize . "\n";
#}
#
#sub tok { "PPI::Token::$_[0]" }
#
#sub _finder_subs {
# return (
# comments => sub { $_[1]->isa( tok 'Comment' ) },
#
# duplicate_whitespace => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Whitespace' );
#
# $current->set_content(' ') if 1 < length $current->content;
#
# return 0 if !$current->next_token;
# return 0 if !$current->next_token->isa( tok 'Whitespace' );
# return 1;
# },
#
# whitespace => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Whitespace' );
# my $prev = $current->previous_token;
# my $next = $current->next_token;
#
# return 1 if $prev->isa( tok 'Number' ) and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # my $P
# return 1 if $prev->isa( tok 'Word' ) and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # my $P
# return 1 if $prev->isa( tok 'Symbol' ) and $next->isa( tok 'Operator' ) and $next->content =~ /^\W/; # $VERSION = but not $v and
#
# return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Quote::Single' ) and $next->content =~ /^\W/; # eq ''
# return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Quote::Double' ) and $next->content =~ /^\W/; # eq ""
# return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Symbol' ) and $next->content =~ /^\W/; # eq $v
# return 1 if $prev->isa( tok 'Operator' ) and $next->isa( tok 'Structure' ) and $next->content =~ /^\W/; # eq (
#
# return 1 if $prev->isa( tok 'Word' ) and $next->isa( tok 'Symbol' ); # my $P
# return 1 if $prev->isa( tok 'Word' ) and $next->isa( tok 'Structure' ); # sub {
# return 1 if $prev->isa( tok 'Word' ) and $next->isa( tok 'Quote::Double' ); # eval "
# return 1 if $prev->isa( tok 'Symbol' ) and $next->isa( tok 'Structure' ); # %a )
# return 1 if $prev->isa( tok 'ArrayIndex' ) and $next->isa( tok 'Operator' ); # $#_ ?
# return 1 if $prev->isa( tok 'Word' ) and $next->isa( tok 'Cast' ); # exists &$_
# return 0;
# },
#
# trailing_whitespace => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Whitespace' );
# my $prev = $current->previous_token;
#
# return 1 if $prev->isa( tok 'Structure' ); # ;[\n\s]
# return 1 if $prev->isa( tok 'Operator' ) and $prev->content =~ /\W$/; # = 0.24
# return 1 if $prev->isa( tok 'Quote::Double' ); # " .
# return 1 if $prev->isa( tok 'Quote::Single' ); # ' }
#
# return 0;
# },
#
# double_semicolon => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Structure' );
# return 0 if $current->content ne ';';
#
# my $prev = $current->previous_token;
#
# return 0 if !$prev->isa( tok 'Structure' );
# return 0 if $prev->content ne ';';
#
# return 1;
# },
#
# del_last_semicolon_in_block => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( 'PPI::Structure::Block' );
#
# my $last = $current->last_token;
#
# return 0 if !$last->isa( tok 'Structure' );
# return 0 if $last->content ne '}';
#
# my $maybe_semi = $last->previous_token;
#
# return 0 if !$maybe_semi->isa( tok 'Structure' );
# return 0 if $maybe_semi->content ne ';';
#
# $maybe_semi->delete;
#
# return 1;
# },
#
# del_superfluous_concat => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Operator' );
#
# my $prev = $current->previous_token;
# my $next = $current->next_token;
#
# return 0 if $current->content ne '.';
# return 0 if !$prev->isa( tok 'Quote::Double' );
# return 0 if !$next->isa( tok 'Quote::Double' );
#
# $current->delete;
# $prev->set_content( $prev->{separator} . $prev->string . $next->string . $prev->{separator} );
# $next->delete;
#
# return 1;
# },
#
# separate_version => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( 'PPI::Statement' );
#
# my $first = $current->first_token;
# return 0 if $first->content ne '$VERSION';
#
# $current->$_( PPI::Token::Whitespace->new( "\n" ) ) for qw( insert_before insert_after );
#
# return 1;
# },
#
# shorten_var_names => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Symbol' );
#
# my $long_name = $current->canonical;
#
# return 1 if $hands_off{$long_name};
# (my $name = $long_name) =~ s/^([\$\@\%])// or die $long_name;
# my $sigil = $1;
# die "variable $long_name conflicts with shortened var name"
# if grep {
# $name eq $_
# } values %short_names;
#
# my $short_name = $short_names{$name};
# $current->set_content( "$sigil$short_name" ) if $short_name;
#
# return 1;
# },
#
# shorten_barewords => sub {
# my ( $top, $current ) = @_;
# return 0 if !$current->isa( tok 'Word' );
#
# my $name = $current->content;
#
# die "bareword $name conflicts with shortened bareword"
# if grep {
# $name eq $_
# } values %short_barewords;
#
# my $short_name = $short_barewords{$name};
# $current->set_content( $short_name ) if $short_name;
#
# return 1;
# },
# );
#}
#
#=head1 SYNOPSIS
#
# perl -MMo::Golf=golf < src/Mo/foo.pm > lib/Mo/foo.pm
#
#=head1 DESCRIPTION
#
#This is the module that is responsible for taking Mo code (which is
#documented and fairly readable) and reducing it to a single undecipherable
#line.
### Mo/Inline.pm ###
###
## name: Mo::Inline
## abstract: Inline Mo and Features into your package
## author: Ingy döt Net <ingy@ingy.net>
## license: perl
## copyright: 2011
## see:
## - Mo
#
#package Mo::Inline;
#use Mo;
#
#our $VERSION='0.40';
#
#use IO::All;
#
#my $matcher = qr/((?m:^#\s*use Mo(\s.*)?;.*\n))(?:#.*\n)*(?:.{400,}\n)?/;
#
#sub run {
# my $self = shift;
# my @files;
# if (not @_ and -d 'lib') {
# print "Searching the 'lib' directory for a Mo to inline:\n";
# @_ = 'lib';
# }
# if (not @_ or @_ == 1 and $_[0] =~ /^(?:-\?|-h|--help)$/) {
# print usage();
# return 0;
# }
# for my $name (@_) {
# die "No file or directory called '$name'"
# unless -e $name;
# die "'$name' is not a Perl module"
# if -f $name and $name !~ /\.pm$/;
# if (-f $name) {
# push @files, $name;
# }
# elsif (-d $name) {
# push @_, grep /\.pm$/, map { "$_" } io($name)->All_Files;
# }
# }
#
# die "No .pm files specified"
# unless @files;
#
# for my $file (@files) {
# my $text = io($file)->all;
# if ($text !~ $matcher) {
# print "Ignoring $file - No Mo to Inline!\n";
# next;
# }
# $self->inline($file, 1);
# }
#}
#
#sub inline {
# my ($self, $file, $noisy) = @_;
# my $text = io($file)->all;
# $text =~ s/$matcher/"$1" . &inliner($2)/eg;
# io($file)->print($text);
# print "Mo Inlined $file\n"
# if $noisy;
#}
#
#sub inliner {
# my $mo = shift;
# require Mo;
# my @features = grep {$_ ne 'qw'} ($mo =~ /(\w+)/g);
# for (@features) {
# eval "require Mo::$_; 1" or die $@;
# }
# my $inline = '';
# $inline .= $_ for map {
# my $module = $_;
# $module .= '.pm';
# my @lines = io($INC{$module})->chomp->getlines;
# $lines[-1];
# } ('Mo', map { s!::!/!g; "Mo/$_" } @features);
# return <<"...";
## The following line of code was produced from the previous line by
## Mo::Inline version $VERSION
#$inline\@f=qw[@features];use strict;use warnings;
#...
#}
#
#sub usage {
# <<'...';
#Usage: mo-linline <perl module files or directories>
#
#...
#}
#
#1;
#
#=head1 SYNOPSIS
#
#In your Mo module:
#
# # This is effectively your own private Mo(ose) setup
# package MyModule::Mo;
# # use Mo qw'build builder default import';
# 1;
#
#From the command line:
#
# > mo-inline lib/MyModule/Mo.pm
#
#or:
#
# > mo-inline lib/
#
#or (if you are really lazy):
#
# > mo-inline
#
#Then from another module:
#
# package MyModule::Foo;
# use MyModule::Mo; # gets build, builder and default automatically
#
#=head1 DESCRIPTION
#
#Mo is so small that you can easily inline it, along with any feature modules.
#Mo provides a script called C<mo-inline> that will do it for you.
#
#All you need to do is comment out the line that uses Mo, and run C<mo-inline>
#on the file. C<mo-inline> will find such comments and do the inlining for you.
#It will also replace any old inlined Mo with the latest version.
#
#What Mo could you possibly want?
#
#=head1 AUTOMATIC FEATURES
#
#By using the L<Mo::import> feature, all uses of your Mo class will turn on all
#the features you specified. You can override it if you want, but that will be
#the default.
#
#=head1 REAL WORLD EXAMPLES
#
#For real world examples of Mo inlined using C<mo-inline>, see L<YAML::Mo>,
#L<Pegex::Mo> and L<TestML::Mo>.
### Mo/Moose.pm ###
#package Mo::Moose;
#$Mo::Moose::VERSION = '0.40';$M="Mo::";
#$VERSION='0.40';
#*{$M.'Moose::e'}=sub{my($P,$e)=@_;$P=~s/::$//;%$e=(M=>1);require Moose;Moose->import({into=>$P});Moose::Util::MetaRole::apply_metaroles(for=>$P,class_metaroles=>{attribute=>['Attr::Trait']},)};BEGIN{package Attr::Trait;
#$Attr::Trait::VERSION = '0.40';use Moose::Role;around _process_options=>sub{my$orig=shift;my$c=shift;my($n,$o)=@_;$o->{is}||='rw';$o->{lazy}||=1 if defined$o->{default}or defined$o->{builder};$c->$orig(@_)};$INC{'Attr/Trait.pm'}=1}
### Mo/Mouse.pm ###
#package Mo::Mouse;
#$Mo::Mouse::VERSION = '0.40';$M="Mo::";
#$VERSION='0.40';
#*{$M.'Mouse::e'}=sub{my($P,$e)=@_;$P=~s/::$//;%$e=(M=>1);require Mouse;require Mouse::Util::MetaRole;Mouse->import({into=>$P});Mouse::Util::MetaRole::apply_metaroles(for=>$P,class_metaroles=>{attribute=>['Attr::Trait']},)};BEGIN{package Attr::Trait;
#$Attr::Trait::VERSION = '0.40';use Mouse::Role;around _process_options=>sub{my$orig=shift;my$c=shift;my($n,$o)=@_;$o->{is}||='rw';$o->{lazy}||=1 if defined$o->{default}or defined$o->{builder};$c->$orig(@_)};$INC{'Attr/Trait.pm'}=1}
### Mo/build.pm ###
#package Mo::build;
#$Mo::build::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};
### Mo/builder.pm ###
#package Mo::builder;
#$Mo::builder::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};
### Mo/chain.pm ###
#package Mo::chain;
#$Mo::chain::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'chain::e'}=sub{my($P,$e,$o)=@_;$o->{chain}=sub{my($m,$n,%a)=@_;$a{chain}or return$m;sub{$#_?($m->(@_),return$_[0]):$m->(@_)}}};
### Mo/coerce.pm ###
#package Mo::coerce;
#$Mo::coerce::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'coerce::e'}=sub{my($P,$e,$o)=@_;$o->{coerce}=sub{my($m,$n,%a)=@_;$a{coerce}or return$m;sub{$#_?$m->($_[0],$a{coerce}->($_[1])):$m->(@_)}};my$C=$e->{new}||*{$M.Object::new}{CODE};$e->{new}=sub{my$s=$C->(@_);$s->$_($s->{$_})for keys%$s;$s}};
### Mo/default.pm ###
#package Mo::default;
#$Mo::default::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};
### Mo/exporter.pm ###
#package Mo::exporter;
#$Mo::exporter::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'exporter::e'}=sub{my($P)=@_;if(@{$M.EXPORT}){*{$P.$_}=\&{$M.$_}for@{$M.EXPORT}}};
### Mo/import.pm ###
#package Mo::import;
#$Mo::import::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};
### Mo/importer.pm ###
#package Mo::importer;
#$Mo::importer::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'importer::e'}=sub{my($P,$e,$o,$f)=@_;(my$pkg=$P)=~s/::$//;&{$P.'importer'}($pkg,@$f)if defined&{$P.'importer'}};
### Mo/is.pm ###
#package Mo::is;
#$Mo::is::VERSION = '0.40';$M="Mo::";
#$VERSION='0.40';
#*{$M.'is::e'}=sub{my($P,$e,$o)=@_;$o->{is}=sub{my($m,$n,%a)=@_;$a{is}or return$m;sub{$#_&&$a{is}eq'ro'&&caller ne'Mo::coerce'?die$n.' is ro':$m->(@_)}}};
### Mo/nonlazy.pm ###
#package Mo::nonlazy;
#$Mo::nonlazy::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'nonlazy::e'}=sub{${shift().':N'}=1};
### Mo/option.pm ###
#package Mo::option;
#$Mo::option::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'option::e'}=sub{my($P,$e,$o)=@_;$o->{option}=sub{my($m,$n,%a)=@_;$a{option}or return$m;my$n2=$n;*{$P."read_$n2"}=sub{$_[0]->{$n2}};sub{$#_?$m->(@_):$m->(@_,1);$_[0]}}};
### Mo/required.pm ###
#package Mo::required;
#$Mo::required::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];die$n." required"if!exists$a{$n};$s}}$m}};
### Mo/xs.pm ###
#package Mo::xs;
#$Mo::xs::VERSION = '0.40';my$M="Mo::";
#$VERSION='0.40';
#require Class::XSAccessor;*{$M.'xs::e'}=sub{my($P,$e,$o,$f)=@_;$P=~s/::$//;$e->{has}=sub{my($n,%a)=@_;Class::XSAccessor->import(class=>$P,accessors=>{$n=>$n})}if!grep!/^xs$/,@$f};
### Module/Installed/Tiny.pm ###
#package Module::Installed::Tiny;
#
#our $DATE = '2016-08-04'; # DATE
#our $VERSION = '0.003'; # VERSION
#
#use strict;
#use warnings;
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(module_installed module_source);
#
#our $SEPARATOR;
#BEGIN {
# if ($^O =~ /^(dos|os2)/i) {
# $SEPARATOR = '\\';
# } elsif ($^O =~ /^MacOS/i) {
# $SEPARATOR = ':';
# } else {
# $SEPARATOR = '/';
# }
#}
#
#sub _module_source {
# my $name_pm = shift;
#
# for my $entry (@INC) {
# next unless defined $entry;
# my $ref = ref($entry);
# my ($is_hook, @hook_res);
# if ($ref eq 'ARRAY') {
# $is_hook++;
# @hook_res = $entry->[0]->($entry, $name_pm);
# } elsif (UNIVERSAL::can($entry, 'INC')) {
# $is_hook++;
# @hook_res = $entry->INC($name_pm);
# } elsif ($ref eq 'CODE') {
# $is_hook++;
# @hook_res = $entry->($entry, $name_pm);
# } else {
# my $path = "$entry$SEPARATOR$name_pm";
# if (-f $path) {
# open my($fh), "<", $path
# or die "Can't locate $name_pm: $path: $!";
# local $/;
# return scalar <$fh>;
# }
# }
#
# if ($is_hook) {
# next unless @hook_res;
# my $prepend_ref = shift @hook_res if ref($hook_res[0]) eq 'SCALAR';
# my $fh = shift @hook_res if ref($hook_res[0]) eq 'GLOB';
# my $code = shift @hook_res if ref($hook_res[0]) eq 'CODE';
# my $code_state = shift @hook_res if @hook_res;
# if ($fh) {
# my $src = "";
# local $_;
# while (!eof($fh)) {
# $_ = <$fh>;
# if ($code) {
# $code->($code, $code_state);
# }
# $src .= $_;
# }
# $src = $$prepend_ref . $src if $prepend_ref;
# return $src;
# } elsif ($code) {
# my $src = "";
# local $_;
# while ($code->($code, $code_state)) {
# $src .= $_;
# }
# $src = $$prepend_ref . $src if $prepend_ref;
# return $src;
# }
# }
# }
#
# die "Can't locate $name_pm in \@INC (\@INC contains: ".join(" ", @INC).")";
#}
#
#sub module_source {
# my $name = shift;
#
# # convert Foo::Bar -> Foo/Bar.pm
# my $name_pm;
# if ($name =~ /\A\w+(?:::\w+)*\z/) {
# ($name_pm = "$name.pm") =~ s!::!$SEPARATOR!g;
# } else {
# $name_pm = $name;
# }
#
# _module_source $name_pm;
#}
#
#sub module_installed {
# my $name = shift;
#
# # convert Foo::Bar -> Foo/Bar.pm
# my $name_pm;
# if ($name =~ /\A\w+(?:::\w+)*\z/) {
# ($name_pm = "$name.pm") =~ s!::!$SEPARATOR!g;
# } else {
# $name_pm = $name;
# }
#
# return 1 if exists $INC{$name_pm};
#
# if (eval { _module_source $name_pm; 1 }) {
# 1;
# } else {
# 0;
# }
#}
#
#1;
## ABSTRACT: Check if a module is installed, with as little code as possible
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Module::Installed::Tiny - Check if a module is installed, with as little code as possible
#
#=head1 VERSION
#
#This document describes version 0.003 of Module::Installed::Tiny (from Perl distribution Module-Installed-Tiny), released on 2016-08-04.
#
#=head1 SYNOPSIS
#
# use Module::Installed::Tiny qw(module_installed module_source);
#
# # check if a module is available
# if (module_installed "Foo::Bar") {
# # Foo::Bar is available
# } elsif (module_installed "Foo/Baz.pm") {
# # Foo::Baz is available
# }
#
# # get a module's source code, dies on failure
# my $src = module_source("Foo/Baz.pm");
#
#=head1 DESCRIPTION
#
#To check if a module is installed (available), generally the simplest way is to
#try to C<require()> it:
#
# if (eval { require Foo::Bar; 1 }) {
# # Foo::Bar is available
# }
#
#However, this actually loads the module. There are some cases where this is not
#desirable: 1) we have to check a lot of modules (actually loading the modules
#will take a lot of CPU time and memory; 2) some of the modules conflict with one
#another and cannot all be loaded; 3) the module is OS specific and might not
#load under another OS; 4) we simply do not want to execute the module, for
#security or other reasons.
#
#C<Module::Installed::Tiny> provides a routine C<module_installed()> which works
#like Perl's C<require> but does not actually load the module.
#
#This module does not require any other module except L<Exporter>.
#
#=head1 FUNCTIONS
#
#=head2 module_installed($name) => bool
#
#Check that module named C<$name> is available to load. This means that: either
#the module file exists on the filesystem and searchable in C<@INC> and the
#contents of the file can be retrieved, or when there is a require hook in
#C<@INC>, the module's source can be retrieved from the hook.
#
#Note that this does not guarantee that the module can eventually be loaded
#successfully, as there might be syntax or runtime errors in the module's source.
#To check for that, one would need to actually load the module using C<require>.
#
#=head2 module_source($name) => str
#
#Return module's source code, without actually loading it. Die on failure.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Module-Installed-Tiny>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Module-Installed-Tiny>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Installed-Tiny>
#
#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 SEE ALSO
#
#L<Module::Load::Conditional> provides C<check_install> which also does what
#C<module_installed> does, plus can check module version. It also has a couple
#other knobs to customize its behavior. It's less tiny than
#Module::Installed::Tiny though.
#
#L<Module::Path> and L<Module::Path::More>. These modules can also be used to
#check if a module on the filesystem is available. They do not handle require
#hooks, nor do they actually check that the module file is readable.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2016 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 = '2019-07-19'; # DATE
#our $VERSION = '0.939'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#use Complete::Util qw(hashify_answer complete_array_elem complete_hash_key combine_answers modify_answer);
#use Complete::Common qw(:all);
#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_index
# 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,
# },
# },
#};
#sub complete_from_schema {
# my %args = @_;
# my $sch = $args{schema}; # must be normalized
# my $word = $args{word} // "";
#
# my $fres;
# log_trace("[comp][periscomp] entering complete_from_schema, word=<%s>, schema=%s", $word, $sch);
#
# my ($type, $cs) = @{$sch};
#
# # schema might be based on other schemas, if that is the case, let's try to
# # look at Sah::SchemaR::* module to quickly find the base type
# unless ($type =~ /\A(all|any|array|bool|buf|cistr|code|date|duration|float|hash|int|num|obj|re|str|undef)\z/) {
# no strict 'refs';
# my $pkg = "Sah::SchemaR::$type";
# (my $pkg_pm = "$pkg.pm") =~ s!::!/!g;
# eval { require $pkg_pm; 1 };
# if ($@) {
# log_trace("[comp][periscomp] couldn't load schema module %s: %s, skipped", $pkg, $@);
# goto RETURN_RES;
# }
# my $rsch = ${"$pkg\::rschema"};
# $type = $rsch->[0];
# # let's just merge everything, for quick checking of clause
# $cs = {};
# for my $cs0 (@{ $rsch->[1] // [] }) {
# for (keys %$cs0) {
# $cs->{$_} = $cs0->{$_};
# }
# }
# log_trace("[comp][periscomp] retrieving schema from module %s, base type=%s", $pkg, $type);
# }
#
# my $static;
# my $words;
# my $summaries;
# eval {
# if (my $xcomp = $cs->{'x.completion'}) {
# require Module::Installed::Tiny;
# my $comp;
# if (ref($xcomp) eq 'CODE') {
# $comp = $xcomp;
# } else {
# my ($submod, $xcargs);
# if (ref($xcomp) eq 'ARRAY') {
# $submod = $xcomp->[0];
# $xcargs = $xcomp->[1];
# } else {
# $submod = $xcomp;
# $xcargs = {};
# }
# my $mod = "Perinci::Sub::XCompletion::$submod";
# if (Module::Installed::Tiny::module_installed($mod)) {
# log_trace("[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"};
# log_trace("[comp][periscomp] invoking %s's gen_completion(%s) ...", $mod, $xcargs);
# $comp = $fref->(%$xcargs);
# } else {
# log_trace("[comp][periscomp] module %s is not installed, skipped", $mod);
# }
# }
# if ($comp) {
# log_trace("[comp][periscomp] using arg completion routine from schema's 'x.completion' attribute");
# $fres = $comp->(
# %{$args{extras} // {}},
# word=>$word, arg=>$args{arg}, args=>$args{args});
# return; # from eval
# }
# }
#
# if ($cs->{is} && !ref($cs->{is})) {
# log_trace("[comp][periscomp] adding completion from schema's 'is' clause");
# push @$words, $cs->{is};
# push @$summaries, undef;
# $static++;
# return; # from eval. there should not be any other value
# }
# if ($cs->{in}) {
# log_trace("[comp][periscomp] adding completion from schema's 'in' clause");
# for my $i (0..$#{ $cs->{in} }) {
# next if ref $cs->{in}[$i];
# push @$words , $cs->{in}[$i];
# push @$summaries, $cs->{'x.in.summaries'} ? $cs->{'x.in.summaries'}[$i] : undef;
# }
# $static++;
# return; # from eval. there should not be any other value
# }
# if ($cs->{'examples'}) {
# log_trace("[comp][periscomp] adding completion from schema's 'examples' clause");
# for my $eg (@{ $cs->{'examples'} }) {
# if (ref $eg eq 'HASH') {
# next unless defined $eg->{value};
# next if ref $eg->{value};
# push @$words, $eg->{value};
# push @$summaries, $eg->{summary};
# } else {
# next unless defined $eg;
# next if ref $eg;
# push @$words, $eg;
# push @$summaries, undef;
# }
# }
# $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,
# )
# } @{ $cs->{of} }
# );
# goto RETURN_RES; # directly return result
# }
# }
# if ($type eq 'bool') {
# log_trace("[comp][periscomp] adding completion from possible values of bool");
# push @$words, 0, 1;
# push @$summaries, undef, undef;
# $static++;
# return; # from eval
# }
# if ($type eq 'int') {
# my $limit = 100;
# if ($cs->{between} &&
# $cs->{between}[0] - $cs->{between}[0] <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'between' clause");
# for ($cs->{between}[0] .. $cs->{between}[1]) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif ($cs->{xbetween} &&
# $cs->{xbetween}[0] - $cs->{xbetween}[0] <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'xbetween' clause");
# for ($cs->{xbetween}[0]+1 .. $cs->{xbetween}[1]-1) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif (defined($cs->{min}) && defined($cs->{max}) &&
# $cs->{max}-$cs->{min} <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'min' & 'max' clauses");
# for ($cs->{min} .. $cs->{max}) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif (defined($cs->{min}) && defined($cs->{xmax}) &&
# $cs->{xmax}-$cs->{min} <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'min' & 'xmax' clauses");
# for ($cs->{min} .. $cs->{xmax}-1) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif (defined($cs->{xmin}) && defined($cs->{max}) &&
# $cs->{max}-$cs->{xmin} <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'xmin' & 'max' clauses");
# for ($cs->{xmin}+1 .. $cs->{max}) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif (defined($cs->{xmin}) && defined($cs->{xmax}) &&
# $cs->{xmax}-$cs->{xmin} <= $limit) {
# log_trace("[comp][periscomp] adding completion from schema's 'xmin' & 'xmax' clauses");
# for ($cs->{xmin}+1 .. $cs->{xmax}-1) {
# push @$words, $_;
# push @$summaries, undef;
# }
# $static++;
# } elsif (length($word) && $word !~ /\A-?\d*\z/) {
# log_trace("[comp][periscomp] word not an int");
# $words = [];
# $summaries = [];
# } else {
# # do a digit by digit completion
# $words = [];
# $summaries = [];
# 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;
# push @$summaries, undef;
# }
# }
# }
# return; # from eval
# }
# if ($type eq 'float') {
# if (length($word) && $word !~ /\A-?\d*(\.\d*)?\z/) {
# log_trace("[comp][periscomp] word not a float");
# $words = [];
# $summaries = [];
# } else {
# $words = [];
# $summaries = [];
# 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;
# push @$summaries, undef;
# }
# }
# my @orders = sort { $words->[$a] cmp $words->[$b] }
# 0..$#{$words};
# my $words = [map {$words->[$_] } @orders];
# my $summaries = [map {$summaries->[$_]} @orders];
# }
# return; # from eval
# }
# }; # eval
#
# log_trace("[periscomp] complete_from_schema died: %s", $@) if $@;
#
# goto RETURN_RES unless $words;
# $fres = hashify_answer(
# complete_array_elem(array=>$words, summaries=>$summaries, word=>$word),
# {static=>$static && $word eq '' ? 1:0},
# );
#
# RETURN_RES:
# log_trace("[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)
#* `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
#<pm: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 => ''],
# },
# 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`, 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_trace("[comp][periscomp] entering complete_arg_val, arg=<%s>", $args{arg});
# my $fres;
#
# my $extras = $args{extras} // {};
#
# my $meta = $args{meta} or do {
# log_trace("[comp][periscomp] meta is not supplied, declining");
# goto RETURN_RES;
# };
# my $arg = $args{arg} or do {
# log_trace("[comp][periscomp] arg is not supplied, declining");
# goto RETURN_RES;
# };
# 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_trace("[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_trace("[comp][periscomp] using arg completion routine from arg spec's 'completion' property");
# last GET_COMP_ROUTINE;
# }
# my $xcomp = $arg_spec->{'x.completion'};
# if ($xcomp) {
# if (ref($xcomp) eq 'CODE') {
# $comp = $xcomp;
# } else {
# my ($submod, $xcargs);
# if (ref($xcomp) eq 'ARRAY') {
# $submod = $xcomp->[0];
# $xcargs = $xcomp->[1];
# } else {
# $submod = $xcomp;
# $xcargs = {};
# }
# my $mod = "Perinci::Sub::XCompletion::$submod";
# require Module::Installed::Tiny;
# if (Module::Installed::Tiny::module_installed($mod)) {
# log_trace("[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"};
# log_trace("[comp][periscomp] invoking gen_completion() from %s ...", $mod);
# $comp = $fref->(%$xcargs);
# } else {
# log_trace("[comp][periscomp] module %s is not installed, skipped", $mod);
# }
# }
# if ($comp) {
# log_trace("[comp][periscomp] using arg completion routine from arg spec's 'x.completion' attribute");
# last GET_COMP_ROUTINE;
# }
# }
# my $ent = $arg_spec->{'x.schema.entity'};
# if ($ent) {
# require Module::Installed::Tiny;
# my $mod = "Perinci::Sub::ArgEntity::$ent";
# if (Module::Installed::Tiny::module_installed($mod)) {
# log_trace("[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_trace("[comp][periscomp] invoking complete_arg_val() from %s ...", $mod);
# $comp = \&{"$mod\::complete_arg_val"};
# last GET_COMP_ROUTINE;
# } else {
# log_trace("[comp][periscomp] module %s doesn't define complete_arg_val(), skipped", $mod);
# }
# } else {
# log_trace("[comp][periscomp] module %s not installed, skipped", $mod);
# }
# }
# } # GET_COMP_ROUTINE
#
# if ($comp) {
# if (ref($comp) eq 'CODE') {
# log_trace("[comp][periscomp] invoking arg completion routine");
# $fres = $comp->(
# %$extras,
# word=>$word, arg=>$arg, args=>$args{args});
# return; # from eval
# } elsif (ref($comp) eq 'ARRAY') {
# # this is deprecated but will be supported for some time
# log_trace("[comp][periscomp] using array specified in arg completion routine: %s", $comp);
# $fres = complete_array_elem(array=>$comp, word=>$word);
# $static++;
# return; # from eval
# }
#
# log_trace("[comp][periscomp] arg spec's 'completion' property is not a coderef or arrayref");
# if ($args{riap_client} && $args{riap_server_url}) {
# log_trace("[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},
# );
# if ($res->[0] != 200) {
# log_trace("[comp][periscomp] Riap request failed (%s), declining", $res);
# return; # from eval
# }
# $fres = $res->[2];
# return; # from eval
# }
#
# log_trace("[comp][periscomp] declining");
# return; # from eval
# }
#
# my $fres_from_arg_examples;
# COMPLETE_FROM_ARG_EXAMPLES:
# {
# my $egs = $arg_spec->{examples};
# unless ($egs) {
# log_trace("[comp][periscomp] arg spec does not specify examples");
# last COMPLETE_FROM_ARG_EXAMPLES;
# }
# my @array;
# my @summaries;
# for my $eg (@$egs) {
# if (ref $eg eq 'HASH') {
# next unless defined $eg->{value};
# next if ref $eg->{value};
# push @array, $eg->{value};
# push @summaries, $eg->{summary};
# } else {
# next unless defined $eg;
# next if ref $eg;
# push @array, $eg;
# push @summaries, undef;
# }
# }
# $fres_from_arg_examples = complete_array_elem(
# word=>$word, array=>\@array, summaries=>\@summaries);
# $static //= 1;
# } # COMPLETE_FROM_ARG_EXAMPLES
#
# my $fres_from_schema;
# COMPLETE_FROM_SCHEMA:
# {
# my $sch = $arg_spec->{schema};
# unless ($sch) {
# log_trace("[comp][periscomp] arg spec does not specify schema");
# last COMPLETE_FROM_SCHEMA;
# }
# # XXX normalize schema if not normalized
# $fres_from_schema = complete_from_schema(arg=>$arg, extras=>$extras, schema=>$sch, word=>$word);
# $static //= 1;
# } # COMPLETE_FROM_SCHEMA
#
# $fres = combine_answers(grep {defined} (
# $fres_from_arg_examples,
# $fres_from_schema,
# ));
# };
# log_debug("[comp][periscomp] completion died: $@") if $@;
# unless ($fres) {
# log_trace("[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_trace("[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 => ['str*'],
# },
# },
#);
#sub complete_arg_elem {
# require Data::Sah::Normalize;
#
# my %args = @_;
#
# my $fres;
#
# log_trace("[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_trace("[comp][periscomp] meta is not supplied, declining");
# goto RETURN_RES;
# };
# my $arg = $args{arg} or do {
# log_trace("[comp][periscomp] arg is not supplied, declining");
# goto RETURN_RES;
# };
# defined(my $index = $args{index}) or do {
# log_trace("[comp][periscomp] index is not supplied, declining");
# goto RETURN_RES;
# };
# 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_trace("[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_trace("[comp][periscomp] using arg element completion routine from 'element_completion' property");
# last GET_ELCOMP_ROUTINE;
# }
# my $xelcomp = $arg_spec->{'x.element_completion'};
# if ($xelcomp) {
# if (ref($xelcomp) eq 'CODE') {
# $elcomp = $xelcomp;
# } else {
# my ($submod, $xcargs);
# if (ref($xelcomp) eq 'ARRAY') {
# $submod = $xelcomp->[0];
# $xcargs = $xelcomp->[1];
# } else {
# $submod = $xelcomp;
# $xcargs = {};
# }
# my $mod = "Perinci::Sub::XCompletion::$submod";
# require Module::Installed::Tiny;
# if (Module::Installed::Tiny::module_installed($mod)) {
# log_trace("[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"};
# log_trace("[comp][periscomp] invoking gen_completion() from %s ...", $mod);
# $elcomp = $fref->(%$xcargs);
# } else {
# log_trace("[comp][periscomp] module %s is not installed, skipped", $mod);
# }
# }
# if ($elcomp) {
# log_trace("[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::Installed::Tiny;
# my $mod = "Perinci::Sub::ArgEntity::$ent";
# if (Module::Installed::Tiny::module_installed($mod)) {
# log_trace("[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_trace("[comp][periscomp] invoking complete_arg_val() from %s ...", $mod);
# $elcomp = \&{"$mod\::complete_arg_val"};
# last GET_ELCOMP_ROUTINE;
# } else {
# log_trace("[comp][periscomp] module %s doesn't defined complete_arg_val(), skipped", $mod);
# }
# } else {
# log_trace("[comp][periscomp] module %s is not installed, skipped", $mod);
# }
# }
# } # GET_ELCOMP_ROUTINE
#
# $ourextras->{index} = $index;
# if ($elcomp) {
# if (ref($elcomp) eq 'CODE') {
# log_trace("[comp][periscomp] invoking arg element completion routine");
# $fres = $elcomp->(
# %$extras,
# %$ourextras,
# word=>$word);
# return; # from eval
# } elsif (ref($elcomp) eq 'ARRAY') {
# log_trace("[comp][periscomp] using array specified in arg element completion routine: %s", $elcomp);
# $fres = complete_array_elem(array=>$elcomp, word=>$word);
# $static = $word eq '';
# }
#
# log_trace("[comp][periscomp] arg spec's 'element_completion' property is not a coderef or ".
# "arrayref");
# if ($args{riap_client} && $args{riap_server_url}) {
# log_trace("[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,
# index=>$index},
# );
# if ($res->[0] != 200) {
# log_trace("[comp][periscomp] Riap request failed (%s), declining", $res);
# return; # from eval
# }
# $fres = $res->[2];
# return; # from eval
# }
#
# log_trace("[comp][periscomp] declining");
# return; # from eval
# } # if ($elcomp)
#
# my $sch = $arg_spec->{schema};
# unless ($sch) {
# log_trace("[comp][periscomp] arg spec does not specify schema, declining");
# return; # from eval
# };
#
# my $nsch = Data::Sah::Normalize::normalize_schema($sch);
#
# my ($type, $cs) = @$nsch;
# if ($type ne 'array') {
# log_trace("[comp][periscomp] can't complete element for non-array");
# return; # from eval
# }
#
# unless ($cs->{of}) {
# log_trace("[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);
# };
# log_debug("[comp][periscomp] completion died: $@") if $@;
# unless ($fres) {
# log_trace("[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_trace("[comp][periscomp] leaving complete_arg_elem, result=%s", $fres);
# $fres;
#}
#
#$SPEC{complete_arg_index} = {
# v => 1.1,
# summary => 'Given argument name and function metadata, complete arg element index',
# description => <<'_',
#
#This is only relevant for arguments which have `index_completion` property set
#(currently only `hash` type arguments). When that property is not set, will
#simply return undef.
#
#Completion routine will get `%args`, with the following keys:
#
#* `word` (str, the word to be completed)
#* `arg` (str, the argument name which value is currently being completed)
#* `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
#<pm: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 => ''],
# },
# 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`, 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_index {
# require Data::Sah::Normalize;
#
# my %args = @_;
#
# my $fres;
#
# log_trace("[comp][periscomp] entering complete_arg_index, arg=<%s>",
# $args{arg});
#
# my $extras = $args{extras} // {};
#
# my $ourextras = {arg=>$args{arg}, args=>$args{args}};
#
# my $meta = $args{meta} or do {
# log_trace("[comp][periscomp] meta is not supplied, declining");
# goto RETURN_RES;
# };
# my $arg = $args{arg} or do {
# log_trace("[comp][periscomp] arg is not supplied, declining");
# goto RETURN_RES;
# };
# 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_trace("[comp][periscomp] arg '$arg' is not specified in meta, declining");
# goto RETURN_RES;
# };
#
# my $static;
# eval { # completion sub can die, etc.
#
# my $idxcomp;
# GET_IDXCOMP_ROUTINE:
# {
# $idxcomp = $arg_spec->{index_completion};
# if ($idxcomp) {
# log_trace("[comp][periscomp] using arg element index completion routine from 'index_completion' property");
# last GET_IDXCOMP_ROUTINE;
# }
# } # GET_IDXCOMP_ROUTINE
#
# if ($idxcomp) {
# if (ref($idxcomp) eq 'CODE') {
# log_trace("[comp][periscomp] invoking arg element index completion routine");
# $fres = $idxcomp->(
# %$extras,
# %$ourextras,
# word=>$word);
# return; # from eval
# } elsif (ref($idxcomp) eq 'ARRAY') {
# log_trace("[comp][periscomp] using array specified in arg element index completion routine: %s", $idxcomp);
# $fres = complete_array_elem(array=>$idxcomp, word=>$word);
# $static = $word eq '';
# }
#
# log_trace("[comp][periscomp] arg spec's 'index_completion' property is not a coderef or ".
# "arrayref");
# if ($args{riap_client} && $args{riap_server_url}) {
# log_trace("[comp][periscomp] trying to perform complete_arg_index request to Riap server");
# my $res = $args{riap_client}->request(
# complete_arg_index => $args{riap_server_url},
# {(uri=>$args{riap_uri}) x !!defined($args{riap_uri}),
# arg=>$arg, args=>$args{args}, word=>$word},
# );
# if ($res->[0] != 200) {
# log_trace("[comp][periscomp] Riap request failed (%s), declining", $res);
# return; # from eval
# }
# $fres = $res->[2];
# return; # from eval
# }
#
# log_trace("[comp][periscomp] declining");
# return; # from eval
# } # if ($idxcomp)
#
# my $sch = $arg_spec->{schema};
# unless ($sch) {
# log_trace("[comp][periscomp] arg spec does not specify schema, declining");
# return; # from eval
# };
#
# my $nsch = Data::Sah::Normalize::normalize_schema($sch);
#
# my ($type, $cs) = @$nsch;
# if ($type ne 'hash') {
# log_trace("[comp][periscomp] can't complete element index for non-hash");
# return; # from eval
# }
#
# # collect known keys from some clauses
# my %keys;
# if ($cs->{keys}) {
# $keys{$_}++ for keys %{ $cs->{keys} };
# }
# if ($cs->{indices}) {
# $keys{$_}++ for keys %{ $cs->{indices} };
# }
# if ($cs->{req_keys}) {
# $keys{$_}++ for @{ $cs->{req_keys} };
# }
# if ($cs->{allowed_keys}) {
# $keys{$_}++ for @{ $cs->{allowed_keys} };
# }
#
# # exclude keys that have been specified in collected args
# for (keys %{$args{args}{$arg} // {}}) {
# delete $keys{$_};
# }
#
# $fres = complete_hash_key(word => $word, hash => \%keys);
#
# }; # eval
# log_debug("[comp][periscomp] completion died: $@") if $@;
# unless ($fres) {
# log_trace("[comp][periscomp] no index completion from metadata possible, declining");
# goto RETURN_RES;
# }
#
# $fres = hashify_answer($fres);
# $fres->{static} //= $static && $word eq '' ? 1:0;
# RETURN_RES:
# log_trace("[comp][periscomp] leaving complete_arg_index, result=%s", $fres);
# $fres;
#}
#
#$SPEC{complete_cli_arg} = {
# v => 1.1,
# summary => 'Complete command-line argument using Rinci function metadata',
# description => <<'_',
#
#This routine uses <pm:Perinci::Sub::GetArgs::Argv> to generate <pm:Getopt::Long>
#specification from arguments list in Rinci function metadata and common options.
#Then, it will use <pm: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 <pm: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`, 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 <pm: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 <pm: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_trace('[comp][periscomp] entering %s(), words=%s, cword=%d, word=<%s>',
# $fname, $words, $cword, $word);
#
# my $ggls_res = 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: $ggls_res->[0] - $ggls_res->[1]"
# unless $ggls_res->[0] == 200;
# $extras->{ggls_res} = $ggls_res;
# my $gospec = $ggls_res->[2];
# my $specmeta = $ggls_res->[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_trace("[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 $fres;
#
# my %rargs = (
# riap_server_url => $args{riap_server_url},
# riap_uri => $args{riap_uri},
# riap_client => $args{riap_client},
# );
#
# $extras->{parsed_opts} = $cargs{parsed_opts};
#
# if (my $sm = $specmeta->{$ospec}) {
# $cargs{type} = 'optval';
# if ($sm->{arg}) {
# log_trace("[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_trace("[comp][periscomp] invoking routine supplied from 'completion' argument");
# my $compres;
# eval { $compres = $comp->(%cargs) };
# log_debug("[comp][periscomp] completion died: $@") if $@;
# log_trace("[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;
# } elsif ($ospec =~ /\%$/) {
# if ($word =~ /(.*?)=(.*)/s) {
# my $key = $1;
# my $val = $2;
# $fres = complete_arg_elem(
# meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
# word=>$val, index=>$key,
# extras=>$extras, %rargs);
# modify_answer(answer=>$fres, prefix=>"$key=");
# goto RETURN_RES;
# } else {
# $fres = complete_arg_index(
# meta=>$meta, arg=>$sm->{arg}, args=>$gares->[2],
# word=>$word, extras=>$extras, %rargs);
# modify_answer(answer=>$fres, suffix=>"=");
# $fres->{path_sep} = "=";
# # XXX actually not entirely correct, we want normal
# # escaping but without escaping "=", maybe we should
# # allow customizing, e.g. esc_mode=normal, dont_esc="="
# # (list of characters to not escape)
# $fres->{esc_mode} = "none";
# 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_trace("[comp][periscomp] completing option value for a common option, ospec=<%s>", $ospec);
# $cargs{arg} = undef;
# my $codata = $copts_by_ospec->{$ospec};
# if ($comp) {
# log_trace("[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_trace("[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_trace("[comp][periscomp] completing with common option's schema");
# $fres = complete_from_schema(
# schema => $nsch, word=>$word);
# goto RETURN_RES;
# }
# goto RETURN_RES;
# }
# } elsif ($type eq 'arg') {
# log_trace("[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-slurpy argument with the exact position
# for my $an (keys %$args_prop) {
# my $arg_spec = $args_prop->{$an};
# next unless !($arg_spec->{slurpy} // $arg_spec->{greedy}) &&
# defined($arg_spec->{pos}) && $arg_spec->{pos} == $pos - $fasa;
# log_trace("[comp][periscomp] this argument position is for non-slurpy function argument <%s>", $an);
# $cargs{arg} = $an;
# if ($comp) {
# log_trace("[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 slurpy 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->{slurpy} // $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_trace("[comp][periscomp] this position is for slurpy function argument <%s>'s element[%d]", $an, $index);
# if ($comp) {
# log_trace("[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_trace("[comp][periscomp] there is no matching function argument at this position");
# if ($comp) {
# log_trace("[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_trace("[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_trace("[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_trace('[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.939 of Perinci::Sub::Complete (from Perl distribution Perinci-Sub-Complete), released on 2019-07-19.
#
#=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
#
#Usage:
#
# complete_arg_elem(%args) -> array
#
#Given argument name and function metadata, complete array element.
#
#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<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
#L<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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<arg>* => I<str>
#
#Argument name.
#
#=item * B<args> => I<hash>
#
#Collected arguments so far, will be passed to completion routines.
#
#=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<word>, C<cword>, and so on as
#described in the function description will not be overwritten by this.
#
#=item * B<index> => I<str>
#
#Index of element to complete.
#
#=item * B<meta>* => I<hash>
#
#Rinci function metadata, must be normalized.
#
#=item * B<riap_client> => I<obj>
#
#Optional, to perform complete_arg_val to the server.
#
#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>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<riap_uri> => I<str>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<word> => I<str> (default: "")
#
#Word to be completed.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 complete_arg_index
#
#Usage:
#
# complete_arg_index(%args) -> array
#
#Given argument name and function metadata, complete arg element index.
#
#This is only relevant for arguments which have C<index_completion> property set
#(currently only C<hash> type arguments). When that property is not set, will
#simply return undef.
#
#Completion routine will get C<%args>, with the following keys:
#
#=over
#
#=item * C<word> (str, the word to be completed)
#
#=item * C<arg> (str, the argument name which value is currently being completed)
#
#=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
#L<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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<arg>* => I<str>
#
#Argument name.
#
#=item * B<args> => I<hash>
#
#Collected arguments so far, will be passed to completion routines.
#
#=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<word>, C<cword>, and so on as
#described in the function description will not be overwritten by this.
#
#=item * B<meta>* => I<hash>
#
#Rinci function metadata, must be normalized.
#
#=item * B<riap_client> => I<obj>
#
#Optional, to perform complete_arg_val to the server.
#
#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>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<riap_uri> => I<str>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<word> => I<str> (default: "")
#
#Word to be completed.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 complete_arg_val
#
#Usage:
#
# complete_arg_val(%args) -> array
#
#Given argument name and function metadata, complete value.
#
#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<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
#L<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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<arg>* => I<str>
#
#Argument name.
#
#=item * B<args> => I<hash>
#
#Collected arguments so far, will be passed to completion routines.
#
#=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<word>, C<cword>, and so on as
#described in the function description will not be overwritten by this.
#
#=item * B<meta>* => I<hash>
#
#Rinci function metadata, must be normalized.
#
#=item * B<riap_client> => I<obj>
#
#Optional, to perform complete_arg_val to the server.
#
#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>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<riap_uri> => I<str>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<word> => I<str> (default: "")
#
#Word to be completed.
#
#=back
#
#Return value: (array)
#
#
#
#=head2 complete_cli_arg
#
#Usage:
#
# complete_cli_arg(%args) -> hash
#
#Complete command-line argument using Rinci function metadata.
#
#This routine uses L<Perinci::Sub::GetArgs::Argv> to generate L<Getopt::Long>
#specification from arguments list in Rinci function metadata and common options.
#Then, it will use L<Complete::Getopt::Long> to complete option names, option
#values, as well as arguments.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<common_opts> => I<hash>
#
#Common options.
#
#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>
#
#Supply custom completion routine.
#
#If supplied, instead of the default completion routine, this code will be called
#instead. Will receive all arguments that L<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>
#
#On which argument cursor is located (zero-based).
#
#=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<word>, C<cword>, 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)
#
#This is a (temporary?) workaround for L<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>
#
#Rinci function metadata.
#
#=item * B<per_arg_json> => I<bool>
#
#Will be passed to Perinci::Sub::GetArgs::Argv.
#
#=item * B<per_arg_yaml> => I<bool>
#
#Will be passed to Perinci::Sub::GetArgs::Argv.
#
#=item * B<riap_client> => I<obj>
#
#Optional, to perform complete_arg_val to the server.
#
#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>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<riap_uri> => I<str>
#
#Optional, to perform complete_arg_val to the server.
#
#See the C<riap_client> argument.
#
#=item * B<words>* => I<array[str]>
#
#Command-line arguments.
#
#=back
#
#Return value: (hash)
#
#
#You can use C<format_completion> function in L<Complete::Bash> module to format
#the result of this function for bash.
#
#
#
#=head2 complete_from_schema
#
#Usage:
#
# complete_from_schema(%args) -> [status, msg, payload, meta]
#
#Complete a value from schema.
#
#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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<schema>* => I<any>
#
#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 (payload) 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 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 SEE ALSO
#
#L<Complete>, L<Complete::Getopt::Long>
#
#L<Perinci::CmdLine>, L<Perinci::CmdLine::Lite>, L<App::riap>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012, 2011 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 = '2019-06-26'; # DATE
#our $VERSION = '0.843'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
##use Log::Any '$log';
#
#use Data::Sah::Normalize qw(normalize_schema);
#use Data::Sah::Util::Type qw(is_type is_simple);
#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)',
#};
#
## 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;
#}
#
## this subroutine checks whether a schema mentions a coercion rule from simple
## types (e.g. 'str_comma_sep', etc).
#sub _is_coercible_from_simple {
# my $nsch = shift;
# my $cset = $nsch->[1] or return 0;
# my $rules = $cset->{'x.perl.coerce_rules'} // $cset->{'x.coerce_rules'}
# or return 0;
# for my $rule (@$rules) {
# next unless $rule =~ /\A([^_]+)_/;
# return 1 if is_simple($1);
# }
# 0;
#}
#
#sub _is_simple_or_coercible_from_simple {
# my $nsch = shift;
# is_simple($nsch) || _is_coercible_from_simple($nsch);
#}
#
## this routine's job is to avoid using Data::Sah::Resolve unless it needs to, to
## reduce startup overhead
#sub _is_simple_or_array_of_simple_or_hash_of_simple {
# my $nsch = shift;
#
# my $is_simple = 0;
# my $is_array_of_simple = 0;
# my $is_hash_of_simple = 0;
# my $eltype;
#
# my $type = $nsch->[0];
# my $cset = $nsch->[1];
#
# {
# # if not known as builtin type, then resolve it first
# unless (is_type($nsch)) {
# require Data::Sah::Resolve;
# my $res = Data::Sah::Resolve::resolve_schema(
# {merge_clause_sets => 0}, $nsch);
# $type = $res->[0];
# $cset = $res->[1][0] // {};
# }
#
# $is_simple = _is_simple_or_coercible_from_simple([$type, $cset]);
# last if $is_simple;
#
# if ($type eq 'array') {
# my $elnsch = $cset->{of} // $cset->{each_elem};
# last unless $elnsch;
# $elnsch = normalize_schema($elnsch);
# $eltype = $elnsch->[0];
#
# # if not known as builtin type, then resolve it first
# unless (is_type($elnsch)) {
# require Data::Sah::Resolve;
# my $res = Data::Sah::Resolve::resolve_schema(
# {merge_clause_sets => 0}, $elnsch);
# $elnsch = [$res->[0], $res->[1][0] // {}]; # XXX we only take the first clause set
# $eltype = $res->[0];
# }
#
# $is_array_of_simple = _is_simple_or_coercible_from_simple($elnsch);
# last;
# }
#
# if ($type eq 'hash') {
# my $elnsch = $cset->{of} // $cset->{each_value} // $cset->{each_elem};
# last unless $elnsch;
# $elnsch = normalize_schema($elnsch);
# $eltype = $elnsch->[0];
#
# # if not known as builtin type, then resolve it first
# unless (is_type($elnsch)) {
# require Data::Sah::Resolve;
# my $res = Data::Sah::Resolve::resolve_schema(
# {merge_clause_sets => 0}, $elnsch);
# $elnsch = [$res->[0], $res->[1][0] // {}]; # XXX we only take the first clause set
# $eltype = $res->[0];
# }
#
# $is_hash_of_simple = _is_simple_or_coercible_from_simple($elnsch);
# last;
# }
# }
#
# #{ no warnings 'uninitialized'; say "D:$nsch->[0]: is_simple=<$is_simple>, is_array_of_simple=<$is_array_of_simple>, is_hash_of_simple=<$is_hash_of_simple>, type=<$type>, eltype=<$eltype>" };
# ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype);
#}
#
## 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 ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype) =
# _is_simple_or_array_of_simple_or_hash_of_simple($schema);
#
# my (@opts, @types, @isaos, @ishos);
#
# if ($is_array_of_simple || $is_hash_of_simple) {
# my $singular_opt;
# if ($arg_spec && $arg_spec->{'x.name.is_plural'}) {
# if ($arg_spec->{'x.name.singular'}) {
# $singular_opt = _arg2opt($arg_spec->{'x.name.singular'});
# } else {
# require Lingua::EN::PluralToSingular;
# $singular_opt = Lingua::EN::PluralToSingular::to_singular($opt);
# }
# } else {
# $singular_opt = $opt;
# }
# push @opts , $singular_opt;
# push @types, $eltype;
# push @isaos, $is_array_of_simple ? 1:0;
# push @ishos, $is_hash_of_simple ? 1:0;
# }
#
# if ($is_simple || !@opts) {
# push @opts , $opt;
# push @types, $type;
# push @isaos, 0;
# push @ishos, 0;
# }
#
# my @res;
#
# for my $i (0..$#opts) {
# my $opt = $opts[$i];
# my $type = $types[$i];
# my $isaos = $isaos[$i];
# my $ishos = $ishos[$i];
#
# if ($type eq 'bool') {
# if (length $opt == 1) {
# # single-letter option like -b doesn't get --nob.
# push @res, ($opt, {opts=>[$opt]}), undef;
# } elsif ($cset->{is} || $cset->{is_true}) {
# # an always-true bool ('true' or [bool => {is=>1}] or
# # [bool=>{is_true=>1}] also means it's a flag and should not get
# # --nofoo.
# push @res, ($opt, {opts=>[$opt]}), undef;
# } elsif ((defined $cset->{is} && !$cset->{is}) ||
# (defined $cset->{is_true} && !$cset->{is_true})) {
# # an always-false bool ('false' or [bool => {is=>0}] or
# # [bool=>{is_true=>0}] also means it's a flag and should only be
# # getting --nofoo.
# for (negations_for_option($opt)) {
# push @res, $_, {opts=>[$_]}, {is_neg=>1, pos_opts=>[$opt]};
# }
# } else {
# # a regular bool gets --foo as well as --nofoo
# 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]};
# }
# }
# } elsif ($type eq 'buf') {
# push @res, (
# "$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' ? 's' : $type eq 'float' ? 's' : 's') .
# ($isaos ? '@' : $ishos ? '%' : '');
# push @res, ("$opt=$t", {opts=>[$opt], desttype=>"", type=>$t}, undef);
# }
# }
#
# @res;
#}
#
#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};
# next if grep { $_ eq 'hidden' || $_ eq 'hidden-cli' }
# @{ $arg_spec->{tags} // [] };
# my $sch = $arg_spec->{schema} // ['any', {}];
# my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype) =
# _is_simple_or_array_of_simple_or_hash_of_simple($sch);
#
# # XXX normalization of 'of' clause should've been handled by sah itself
# if ($type eq 'array' && $cset->{of}) {
# $cset->{of} = normalize_schema($cset->{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 $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_simple) {
# $val_set = 1; $val = $_[1];
# $rargs->{$arg} = $val;
# } elsif ($is_array_of_simple) {
# $rargs->{$arg} //= [];
# $val_set = 1; $val = $_[1];
# push @{ $rargs->{$arg} }, $val;
# } elsif ($is_hash_of_simple) {
# $rargs->{$arg} //= {};
# $val_set = 1; $val = $_[2];
# $rargs->{$arg}{$_[1]} = $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} && !$is_simple) {
# 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} && !$is_simple) {
# 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 <pm: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 <pm: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.
#
#_
# },
# ggls_res => {
# summary => 'Full result from gen_getopt_long_spec_from_meta()',
# schema => 'array*', # XXX envres
# description => <<'_',
#
#If you already call `gen_getopt_long_spec_from_meta()`, you can pass the _full_ enveloped result
#here, to avoid calculating twice.
#
#_
# tags => ['category:optimization'],
# },
# },
# 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 = $fargs{ggls_res} // 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", "no_getopt_compat", "gnu_compat", "bundling");
# 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 ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $cset, $eltype) =
# _is_simple_or_array_of_simple_or_hash_of_simple($arg_spec->{schema});
#
# if (($arg_spec->{slurpy} // $arg_spec->{greedy}) && ref($val) eq 'ARRAY' &&
# !$is_array_of_simple && !$is_hash_of_simple) {
# 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->{slurpy} // $arg_spec->{greedy}) && !$is_simple) {
# 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->{slurpy} // $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.843 of Perinci::Sub::GetArgs::Argv (from Perl distribution Perinci-Sub-GetArgs-Argv), released on 2019-06-26.
#
#=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
#
#Usage:
#
# gen_getopt_long_spec_from_meta(%args) -> [status, msg, payload, meta]
#
#Generate Getopt::Long spec from Rinci function metadata.
#
#This routine will produce a L<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).
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<args> => I<hash>
#
#Reference to hash which will store the result.
#
#=item * B<common_opts> => I<hash>
#
#Common options.
#
#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)
#
#Whether to ignore coderefs converted to string.
#
#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>
#
#Rinci function metadata.
#
#=item * B<meta_is_normalized> => I<bool>
#
#=item * B<per_arg_json> => I<bool> (default: 0)
#
#Whether to add --NAME-json for non-simple arguments.
#
#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)
#
#Whether to add --NAME-yaml for non-simple arguments.
#
#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 (payload) 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
#
#Usage:
#
# get_args_from_argv(%args) -> [status, msg, payload, meta]
#
#Get subroutine arguments (%args) from command-line arguments (@ARGV).
#
#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 L<Getopt::Long>'s C<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.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<allow_extra_elems> => I<bool> (default: 0)
#
#Allow extra/unassigned elements in argv.
#
#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>
#
#Specify input args, with some arguments preset.
#
#=item * B<argv> => I<array[str]>
#
#If not specified, defaults to @ARGV
#
#=item * B<common_opts> => I<hash>
#
#Common options.
#
#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<ggls_res> => I<array>
#
#Full result from gen_getopt_long_spec_from_meta().
#
#If you already call C<gen_getopt_long_spec_from_meta()>, you can pass the I<full> enveloped result
#here, to avoid calculating twice.
#
#=item * B<ignore_converted_code> => I<bool> (default: 0)
#
#Whether to ignore coderefs converted to string.
#
#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)
#
#Can be set to 1 if your metadata is normalized, to avoid duplicate effort.
#
#=item * B<on_missing_required_args> => I<code>
#
#Execute code when there is missing required args.
#
#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)
#
#Whether to recognize --ARGNAME-json.
#
#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)
#
#Whether to recognize --ARGNAME-yaml.
#
#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)
#
#Strict mode.
#
#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 (payload) is optional, the actual result. Fourth
#element (meta) is called result metadata and is optional, a hash
#that contains extra information.
#
#Return value: (any)
#
#
#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 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 SEE ALSO
#
#L<Perinci>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2017, 2016, 2015, 2014, 2013, 2012, 2011 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;
#
#our $DATE = '2019-04-15'; # DATE
#our $VERSION = '0.170'; # VERSION
#
#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 %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
#};
#
#$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
#`slurpy` 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->{slurpy} // $as->{greedy}) {
# my $type = $as->{schema}[0];
# my @elems = splice(@$ary, $i);
# if ($type eq 'array') {
# $rargs->{$a} = \@elems;
# } elsif ($type eq 'hash') {
# $rargs->{$a} = {};
# for my $j (0..$#elems) {
# my $elem = $elems[$j];
# unless ($elem =~ /(.*?)=(.*)/) {
# return [400, "Invalid key=value pair in element #$j"];
# }
# $rargs->{$a}{$1} = $2;
# }
# } 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 (%args) from array
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Perinci::Sub::GetArgs::Array - Get subroutine arguments (%args) from array
#
#=head1 VERSION
#
#This document describes version 0.170 of Perinci::Sub::GetArgs::Array (from Perl distribution Perinci-Sub-GetArgs-Array), released on 2019-04-15.
#
#=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
#
#Usage:
#
# get_args_from_array(%args) -> [status, msg, payload, meta]
#
#Get subroutine arguments (%args) from array.
#
#Using information in metadata's C<args> property (particularly the C<pos> and
#C<slurpy> 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=E<gt>[2, 3], meta=E<gt>$meta) >> will produce:
#
# [200, "OK", {a=>2, b=>3}]
#
#This function is not exported by default, but exportable.
#
#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
#
#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 (payload) is optional, the actual result. Fourth
#element (meta) is called result metadata and is optional, a hash
#that contains extra information.
#
#Return value: (any)
#
#=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/perlancar/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 SEE ALSO
#
#L<Perinci>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2016, 2015, 2014, 2013, 2012, 2011 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/Normalize.pm ###
#package Perinci::Sub::Normalize;
#
#our $DATE = '2018-09-10'; # DATE
#our $VERSION = '0.200'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# normalize_function_metadata
# );
#
#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;
#
# require Sah::Schema::rinci::function_meta;
# my $sch = $Sah::Schema::rinci::function_meta::schema;
# my $sch_proplist = $sch->[1]{_prop}
# or die "BUG: Rinci schema structure changed (1a)";
#
# _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.200 of Perinci::Sub::Normalize (from Perl distribution Perinci-Sub-Normalize), released on 2018-09-10.
#
#=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 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 SEE ALSO
#
#L<Rinci::function>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2018, 2016, 2015, 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
### Perinci/Sub/Util.pm ###
#package Perinci::Sub::Util;
#
#our $DATE = '2017-01-31'; # DATE
#our $VERSION = '0.46'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# err
# caller
# warn_err
# die_err
# gen_modified_sub
# gen_curried_sub
# );
#
#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 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]");
#}
#
#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}];
#}
#
#$SPEC{gen_curried_sub} = {
# v => 1.1,
# summary => 'Generate curried subroutine (and its metadata)',
# description => <<'_',
#
#This is a more convenient helper than `gen_modified_sub` if you want to create a
#new subroutine that has some of its arguments preset (so they no longer need to
#be present in the new metadata).
#
#For more general needs of modifying a subroutine (e.g. add some arguments,
#modify some arguments, etc) use `gen_modified_sub`.
#
#_
# 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.
#
#_
# req => 1,
# pos => 0,
# },
# set_args => {
# summary => 'Arguments to set',
# schema => 'hash*',
# },
# 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.
#
#_
# req => 1,
# pos => 2,
# },
# },
# args_as => 'array',
# result_naked => 1,
#};
#sub gen_curried_sub {
# my ($base_name, $set_args, $output_name) = @_;
#
# my $caller = CORE::caller();
#
# my ($base_pkg, $base_leaf);
# if ($base_name =~ /(.+)::(.+)/) {
# ($base_pkg, $base_leaf) = ($1, $2);
# } else {
# $base_pkg = $caller;
# $base_leaf = $base_name;
# }
#
# my ($output_pkg, $output_leaf);
# if ($output_name =~ /(.+)::(.+)/) {
# ($output_pkg, $output_leaf) = ($1, $2);
# } else {
# $output_pkg = $caller;
# $output_leaf = $output_name;
# }
#
# my $base_sub = \&{"$base_pkg\::$base_leaf"};
#
# my $res = gen_modified_sub(
# base_name => "$base_pkg\::$base_leaf",
# output_name => "$output_pkg\::$output_leaf",
# output_code => sub {
# no strict 'refs';
# $base_sub->(@_, %$set_args);
# },
# remove_args => [keys %$set_args],
# install => 1,
# );
#
# die "Can't generate curried sub: $res->[0] - $res->[1]"
# unless $res->[0] == 200;
#
# 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.46 of Perinci::Sub::Util (from Perl distribution Perinci-Sub-Util), released on 2017-01-31.
#
#=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 die_err() and warn_err():
#
# use Perinci::Sub::Util qw(warn_err die_err);
# warn_err(403, "Forbidden");
# die_err(403, "Forbidden");
#
#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 gen_curried_sub():
#
# use Perinci::Sub::Util qw(gen_curried_sub);
#
# $SPEC{list_users} = {
# v => 1.1,
# args => {
# search => {},
# is_suspended => {},
# },
# };
# sub list_users { ... }
#
# # simpler/shorter than gen_modified_sub, but can be used for currying only
# gen_curried_sub('list_users', {is_suspended=>1}, 'list_suspended_users');
#
#=head1 FUNCTIONS
#
#
#=head2 gen_curried_sub($base_name, $output_name, $set_args) -> any
#
#Generate curried subroutine (and its metadata).
#
#This is a more convenient helper than C<gen_modified_sub> if you want to create a
#new subroutine that has some of its arguments preset (so they no longer need to
#be present in the new metadata).
#
#For more general needs of modifying a subroutine (e.g. add some arguments,
#modify some arguments, etc) use C<gen_modified_sub>.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=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.
#
#=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.
#
#=item * B<$set_args> => I<hash>
#
#Arguments to set.
#
#=back
#
#Return value: (any)
#
#
#=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).
#
#This function is not exported by default, but exportable.
#
#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)
#
#=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]";
#
#=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 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 SEE ALSO
#
#L<Perinci>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2017 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/Args.pm ###
#package Perinci::Sub::Util::Args;
#
#our $DATE = '2017-01-31'; # DATE
#our $VERSION = '0.46'; # VERSION
#
#use 5.010001;
#use strict 'subs', 'vars';
#use warnings;
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(
# args_by_tag
# argnames_by_tag
# func_args_by_tag
# func_argnames_by_tag
# call_with_its_args
#);
#
#sub args_by_tag {
# my ($meta, $args, $tag) = @_;
#
# my @res;
# my $args_prop = $meta->{args} or return ();
# my $neg = $tag =~ s/\A!//;
# for my $argname (keys %$args_prop) {
# my $argspec = $args_prop->{$argname};
# if ($neg) {
# next unless !$argspec->{tags} ||
# !(grep {$_ eq $tag} @{$argspec->{tags}});
# } else {
# next unless $argspec->{tags} &&
# grep {$_ eq $tag} @{$argspec->{tags}};
# }
# push @res, $argname, $args->{$argname}
# if exists $args->{$argname};
# }
# @res;
#}
#
#sub argnames_by_tag {
# my ($meta, $tag) = @_;
#
# my @res;
# my $args_prop = $meta->{args} or return ();
# my $neg = 1 if $tag =~ s/\A!//;
# for my $argname (keys %$args_prop) {
# my $argspec = $args_prop->{$argname};
# if ($neg) {
# next unless !$argspec->{tags} ||
# !(grep {$_ eq $tag} @{$argspec->{tags}});
# } else {
# next unless $argspec->{tags} &&
# grep {$_ eq $tag} @{$argspec->{tags}};
# }
# push @res, $argname;
# }
# sort @res;
#}
#
#sub _find_meta {
# my $caller = shift;
# my $func_name = shift;
#
# if ($func_name =~ /(.+)::(.+)/) {
# return ${"$1::SPEC"}{$2};
# } else {
# return ${"$caller->[0]::SPEC"}{$func_name};
# }
#}
#
#sub func_args_by_tag {
# my ($func_name, $args, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# args_by_tag($meta, $args, $tag);
#}
#
#sub func_argnames_by_tag {
# my ($func_name, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# argnames_by_tag($meta, $tag);
#}
#
#sub call_with_its_args {
# my ($func_name, $args) = @_;
#
# my ($meta, $func);
# if ($func_name =~ /(.+)::(.+)/) {
# defined &{$func_name}
# or die "Function $func_name not defined";
# $func = \&{$func_name};
# $meta = ${"$1::SPEC"}{$2};
# } else {
# my @caller = caller(1);
# my $fullname = "$caller[0]::$func_name";
# defined &{$fullname}
# or die "Function $fullname not defined";
# $func = \&{$fullname};
# $meta = ${"$caller[0]::SPEC"}{$func_name};
# }
# $meta or die "Can't find Rinci function metadata for $func_name";
#
# my @args;
# if ($meta->{args}) {
# for my $argname (keys %{ $meta->{args} }) {
# push @args, $argname, $args->{$argname}
# if exists $args->{$argname};
# }
# }
# $func->(@args);
#}
#
#1;
## ABSTRACT: Utility routines related to Rinci arguments
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Perinci::Sub::Util::Args - Utility routines related to Rinci arguments
#
#=head1 VERSION
#
#This document describes version 0.46 of Perinci::Sub::Util::Args (from Perl distribution Perinci-Sub-Util), released on 2017-01-31.
#
#=head1 SYNOPSIS
#
# package MyPackage;
#
# use Perinci::Sub::Util::Args qw(
# args_by_tag
# argnames_by_tag
# func_args_by_tag
# func_argnames_by_tag
# call_with_its_args
# );
#
# our %SPEC;
#
# my %func1_args;
#
# $SPEC{myfunc1} = {
# v => 1.1,
# summary => 'My function one',
# args => {
# %func1_args = (
# foo => {tags=>['t1', 't2']},
# bar => {tags=>['t2', 't3']},
# baz => {},
# ),
# },
# };
# sub myfunc1 {
# my %args = @_;
# }
#
# $SPEC{myfunc2} = {
# v => 1.1,
# summary => 'My function two',
# args => {
# %func1_args,
# qux => {tags=>['t3']},
# },
# };
# sub myfunc2 {
# my %args = @_;
# my $res = call_with_its_args('myfunc1', \%args);
# }
#
#=head1 DESCRIPTION
#
#=head1 FUNCTIONS
#
#=head2 args_by_tag
#
#Usage:
#
# my %args = args_by_tag($meta, \%args0, $tag);
#
#Will select only keypairs from C<%args0> arguments which have tag C<$tag>.
#Examples:
#
# my %args = args_by_tag($SPEC{myfunc1}, {foo=>1, bar=>2, baz=>3, qux=>4}, 't2'); # (foo=>1, bar=>2)
#
#=head2 argnames_by_tag
#
#Usage:
#
# my @arg_names = argnames_by_tag($meta, $tag);
#
#Will select only argument names which have tag C<$tag>.
#
#=head2 func_args_by_tag
#
#Usage:
#
# my %args = func_args_by_tag($func_name, \%args0, $tag);
#
#Like L</args_by_tag> except that instead of supplying Rinci function metadata,
#you supply a function name. Rinci metadata will be searched in C<%SPEC>
#variable.
#
#=head2 func_argnames_by_tag
#
#Usage:
#
# my @argnames = func_argnames_by_tag($func_name, $tag);
#
#Like L</argnames_by_tag> except that instead of supplying Rinci function
#metadata, you supply a function name. Rinci metadata will be searched in
#C<%SPEC> variable.
#
#=head2 call_with_its_args
#
#Usage:
#
# my $res = call_with_its_args($func_name, \%args);
#
#Call function with arguments taken from C<%args>. Only arguments which the
#function declares it accepts will be passed.
#
#=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) 2017 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 = '2017-01-31'; # DATE
#our $VERSION = '0.46'; # 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.46 of Perinci::Sub::Util::ResObj (from Perl distribution Perinci-Sub-Util), released on 2017-01-31.
#
#=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) 2017 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 = '2017-01-31'; # DATE
#our $VERSION = '0.46'; # 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.46 of Perinci::Sub::Util::Sort (from Perl distribution Perinci-Sub-Util), released on 2017-01-31.
#
#=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) 2017 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
### Regexp/Stringify.pm ###
#package Regexp::Stringify;
#
#our $DATE = '2016-10-29'; # DATE
#our $VERSION = '0.06'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use re qw(regexp_pattern);
#
#use Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(stringify_regexp);
#
#our %SPEC;
#
#$SPEC{stringify_regexp} = {
# v => 1.1,
# summary => 'Stringify a Regexp object',
# description => <<'_',
#
#This routine is an alternative to Perl's default stringification of Regexp
#object (i.e.:`"$re"`) and has some features/options, e.g.: producing regexp
#string that is compatible with certain perl versions.
#
#If given a string (or other non-Regexp object), will return it as-is.
#
#_
# args => {
# regexp => {
# schema => 're*',
# req => 1,
# pos => 0,
# },
# plver => {
# summary => 'Target perl version',
# schema => 'str*',
# description => <<'_',
#
#Try to produce a regexp object compatible with a certain perl version (should at
#least be >= 5.10).
#
#For example, in perl 5.14 regex stringification changes, e.g. `qr/hlagh/i` would
#previously be stringified as `(?i-xsm:hlagh)`, but now it's stringified as
#`(?^i:hlagh)`. If you set `plver` to 5.10 or 5.12, then this routine will
#still produce the former. It will also ignore regexp modifiers that are
#introduced in newer perls.
#
#Note that not all regexp objects are translatable to older perls, e.g. if they
#contain constructs not known to older perls like `(?^...)` before perl 5.14.
#
#_
# },
# with_qr => {
# schema => 'bool',
# description => <<'_',
#
#If you set this to 1, then `qr/a/i` will be stringified as `'qr/a/i'` instead as
#`'(?^i:a)'`. The resulting string can then be eval-ed to recreate the Regexp
#object.
#
#_
# },
# },
# result_naked => 1,
# result => {
# schema => 'str*',
# },
#};
#sub stringify_regexp {
# my %args = @_;
#
# my $re = $args{regexp};
# return $re unless ref($re) eq 'Regexp';
# my $plver = $args{plver} // $^V;
#
# my ($pat, $mod) = regexp_pattern($re);
#
# my $ge_5140 = version->parse($plver) >= version->parse('5.14.0');
# unless ($ge_5140) {
# $mod =~ s/[adlu]//g;
# }
#
# if ($args{with_qr}) {
# return "qr($pat)$mod";
# } else {
# if ($ge_5140) {
# return "(^$mod:$pat)";
# } else {
# return "(?:(?$mod-)$pat)";
# }
# }
#}
#
#1;
## ABSTRACT: Stringify a Regexp object
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Regexp::Stringify - Stringify a Regexp object
#
#=head1 VERSION
#
#This document describes version 0.06 of Regexp::Stringify (from Perl distribution Regexp-Stringify), released on 2016-10-29.
#
#=head1 SYNOPSIS
#
#Assuming this runs on Perl 5.14 or newer.
#
# use Regexp::Stringify qw(stringify_regexp);
# $str = stringify_regexp(regexp=>qr/a/i); # '(^i:a)'
# $str = stringify_regexp(regexp=>qr/a/i, with_qr=>1); # 'qr(a)i'
# $str = stringify_regexp(regexp=>qr/a/i, plver=>5.010); # '(?:(?i-)a)'
# $str = stringify_regexp(regexp=>qr/a/ui, plver=>5.010); # '(?:(?i-)a)'
#
#=head1 FUNCTIONS
#
#
#=head2 stringify_regexp(%args) -> str
#
#Stringify a Regexp object.
#
#This routine is an alternative to Perl's default stringification of Regexp
#object (i.e.:C<"$re">) and has some features/options, e.g.: producing regexp
#string that is compatible with certain perl versions.
#
#If given a string (or other non-Regexp object), will return it as-is.
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<plver> => I<str>
#
#Target perl version.
#
#Try to produce a regexp object compatible with a certain perl version (should at
#least be >= 5.10).
#
#For example, in perl 5.14 regex stringification changes, e.g. C<qr/hlagh/i> would
#previously be stringified as C<(?i-xsm:hlagh)>, but now it's stringified as
#C<(?^i:hlagh)>. If you set C<plver> to 5.10 or 5.12, then this routine will
#still produce the former. It will also ignore regexp modifiers that are
#introduced in newer perls.
#
#Note that not all regexp objects are translatable to older perls, e.g. if they
#contain constructs not known to older perls like C<(?^...)> before perl 5.14.
#
#=item * B<regexp>* => I<re>
#
#=item * B<with_qr> => I<bool>
#
#If you set this to 1, then C<qr/a/i> will be stringified as C<'qr/a/i'> instead as
#C<'(?^i:a)'>. The resulting string can then be eval-ed to recreate the Regexp
#object.
#
#=back
#
#Return value: (str)
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Regexp-Stringify>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Regexp-Stringify>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Regexp-Stringify>
#
#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) 2016 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/function_meta.pm ###
#package Sah::Schema::rinci::function_meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Data::Sah::Normalize ();
#use Sah::Schema::rinci::meta ();
#
#our $schema = [hash => {
# summary => 'Rinci function metadata',
#
# # tmp
# _ver => 1.1,
# _prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# # from common rinci metadata
# entity_v => {},
# entity_date => {},
# links => {},
#
# is_func => {},
# is_meth => {},
# is_class_meth => {},
# args => {
# _value_prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# # common rinci metadata
# links => {},
#
# schema => {},
# filters => {},
# default => {},
# req => {},
# pos => {},
# slurpy => {},
# greedy => {}, # old alias for slurpy, will be removed in Rinci 1.2
# partial => {},
# stream => {},
# is_password => {},
# cmdline_aliases => {
# _value_prop => {
# summary => {},
# description => {},
# schema => {},
# code => {},
# is_flag => {},
# },
# },
# cmdline_on_getopt => {},
# cmdline_prompt => {},
# completion => {},
# index_completion => {},
# element_completion => {},
# cmdline_src => {},
# meta => 'fix',
# element_meta => 'fix',
# deps => {
# _keys => {
# arg => {},
# all => {},
# any => {},
# none => {},
# },
# },
# examples => {},
# },
# },
# args_as => {},
# args_rels => {},
# result => {
# _prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# schema => {},
# statuses => {
# _value_prop => {
# # from defhash
# summary => {},
# description => {},
# schema => {},
# },
# },
# partial => {},
# stream => {},
# },
# },
# result_naked => {},
# examples => {
# _elem_prop => {
# %Sah::Schema::rinci::meta::_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 => {},
# },
# },
# },
#}, {}];
#
#$schema->[1]{_prop}{args}{_value_prop}{meta} = $schema->[1];
#$schema->[1]{_prop}{args}{_value_prop}{element_meta} = $schema->[1];
#
## just so the dzil plugin won't complain about schema not being normalized.
## because this is a circular structure and normalizing creates a shallow copy.
#
#$schema = Data::Sah::Normalize::normalize_schema($schema);
#
#1;
## ABSTRACT: Rinci function metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::Schema::rinci::function_meta - Rinci function metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::Schema::rinci::function_meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/meta.pm ###
#package Sah::Schema::rinci::meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#our %_dh_props = (
# v => {},
# defhash_v => {},
# name => {},
# caption => {},
# summary => {},
# description => {},
# tags => {},
# default_lang => {},
# x => {},
#);
#
#our $schema = [hash => {
# summary => 'Rinci metadata',
# # tmp
# _ver => 1.1, # this has the effect of version checking
# _prop => {
# %_dh_props,
#
# entity_v => {},
# entity_date => {},
# links => {
# _elem_prop => {
# %_dh_props,
#
# url => {},
# },
# },
# },
#}, {}];
#
#1;
## ABSTRACT: Rinci metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::Schema::rinci::meta - Rinci metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::Schema::rinci::meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/result_meta.pm ###
#package Sah::Schema::rinci::result_meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Sah::Schema::rinci::meta;
#
#our $schema = [hash => {
# summary => 'Rinci envelope result metadata',
#
# # tmp
# _ver => 1.1,
# _prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# schema => {},
# perm_err => {},
# func => {}, # XXX func.*
# cmdline => {}, # XXX cmdline.*
# logs => {},
# prev => {},
# results => {},
# part_start => {},
# part_len => {},
# len => {},
# stream => {},
# },
#}, {}];
#
#1;
## ABSTRACT: Rinci envelope result metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::Schema::rinci::result_meta - Rinci envelope result metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::Schema::rinci::result_meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/SchemaR/rinci/function_meta.pm ###
#package Sah::SchemaR::rinci::function_meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#our $rschema = do{my$a=["hash",[{_prop=>{args=>{_value_prop=>{caption=>{},cmdline_aliases=>{_value_prop=>{code=>{},description=>{},is_flag=>{},schema=>{},summary=>{}}},cmdline_on_getopt=>{},cmdline_prompt=>{},cmdline_src=>{},completion=>{},default=>{},default_lang=>{},defhash_v=>{},deps=>{_keys=>{all=>{},any=>{},arg=>{},none=>{}}},description=>{},element_completion=>{},element_meta=>{_prop=>'fix',_ver=>1.1,summary=>"Rinci function metadata"},examples=>{},filters=>{},greedy=>{},index_completion=>{},is_password=>{},links=>{},meta=>'fix',name=>{},partial=>{},pos=>{},req=>{},schema=>{},slurpy=>{},stream=>{},summary=>{},tags=>{},v=>{},x=>{}}},args_as=>{},args_rels=>{},caption=>'fix',default_lang=>'fix',defhash_v=>'fix',deps=>{_keys=>{all=>{},any=>{},code=>{},env=>{},func=>{},none=>{},pkg=>{},prog=>{},tmp_dir=>{},trash_dir=>{}}},description=>'fix',entity_date=>{},entity_v=>{},examples=>{_elem_prop=>{args=>{},argv=>{},caption=>'fix',default_lang=>'fix',defhash_v=>'fix',description=>'fix',name=>'fix',result=>{},src=>{},src_plang=>{},status=>{},summary=>'fix',tags=>'fix',test=>{},v=>'fix',x=>'fix'}},features=>{_keys=>{check_arg=>{},dry_run=>{},idempotent=>{},immutable=>{},pure=>{},reverse=>{},tx=>{}}},is_class_meth=>{},is_func=>{},is_meth=>{},links=>{},name=>'fix',result=>{_prop=>{caption=>'fix',default_lang=>'fix',defhash_v=>'fix',description=>'fix',name=>'fix',partial=>{},schema=>{},statuses=>{_value_prop=>{description=>{},schema=>{},summary=>{}}},stream=>{},summary=>'fix',tags=>'fix',v=>'fix',x=>'fix'}},result_naked=>{},summary=>'fix',tags=>'fix',v=>'fix',x=>'fix'},_ver=>1.1,summary=>"Rinci function metadata"}],["hash"]];$a->[1][0]{_prop}{args}{_value_prop}{element_meta}{_prop}=$a->[1][0]{_prop};$a->[1][0]{_prop}{args}{_value_prop}{meta}=$a->[1][0]{_prop}{args}{_value_prop}{element_meta};$a->[1][0]{_prop}{caption}=$a->[1][0]{_prop}{args}{_value_prop}{caption};$a->[1][0]{_prop}{default_lang}=$a->[1][0]{_prop}{args}{_value_prop}{default_lang};$a->[1][0]{_prop}{defhash_v}=$a->[1][0]{_prop}{args}{_value_prop}{defhash_v};$a->[1][0]{_prop}{description}=$a->[1][0]{_prop}{args}{_value_prop}{description};$a->[1][0]{_prop}{examples}{_elem_prop}{caption}=$a->[1][0]{_prop}{args}{_value_prop}{caption};$a->[1][0]{_prop}{examples}{_elem_prop}{default_lang}=$a->[1][0]{_prop}{args}{_value_prop}{default_lang};$a->[1][0]{_prop}{examples}{_elem_prop}{defhash_v}=$a->[1][0]{_prop}{args}{_value_prop}{defhash_v};$a->[1][0]{_prop}{examples}{_elem_prop}{description}=$a->[1][0]{_prop}{args}{_value_prop}{description};$a->[1][0]{_prop}{examples}{_elem_prop}{name}=$a->[1][0]{_prop}{args}{_value_prop}{name};$a->[1][0]{_prop}{examples}{_elem_prop}{summary}=$a->[1][0]{_prop}{args}{_value_prop}{summary};$a->[1][0]{_prop}{examples}{_elem_prop}{tags}=$a->[1][0]{_prop}{args}{_value_prop}{tags};$a->[1][0]{_prop}{examples}{_elem_prop}{v}=$a->[1][0]{_prop}{args}{_value_prop}{v};$a->[1][0]{_prop}{examples}{_elem_prop}{x}=$a->[1][0]{_prop}{args}{_value_prop}{x};$a->[1][0]{_prop}{name}=$a->[1][0]{_prop}{args}{_value_prop}{name};$a->[1][0]{_prop}{result}{_prop}{caption}=$a->[1][0]{_prop}{args}{_value_prop}{caption};$a->[1][0]{_prop}{result}{_prop}{default_lang}=$a->[1][0]{_prop}{args}{_value_prop}{default_lang};$a->[1][0]{_prop}{result}{_prop}{defhash_v}=$a->[1][0]{_prop}{args}{_value_prop}{defhash_v};$a->[1][0]{_prop}{result}{_prop}{description}=$a->[1][0]{_prop}{args}{_value_prop}{description};$a->[1][0]{_prop}{result}{_prop}{name}=$a->[1][0]{_prop}{args}{_value_prop}{name};$a->[1][0]{_prop}{result}{_prop}{summary}=$a->[1][0]{_prop}{args}{_value_prop}{summary};$a->[1][0]{_prop}{result}{_prop}{tags}=$a->[1][0]{_prop}{args}{_value_prop}{tags};$a->[1][0]{_prop}{result}{_prop}{v}=$a->[1][0]{_prop}{args}{_value_prop}{v};$a->[1][0]{_prop}{result}{_prop}{x}=$a->[1][0]{_prop}{args}{_value_prop}{x};$a->[1][0]{_prop}{summary}=$a->[1][0]{_prop}{args}{_value_prop}{summary};$a->[1][0]{_prop}{tags}=$a->[1][0]{_prop}{args}{_value_prop}{tags};$a->[1][0]{_prop}{v}=$a->[1][0]{_prop}{args}{_value_prop}{v};$a->[1][0]{_prop}{x}=$a->[1][0]{_prop}{args}{_value_prop}{x};$a};
#
#1;
## ABSTRACT: Rinci function metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::SchemaR::rinci::function_meta - Rinci function metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::SchemaR::rinci::function_meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 DESCRIPTION
#
#This module is automatically generated by Dist::Zilla::Plugin::Sah::Schemas during distribution build.
#
#A Sah::SchemaR::* module is useful if a client wants to quickly lookup the base type of a schema without having to do any extra resolving. With Sah::Schema::*, one might need to do several lookups if a schema is based on another schema, and so on. Compare for example L<Sah::Schema::poseven> vs L<Sah::SchemaR::poseven>, where in Sah::SchemaR::poseven one can immediately get that the base type is C<int>. Currently L<Perinci::Sub::Complete> uses Sah::SchemaR::* instead of Sah::Schema::* for reduced startup overhead when doing tab completion.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/SchemaR/rinci/meta.pm ###
#package Sah::SchemaR::rinci::meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#our $rschema = do{my$a=["hash",[{_prop=>{caption=>{},default_lang=>{},defhash_v=>{},description=>{},entity_date=>{},entity_v=>{},links=>{_elem_prop=>{caption=>'fix',default_lang=>'fix',defhash_v=>'fix',description=>'fix',name=>{},summary=>{},tags=>{},url=>{},v=>{},x=>{}}},name=>'fix',summary=>'fix',tags=>'fix',v=>'fix',x=>'fix'},_ver=>1.1,summary=>"Rinci metadata"}],["hash"]];$a->[1][0]{_prop}{links}{_elem_prop}{caption}=$a->[1][0]{_prop}{caption};$a->[1][0]{_prop}{links}{_elem_prop}{default_lang}=$a->[1][0]{_prop}{default_lang};$a->[1][0]{_prop}{links}{_elem_prop}{defhash_v}=$a->[1][0]{_prop}{defhash_v};$a->[1][0]{_prop}{links}{_elem_prop}{description}=$a->[1][0]{_prop}{description};$a->[1][0]{_prop}{name}=$a->[1][0]{_prop}{links}{_elem_prop}{name};$a->[1][0]{_prop}{summary}=$a->[1][0]{_prop}{links}{_elem_prop}{summary};$a->[1][0]{_prop}{tags}=$a->[1][0]{_prop}{links}{_elem_prop}{tags};$a->[1][0]{_prop}{v}=$a->[1][0]{_prop}{links}{_elem_prop}{v};$a->[1][0]{_prop}{x}=$a->[1][0]{_prop}{links}{_elem_prop}{x};$a};
#
#1;
## ABSTRACT: Rinci metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::SchemaR::rinci::meta - Rinci metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::SchemaR::rinci::meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 DESCRIPTION
#
#This module is automatically generated by Dist::Zilla::Plugin::Sah::Schemas during distribution build.
#
#A Sah::SchemaR::* module is useful if a client wants to quickly lookup the base type of a schema without having to do any extra resolving. With Sah::Schema::*, one might need to do several lookups if a schema is based on another schema, and so on. Compare for example L<Sah::Schema::poseven> vs L<Sah::SchemaR::poseven>, where in Sah::SchemaR::poseven one can immediately get that the base type is C<int>. Currently L<Perinci::Sub::Complete> uses Sah::SchemaR::* instead of Sah::Schema::* for reduced startup overhead when doing tab completion.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/SchemaR/rinci/result_meta.pm ###
#package Sah::SchemaR::rinci::result_meta;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#our $rschema = ["hash",[{_prop=>{caption=>{},cmdline=>{},default_lang=>{},defhash_v=>{},description=>{},func=>{},len=>{},logs=>{},name=>{},part_len=>{},part_start=>{},perm_err=>{},prev=>{},results=>{},schema=>{},stream=>{},summary=>{},tags=>{},v=>{},x=>{}},_ver=>1.1,summary=>"Rinci envelope result metadata"}],["hash"]];
#
#1;
## ABSTRACT: Rinci envelope result metadata
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::SchemaR::rinci::result_meta - Rinci envelope result metadata
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::SchemaR::rinci::result_meta (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 DESCRIPTION
#
#This module is automatically generated by Dist::Zilla::Plugin::Sah::Schemas during distribution build.
#
#A Sah::SchemaR::* module is useful if a client wants to quickly lookup the base type of a schema without having to do any extra resolving. With Sah::Schema::*, one might need to do several lookups if a schema is based on another schema, and so on. Compare for example L<Sah::Schema::poseven> vs L<Sah::SchemaR::poseven>, where in Sah::SchemaR::poseven one can immediately get that the base type is C<int>. Currently L<Perinci::Sub::Complete> uses Sah::SchemaR::* instead of Sah::Schema::* for reduced startup overhead when doing tab completion.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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) 2019, 2018, 2016 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/Schemas/Rinci.pm ###
#package Sah::Schemas::Rinci;
#
#our $DATE = '2019-05-24'; # DATE
#our $VERSION = '1.1.90.0'; # VERSION
#
#1;
## ABSTRACT: Sah schemas for Rinci
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Sah::Schemas::Rinci - Sah schemas for Rinci
#
#=head1 VERSION
#
#This document describes version 1.1.90.0 of Sah::Schemas::Rinci (from Perl distribution Sah-Schemas-Rinci), released on 2019-05-24.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Sah-Schemas-Rinci>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Sah-Schemas-Rinci>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sah-Schemas-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 SEE ALSO
#
#L<Sah> - specification
#
#L<Data::Sah>
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2018, 2016 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/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 String-LineNumber), 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 = '2016-10-07'; # DATE
#our $VERSION = '0.02'; # 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 as Perl does
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#String::PerlQuote - Quote a string as Perl does
#
#=head1 VERSION
#
#This document describes version 0.02 of String::PerlQuote (from Perl distribution String-PerlQuote), released on 2016-10-07.
#
#=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) 2016 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;
#
#our $DATE = '2019-07-25'; # DATE
#our $VERSION = '0.040'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# $RE_WILDCARD_BASH
# contains_wildcard
# convert_wildcard_to_sql
# convert_wildcard_to_re
# );
#
#our $re_bash_brace_element =
# qr(
# (?:(?:\\\\ | \\, | \\\{ | \\\} | [^\\\{,\}])*)
# )x;
#
## note: order is important here, brace encloses the other
#our $RE_WILDCARD_BASH =
# qr(
# # non-escaped brace expression, with at least one comma
# (?P<bash_brace>
# (?<!\\)(?P<slashes_before_bash_brace>\\\\)*\{
# (?P<bash_brace_content>
# $re_bash_brace_element(?:, $re_bash_brace_element )+
# )
# (?<!\\)(?:\\\\)*\}
# )
# |
# # 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<literal_brace_single_element>
# (?<!\\)(?:\\\\)*\{
# $re_bash_brace_element
# (?<!\\)(?:\\\\)*\}
# )
# |
# (?P<bash_class>
# # non-empty, non-escaped character class
# (?<!\\)(?:\\\\)*\[
# (?: \\\\ | \\\[ | \\\] | [^\\\[\]] )+
# (?<!\\)(?:\\\\)*\]
# )
# |
# (?P<bash_joker>
# # non-escaped * and ?
# (?<!\\)(?:\\\\)*(?:\*\*?|\?)
# )
# |
# (?P<sql_joker>
# # non-escaped % and ?
# (?<!\\)(?:\\\\)*[%_]
# )
# |
# (?P<literal>
# [^\\\[\]\{\}*?%_]+
# |
# .+?
# )
# )ox;
#
#sub contains_wildcard {
# my $str = shift;
#
# while ($str =~ /$RE_WILDCARD_BASH/go) {
# my %m = %+;
# return 1 if $m{bash_brace} || $m{bash_class} || $m{bash_joker};
# }
# 0;
#}
#
#sub convert_wildcard_to_sql {
# my $str = shift;
#
# $str =~ s/$RE_WILDCARD_BASH/
# if ($+{bash_joker}) {
# if ($+{bash_joker} eq '*') {
# "%";
# } else {
# "_";
# }
# } elsif ($+{sql_joker}) {
# "\\$+{sql_joker}";
# } else {
# $&;
# }
# /eg;
#
# $str;
#}
#
#sub convert_wildcard_to_re {
# my $opts = ref $_[0] eq 'HASH' ? shift : {};
# my $str = shift;
#
# my $opt_brace = $opts->{brace} // 1;
# my $opt_dotglob = $opts->{dotglob} // 0;
#
# my @res;
# my $p;
# while ($str =~ /$RE_WILDCARD_BASH/g) {
# my %m = %+;
# if (defined($p = $m{bash_brace_content})) {
# push @res, quotemeta($m{slashes_before_bash_brace}) if
# $m{slashes_before_bash_brace};
# if ($opt_brace) {
# my @elems;
# while ($p =~ /($re_bash_brace_element)(,|\z)/g) {
# push @elems, $1;
# last unless $2;
# }
# #use DD; dd \@elems;
# push @res, "(?:", join("|", map {
# convert_wildcard_to_re({
# bash_brace => 0,
# dotglob => $opt_dotglob || @res,
# }, $_)} @elems), ")";
# } else {
# push @res, quotemeta($m{bash_brace});
# }
#
# } elsif (defined($p = $m{bash_joker})) {
# if ($p eq '?') {
# push @res, '.';
# } elsif ($p eq '*') {
# push @res, $opt_dotglob || @res ? '.*' : '[^.].*';
# } elsif ($p eq '**') {
# push @res, '.*';
# }
#
# } elsif (defined($p = $m{literal_brace_single_element})) {
# push @res, quotemeta($p);
# } elsif (defined($p = $m{bash_class})) {
# # XXX no need to escape some characters?
# push @res, $p;
# } elsif (defined($p = $m{sql_joker})) {
# push @res, quotemeta($p);
# } elsif (defined($p = $m{literal})) {
# push @res, quotemeta($p);
# }
# }
#
# join "", @res;
#}
#
#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.040 of String::Wildcard::Bash (from Perl distribution String-Wildcard-Bash), released on 2019-07-25.
#
#=head1 SYNOPSIS
#
# use String::Wildcard::Bash qw(
# $RE_WILDCARD_BASH
# contains_wildcard
# convert_wildcard_to_sql
# convert_wildcard_to_re
# );
#
# say 1 if contains_wildcard("")); # -> 0
# say 1 if contains_wildcard("ab*")); # -> 1
# say 1 if contains_wildcard("ab\\*")); # -> 0
#
# say convert_wildcard_to_sql("foo*"); # -> "foo%"
#
# say convert_wildcard_to_re("foo*"); # -> "foo.*"
#
#=head1 DESCRIPTION
#
#=for Pod::Coverage ^(qqquote)$
#
#=head1 VARIABLES
#
#=head2 $RE_WILDCARD_BASH
#
#=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.
#
#For more specific needs, e.g. you want to check if a string just contains joker
#and not other types of wildcard patterns, use L</"$RE_WILDCARD_BASH"> directly.
#
#=head2 convert_wildcard_to_sql
#
#Usage:
#
# $sql_str = convert_wildcard_to_sql($wildcard_str);
#
#Convert bash wildcard to SQL pattern. This includes:
#
#=over
#
#=item * converting unescaped C<*> to C<%>
#
#=item * converting unescaped C<?> to C<_>
#
#=item * escaping unescaped C<%>
#
#=item * escaping unescaped C<_>
#
#=back
#
#Unsupported constructs currently will be passed as-is.
#
#=head2 convert_wildcard_to_re
#
#Usage:
#
# $re_str = convert_wildcard_to_re([ \%opts, ] $wildcard_str);
#
#Convert bash wildcard to regular expression string.
#
#Known options:
#
#=over
#
#=item * brace
#
#Bool. Default is true. Whether to expand braces or not. If set to false, will
#simply treat brace as literals.
#
#Examples:
#
# convert_wildcard_to_re( "{a,b}"); # => "(?:a|b)"
# convert_wildcard_to_re({brace=>0}, "{a,b}"); # => "\\{a\\,b\\}"
#
#=item * dotglob
#
#Bool. Default is false. Whether joker C<*> (asterisk) will match a dot file. The
#default behavior follows bash; that is, dot file must be matched explicitly with
#C<.*>.
#
#This setting is similar to shell behavior (shopt) setting C<dotglob>.
#
#Examples:
#
# convert_wildcard_to_re({} , '*a*'); # => "[^.].*a.*"
# convert_wildcard_to_re({dotglob=>1}, '*a*'); # => ".*a.*"
#
#=back
#
#=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 SEE ALSO
#
#L<Regexp::Wildcards> can also convert a string with wildcard pattern to
#equivalent regexp pattern, like L</convert_wildcard_to_re>. 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. String::Wildcard::Bash's C<convert_wildcard_to_re> follows bash
#behavior more closely and also provides more options.
#
#Other C<String::Wildcard::*> modules.
#
#=head1 AUTHOR
#
#perlancar <perlancar@cpan.org>
#
#=head1 COPYRIGHT AND LICENSE
#
#This software is copyright (c) 2019, 2015, 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
### YAML/Old.pm ###
#package YAML::Old;
#our $VERSION = '1.23';
#
#use YAML::Old::Mo;
#
#use Exporter;
#push @YAML::Old::ISA, 'Exporter';
#our @EXPORT = qw{ Dump Load };
#our @EXPORT_OK = qw{ freeze thaw DumpFile LoadFile Bless Blessed };
#our (
# $UseCode, $DumpCode, $LoadCode,
# $SpecVersion,
# $UseHeader, $UseVersion, $UseBlock, $UseFold, $UseAliases,
# $Indent, $SortKeys, $Preserve,
# $AnchorPrefix, $CompressSeries, $InlineSeries, $Purity,
# $Stringify, $Numify
#);
#
#
#use YAML::Old::Node; # XXX This is a temp fix for Module::Build
#use Scalar::Util qw/ openhandle /;
#
## XXX This VALUE nonsense needs to go.
#use constant VALUE => "\x07YAML\x07VALUE\x07";
#
## YAML Object Properties
#has dumper_class => default => sub {'YAML::Old::Dumper'};
#has loader_class => default => sub {'YAML::Old::Loader'};
#has dumper_object => default => sub {$_[0]->init_action_object("dumper")};
#has loader_object => default => sub {$_[0]->init_action_object("loader")};
#
#sub Dump {
# my $yaml = YAML::Old->new;
# $yaml->dumper_class($YAML::DumperClass)
# if $YAML::DumperClass;
# return $yaml->dumper_object->dump(@_);
#}
#
#sub Load {
# my $yaml = YAML::Old->new;
# $yaml->loader_class($YAML::LoaderClass)
# if $YAML::LoaderClass;
# return $yaml->loader_object->load(@_);
#}
#
#{
# no warnings 'once';
# # freeze/thaw is the API for Storable string serialization. Some
# # modules make use of serializing packages on if they use freeze/thaw.
# *freeze = \ &Dump;
# *thaw = \ &Load;
#}
#
#sub DumpFile {
# my $OUT;
# my $filename = shift;
# if (openhandle $filename) {
# $OUT = $filename;
# }
# else {
# my $mode = '>';
# if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
# ($mode, $filename) = ($1, $2);
# }
# open $OUT, $mode, $filename
# or YAML::Old::Mo::Object->die('YAML_DUMP_ERR_FILE_OUTPUT', $filename, "$!");
# }
# binmode $OUT, ':utf8'; # if $Config{useperlio} eq 'define';
# local $/ = "\n"; # reset special to "sane"
# print $OUT Dump(@_);
# unless (ref $filename eq 'GLOB') {
# close $OUT
# or do {
# my $errsav = $!;
# YAML::Old::Mo::Object->die('YAML_DUMP_ERR_FILE_OUTPUT_CLOSE', $filename, $errsav);
# }
# }
#}
#
#sub LoadFile {
# my $IN;
# my $filename = shift;
# if (openhandle $filename) {
# $IN = $filename;
# }
# else {
# open $IN, '<', $filename
# or YAML::Old::Mo::Object->die('YAML_LOAD_ERR_FILE_INPUT', $filename, "$!");
# }
# binmode $IN, ':utf8'; # if $Config{useperlio} eq 'define';
# return Load(do { local $/; <$IN> });
#}
#
#sub init_action_object {
# my $self = shift;
# my $object_class = (shift) . '_class';
# my $module_name = $self->$object_class;
# eval "require $module_name";
# $self->die("Error in require $module_name - $@")
# if $@ and "$@" !~ /Can't locate/;
# my $object = $self->$object_class->new;
# $object->set_global_options;
# return $object;
#}
#
#my $global = {};
#sub Bless {
# require YAML::Old::Dumper::Base;
# YAML::Old::Dumper::Base::bless($global, @_)
#}
#sub Blessed {
# require YAML::Old::Dumper::Base;
# YAML::Old::Dumper::Base::blessed($global, @_)
#}
#sub global_object { $global }
#
#1;
### YAML/Old/Dumper.pm ###
#package YAML::Old::Dumper;
#
#use YAML::Old::Mo;
#extends 'YAML::Old::Dumper::Base';
#
#use YAML::Old::Dumper::Base;
#use YAML::Old::Node;
#use YAML::Old::Types;
#use Scalar::Util qw();
#use B ();
#use Carp ();
#
## Context constants
#use constant KEY => 3;
#use constant BLESSED => 4;
#use constant FROMARRAY => 5;
#use constant VALUE => "\x07YAML\x07VALUE\x07";
#
## Common YAML character sets
#my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
#my $LIT_CHAR = '|';
#
##==============================================================================
## OO version of Dump. YAML->new->dump($foo);
#sub dump {
# my $self = shift;
# $self->stream('');
# $self->document(0);
# for my $document (@_) {
# $self->{document}++;
# $self->transferred({});
# $self->id_refcnt({});
# $self->id_anchor({});
# $self->anchor(1);
# $self->level(0);
# $self->offset->[0] = 0 - $self->indent_width;
# $self->_prewalk($document);
# $self->_emit_header($document);
# $self->_emit_node($document);
# }
# return $self->stream;
#}
#
## Every YAML document in the stream must begin with a YAML header, unless
## there is only a single document and the user requests "no header".
#sub _emit_header {
# my $self = shift;
# my ($node) = @_;
# if (not $self->use_header and
# $self->document == 1
# ) {
# $self->die('YAML_DUMP_ERR_NO_HEADER')
# unless ref($node) =~ /^(HASH|ARRAY)$/;
# $self->die('YAML_DUMP_ERR_NO_HEADER')
# if ref($node) eq 'HASH' and keys(%$node) == 0;
# $self->die('YAML_DUMP_ERR_NO_HEADER')
# if ref($node) eq 'ARRAY' and @$node == 0;
# # XXX Also croak if aliased, blessed, or ynode
# $self->headless(1);
# return;
# }
# $self->{stream} .= '---';
## XXX Consider switching to 1.1 style
# if ($self->use_version) {
## $self->{stream} .= " #YAML:1.0";
# }
#}
#
## Walk the tree to be dumped and keep track of its reference counts.
## This function is where the Dumper does all its work. All type
## transfers happen here.
#sub _prewalk {
# my $self = shift;
# my $stringify = $self->stringify;
# my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
#
# # Handle typeglobs
# if ($type eq 'GLOB') {
# $self->transferred->{$node_id} =
# YAML::Old::Type::glob->yaml_dump($_[0]);
# $self->_prewalk($self->transferred->{$node_id});
# return;
# }
#
# # Handle regexps
# if (ref($_[0]) eq 'Regexp') {
# return;
# }
#
# # Handle Purity for scalars.
# # XXX can't find a use case yet. Might be YAGNI.
# if (not ref $_[0]) {
# $self->{id_refcnt}{$node_id}++ if $self->purity;
# return;
# }
#
# # Make a copy of original
# my $value = $_[0];
# ($class, $type, $node_id) = $self->node_info($value, $stringify);
#
# # Must be a stringified object.
# return if (ref($value) and not $type);
#
# # Look for things already transferred.
# if ($self->transferred->{$node_id}) {
# (undef, undef, $node_id) = (ref $self->transferred->{$node_id})
# ? $self->node_info($self->transferred->{$node_id}, $stringify)
# : $self->node_info(\ $self->transferred->{$node_id}, $stringify);
# $self->{id_refcnt}{$node_id}++;
# return;
# }
#
# # Handle code refs
# if ($type eq 'CODE') {
# $self->transferred->{$node_id} = 'placeholder';
# YAML::Old::Type::code->yaml_dump(
# $self->dump_code,
# $_[0],
# $self->transferred->{$node_id}
# );
# ($class, $type, $node_id) =
# $self->node_info(\ $self->transferred->{$node_id}, $stringify);
# $self->{id_refcnt}{$node_id}++;
# return;
# }
#
# # Handle blessed things
# if (defined $class) {
# if ($value->can('yaml_dump')) {
# $value = $value->yaml_dump;
# }
# elsif ($type eq 'SCALAR') {
# $self->transferred->{$node_id} = 'placeholder';
# YAML::Old::Type::blessed->yaml_dump
# ($_[0], $self->transferred->{$node_id});
# ($class, $type, $node_id) =
# $self->node_info(\ $self->transferred->{$node_id}, $stringify);
# $self->{id_refcnt}{$node_id}++;
# return;
# }
# else {
# $value = YAML::Old::Type::blessed->yaml_dump($value);
# }
# $self->transferred->{$node_id} = $value;
# (undef, $type, $node_id) = $self->node_info($value, $stringify);
# }
#
# # Handle YAML Blessed things
# require YAML::Old;
# if (defined YAML::Old->global_object()->{blessed_map}{$node_id}) {
# $value = YAML::Old->global_object()->{blessed_map}{$node_id};
# $self->transferred->{$node_id} = $value;
# ($class, $type, $node_id) = $self->node_info($value, $stringify);
# $self->_prewalk($value);
# return;
# }
#
# # Handle hard refs
# if ($type eq 'REF' or $type eq 'SCALAR') {
# $value = YAML::Old::Type::ref->yaml_dump($value);
# $self->transferred->{$node_id} = $value;
# (undef, $type, $node_id) = $self->node_info($value, $stringify);
# }
#
# # Handle ref-to-glob's
# elsif ($type eq 'GLOB') {
# my $ref_ynode = $self->transferred->{$node_id} =
# YAML::Old::Type::ref->yaml_dump($value);
#
# my $glob_ynode = $ref_ynode->{&VALUE} =
# YAML::Old::Type::glob->yaml_dump($$value);
#
# (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
# $self->transferred->{$node_id} = $glob_ynode;
# $self->_prewalk($glob_ynode);
# return;
# }
#
# # Increment ref count for node
# return if ++($self->{id_refcnt}{$node_id}) > 1;
#
# # Keep on walking
# if ($type eq 'HASH') {
# $self->_prewalk($value->{$_})
# for keys %{$value};
# return;
# }
# elsif ($type eq 'ARRAY') {
# $self->_prewalk($_)
# for @{$value};
# return;
# }
#
# # Unknown type. Need to know about it.
# $self->warn(<<"...");
#YAML::Old::Dumper can't handle dumping this type of data.
#Please report this to the author.
#
#id: $node_id
#type: $type
#class: $class
#value: $value
#
#...
#
# return;
#}
#
## Every data element and sub data element is a node.
## Everything emitted goes through this function.
#sub _emit_node {
# my $self = shift;
# my ($type, $node_id);
# my $ref = ref($_[0]);
# if ($ref) {
# if ($ref eq 'Regexp') {
# $self->_emit(' !!perl/regexp');
# $self->_emit_str("$_[0]");
# return;
# }
# (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
# }
# else {
# $type = $ref || 'SCALAR';
# (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
# }
#
# my ($ynode, $tag) = ('') x 2;
# my ($value, $context) = (@_, 0);
#
# if (defined $self->transferred->{$node_id}) {
# $value = $self->transferred->{$node_id};
# $ynode = ynode($value);
# if (ref $value) {
# $tag = defined $ynode ? $ynode->tag->short : '';
# (undef, $type, $node_id) =
# $self->node_info($value, $self->stringify);
# }
# else {
# $ynode = ynode($self->transferred->{$node_id});
# $tag = defined $ynode ? $ynode->tag->short : '';
# $type = 'SCALAR';
# (undef, undef, $node_id) =
# $self->node_info(
# \ $self->transferred->{$node_id},
# $self->stringify
# );
# }
# }
# elsif ($ynode = ynode($value)) {
# $tag = $ynode->tag->short;
# }
#
# if ($self->use_aliases) {
# $self->{id_refcnt}{$node_id} ||= 0;
# if ($self->{id_refcnt}{$node_id} > 1) {
# if (defined $self->{id_anchor}{$node_id}) {
# $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
# return;
# }
# my $anchor = $self->anchor_prefix . $self->{anchor}++;
# $self->{stream} .= ' &' . $anchor;
# $self->{id_anchor}{$node_id} = $anchor;
# }
# }
#
# return $self->_emit_str("$value") # Stringified object
# if ref($value) and not $type;
# return $self->_emit_scalar($value, $tag)
# if $type eq 'SCALAR' and $tag;
# return $self->_emit_str($value)
# if $type eq 'SCALAR';
# return $self->_emit_mapping($value, $tag, $node_id, $context)
# if $type eq 'HASH';
# return $self->_emit_sequence($value, $tag)
# if $type eq 'ARRAY';
# $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
# return $self->_emit_str("$value");
#}
#
## A YAML mapping is akin to a Perl hash.
#sub _emit_mapping {
# my $self = shift;
# my ($value, $tag, $node_id, $context) = @_;
# $self->{stream} .= " !$tag" if $tag;
#
# # Sometimes 'keys' fails. Like on a bad tie implementation.
# my $empty_hash = not(eval {keys %$value});
# $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
# return ($self->{stream} .= " {}\n") if $empty_hash;
#
# # If CompressSeries is on (default) and legal is this context, then
# # use it and make the indent level be 2 for this node.
# if ($context == FROMARRAY and
# $self->compress_series and
# not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
# ) {
# $self->{stream} .= ' ';
# $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
# }
# else {
# $context = 0;
# $self->{stream} .= "\n"
# unless $self->headless && not($self->headless(0));
# $self->offset->[$self->level+1] =
# $self->offset->[$self->level] + $self->indent_width;
# }
#
# $self->{level}++;
# my @keys;
# if ($self->sort_keys == 1) {
# if (ynode($value)) {
# @keys = keys %$value;
# }
# else {
# @keys = sort keys %$value;
# }
# }
# elsif ($self->sort_keys == 2) {
# @keys = sort keys %$value;
# }
# # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
# elsif (ref($self->sort_keys) eq 'ARRAY') {
# my $i = 1;
# my %order = map { ($_, $i++) } @{$self->sort_keys};
# @keys = sort {
# (defined $order{$a} and defined $order{$b})
# ? ($order{$a} <=> $order{$b})
# : ($a cmp $b);
# } keys %$value;
# }
# else {
# @keys = keys %$value;
# }
# # Force the YAML::VALUE ('=') key to sort last.
# if (exists $value->{&VALUE}) {
# for (my $i = 0; $i < @keys; $i++) {
# if ($keys[$i] eq &VALUE) {
# splice(@keys, $i, 1);
# push @keys, &VALUE;
# last;
# }
# }
# }
#
# for my $key (@keys) {
# $self->_emit_key($key, $context);
# $context = 0;
# $self->{stream} .= ':';
# $self->_emit_node($value->{$key});
# }
# $self->{level}--;
#}
#
## A YAML series is akin to a Perl array.
#sub _emit_sequence {
# my $self = shift;
# my ($value, $tag) = @_;
# $self->{stream} .= " !$tag" if $tag;
#
# return ($self->{stream} .= " []\n") if @$value == 0;
#
# $self->{stream} .= "\n"
# unless $self->headless && not($self->headless(0));
#
# # XXX Really crufty feature. Better implemented by ynodes.
# if ($self->inline_series and
# @$value <= $self->inline_series and
# not (scalar grep {ref or /\n/} @$value)
# ) {
# $self->{stream} =~ s/\n\Z/ /;
# $self->{stream} .= '[';
# for (my $i = 0; $i < @$value; $i++) {
# $self->_emit_str($value->[$i], KEY);
# last if $i == $#{$value};
# $self->{stream} .= ', ';
# }
# $self->{stream} .= "]\n";
# return;
# }
#
# $self->offset->[$self->level + 1] =
# $self->offset->[$self->level] + $self->indent_width;
# $self->{level}++;
# for my $val (@$value) {
# $self->{stream} .= ' ' x $self->offset->[$self->level];
# $self->{stream} .= '-';
# $self->_emit_node($val, FROMARRAY);
# }
# $self->{level}--;
#}
#
## Emit a mapping key
#sub _emit_key {
# my $self = shift;
# my ($value, $context) = @_;
# $self->{stream} .= ' ' x $self->offset->[$self->level]
# unless $context == FROMARRAY;
# $self->_emit_str($value, KEY);
#}
#
## Emit a blessed SCALAR
#sub _emit_scalar {
# my $self = shift;
# my ($value, $tag) = @_;
# $self->{stream} .= " !$tag";
# $self->_emit_str($value, BLESSED);
#}
#
#sub _emit {
# my $self = shift;
# $self->{stream} .= join '', @_;
#}
#
## Emit a string value. YAML has many scalar styles. This routine attempts to
## guess the best style for the text.
#sub _emit_str {
# my $self = shift;
# my $type = $_[1] || 0;
#
# # Use heuristics to find the best scalar emission style.
# $self->offset->[$self->level + 1] =
# $self->offset->[$self->level] + $self->indent_width;
# $self->{level}++;
#
# my $sf = $type == KEY ? '' : ' ';
# my $sb = $type == KEY ? '? ' : ' ';
# my $ef = $type == KEY ? '' : "\n";
# my $eb = "\n";
#
# while (1) {
# $self->_emit($sf),
# $self->_emit_plain($_[0]),
# $self->_emit($ef), last
# if not defined $_[0];
# $self->_emit($sf, '=', $ef), last
# if $_[0] eq VALUE;
# $self->_emit($sf),
# $self->_emit_double($_[0]),
# $self->_emit($ef), last
# if $_[0] =~ /$ESCAPE_CHAR/;
# if ($_[0] =~ /\n/) {
# $self->_emit($sb),
# $self->_emit_block($LIT_CHAR, $_[0]),
# $self->_emit($eb), last
# if $self->use_block;
# Carp::cluck "[YAML::Old] \$UseFold is no longer supported"
# if $self->use_fold;
# $self->_emit($sf),
# $self->_emit_double($_[0]),
# $self->_emit($ef), last
# if length $_[0] <= 30;
# $self->_emit($sf),
# $self->_emit_double($_[0]),
# $self->_emit($ef), last
# if $_[0] !~ /\n\s*\S/;
# $self->_emit($sb),
# $self->_emit_block($LIT_CHAR, $_[0]),
# $self->_emit($eb), last;
# }
# $self->_emit($sf),
# $self->_emit_number($_[0]),
# $self->_emit($ef), last
# if $self->is_literal_number($_[0]);
# $self->_emit($sf),
# $self->_emit_plain($_[0]),
# $self->_emit($ef), last
# if $self->is_valid_plain($_[0]);
# $self->_emit($sf),
# $self->_emit_double($_[0]),
# $self->_emit($ef), last
# if $_[0] =~ /'/;
# $self->_emit($sf),
# $self->_emit_single($_[0]),
# $self->_emit($ef);
# last;
# }
#
# $self->{level}--;
#
# return;
#}
#
#sub is_literal_number {
# my $self = shift;
# # Stolen from JSON::Tiny
# return B::svref_2object(\$_[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK)
# && 0 + $_[0] eq $_[0];
#}
#
#sub _emit_number {
# my $self = shift;
# return $self->_emit_plain($_[0]);
#}
#
## Check whether or not a scalar should be emitted as an plain scalar.
#sub is_valid_plain {
# my $self = shift;
# return 0 unless length $_[0];
# return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[0]);
# # refer to YAML::Old::Loader::parse_inline_simple()
# return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
# return 0 if $_[0] =~ /[\{\[\]\},]/;
# return 0 if $_[0] =~ /[:\-\?]\s/;
# return 0 if $_[0] =~ /\s#/;
# return 0 if $_[0] =~ /\:(\s|$)/;
# return 0 if $_[0] =~ /[\s\|\>]$/;
# return 0 if $_[0] eq '-';
# return 1;
#}
#
#sub _emit_block {
# my $self = shift;
# my ($indicator, $value) = @_;
# $self->{stream} .= $indicator;
# $value =~ /(\n*)\Z/;
# my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
# $value = '~' if not defined $value;
# $self->{stream} .= $chomp;
# $self->{stream} .= $self->indent_width if $value =~ /^\s/;
# $self->{stream} .= $self->indent($value);
#}
#
## Plain means that the scalar is unquoted.
#sub _emit_plain {
# my $self = shift;
# $self->{stream} .= defined $_[0] ? $_[0] : '~';
#}
#
## Double quoting is for single lined escaped strings.
#sub _emit_double {
# my $self = shift;
# (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
# $self->{stream} .= qq{"$escaped"};
#}
#
## Single quoting is for single lined unescaped strings.
#sub _emit_single {
# my $self = shift;
# my $item = shift;
# $item =~ s{'}{''}g;
# $self->{stream} .= "'$item'";
#}
#
##==============================================================================
## Utility subroutines.
##==============================================================================
#
## Indent a scalar to the current indentation level.
#sub indent {
# my $self = shift;
# my ($text) = @_;
# return $text unless length $text;
# $text =~ s/\n\Z//;
# my $indent = ' ' x $self->offset->[$self->level];
# $text =~ s/^/$indent/gm;
# $text = "\n$text";
# return $text;
#}
#
## Escapes for unprintable characters
#my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a
# \x08 \t \n \v \f \r \x0e \x0f
# \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
# \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
# );
#
## Escape the unprintable characters
#sub escape {
# my $self = shift;
# my ($text) = @_;
# $text =~ s/\\/\\\\/g;
# $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
# return $text;
#}
#
#1;
### YAML/Old/Dumper/Base.pm ###
#package YAML::Old::Dumper::Base;
#
#use YAML::Old::Mo;
#
#use YAML::Old::Node;
#
## YAML Dumping options
#has spec_version => default => sub {'1.0'};
#has indent_width => default => sub {2};
#has use_header => default => sub {1};
#has use_version => default => sub {0};
#has sort_keys => default => sub {1};
#has anchor_prefix => default => sub {''};
#has dump_code => default => sub {0};
#has use_block => default => sub {0};
#has use_fold => default => sub {0};
#has compress_series => default => sub {1};
#has inline_series => default => sub {0};
#has use_aliases => default => sub {1};
#has purity => default => sub {0};
#has stringify => default => sub {0};
#has quote_numeric_strings => default => sub {0};
#
## Properties
#has stream => default => sub {''};
#has document => default => sub {0};
#has transferred => default => sub {{}};
#has id_refcnt => default => sub {{}};
#has id_anchor => default => sub {{}};
#has anchor => default => sub {1};
#has level => default => sub {0};
#has offset => default => sub {[]};
#has headless => default => sub {0};
#has blessed_map => default => sub {{}};
#
## Global Options are an idea taken from Data::Dumper. Really they are just
## sugar on top of real OO properties. They make the simple Dump/Load API
## easy to configure.
#sub set_global_options {
# my $self = shift;
# $self->spec_version($YAML::SpecVersion)
# if defined $YAML::SpecVersion;
# $self->indent_width($YAML::Indent)
# if defined $YAML::Indent;
# $self->use_header($YAML::UseHeader)
# if defined $YAML::UseHeader;
# $self->use_version($YAML::UseVersion)
# if defined $YAML::UseVersion;
# $self->sort_keys($YAML::SortKeys)
# if defined $YAML::SortKeys;
# $self->anchor_prefix($YAML::AnchorPrefix)
# if defined $YAML::AnchorPrefix;
# $self->dump_code($YAML::DumpCode || $YAML::UseCode)
# if defined $YAML::DumpCode or defined $YAML::UseCode;
# $self->use_block($YAML::UseBlock)
# if defined $YAML::UseBlock;
# $self->use_fold($YAML::UseFold)
# if defined $YAML::UseFold;
# $self->compress_series($YAML::CompressSeries)
# if defined $YAML::CompressSeries;
# $self->inline_series($YAML::InlineSeries)
# if defined $YAML::InlineSeries;
# $self->use_aliases($YAML::UseAliases)
# if defined $YAML::UseAliases;
# $self->purity($YAML::Purity)
# if defined $YAML::Purity;
# $self->stringify($YAML::Stringify)
# if defined $YAML::Stringify;
# $self->quote_numeric_strings($YAML::QuoteNumericStrings)
# if defined $YAML::QuoteNumericStrings;
#}
#
#sub dump {
# my $self = shift;
# $self->die('dump() not implemented in this class.');
#}
#
#sub blessed {
# my $self = shift;
# my ($ref) = @_;
# $ref = \$_[0] unless ref $ref;
# my (undef, undef, $node_id) = YAML::Old::Mo::Object->node_info($ref);
# $self->{blessed_map}->{$node_id};
#}
#
#sub bless {
# my $self = shift;
# my ($ref, $blessing) = @_;
# my $ynode;
# $ref = \$_[0] unless ref $ref;
# my (undef, undef, $node_id) = YAML::Old::Mo::Object->node_info($ref);
# if (not defined $blessing) {
# $ynode = YAML::Old::Node->new($ref);
# }
# elsif (ref $blessing) {
# $self->die() unless ynode($blessing);
# $ynode = $blessing;
# }
# else {
# no strict 'refs';
# my $transfer = $blessing . "::yaml_dump";
# $self->die() unless defined &{$transfer};
# $ynode = &{$transfer}($ref);
# $self->die() unless ynode($ynode);
# }
# $self->{blessed_map}->{$node_id} = $ynode;
# my $object = ynode($ynode) or $self->die();
# return $object;
#}
#
#1;
### YAML/Old/Error.pm ###
#package YAML::Old::Error;
#
#use YAML::Old::Mo;
#
#has 'code';
#has 'type' => default => sub {'Error'};
#has 'line';
#has 'document';
#has 'arguments' => default => sub {[]};
#
#my ($error_messages, %line_adjust);
#
#sub format_message {
# my $self = shift;
# my $output = 'YAML::Old ' . $self->type . ': ';
# my $code = $self->code;
# if ($error_messages->{$code}) {
# $code = sprintf($error_messages->{$code}, @{$self->arguments});
# }
# $output .= $code . "\n";
#
# $output .= ' Code: ' . $self->code . "\n"
# if defined $self->code;
# $output .= ' Line: ' . $self->line . "\n"
# if defined $self->line;
# $output .= ' Document: ' . $self->document . "\n"
# if defined $self->document;
# return $output;
#}
#
#sub error_messages {
# $error_messages;
#}
#
#%$error_messages = map {s/^\s+//;s/\\n/\n/;$_} split "\n", <<'...';
#YAML_PARSE_ERR_BAD_CHARS
# Invalid characters in stream. This parser only supports printable ASCII
#YAML_PARSE_ERR_BAD_MAJOR_VERSION
# Can't parse a %s document with a 1.0 parser
#YAML_PARSE_WARN_BAD_MINOR_VERSION
# Parsing a %s document with a 1.0 parser
#YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
# '%s directive used more than once'
#YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
# No text allowed after indicator
#YAML_PARSE_ERR_NO_ANCHOR
# No anchor for alias '*%s'
#YAML_PARSE_ERR_NO_SEPARATOR
# Expected separator '---'
#YAML_PARSE_ERR_SINGLE_LINE
# Couldn't parse single line value
#YAML_PARSE_ERR_BAD_ANCHOR
# Invalid anchor
#YAML_DUMP_ERR_INVALID_INDENT
# Invalid Indent width specified: '%s'
#YAML_LOAD_USAGE
# usage: YAML::Old::Load($yaml_stream_scalar)
#YAML_PARSE_ERR_BAD_NODE
# Can't parse node
#YAML_PARSE_ERR_BAD_EXPLICIT
# Unsupported explicit transfer: '%s'
#YAML_DUMP_USAGE_DUMPCODE
# Invalid value for DumpCode: '%s'
#YAML_LOAD_ERR_FILE_INPUT
# Couldn't open %s for input:\n%s
#YAML_DUMP_ERR_FILE_CONCATENATE
# Can't concatenate to YAML file %s
#YAML_DUMP_ERR_FILE_OUTPUT
# Couldn't open %s for output:\n%s
#YAML_DUMP_ERR_FILE_OUTPUT_CLOSE
# Error closing %s:\n%s
#YAML_DUMP_ERR_NO_HEADER
# With UseHeader=0, the node must be a plain hash or array
#YAML_DUMP_WARN_BAD_NODE_TYPE
# Can't perform serialization for node type: '%s'
#YAML_EMIT_WARN_KEYS
# Encountered a problem with 'keys':\n%s
#YAML_DUMP_WARN_DEPARSE_FAILED
# Deparse failed for CODE reference
#YAML_DUMP_WARN_CODE_DUMMY
# Emitting dummy subroutine for CODE reference
#YAML_PARSE_ERR_MANY_EXPLICIT
# More than one explicit transfer
#YAML_PARSE_ERR_MANY_IMPLICIT
# More than one implicit request
#YAML_PARSE_ERR_MANY_ANCHOR
# More than one anchor
#YAML_PARSE_ERR_ANCHOR_ALIAS
# Can't define both an anchor and an alias
#YAML_PARSE_ERR_BAD_ALIAS
# Invalid alias
#YAML_PARSE_ERR_MANY_ALIAS
# More than one alias
#YAML_LOAD_ERR_NO_CONVERT
# Can't convert implicit '%s' node to explicit '%s' node
#YAML_LOAD_ERR_NO_DEFAULT_VALUE
# No default value for '%s' explicit transfer
#YAML_LOAD_ERR_NON_EMPTY_STRING
# Only the empty string can be converted to a '%s'
#YAML_LOAD_ERR_BAD_MAP_TO_SEQ
# Can't transfer map as sequence. Non numeric key '%s' encountered.
#YAML_DUMP_ERR_BAD_GLOB
# '%s' is an invalid value for Perl glob
#YAML_DUMP_ERR_BAD_REGEXP
# '%s' is an invalid value for Perl Regexp
#YAML_LOAD_ERR_BAD_MAP_ELEMENT
# Invalid element in map
#YAML_LOAD_WARN_DUPLICATE_KEY
# Duplicate map key '%s' found. Ignoring.
#YAML_LOAD_ERR_BAD_SEQ_ELEMENT
# Invalid element in sequence
#YAML_PARSE_ERR_INLINE_MAP
# Can't parse inline map
#YAML_PARSE_ERR_INLINE_SEQUENCE
# Can't parse inline sequence
#YAML_PARSE_ERR_BAD_DOUBLE
# Can't parse double quoted string
#YAML_PARSE_ERR_BAD_SINGLE
# Can't parse single quoted string
#YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
# Can't parse inline implicit value '%s'
#YAML_PARSE_ERR_BAD_IMPLICIT
# Unrecognized implicit value '%s'
#YAML_PARSE_ERR_INDENTATION
# Error. Invalid indentation level
#YAML_PARSE_ERR_INCONSISTENT_INDENTATION
# Inconsistent indentation level
#YAML_LOAD_WARN_UNRESOLVED_ALIAS
# Can't resolve alias *%s
#YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
# No 'REGEXP' element for Perl regexp
#YAML_LOAD_WARN_BAD_REGEXP_ELEM
# Unknown element '%s' in Perl regexp
#YAML_LOAD_WARN_GLOB_NAME
# No 'NAME' element for Perl glob
#YAML_LOAD_WARN_PARSE_CODE
# Couldn't parse Perl code scalar: %s
#YAML_LOAD_WARN_CODE_DEPARSE
# Won't parse Perl code unless $YAML::LoadCode is set
#YAML_EMIT_ERR_BAD_LEVEL
# Internal Error: Bad level detected
#YAML_PARSE_WARN_AMBIGUOUS_TAB
# Amibiguous tab converted to spaces
#YAML_LOAD_WARN_BAD_GLOB_ELEM
# Unknown element '%s' in Perl glob
#YAML_PARSE_ERR_ZERO_INDENT
# Can't use zero as an indentation width
#YAML_LOAD_WARN_GLOB_IO
# Can't load an IO filehandle. Yet!!!
#...
#
#%line_adjust = map {($_, 1)}
# qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION
# YAML_PARSE_WARN_BAD_MINOR_VERSION
# YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
# YAML_PARSE_ERR_NO_ANCHOR
# YAML_PARSE_ERR_MANY_EXPLICIT
# YAML_PARSE_ERR_MANY_IMPLICIT
# YAML_PARSE_ERR_MANY_ANCHOR
# YAML_PARSE_ERR_ANCHOR_ALIAS
# YAML_PARSE_ERR_BAD_ALIAS
# YAML_PARSE_ERR_MANY_ALIAS
# YAML_LOAD_ERR_NO_CONVERT
# YAML_LOAD_ERR_NO_DEFAULT_VALUE
# YAML_LOAD_ERR_NON_EMPTY_STRING
# YAML_LOAD_ERR_BAD_MAP_TO_SEQ
# YAML_LOAD_ERR_BAD_STR_TO_INT
# YAML_LOAD_ERR_BAD_STR_TO_DATE
# YAML_LOAD_ERR_BAD_STR_TO_TIME
# YAML_LOAD_WARN_DUPLICATE_KEY
# YAML_PARSE_ERR_INLINE_MAP
# YAML_PARSE_ERR_INLINE_SEQUENCE
# YAML_PARSE_ERR_BAD_DOUBLE
# YAML_PARSE_ERR_BAD_SINGLE
# YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
# YAML_PARSE_ERR_BAD_IMPLICIT
# YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
# YAML_LOAD_WARN_BAD_REGEXP_ELEM
# YAML_LOAD_WARN_REGEXP_CREATE
# YAML_LOAD_WARN_GLOB_NAME
# YAML_LOAD_WARN_PARSE_CODE
# YAML_LOAD_WARN_CODE_DEPARSE
# YAML_LOAD_WARN_BAD_GLOB_ELEM
# YAML_PARSE_ERR_ZERO_INDENT
# );
#
#package YAML::Old::Warning;
#
#our @ISA = 'YAML::Old::Error';
#
#1;
### YAML/Old/Loader.pm ###
#package YAML::Old::Loader;
#
#use YAML::Old::Mo;
#extends 'YAML::Old::Loader::Base';
#
#use YAML::Old::Loader::Base;
#use YAML::Old::Types;
#use YAML::Old::Node;
#
## Context constants
#use constant LEAF => 1;
#use constant COLLECTION => 2;
#use constant VALUE => "\x07YAML\x07VALUE\x07";
#use constant COMMENT => "\x07YAML\x07COMMENT\x07";
#
## Common YAML character sets
#my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
#my $FOLD_CHAR = '>';
#my $LIT_CHAR = '|';
#my $LIT_CHAR_RX = "\\$LIT_CHAR";
#
#sub load {
# my $self = shift;
# $self->stream($_[0] || '');
# return $self->_parse();
#}
#
## Top level function for parsing. Parse each document in order and
## handle processing for YAML headers.
#sub _parse {
# my $self = shift;
# my (%directives, $preface);
# $self->{stream} =~ s|\015\012|\012|g;
# $self->{stream} =~ s|\015|\012|g;
# $self->line(0);
# $self->die('YAML_PARSE_ERR_BAD_CHARS')
# if $self->stream =~ /$ESCAPE_CHAR/;
# $self->{stream} =~ s/(.)\n\Z/$1/s;
# $self->lines([split /\x0a/, $self->stream, -1]);
# $self->line(1);
# # Throw away any comments or blanks before the header (or start of
# # content for headerless streams)
# $self->_parse_throwaway_comments();
# $self->document(0);
# $self->documents([]);
# # Add an "assumed" header if there is no header and the stream is
# # not empty (after initial throwaways).
# if (not $self->eos) {
# if ($self->lines->[0] !~ /^---(\s|$)/) {
# unshift @{$self->lines}, '---';
# $self->{line}--;
# }
# }
#
# # Main Loop. Parse out all the top level nodes and return them.
# while (not $self->eos) {
# $self->anchor2node({});
# $self->{document}++;
# $self->done(0);
# $self->level(0);
# $self->offset->[0] = -1;
#
# if ($self->lines->[0] =~ /^---\s*(.*)$/) {
# my @words = split /\s+/, $1;
# %directives = ();
# while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
# my ($key, $value) = ($1, $2);
# shift(@words);
# if (defined $directives{$key}) {
# $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES',
# $key, $self->document);
# next;
# }
# $directives{$key} = $value;
# }
# $self->preface(join ' ', @words);
# }
# else {
# $self->die('YAML_PARSE_ERR_NO_SEPARATOR');
# }
#
# if (not $self->done) {
# $self->_parse_next_line(COLLECTION);
# }
# if ($self->done) {
# $self->{indent} = -1;
# $self->content('');
# }
#
# $directives{YAML} ||= '1.0';
# $directives{TAB} ||= 'NONE';
# ($self->{major_version}, $self->{minor_version}) =
# split /\./, $directives{YAML}, 2;
# $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
# if $self->major_version ne '1';
# $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML})
# if $self->minor_version ne '0';
# $self->die('Unrecognized TAB policy')
# unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
#
# push @{$self->documents}, $self->_parse_node();
# }
# return wantarray ? @{$self->documents} : $self->documents->[-1];
#}
#
## This function is the dispatcher for parsing each node. Every node
## recurses back through here. (Inlines are an exception as they have
## their own sub-parser.)
#sub _parse_node {
# my $self = shift;
# my $preface = $self->preface;
# $self->preface('');
# my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
# my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
# ($anchor, $alias, $explicit, $implicit, $preface) =
# $self->_parse_qualifiers($preface);
# if ($anchor) {
# $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
# }
# $self->inline('');
# while (length $preface) {
# my $line = $self->line - 1;
# if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
# $indicator = $1;
# $chomp = $2 if defined($2);
# }
# else {
# $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator;
# $self->inline($preface);
# $preface = '';
# }
# }
# if ($alias) {
# $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
# unless defined $self->anchor2node->{$alias};
# if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
# $node = $self->anchor2node->{$alias};
# }
# else {
# $node = do {my $sv = "*$alias"};
# push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
# }
# }
# elsif (length $self->inline) {
# $node = $self->_parse_inline(1, $implicit, $explicit);
# if (length $self->inline) {
# $self->die('YAML_PARSE_ERR_SINGLE_LINE');
# }
# }
# elsif ($indicator eq $LIT_CHAR) {
# $self->{level}++;
# $node = $self->_parse_block($chomp);
# $node = $self->_parse_implicit($node) if $implicit;
# $self->{level}--;
# }
# elsif ($indicator eq $FOLD_CHAR) {
# $self->{level}++;
# $node = $self->_parse_unfold($chomp);
# $node = $self->_parse_implicit($node) if $implicit;
# $self->{level}--;
# }
# else {
# $self->{level}++;
# $self->offset->[$self->level] ||= 0;
# if ($self->indent == $self->offset->[$self->level]) {
# if ($self->content =~ /^-( |$)/) {
# $node = $self->_parse_seq($anchor);
# }
# elsif ($self->content =~ /(^\?|\:( |$))/) {
# $node = $self->_parse_mapping($anchor);
# }
# elsif ($preface =~ /^\s*$/) {
# $node = $self->_parse_implicit('');
# }
# else {
# $self->die('YAML_PARSE_ERR_BAD_NODE');
# }
# }
# else {
# $node = undef;
# }
# $self->{level}--;
# }
# $#{$self->offset} = $self->level;
#
# if ($explicit) {
# if ($class) {
# if (not ref $node) {
# my $copy = $node;
# undef $node;
# $node = \$copy;
# }
# CORE::bless $node, $class;
# }
# else {
# $node = $self->_parse_explicit($node, $explicit);
# }
# }
# if ($anchor) {
# if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
# # XXX Can't remember what this code actually does
# for my $ref (@{$self->anchor2node->{$anchor}}) {
# ${$ref->[0]} = $node;
# $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
# $anchor, $ref->[1]);
# }
# }
# $self->anchor2node->{$anchor} = $node;
# }
# return $node;
#}
#
## Preprocess the qualifiers that may be attached to any node.
#sub _parse_qualifiers {
# my $self = shift;
# my ($preface) = @_;
# my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5;
# $self->inline('');
# while ($preface =~ /^[&*!]/) {
# my $line = $self->line - 1;
# if ($preface =~ s/^\!(\S+)\s*//) {
# $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit;
# $explicit = $1;
# }
# elsif ($preface =~ s/^\!\s*//) {
# $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit;
# $implicit = 1;
# }
# elsif ($preface =~ s/^\&([^ ,:]*)\s*//) {
# $token = $1;
# $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
# unless $token =~ /^[a-zA-Z0-9]+$/;
# $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
# $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
# $anchor = $token;
# }
# elsif ($preface =~ s/^\*([^ ,:]*)\s*//) {
# $token = $1;
# $self->die('YAML_PARSE_ERR_BAD_ALIAS')
# unless $token =~ /^[a-zA-Z0-9]+$/;
# $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias;
# $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor;
# $alias = $token;
# }
# }
# return ($anchor, $alias, $explicit, $implicit, $preface);
#}
#
## Morph a node to it's explicit type
#sub _parse_explicit {
# my $self = shift;
# my ($node, $explicit) = @_;
# my ($type, $class);
# if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
# ($type, $class) = (($1 || ''), ($2 || ''));
#
# # FIXME # die unless uc($type) eq ref($node) ?
#
# if ( $type eq "ref" ) {
# $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
# unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
#
# my $value = $node->{VALUE()};
# $node = \$value;
# }
#
# if ( $type eq "scalar" and length($class) and !ref($node) ) {
# my $value = $node;
# $node = \$value;
# }
#
# if ( length($class) ) {
# CORE::bless($node, $class);
# }
#
# return $node;
# }
# if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
# ($type, $class) = (($1 || ''), ($2 || ''));
# my $type_class = "YAML::Old::Type::$type";
# no strict 'refs';
# if ($type_class->can('yaml_load')) {
# return $type_class->yaml_load($node, $class, $self);
# }
# else {
# $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit);
# }
# }
# # This !perl/@Foo and !perl/$Foo are deprecated but still parsed
# elsif ($YAML::TagClass->{$explicit} ||
# $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}
# ) {
# $class = $YAML::TagClass->{$explicit} || $2;
# if ($class->can('yaml_load')) {
# require YAML::Old::Node;
# return $class->yaml_load(YAML::Old::Node->new($node, $explicit));
# }
# else {
# if (ref $node) {
# return CORE::bless $node, $class;
# }
# else {
# return CORE::bless \$node, $class;
# }
# }
# }
# elsif (ref $node) {
# require YAML::Old::Node;
# return YAML::Old::Node->new($node, $explicit);
# }
# else {
# # XXX This is likely wrong. Failing test:
# # --- !unknown 'scalar value'
# return $node;
# }
#}
#
## Parse a YAML mapping into a Perl hash
#sub _parse_mapping {
# my $self = shift;
# my ($anchor) = @_;
# my $mapping = $self->preserve ? YAML::Old::Node->new({}) : {};
# $self->anchor2node->{$anchor} = $mapping;
# my $key;
# while (not $self->done and $self->indent == $self->offset->[$self->level]) {
# # If structured key:
# if ($self->{content} =~ s/^\?\s*//) {
# $self->preface($self->content);
# $self->_parse_next_line(COLLECTION);
# $key = $self->_parse_node();
# $key = "$key";
# }
# # If "default" key (equals sign)
# elsif ($self->{content} =~ s/^\=\s*//) {
# $key = VALUE;
# }
# # If "comment" key (slash slash)
# elsif ($self->{content} =~ s/^\=\s*//) {
# $key = COMMENT;
# }
# # Regular scalar key:
# else {
# $self->inline($self->content);
# $key = $self->_parse_inline();
# $key = "$key";
# $self->content($self->inline);
# $self->inline('');
# }
#
# unless ($self->{content} =~ s/^:\s*//) {
# $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
# }
# $self->preface($self->content);
# my $line = $self->line;
# $self->_parse_next_line(COLLECTION);
# my $value = $self->_parse_node();
# if (exists $mapping->{$key}) {
# $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY', $key);
# }
# else {
# $mapping->{$key} = $value;
# }
# }
# return $mapping;
#}
#
## Parse a YAML sequence into a Perl array
#sub _parse_seq {
# my $self = shift;
# my ($anchor) = @_;
# my $seq = [];
# $self->anchor2node->{$anchor} = $seq;
# while (not $self->done and $self->indent == $self->offset->[$self->level]) {
# if ($self->content =~ /^-(?: (.*))?$/) {
# $self->preface(defined($1) ? $1 : '');
# }
# else {
# $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT');
# }
#
# # Check whether the preface looks like a YAML mapping ("key: value").
# # This is complicated because it has to account for the possibility
# # that a key is a quoted string, which itself may contain escaped
# # quotes.
# my $preface = $self->preface;
# if ( $preface =~ /^ (\s*) ( \w .*? \: (?:\ |$).*) $/x or
# $preface =~ /^ (\s*) ((') (?:''|[^'])*? ' \s* \: (?:\ |$).*) $/x or
# $preface =~ /^ (\s*) ((") (?:\\\\|[^"])*? " \s* \: (?:\ |$).*) $/x
# ) {
# $self->indent($self->offset->[$self->level] + 2 + length($1));
# $self->content($2);
# $self->level($self->level + 1);
# $self->offset->[$self->level] = $self->indent;
# $self->preface('');
# push @$seq, $self->_parse_mapping('');
# $self->{level}--;
# $#{$self->offset} = $self->level;
# }
# else {
# $self->_parse_next_line(COLLECTION);
# push @$seq, $self->_parse_node();
# }
# }
# return $seq;
#}
#
## Parse an inline value. Since YAML supports inline collections, this is
## the top level of a sub parsing.
#sub _parse_inline {
# my $self = shift;
# my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
# $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
# my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
# ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
# $self->_parse_qualifiers($self->inline);
# if ($anchor) {
# $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
# }
# $implicit ||= $top_implicit;
# $explicit ||= $top_explicit;
# ($top_implicit, $top_explicit) = ('', '');
# if ($alias) {
# $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
# unless defined $self->anchor2node->{$alias};
# if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
# $node = $self->anchor2node->{$alias};
# }
# else {
# $node = do {my $sv = "*$alias"};
# push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
# }
# }
# elsif ($self->inline =~ /^\{/) {
# $node = $self->_parse_inline_mapping($anchor);
# }
# elsif ($self->inline =~ /^\[/) {
# $node = $self->_parse_inline_seq($anchor);
# }
# elsif ($self->inline =~ /^"/) {
# $node = $self->_parse_inline_double_quoted();
# $node = $self->_unescape($node);
# $node = $self->_parse_implicit($node) if $implicit;
# }
# elsif ($self->inline =~ /^'/) {
# $node = $self->_parse_inline_single_quoted();
# $node = $self->_parse_implicit($node) if $implicit;
# }
# else {
# if ($top) {
# $node = $self->inline;
# $self->inline('');
# }
# else {
# $node = $self->_parse_inline_simple();
# }
# $node = $self->_parse_implicit($node) unless $explicit;
#
# if ($self->numify and defined $node and not ref $node and length $node
# and $node =~ m/\A-?(?:0|[1-9][0-9]*)?(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?\z/) {
# $node += 0;
# }
# }
# if ($explicit) {
# $node = $self->_parse_explicit($node, $explicit);
# }
# if ($anchor) {
# if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
# for my $ref (@{$self->anchor2node->{$anchor}}) {
# ${$ref->[0]} = $node;
# $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
# $anchor, $ref->[1]);
# }
# }
# $self->anchor2node->{$anchor} = $node;
# }
# return $node;
#}
#
## Parse the inline YAML mapping into a Perl hash
#sub _parse_inline_mapping {
# my $self = shift;
# my ($anchor) = @_;
# my $node = {};
# $self->anchor2node->{$anchor} = $node;
#
# $self->die('YAML_PARSE_ERR_INLINE_MAP')
# unless $self->{inline} =~ s/^\{\s*//;
# while (not $self->{inline} =~ s/^\s*\}\s*//) {
# my $key = $self->_parse_inline();
# $self->die('YAML_PARSE_ERR_INLINE_MAP')
# unless $self->{inline} =~ s/^\: \s*//;
# my $value = $self->_parse_inline();
# if (exists $node->{$key}) {
# $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY', $key);
# }
# else {
# $node->{$key} = $value;
# }
# next if $self->inline =~ /^\s*\}/;
# $self->die('YAML_PARSE_ERR_INLINE_MAP')
# unless $self->{inline} =~ s/^\,\s*//;
# }
# return $node;
#}
#
## Parse the inline YAML sequence into a Perl array
#sub _parse_inline_seq {
# my $self = shift;
# my ($anchor) = @_;
# my $node = [];
# $self->anchor2node->{$anchor} = $node;
#
# $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
# unless $self->{inline} =~ s/^\[\s*//;
# while (not $self->{inline} =~ s/^\s*\]\s*//) {
# my $value = $self->_parse_inline();
# push @$node, $value;
# next if $self->inline =~ /^\s*\]/;
# $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
# unless $self->{inline} =~ s/^\,\s*//;
# }
# return $node;
#}
#
## Parse the inline double quoted string.
#sub _parse_inline_double_quoted {
# my $self = shift;
# my $node;
# # https://rt.cpan.org/Public/Bug/Display.html?id=90593
# if ($self->inline =~ /^"((?:(?:\\"|[^"]){0,32766}){0,32766})"\s*(.*)$/) {
# $node = $1;
# $self->inline($2);
# $node =~ s/\\"/"/g;
# }
# else {
# $self->die('YAML_PARSE_ERR_BAD_DOUBLE');
# }
# return $node;
#}
#
#
## Parse the inline single quoted string.
#sub _parse_inline_single_quoted {
# my $self = shift;
# my $node;
# if ($self->inline =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\s*(.*)$/) {
# $node = $1;
# $self->inline($2);
# $node =~ s/''/'/g;
# }
# else {
# $self->die('YAML_PARSE_ERR_BAD_SINGLE');
# }
# return $node;
#}
#
## Parse the inline unquoted string and do implicit typing.
#sub _parse_inline_simple {
# my $self = shift;
# my $value;
# if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) {
# $value = $1;
# substr($self->{inline}, 0, length($1)) = '';
# }
# else {
# $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value);
# }
# return $value;
#}
#
#sub _parse_implicit {
# my $self = shift;
# my ($value) = @_;
# $value =~ s/\s*$//;
# return $value if $value eq '';
# return undef if $value =~ /^~$/;
# return $value
# unless $value =~ /^[\@\`]/ or
# $value =~ /^[\-\?]\s/;
# $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
#}
#
## Unfold a YAML multiline scalar into a single string.
#sub _parse_unfold {
# my $self = shift;
# my ($chomp) = @_;
# my $node = '';
# my $space = 0;
# while (not $self->done and $self->indent == $self->offset->[$self->level]) {
# $node .= $self->content. "\n";
# $self->_parse_next_line(LEAF);
# }
# $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
# $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
# $node =~ s/\n*\Z// unless $chomp eq '+';
# $node .= "\n" unless $chomp;
# return $node;
#}
#
## Parse a YAML block style scalar. This is like a Perl here-document.
#sub _parse_block {
# my $self = shift;
# my ($chomp) = @_;
# my $node = '';
# while (not $self->done and $self->indent == $self->offset->[$self->level]) {
# $node .= $self->content . "\n";
# $self->_parse_next_line(LEAF);
# }
# return $node if '+' eq $chomp;
# $node =~ s/\n*\Z/\n/;
# $node =~ s/\n\Z// if $chomp eq '-';
# return $node;
#}
#
## Handle Perl style '#' comments. Comments must be at the same indentation
## level as the collection line following them.
#sub _parse_throwaway_comments {
# my $self = shift;
# while (@{$self->lines} and
# $self->lines->[0] =~ m{^\s*(\#|$)}
# ) {
# shift @{$self->lines};
# $self->{line}++;
# }
# $self->eos($self->{done} = not @{$self->lines});
#}
#
## This is the routine that controls what line is being parsed. It gets called
## once for each line in the YAML stream.
##
## This routine must:
## 1) Skip past the current line
## 2) Determine the indentation offset for a new level
## 3) Find the next _content_ line
## A) Skip over any throwaways (Comments/blanks)
## B) Set $self->indent, $self->content, $self->line
## 4) Expand tabs appropriately
#sub _parse_next_line {
# my $self = shift;
# my ($type) = @_;
# my $level = $self->level;
# my $offset = $self->offset->[$level];
# $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset;
# shift @{$self->lines};
# $self->eos($self->{done} = not @{$self->lines});
# if ($self->eos) {
# $self->offset->[$level + 1] = $offset + 1;
# return;
# }
# $self->{line}++;
#
# # Determine the offset for a new leaf node
# if ($self->preface =~
# qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/
# ) {
# $self->die('YAML_PARSE_ERR_ZERO_INDENT')
# if length($1) and $1 == 0;
# $type = LEAF;
# if (length($1)) {
# $self->offset->[$level + 1] = $offset + $1;
# }
# else {
# # First get rid of any comments.
# while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
# $self->lines->[0] =~ /^( *)/;
# last unless length($1) <= $offset;
# shift @{$self->lines};
# $self->{line}++;
# }
# $self->eos($self->{done} = not @{$self->lines});
# return if $self->eos;
# if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) {
# $self->offset->[$level+1] = length($1);
# }
# else {
# $self->offset->[$level+1] = $offset + 1;
# }
# }
# $offset = $self->offset->[++$level];
# }
# # Determine the offset for a new collection level
# elsif ($type == COLLECTION and
# $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
# $self->_parse_throwaway_comments();
# if ($self->eos) {
# $self->offset->[$level+1] = $offset + 1;
# return;
# }
# else {
# $self->lines->[0] =~ /^( *)\S/ or
# $self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION');
# if (length($1) > $offset) {
# $self->offset->[$level+1] = length($1);
# }
# else {
# $self->offset->[$level+1] = $offset + 1;
# }
# }
# $offset = $self->offset->[++$level];
# }
#
# if ($type == LEAF) {
# while (@{$self->lines} and
# $self->lines->[0] =~ m{^( *)(\#)} and
# length($1) < $offset
# ) {
# shift @{$self->lines};
# $self->{line}++;
# }
# $self->eos($self->{done} = not @{$self->lines});
# }
# else {
# $self->_parse_throwaway_comments();
# }
# return if $self->eos;
#
# if ($self->lines->[0] =~ /^---(\s|$)/) {
# $self->done(1);
# return;
# }
# if ($type == LEAF and
# $self->lines->[0] =~ /^ {$offset}(.*)$/
# ) {
# $self->indent($offset);
# $self->content($1);
# }
# elsif ($self->lines->[0] =~ /^\s*$/) {
# $self->indent($offset);
# $self->content('');
# }
# else {
# $self->lines->[0] =~ /^( *)(\S.*)$/;
# while ($self->offset->[$level] > length($1)) {
# $level--;
# }
# $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
# if $self->offset->[$level] != length($1);
# $self->indent(length($1));
# $self->content($2);
# }
# $self->die('YAML_PARSE_ERR_INDENTATION')
# if $self->indent - $offset > 1;
#}
#
##==============================================================================
## Utility subroutines.
##==============================================================================
#
## Printable characters for escapes
#my %unescapes = (
# 0 => "\x00",
# a => "\x07",
# t => "\x09",
# n => "\x0a",
# 'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
# f => "\x0c",
# r => "\x0d",
# e => "\x1b",
# '\\' => '\\',
# );
#
## Transform all the backslash style escape characters to their literal meaning
#sub _unescape {
# my $self = shift;
# my ($node) = @_;
# $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
# (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
# return $node;
#}
#
#1;
### YAML/Old/Loader/Base.pm ###
#package YAML::Old::Loader::Base;
#
#use YAML::Old::Mo;
#
#has load_code => default => sub {0};
#has preserve => default => sub {0};
#has stream => default => sub {''};
#has document => default => sub {0};
#has line => default => sub {0};
#has documents => default => sub {[]};
#has lines => default => sub {[]};
#has eos => default => sub {0};
#has done => default => sub {0};
#has anchor2node => default => sub {{}};
#has level => default => sub {0};
#has offset => default => sub {[]};
#has preface => default => sub {''};
#has content => default => sub {''};
#has indent => default => sub {0};
#has major_version => default => sub {0};
#has minor_version => default => sub {0};
#has inline => default => sub {''};
#has numify => default => sub {0};
#
#sub set_global_options {
# my $self = shift;
# $self->load_code($YAML::LoadCode || $YAML::UseCode)
# if defined $YAML::LoadCode or defined $YAML::UseCode;
# $self->preserve($YAML::Preserve) if defined $YAML::Preserve;
# $self->numify($YAML::Numify) if defined $YAML::Numify;
#}
#
#sub load {
# die 'load() not implemented in this class.';
#}
#
#1;
### YAML/Old/Marshall.pm ###
#use strict; use warnings;
#package YAML::Old::Marshall;
#
#use YAML::Old::Node ();
#
#sub import {
# my $class = shift;
# no strict 'refs';
# my $package = caller;
# unless (grep { $_ eq $class} @{$package . '::ISA'}) {
# push @{$package . '::ISA'}, $class;
# }
#
# my $tag = shift;
# if ( $tag ) {
# no warnings 'once';
# $YAML::TagClass->{$tag} = $package;
# ${$package . "::YamlTag"} = $tag;
# }
#}
#
#sub yaml_dump {
# my $self = shift;
# no strict 'refs';
# my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self);
# $self->yaml_node($self, $tag);
#}
#
#sub yaml_load {
# my ($class, $node) = @_;
# if (my $ynode = $class->yaml_ynode($node)) {
# $node = $ynode->{NODE};
# }
# bless $node, $class;
#}
#
#sub yaml_node {
# shift;
# YAML::Old::Node->new(@_);
#}
#
#sub yaml_ynode {
# shift;
# YAML::Old::Node::ynode(@_);
#}
#
#1;
### YAML/Old/Mo.pm ###
#package YAML::Old::Mo;
## use Mo qw[builder default import];
## The following line of code was produced from the previous line by
## Mo::Inline version 0.40
#no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.'::'.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[builder default import];use strict;use warnings;
#
#our $DumperModule = 'Data::Dumper';
#
#my ($_new_error, $_info, $_scalar_info);
#
#no strict 'refs';
#*{$M.'Object::die'} = sub {
# my $self = shift;
# my $error = $self->$_new_error(@_);
# $error->type('Error');
# Carp::croak($error->format_message);
#};
#
#*{$M.'Object::warn'} = sub {
# my $self = shift;
# return unless $^W;
# my $error = $self->$_new_error(@_);
# $error->type('Warning');
# Carp::cluck($error->format_message);
#};
#
## This code needs to be refactored to be simpler and more precise, and no,
## Scalar::Util doesn't DWIM.
##
## Can't handle:
## * blessed regexp
#*{$M.'Object::node_info'} = sub {
# my $self = shift;
# my $stringify = $_[1] || 0;
# my ($class, $type, $id) =
# ref($_[0])
# ? $stringify
# ? &$_info("$_[0]")
# : do {
# require overload;
# my @info = &$_info(overload::StrVal($_[0]));
# if (ref($_[0]) eq 'Regexp') {
# @info[0, 1] = (undef, 'REGEXP');
# }
# @info;
# }
# : &$_scalar_info($_[0]);
# ($class, $type, $id) = &$_scalar_info("$_[0]")
# unless $id;
# return wantarray ? ($class, $type, $id) : $id;
#};
#
##-------------------------------------------------------------------------------
#$_info = sub {
# return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
#};
#
#$_scalar_info = sub {
# my $id = 'undef';
# if (defined $_[0]) {
# \$_[0] =~ /\((\w+)\)$/o or CORE::die();
# $id = "$1-S";
# }
# return (undef, undef, $id);
#};
#
#$_new_error = sub {
# require Carp;
# my $self = shift;
# require YAML::Old::Error;
#
# my $code = shift || 'unknown error';
# my $error = YAML::Old::Error->new(code => $code);
# $error->line($self->line) if $self->can('line');
# $error->document($self->document) if $self->can('document');
# $error->arguments([@_]);
# return $error;
#};
#
#1;
### YAML/Old/Node.pm ###
#use strict; use warnings;
#package YAML::Old::Node;
#
#use YAML::Old::Tag;
#require YAML::Old::Mo;
#
#use Exporter;
#our @ISA = qw(Exporter YAML::Old::Mo::Object);
#our @EXPORT = qw(ynode);
#
#sub ynode {
# my $self;
# if (ref($_[0]) eq 'HASH') {
# $self = tied(%{$_[0]});
# }
# elsif (ref($_[0]) eq 'ARRAY') {
# $self = tied(@{$_[0]});
# }
# elsif (ref(\$_[0]) eq 'GLOB') {
# $self = tied(*{$_[0]});
# }
# else {
# $self = tied($_[0]);
# }
# return (ref($self) =~ /^yaml_/) ? $self : undef;
#}
#
#sub new {
# my ($class, $node, $tag) = @_;
# my $self;
# $self->{NODE} = $node;
# my (undef, $type) = YAML::Old::Mo::Object->node_info($node);
# $self->{KIND} = (not defined $type) ? 'scalar' :
# ($type eq 'ARRAY') ? 'sequence' :
# ($type eq 'HASH') ? 'mapping' :
# $class->die("Can't create YAML::Old::Node from '$type'");
# tag($self, ($tag || ''));
# if ($self->{KIND} eq 'scalar') {
# yaml_scalar->new($self, $_[1]);
# return \ $_[1];
# }
# my $package = "yaml_" . $self->{KIND};
# $package->new($self)
#}
#
#sub node { $_->{NODE} }
#sub kind { $_->{KIND} }
#sub tag {
# my ($self, $value) = @_;
# if (defined $value) {
# $self->{TAG} = YAML::Old::Tag->new($value);
# return $self;
# }
# else {
# return $self->{TAG};
# }
#}
#sub keys {
# my ($self, $value) = @_;
# if (defined $value) {
# $self->{KEYS} = $value;
# return $self;
# }
# else {
# return $self->{KEYS};
# }
#}
#
##==============================================================================
#package yaml_scalar;
#
#@yaml_scalar::ISA = qw(YAML::Old::Node);
#
#sub new {
# my ($class, $self) = @_;
# tie $_[2], $class, $self;
#}
#
#sub TIESCALAR {
# my ($class, $self) = @_;
# bless $self, $class;
# $self
#}
#
#sub FETCH {
# my ($self) = @_;
# $self->{NODE}
#}
#
#sub STORE {
# my ($self, $value) = @_;
# $self->{NODE} = $value
#}
#
##==============================================================================
#package yaml_sequence;
#
#@yaml_sequence::ISA = qw(YAML::Old::Node);
#
#sub new {
# my ($class, $self) = @_;
# my $new;
# tie @$new, $class, $self;
# $new
#}
#
#sub TIEARRAY {
# my ($class, $self) = @_;
# bless $self, $class
#}
#
#sub FETCHSIZE {
# my ($self) = @_;
# scalar @{$self->{NODE}};
#}
#
#sub FETCH {
# my ($self, $index) = @_;
# $self->{NODE}[$index]
#}
#
#sub STORE {
# my ($self, $index, $value) = @_;
# $self->{NODE}[$index] = $value
#}
#
#sub undone {
# die "Not implemented yet"; # XXX
#}
#
#*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
#*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
#*undone; # XXX Must implement before release
#
##==============================================================================
#package yaml_mapping;
#
#@yaml_mapping::ISA = qw(YAML::Old::Node);
#
#sub new {
# my ($class, $self) = @_;
# @{$self->{KEYS}} = sort keys %{$self->{NODE}};
# my $new;
# tie %$new, $class, $self;
# $new
#}
#
#sub TIEHASH {
# my ($class, $self) = @_;
# bless $self, $class
#}
#
#sub FETCH {
# my ($self, $key) = @_;
# if (exists $self->{NODE}{$key}) {
# return (grep {$_ eq $key} @{$self->{KEYS}})
# ? $self->{NODE}{$key} : undef;
# }
# return $self->{HASH}{$key};
#}
#
#sub STORE {
# my ($self, $key, $value) = @_;
# if (exists $self->{NODE}{$key}) {
# $self->{NODE}{$key} = $value;
# }
# elsif (exists $self->{HASH}{$key}) {
# $self->{HASH}{$key} = $value;
# }
# else {
# if (not grep {$_ eq $key} @{$self->{KEYS}}) {
# push(@{$self->{KEYS}}, $key);
# }
# $self->{HASH}{$key} = $value;
# }
# $value
#}
#
#sub DELETE {
# my ($self, $key) = @_;
# my $return;
# if (exists $self->{NODE}{$key}) {
# $return = $self->{NODE}{$key};
# }
# elsif (exists $self->{HASH}{$key}) {
# $return = delete $self->{NODE}{$key};
# }
# for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
# if ($self->{KEYS}[$i] eq $key) {
# splice(@{$self->{KEYS}}, $i, 1);
# }
# }
# return $return;
#}
#
#sub CLEAR {
# my ($self) = @_;
# @{$self->{KEYS}} = ();
# %{$self->{HASH}} = ();
#}
#
#sub FIRSTKEY {
# my ($self) = @_;
# $self->{ITER} = 0;
# $self->{KEYS}[0]
#}
#
#sub NEXTKEY {
# my ($self) = @_;
# $self->{KEYS}[++$self->{ITER}]
#}
#
#sub EXISTS {
# my ($self, $key) = @_;
# exists $self->{NODE}{$key}
#}
#
#1;
### YAML/Old/Tag.pm ###
#use strict; use warnings;
#package YAML::Old::Tag;
#
#use overload '""' => sub { ${$_[0]} };
#
#sub new {
# my ($class, $self) = @_;
# bless \$self, $class
#}
#
#sub short {
# ${$_[0]}
#}
#
#sub canonical {
# ${$_[0]}
#}
#
#1;
### YAML/Old/Types.pm ###
#package YAML::Old::Types;
#
#use YAML::Old::Mo;
#use YAML::Old::Node;
#
## XXX These classes and their APIs could still use some refactoring,
## but at least they work for now.
##-------------------------------------------------------------------------------
#package YAML::Old::Type::blessed;
#
#use YAML::Old::Mo; # XXX
#
#sub yaml_dump {
# my $self = shift;
# my ($value) = @_;
# my ($class, $type) = YAML::Old::Mo::Object->node_info($value);
# no strict 'refs';
# my $kind = lc($type) . ':';
# my $tag = ${$class . '::ClassTag'} ||
# "!perl/$kind$class";
# if ($type eq 'REF') {
# YAML::Old::Node->new(
# {(&YAML::Old::VALUE, ${$_[0]})}, $tag
# );
# }
# elsif ($type eq 'SCALAR') {
# $_[1] = $$value;
# YAML::Old::Node->new($_[1], $tag);
# }
# elsif ($type eq 'GLOB') {
# # blessed glob support is minimal, and will not round-trip
# # initial aim: to not cause an error
# return YAML::Old::Type::glob->yaml_dump($value, $tag);
# } else {
# YAML::Old::Node->new($value, $tag);
# }
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::undef;
#
#sub yaml_dump {
# my $self = shift;
#}
#
#sub yaml_load {
# my $self = shift;
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::glob;
#
#sub yaml_dump {
# my $self = shift;
# # $_[0] remains as the glob
# my $tag = pop @_ if 2==@_;
#
# $tag = '!perl/glob:' unless defined $tag;
# my $ynode = YAML::Old::Node->new({}, $tag);
# for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
# my $value = *{$_[0]}{$type};
# $value = $$value if $type eq 'SCALAR';
# if (defined $value) {
# if ($type eq 'IO') {
# my @stats = qw(device inode mode links uid gid rdev size
# atime mtime ctime blksize blocks);
# undef $value;
# $value->{stat} = YAML::Old::Node->new({});
# if ($value->{fileno} = fileno(*{$_[0]})) {
# local $^W;
# map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
# $value->{tell} = tell(*{$_[0]});
# }
# }
# $ynode->{$type} = $value;
# }
# }
# return $ynode;
#}
#
#sub yaml_load {
# my $self = shift;
# my ($node, $class, $loader) = @_;
# my ($name, $package);
# if (defined $node->{NAME}) {
# $name = $node->{NAME};
# delete $node->{NAME};
# }
# else {
# $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
# return undef;
# }
# if (defined $node->{PACKAGE}) {
# $package = $node->{PACKAGE};
# delete $node->{PACKAGE};
# }
# else {
# $package = 'main';
# }
# no strict 'refs';
# if (exists $node->{SCALAR}) {
# *{"${package}::$name"} = \$node->{SCALAR};
# delete $node->{SCALAR};
# }
# for my $elem (qw(ARRAY HASH CODE IO)) {
# if (exists $node->{$elem}) {
# if ($elem eq 'IO') {
# $loader->warn('YAML_LOAD_WARN_GLOB_IO');
# delete $node->{IO};
# next;
# }
# *{"${package}::$name"} = $node->{$elem};
# delete $node->{$elem};
# }
# }
# for my $elem (sort keys %$node) {
# $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
# }
# return *{"${package}::$name"};
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::code;
#
#my $dummy_warned = 0;
#my $default = '{ "DUMMY" }';
#
#sub yaml_dump {
# my $self = shift;
# my $code;
# my ($dumpflag, $value) = @_;
# my ($class, $type) = YAML::Old::Mo::Object->node_info($value);
# my $tag = "!perl/code";
# $tag .= ":$class" if defined $class;
# if (not $dumpflag) {
# $code = $default;
# }
# else {
# bless $value, "CODE" if $class;
# eval { require B::Deparse };
# return if $@;
# my $deparse = B::Deparse->new();
# eval {
# local $^W = 0;
# $code = $deparse->coderef2text($value);
# };
# if ($@) {
# warn YAML::Old::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
# $code = $default;
# }
# bless $value, $class if $class;
# chomp $code;
# $code .= "\n";
# }
# $_[2] = $code;
# YAML::Old::Node->new($_[2], $tag);
#}
#
#sub yaml_load {
# my $self = shift;
# my ($node, $class, $loader) = @_;
# if ($loader->load_code) {
# my $code = eval "package main; sub $node";
# if ($@) {
# $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
# return sub {};
# }
# else {
# CORE::bless $code, $class if $class;
# return $code;
# }
# }
# else {
# return CORE::bless sub {}, $class if $class;
# return sub {};
# }
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::ref;
#
#sub yaml_dump {
# my $self = shift;
# YAML::Old::Node->new({(&YAML::Old::VALUE, ${$_[0]})}, '!perl/ref')
#}
#
#sub yaml_load {
# my $self = shift;
# my ($node, $class, $loader) = @_;
# $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
# unless exists $node->{&YAML::Old::VALUE};
# return \$node->{&YAML::Old::VALUE};
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::regexp;
#
## XXX Be sure to handle blessed regexps (if possible)
#sub yaml_dump {
# die "YAML::Old::Type::regexp::yaml_dump not currently implemented";
#}
#
#use constant _QR_TYPES => {
# '' => sub { qr{$_[0]} },
# x => sub { qr{$_[0]}x },
# i => sub { qr{$_[0]}i },
# s => sub { qr{$_[0]}s },
# m => sub { qr{$_[0]}m },
# ix => sub { qr{$_[0]}ix },
# sx => sub { qr{$_[0]}sx },
# mx => sub { qr{$_[0]}mx },
# si => sub { qr{$_[0]}si },
# mi => sub { qr{$_[0]}mi },
# ms => sub { qr{$_[0]}sm },
# six => sub { qr{$_[0]}six },
# mix => sub { qr{$_[0]}mix },
# msx => sub { qr{$_[0]}msx },
# msi => sub { qr{$_[0]}msi },
# msix => sub { qr{$_[0]}msix },
#};
#
#sub yaml_load {
# my $self = shift;
# my ($node, $class) = @_;
# return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s;
# my ($flags, $re) = ($1, $2);
# $flags =~ s/-.*//;
# $flags =~ s/^\^//;
# my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
# my $qr = &$sub($re);
# bless $qr, $class if length $class;
# return $qr;
#}
#
#1;