—#!perl
### code_after_shebang
# Note: This script is a CLI for Riap function /Module/CheckVersion/check_module_version
# and generated automatically using Perinci::CmdLine::Gen version 0.45
# PERICMD_INLINE_SCRIPT: {"code_after_shebang":"...","config_dirs":null,"config_filename":"check-module-version.conf","env_name":"CHECK_MODULE_VERSION_OPT","include":null,"log":null,"pack_deps":1,"pod":0,"read_config":1,"read_env":1,"script_name":"check-module-version","script_summary":null,"script_version":"0.08","shebang":"perl","skip_format":0,"subcommands":null,"url":"/Module/CheckVersion/check_module_version","use_cleanser":1,"validate_args":1}
my
$_pci_metas
= {
""
=>{
args
=>{
check_latest_version
=>{
default
=>1,
schema
=>[
"bool"
,{},{}]},
default_authority_scheme
=>{
default
=>
"cpan"
,
description
=>
"\nIf a module does not set `\$AUTHORITY` (which contains string like\n`<scheme>:<extra>` like `cpan:PERLANCAR`), the default authority scheme will be\ndetermined from this setting. The module `Module::CheckVersion::<scheme>` module\nis used to implement actual checking.\n\nCan also be set to undef, in which case when module's `\$AUTHORITY` is not\navailable, will return 412 status.\n\n"
,
schema
=>[
"str"
,{},{}]},
module
=>{
description
=>
"\nThis routine will try to load the module, and retrieve its `\$VERSION`. If\nloading fails will assume module's installed version is undef.\n\n"
,
pos
=>0,
req
=>1,
schema
=>[
"str"
,{
match
=>
qr(\A\w+(::\w+)
*\z),
req
=>1},{}]}},
description
=>
"\nDesigned to be more general and able to provide more information in the future\nin addition to mere checking of latest version, but checking latest version is\ncurrently the only implemented feature.\n\nCan handle non-CPAN modules, as long as you put the appropriate `\$AUTHORITY` in\nyour modules and create the `Module::CheckVersion::<scheme>` to handle your\nauthority scheme.\n\n"
,
result
=>{},
summary
=>
"Check module (e.g. check latest version) with CPAN (or equivalent repo)"
,
v
=>1.1}};
# This script is generated by Perinci::CmdLine::Inline version 0.50 on Fri Jun 9 18:15:13 2017.
# Rinci metadata taken from these modules: Module::CheckVersion (no version)
# You probably should not manually edit this file.
our
$DATE
=
'2017-06-09'
;
# DATE
our
$VERSION
=
'0.08'
;
# VERSION
# PODNAME: check-module-version
# ABSTRACT: Check module (e.g. check latest version) with CPAN (or equivalent repo)
# 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
package
main;
use
5.010001;
use
strict;
#use warnings;
### declare global variables
our
$_pci_meta_result_stream
= 0;
our
$_pci_meta_result_type
;
our
$_pci_meta_result_type_is_simple
;
our
$_pci_meta_skip_format
= 0;
our
$_pci_r
= {
naked_res
=>0,
read_config
=>1,
read_env
=>1,
subcommand_name
=>
""
};
our
%_pci_args
;
### declare subroutines
sub
_pci_err {
my
$res
=
shift
;
STDERR
"ERROR $res->[0]: $res->[1]\n"
;
exit
$res
->[0]-300;
}
sub
_pci_json {
state
$json
=
do
{
};
$json
;
}
### get arguments (from config file, env, command-line args
{
my
%mentioned_args
;
require
Getopt::Long::EvenLess;
require
Getopt::Long::EvenLess;
my
$go_spec1
= {
'config-path=s@'
=>
sub
{
$_pci_r
->{config_paths} //= [];
push
@{
$_pci_r
->{config_paths} },
$_
[1]; },
'config-profile=s'
=>
sub
{
$_pci_r
->{config_profile} =
$_
[1]; },
'format=s'
=>
sub
{
$_pci_r
->{
format
} =
$_
[1]; },
'help|h|?'
=>
sub
{
"check-module-version - Check module (e.g. check latest version) with CPAN (or equivalent repo)\n\nUsage:\n check-module-version --help (or -h, -?)\n check-module-version --version (or -v)\n check-module-version [options] <module>\n\nDesigned to be more general and able to provide more information in the future\nin addition to mere checking of latest version, but checking latest version is\ncurrently the only implemented feature.\n\nCan handle non-CPAN modules, as long as you put the appropriate `\$AUTHORITY` in\nyour modules and create the `Module::CheckVersion::<scheme>` to handle your\nauthority scheme.\n\nMain options:\n --default-authority-scheme=s [\"cpan\"]\n --module=s* (=arg[0])\n --no-check-latest-version \n\nConfiguration options:\n --config-path=filename Set path to configuration file\n --config-profile=s Set configuration profile to use\n --no-config Do not use any configuration file\n\nEnvironment options:\n --no-env Do not read environment for default options\n\nOutput options:\n --format=s Choose output format, e.g. json, text\n --json Set output format to json\n\nOther options:\n --help, -h, -? Display help message and exit\n --naked-res When outputing as JSON, strip result envelope\n --no-naked-res, --nonaked-res When outputing as JSON, don't strip result envelope\n --version, -v Display program's version and exit\n"
;
exit
0; },
'json'
=>
sub
{
$_pci_r
->{
format
} = (-t STDOUT) ?
"json-pretty"
:
"json"
; },
'naked-res'
=>
sub
{
$_pci_r
->{naked_res} = 1; },
'no-config'
=>
sub
{
$_pci_r
->{read_config} = 0; },
'no-env'
=>
sub
{
$_pci_r
->{read_env} = 0; },
'no-naked-res|nonaked-res'
=>
sub
{
$_pci_r
->{naked_res} = 0; },
'version|v'
=>
sub
{
no
warnings
'once'
;
require
Module::CheckVersion;
"check-module-version version "
,
"0.08"
, (
$Module::CheckVersion::DATE
?
" ($Module::CheckVersion::DATE)"
:
''
),
"\n"
;
" Generated by Perinci::CmdLine::Inline version 0.50 (2017-01-19)\n"
;
exit
0 },
};
my
$go_spec2
= {
'check-latest-version'
=>
sub
{
$_pci_args
{
'check_latest_version'
} =
$_
[1];
},
'config-path=s@'
=>
sub
{ },
'config-profile=s'
=>
sub
{ },
'default-authority-scheme=s'
=>
sub
{
$_pci_args
{
'default_authority_scheme'
} =
$_
[1];
},
'format=s'
=>
sub
{ },
'help|h|?'
=>
sub
{ },
'json'
=>
sub
{ },
'module=s'
=>
sub
{
$_pci_args
{
'module'
} =
$_
[1];
},
'naked-res'
=>
sub
{ },
'no-check-latest-version'
=>
sub
{
$_pci_args
{
'check_latest_version'
} =
$_
[1];
},
'no-config'
=>
sub
{ },
'no-env'
=>
sub
{ },
'no-naked-res|nonaked-res'
=>
sub
{ },
'nocheck-latest-version'
=>
sub
{
$_pci_args
{
'check_latest_version'
} =
$_
[1];
},
'version|v'
=>
sub
{ },
};
my
$old_conf
= Getopt::Long::EvenLess::Configure(
"pass_through"
);
Getopt::Long::EvenLess::GetOptions(
%$go_spec1
);
Getopt::Long::EvenLess::Configure(
$old_conf
);
{
last
unless
$_pci_r
->{read_env};
my
$env
=
$ENV
{
"CHECK_MODULE_VERSION_OPT"
};
last
unless
defined
$env
;
my
(
$words
,
undef
) = @{ Complete::Bash::parse_cmdline(
$env
, 0) };
unshift
@ARGV
,
@$words
;
}
if
(
$_pci_r
->{read_config}) {
my
$res
= Perinci::CmdLine::Util::Config::read_config(
config_paths
=>
$_pci_r
->{config_paths},
config_filename
=>
"check-module-version.conf"
,
config_dirs
=>
undef
// [
"$ENV{HOME}/.config"
,
$ENV
{HOME},
"/etc"
],
program_name
=>
"check-module-version"
,
);
_pci_err(
$res
)
unless
$res
->[0] == 200;
$_pci_r
->{config} =
$res
->[2];
$_pci_r
->{read_config_files} =
$res
->[3]{
"func.read_files"
};
$_pci_r
->{_config_section_read_order} =
$res
->[3]{
"func.section_read_order"
};
# we currently dont want to publish this request key
$res
= Perinci::CmdLine::Util::Config::get_args_from_config(
r
=>
$_pci_r
,
config
=>
$_pci_r
->{config},
args
=> \
%_pci_args
,
program_name
=>
"check-module-version"
,
subcommand_name
=>
$_pci_r
->{subcommand_name},
config_profile
=>
$_pci_r
->{config_profile},
common_opts
=> {},
meta
=>
$_pci_metas
->{
$_pci_r
->{subcommand_name} },
meta_is_normalized
=> 1,
);
die
$res
unless
$res
->[0] == 200;
my
$found
=
$res
->[3]{
"func.found"
};
if
(
defined
(
$_pci_r
->{config_profile}) && !
$found
&&
defined
(
$_pci_r
->{read_config_files}) && @{
$_pci_r
->{read_config_files}} && !
$_pci_r
->{ignore_missing_config_profile_section}) {
_pci_err([412,
"Profile '$_pci_r->{config_profile}' not found in configuration file"
]);
}
}
my
$res
= Getopt::Long::EvenLess::GetOptions(
%$go_spec2
);
_pci_err([500,
"GetOptions failed"
])
unless
$res
;
}
### check arguments
{
_pci_err(
$res
)
if
$res
->[0] != 200;
$_pci_r
->{args} = \
%_pci_args
;
}
### call function
{
my
$sc_name
=
$_pci_r
->{subcommand_name};
if
(
$sc_name
eq
""
) {
$_pci_meta_result_type
=
""
;
eval
{
$_pci_r
->{res} = Module::CheckVersion::check_module_version(
%_pci_args
) };
if
($@) {
$_pci_r
->{res} = [500,
"Function died: $@"
] }
}
}
### format & display result
{
my
$fres
;
my
$save_res
;
if
(
exists
$_pci_r
->{res}[3]{
"cmdline.result"
}) {
$save_res
=
$_pci_r
->{res}[2];
$_pci_r
->{res}[2] =
$_pci_r
->{res}[3]{
"cmdline.result"
} }
my
$is_success
=
$_pci_r
->{res}[0] =~ /\A2/ ||
$_pci_r
->{res}[0] == 304;
my
$is_stream
=
$_pci_r
->{res}[3]{stream} //
$_pci_meta_result_stream
// 0;
if
(
$is_success
&& (0 ||
$_pci_meta_skip_format
||
$_pci_r
->{res}[3]{
"cmdline.skip_format"
})) {
$fres
=
$_pci_r
->{res}[2] }
elsif
(
$is_success
&&
$is_stream
) {}
else
{
require
Local::_pci_clean_json;
require
Perinci::Result::Format::Lite;
$is_stream
=0; _pci_clean_json(
$_pci_r
->{res});
$fres
= Perinci::Result::Format::Lite::
format
(
$_pci_r
->{res}, (
$_pci_r
->{
format
} //
$_pci_r
->{res}[3]{
"cmdline.default_format"
} //
"text"
),
$_pci_r
->{naked_res}, 0) }
my
$use_utf8
=
$_pci_r
->{res}[3]{
"x.hint.result_binary"
} ? 0 : 0;
if
(
$use_utf8
) {
binmode
STDOUT,
":utf8"
}
if
(
$is_stream
) {
my
$code
=
$_pci_r
->{res}[2];
if
(
ref
(
$code
) ne
"CODE"
) {
die
"Result is a stream but no coderef provided"
}
if
(
$_pci_meta_result_type_is_simple
) {
while
(
defined
(
my
$l
=
$code
->())) {
$l
;
"\n"
unless
$_pci_meta_result_type
eq
"buf"
; } }
else
{
while
(
defined
(
my
$rec
=
$code
->())) {
_pci_json()->encode(
$rec
),
"\n"
} }
}
else
{
$fres
;
}
if
(
defined
$save_res
) {
$_pci_r
->{res}[2] =
$save_res
}
}
### exit
{
my
$status
=
$_pci_r
->{res}[0];
my
$exit_code
=
$_pci_r
->{res}[3]{
"cmdline.exit_code"
} // (
$status
=~ /200|304/ ? 0 : (
$status
-300));
exit
(
$exit_code
);
}
=pod
=encoding UTF-8
=head1 NAME
check-module-version - Check module (e.g. check latest version) with CPAN (or equivalent repo)
=head1 VERSION
This document describes version 0.08 of main (from Perl distribution Module-CheckVersion), released on 2017-06-09.
=head1 SYNOPSIS
Usage:
% check-module-version [options] <module>
=head1 DESCRIPTION
Designed to be more general and able to provide more information in the future
in addition to mere checking of latest version, but checking latest version is
currently the only implemented feature.
Can handle non-CPAN modules, as long as you put the appropriate C<$AUTHORITY> in
your modules and create the C<< Module::CheckVersion::E<lt>schemeE<gt> >> to handle your
authority scheme.
=head1 OPTIONS
C<*> marks required options.
=head2 Main options
=over
=item B<--default-authority-scheme>=I<s>
Default value:
"cpan"
If a module does not set `$AUTHORITY` (which contains string like
`<scheme>:<extra>` like `cpan:PERLANCAR`), the default authority scheme will be
determined from this setting. The module `Module::CheckVersion::<scheme>` module
is used to implement actual checking.
Can also be set to undef, in which case when module's `$AUTHORITY` is not
available, will return 412 status.
=item B<--module>=I<s>*
This routine will try to load the module, and retrieve its `$VERSION`. If
loading fails will assume module's installed version is undef.
=item B<--no-check-latest-version>
=back
=head2 Configuration options
=over
=item B<--config-path>=I<filename>
Set path to configuration file.
Can be specified multiple times.
=item B<--config-profile>=I<s>
Set configuration profile to use.
=item B<--no-config>
Do not use any configuration file.
=back
=head2 Environment options
=over
=item B<--no-env>
Do not read environment for default options.
=back
=head2 Output options
=over
=item B<--format>=I<s>
Choose output format, e.g. json, text.
Default value:
undef
=item B<--json>
Set output format to json.
=item B<--naked-res>
When outputing as JSON, strip result envelope.
Default value:
0
By default, when outputing as JSON, the full enveloped result is returned, e.g.:
[200,"OK",[1,2,3],{"func.extra"=>4}]
The reason is so you can get the status (1st element), status message (2nd
element) as well as result metadata/extra result (4th element) instead of just
the result (3rd element). However, sometimes you want just the result, e.g. when
you want to pipe the result for more post-processing. In this case you can use
`--naked-res` so you just get:
[1,2,3]
=back
=head2 Other options
=over
=item B<--help>, B<-h>, B<-?>
Display help message and exit.
=item B<--version>, B<-v>
Display program's version and exit.
=back
=head1 COMPLETION
The script comes with a companion shell completer script (L<_check-module-version>)
for this script.
=head2 bash
To activate bash completion for this script, put:
complete -C _check-module-version check-module-version
in your bash startup (e.g. F<~/.bashrc>). Your next shell session will then
recognize tab completion for the command. Or, you can also directly execute the
line above in your shell to activate immediately.
It is recommended, however, that you install L<shcompgen> which allows you to
activate completion scripts for several kinds of scripts on multiple shells.
Some CPAN distributions (those that are built with
L<Dist::Zilla::Plugin::GenShellCompletion>) will even automatically enable shell
completion for their included scripts (using L<shcompgen>) at installation time,
so you can immediately have tab completion.
=head2 tcsh
To activate tcsh completion for this script, put:
complete check-module-version 'p/*/`check-module-version`/'
in your tcsh startup (e.g. F<~/.tcshrc>). Your next shell session will then
recognize tab completion for the command. Or, you can also directly execute the
line above in your shell to activate immediately.
It is also recommended to install L<shcompgen> (see above).
=head2 other shells
For fish and zsh, install L<shcompgen> as described above.
=head1 CONFIGURATION FILE
This script can read configuration files. Configuration files are in the format of L<IOD>, which is basically INI with some extra features.
By default, these names are searched for configuration filenames (can be changed using C<--config-path>): F<~/.config/check-module-version.conf>, F<~/check-module-version.conf>, or F</etc/check-module-version.conf>.
All found files will be read and merged.
To disable searching for configuration files, pass C<--no-config>.
You can put multiple profiles in a single file by using section names like C<[profile=SOMENAME]> or C<[SOMESECTION profile=SOMENAME]>. Those sections will only be read if you specify the matching C<--config-profile SOMENAME>.
You can also put configuration for multiple programs inside a single file, and use filter C<program=NAME> in section names, e.g. C<[program=NAME ...]> or C<[SOMESECTION program=NAME]>. The section will then only be used when the reading program matches.
Finally, you can filter a section by environment variable using the filter C<env=CONDITION> in section names. For example if you only want a section to be read if a certain environment variable is true: C<[env=SOMEVAR ...]> or C<[SOMESECTION env=SOMEVAR ...]>. If you only want a section to be read when the value of an environment variable has value equals something: C<[env=HOSTNAME=blink ...]> or C<[SOMESECTION env=HOSTNAME=blink ...]>. If you only want a section to be read when the value of an environment variable does not equal something: C<[env=HOSTNAME!=blink ...]> or C<[SOMESECTION env=HOSTNAME!=blink ...]>. If you only want a section to be read when an environment variable contains something: C<[env=HOSTNAME*=server ...]> or C<[SOMESECTION env=HOSTNAME*=server ...]>. Note that currently due to simplistic parsing, there must not be any whitespace in the value being compared because it marks the beginning of a new section filter or section name.
List of available configuration parameters:
check_latest_version (see --no-check-latest-version)
default_authority_scheme (see --default-authority-scheme)
format (see --format)
module (see --module)
naked_res (see --naked-res)
=head1 ENVIRONMENT
=head2 CHECK_MODULE_VERSION_OPT => str
Specify additional command-line options.
=head1 FILES
F<~/.config/check-module-version.conf>
F<~/check-module-version.conf>
F</etc/check-module-version.conf>
=head1 HOMEPAGE
Please visit the project's homepage at L<https://metacpan.org/release/Module-CheckVersion>.
=head1 SOURCE
Source repository is at L<https://github.com/perlancar/perl-Module-CheckVersion>.
=head1 BUGS
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-CheckVersion>
When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.
=head1 AUTHOR
perlancar <perlancar@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017, 2015 by perlancar@cpan.org.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__DATA__
Data::Section::Seekable v1
Clone/PP.pm,20,1884,0;0
Complete/Bash.pm,1929,17459,1;71
Config/IOD/Base.pm,19415,13009,2;596
Config/IOD/Reader.pm,32453,6377,3;1088
Data/Check/Structure.pm,38862,3555,4;1295
Data/Sah/Normalize.pm,42447,6073,5;1460
Getopt/Long/EvenLess.pm,48552,5670,6;1641
Local/_pci_check_args.pm,54255,903,7;1843
Local/_pci_clean_json.pm,55191,3724,8;1863
Perinci/CmdLine/Util/Config.pm,58954,7499,9;1916
Perinci/Result/Format/Lite.pm,66491,17690,10;2178
Perinci/Sub/Normalize.pm,84214,4885,11;2641
Sah/Schema/rinci/function_meta.pm,89141,3632,12;2793
Text/Table/Tiny.pm,92800,2733,13;2931
### Clone/PP.pm ###
#package Clone::PP;
#
#use 5.006;
#use strict;
#use warnings;
#use vars qw($VERSION @EXPORT_OK);
#use Exporter;
#
#$VERSION = 1.06;
#
#@EXPORT_OK = qw( clone );
#sub import { goto &Exporter::import }
#
#use vars qw( $CloneSelfMethod $CloneInitMethod );
#$CloneSelfMethod ||= 'clone_self';
#$CloneInitMethod ||= 'clone_init';
#
#use vars qw( %CloneCache );
#
#sub clone {
# my $source = shift;
#
# return undef if not defined($source);
#
# my $depth = shift;
# return $source if ( defined $depth and $depth -- < 1 );
#
# local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
#
# return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
#
# my $ref_type = ref $source or return $source;
#
# my $class_name;
# if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
# $class_name = $ref_type;
# $ref_type = $1;
# return $CloneCache{ $source } = $source->$CloneSelfMethod()
# if $source->can($CloneSelfMethod);
# }
#
#
# 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 {
# $CloneCache{ $source } = $copy = $source;
# }
#
# if ( $class_name ) {
# bless $copy, $class_name;
# $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
# }
#
# return $copy;
#}
#
#1;
#
#__END__
#
### Complete/Bash.pm ###
#package Complete::Bash;
#
#our $DATE = '2016-12-28';
#our $VERSION = '0.31';
#
#use 5.010001;
#use strict;
#use warnings;
#
#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";
#}
#
#sub _add_unquoted {
# no warnings 'uninitialized';
#
# my ($word, $is_cur_word, $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;
#
#
# my @words;
# my $cword;
# my $pos = 0;
# my $pos_min_ws = 0;
# my $after_ws = 1;
# my $chunk;
# my $add_blank;
# my $is_cur_word;
# $line =~ s!( # 1) everything
# (")((?: \\\\|\\"|[^"])*)(?:"|\z)(\s*) | # 2) open " 3) content 4) space after
# (')((?: \\\\|\\'|[^'])*)(?:'|\z)(\s*) | # 5) open ' 6) content 7) space after
# ((?: \\\\|\\"|\\'|\\=|\\\s|[^"'@><=|&\(:\s])+)(\s*) | # 8) unquoted word 9) space after
# ([\@><=|&\(:]+) | # 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] //= '';
#
# [\@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];
#}
#
#$SPEC{format_completion} = {
# v => 1.1,
# summary => 'Format completion for output (for shell)',
# description => <<'_',
#
#Bash accepts completion reply in the form of one entry per line to STDOUT. Some
#characters will need to be escaped. This function helps you do the formatting,
#with some options.
#
#This function accepts completion answer structure as described in the `Complete`
#POD. Aside from `words`, this function also recognizes these keys:
#
#* `as` (str): Either `string` (the default) or `array` (to return array of lines
# instead of the lines joined together). Returning array is useful if you are
# doing completion inside `Term::ReadLine`, for example, where the library
# expects an array.
#
#* `esc_mode` (str): Escaping mode for entries. Either `default` (most
# nonalphanumeric characters will be escaped), `shellvar` (like `default`, but
# dollar sign `$` will not be escaped, convenient when completing environment
# variables for example), `filename` (currently equals to `default`), `option`
# (currently equals to `default`), or `none` (no escaping will be done).
#
#* `path_sep` (str): If set, will enable "path mode", useful for
# completing/drilling-down path. Below is the description of "path mode".
#
# In shell, when completing filename (e.g. `foo`) and there is only a single
# possible completion (e.g. `foo` or `foo.txt`), the shell will display the
# completion in the buffer and automatically add a space so the user can move to
# the next argument. This is also true when completing other values like
# variables or program names.
#
# However, when completing directory (e.g. `/et` or `Downloads`) and there is
# solely a single completion possible and it is a directory (e.g. `/etc` or
# `Downloads`), the shell automatically adds the path separator character
# instead (`/etc/` or `Downloads/`). The user can press Tab again to complete
# for files/directories inside that directory, and so on. This is obviously more
# convenient compared to when shell adds a space instead.
#
# The `path_sep` option, when set, will employ a trick to mimic this behaviour.
# The trick is, if you have a completion array of `['foo/']`, it will be changed
# to `['foo/', 'foo/ ']` (the second element is the first element with added
# space at the end) to prevent bash from adding a space automatically.
#
# Path mode is not restricted to completing filesystem paths. Anything path-like
# can use it. For example when you are completing Java or Perl module name (e.g.
# `com.company.product.whatever` or `File::Spec::Unix`) you can use this mode
# (with `path_sep` appropriately set to, e.g. `.` or `::`).
#
#_
# args_as => 'array',
# args => {
# completion => {
# summary => 'Completion answer structure',
# description => <<'_',
#
#Either an array or hash. See function description for more details.
#
#_
# schema=>['any*' => of => ['hash*', 'array*']],
# req=>1,
# pos=>0,
# },
# opts => {
# schema=>'hash*',
# pos=>1,
# },
# },
# result => {
# summary => 'Formatted string (or array, if `as` is set to `array`)',
# schema => ['any*' => of => ['str*', 'array*']],
# },
# result_naked => 1,
#};
#sub format_completion {
# my ($hcomp, $opts) = @_;
#
# $opts //= {};
#
# $hcomp = {words=>$hcomp} unless ref($hcomp) eq 'HASH';
# my $comp = $hcomp->{words};
# my $as = $hcomp->{as} // 'string';
# my $esc_mode = $hcomp->{esc_mode} // $hcomp->{escmode} // 'default';
# my $path_sep = $hcomp->{path_sep};
#
# if (defined($path_sep) && @$comp == 1) {
# my $re = qr/\Q$path_sep\E\z/;
# my $word;
# if (ref($comp->[0]) eq 'HASH') {
# $comp = [$comp->[0], {word=>"$comp->[0] "}] if
# $comp->[0]{word} =~ $re;
# } else {
# $comp = [$comp->[0], "$comp->[0] "]
# if $comp->[0] =~ $re;
# }
# }
#
# if (defined($opts->{word})) {
# if ($opts->{word} =~ s/(.+[\@><=;|&\(:])//) {
# my $prefix = $1;
# for (@$comp) {
# if (ref($_) eq 'HASH') {
# $_->{word} =~ s/\A\Q$prefix\E//i;
# } else {
# s/\A\Q$prefix\E//i;
# }
# }
# }
# }
#
# my @res;
# for my $entry (@$comp) {
# my $word = ref($entry) eq 'HASH' ? $entry->{word} : $entry;
# if ($esc_mode eq 'shellvar') {
# $word =~ s!([^A-Za-z0-9,+._/\$~-])!\\$1!g;
# } elsif ($esc_mode eq 'none') {
# } else {
# $word =~ s!([^A-Za-z0-9,+._/:~-])!\\$1!g;
# }
# push @res, $word;
# }
#
# if ($as eq 'array') {
# return \@res;
# } else {
# return join("", map {($_, "\n")} @res);
# }
#}
#
#1;
#
#__END__
#
### Config/IOD/Base.pm ###
#package Config::IOD::Base;
#
#our $DATE = '2017-01-16';
#our $VERSION = '0.32';
#
#use 5.010001;
#use strict;
#use warnings;
#
#use constant +{
# COL_V_ENCODING => 0,
# COL_V_WS1 => 1,
# COL_V_VALUE => 2,
# COL_V_WS2 => 3,
# COL_V_COMMENT_CHAR => 4,
# COL_V_COMMENT => 5,
#};
#
#sub new {
# my ($class, %attrs) = @_;
# $attrs{default_section} //= 'GLOBAL';
# $attrs{allow_bang_only} //= 1;
# $attrs{allow_duplicate_key} //= 1;
# $attrs{enable_encoding} //= 1;
# $attrs{enable_quoting} //= 1;
# $attrs{enable_bracket} //= 1;
# $attrs{enable_brace} //= 1;
# $attrs{enable_tilde} //= 1;
# $attrs{enable_expr} //= 0;
# $attrs{ignore_unknown_directive} //= 0;
# bless \%attrs, $class;
#}
#
#sub _parse_command_line {
# my ($self, $str) = @_;
#
# $str =~ s/\A\s+//ms;
# $str =~ s/\s+\z//ms;
#
# my @argv;
# my $buf;
# my $escaped;
# my $double_quoted;
# my $single_quoted;
#
# for my $char (split //, $str) {
# if ($escaped) {
# $buf .= $char;
# $escaped = undef;
# next;
# }
#
# if ($char eq '\\') {
# if ($single_quoted) {
# $buf .= $char;
# }
# else {
# $escaped = 1;
# }
# next;
# }
#
# if ($char =~ /\s/) {
# if ($single_quoted || $double_quoted) {
# $buf .= $char;
# }
# else {
# push @argv, $buf if defined $buf;
# undef $buf;
# }
# next;
# }
#
# if ($char eq '"') {
# if ($single_quoted) {
# $buf .= $char;
# next;
# }
# $double_quoted = !$double_quoted;
# next;
# }
#
# if ($char eq "'") {
# if ($double_quoted) {
# $buf .= $char;
# next;
# }
# $single_quoted = !$single_quoted;
# next;
# }
#
# $buf .= $char;
# }
# push @argv, $buf if defined $buf;
#
# if ($escaped || $single_quoted || $double_quoted) {
# return undef;
# }
#
# \@argv;
#}
#
#sub _parse_raw_value {
# my ($self, $val, $needs_res) = @_;
#
# if ($val =~ /\A!/ && $self->{enable_encoding}) {
#
# $val =~ s/!(\w+)(\s+)// or return ("Invalid syntax in encoded value");
# my ($enc, $ws1) = ($1, $2);
#
# my $res = [
# "!$enc",
# $ws1,
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
#
# $enc = "json" if $enc eq 'j';
# $enc = "hex" if $enc eq 'h';
# $enc = "expr" if $enc eq 'e';
#
# if ($self->{allow_encodings}) {
# return ("Encoding '$enc' is not in ".
# "allow_encodings list")
# unless grep {$_ eq $enc} @{$self->{allow_encodings}};
# }
# if ($self->{disallow_encodings}) {
# return ("Encoding '$enc' is in ".
# "disallow_encodings list")
# if grep {$_ eq $enc} @{$self->{disallow_encodings}};
# }
#
# if ($enc eq 'json') {
#
# $val =~ /\A
# (".*"|\[.*\]|\{.*\}|\S+)
# (\s*)
# (?: ([;#])(.*) )?
# \z/x or return ("Invalid syntax in JSON-encoded value");
# my $decode_res = $self->_decode_json($val);
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($enc eq 'path' || $enc eq 'paths') {
#
# my $decode_res = $self->_decode_path_or_paths($val, $enc);
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($enc eq 'hex') {
#
# $val =~ /\A
# ([0-9A-Fa-f]*)
# (\s*)
# (?: ([;#])(.*) )?
# \z/x or return ("Invalid syntax in hex-encoded value");
# my $decode_res = $self->_decode_hex($1);
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($enc eq 'base64') {
#
# $val =~ m!\A
# ([A-Za-z0-9+/]*=*)
# (\s*)
# (?: ([;#])(.*) )?
# \z!x or return ("Invalid syntax in base64-encoded value");
# my $decode_res = $self->_decode_base64($1);
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($enc eq 'none') {
#
# return (undef, $res, $val);
#
# } elsif ($enc eq 'expr') {
#
# return ("expr is not allowed (enable_expr=0)")
# unless $self->{enable_expr};
# $val =~ m!\A
# ((?:[^#;])+?)
# (\s*)
# (?: ([;#])(.*) )?
# \z!x or return ("Invalid syntax in expr-encoded value");
# my $decode_res = $self->_decode_expr($1);
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } else {
#
# return ("unknown encoding '$enc'");
#
# }
#
# } elsif ($val =~ /\A"/ && $self->{enable_quoting}) {
#
# $val =~ /\A
# "( (?:
# \\\\ | # backslash
# \\. | # escaped something
# [^"\\]+ # non-doublequote or non-backslash
# )* )"
# (\s*)
# (?: ([;#])(.*) )?
# \z/x or return ("Invalid syntax in quoted string value");
# my $res = [
# '"',
# '',
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
# my $decode_res = $self->_decode_json(qq("$1"));
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($val =~ /\A\[/ && $self->{enable_bracket}) {
#
# $val =~ /\A
# \[(.*)\]
# (?:
# (\s*)
# ([#;])(.*)
# )?
# \z/x or return ("Invalid syntax in bracketed array value");
# my $res = [
# '[',
# '',
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
# my $decode_res = $self->_decode_json("[$1]");
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($val =~ /\A\{/ && $self->{enable_brace}) {
#
# $val =~ /\A
# \{(.*)\}
# (?:
# (\s*)
# ([#;])(.*)
# )?
# \z/x or return ("Invalid syntax in braced hash value");
# my $res = [
# '{',
# '',
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
# my $decode_res = $self->_decode_json("{$1}");
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } elsif ($val =~ /\A~/ && $self->{enable_tilde}) {
#
# $val =~ /\A
# ~(.*)
# (\s*)
# (?: ([;#])(.*) )?
# \z/x or return ("Invalid syntax in path value");
# my $res = [
# '~',
# '',
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
#
# my $decode_res = $self->_decode_path_or_paths($val, 'path');
# return ($decode_res->[1]) unless $decode_res->[0] == 200;
# return (undef, $res, $decode_res->[2]);
#
# } else {
#
# $val =~ /\A
# (.*?)
# (\s*)
# (?: ([#;])(.*) )?
# \z/x or return ("Invalid syntax in value");
# my $res = [
# '',
# '',
# $1,
# $2,
# $3,
# $4,
# ] if $needs_res;
# return (undef, $res, $1);
#
# }
#}
#
#sub _get_my_user_name {
# if ($^O eq 'MSWin32') {
# return $ENV{USERNAME};
# } else {
# return $ENV{USER} if $ENV{USER};
# my @pw;
# eval { @pw = getpwuid($>) };
# return $pw[0] if @pw;
# }
#}
#
#sub _get_my_home_dir {
# if ($^O eq 'MSWin32') {
# return $ENV{HOME} if $ENV{HOME};
# return $ENV{USERPROFILE} if $ENV{USERPROFILE};
# return join($ENV{HOMEDRIVE}, "\\", $ENV{HOMEPATH})
# if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
# } else {
# return $ENV{HOME} if $ENV{HOME};
# my @pw;
# eval { @pw = getpwuid($>) };
# return $pw[7] if @pw;
# }
#
# die "Can't get home directory";
#}
#
#sub _get_users_home_dir {
# my ($name) = @_;
#
# if ($^O eq 'MSWin32') {
# return undef;
# } else {
# if ($name eq getpwuid($<)) {
# return _get_my_home_dir();
# }
#
# SCOPE: {
# my $home = (getpwnam($name))[7];
# return $home if $home and -d $home;
# }
#
# return undef;
# }
#
#}
#
#sub _decode_json {
# my ($self, $val) = @_;
# state $json = do {
# if (eval { require Cpanel::JSON::XS; 1 }) {
# Cpanel::JSON::XS->new->allow_nonref;
# } else {
# require JSON::PP;
# JSON::PP->new->allow_nonref;
# }
# };
# my $res;
# eval { $res = $json->decode($val) };
# if ($@) {
# return [500, "Invalid JSON: $@"];
# } else {
# return [200, "OK", $res];
# }
#}
#
#sub _decode_path_or_paths {
# my ($self, $val, $which) = @_;
#
# if ($val =~ m!\A~([^/]+)?(?:/|\z)!) {
# my $home_dir = length($1) ?
# _get_users_home_dir($1) : _get_my_home_dir();
# unless ($home_dir) {
# if (length $1) {
# return [500, "Can't get home directory for user '$1' in path"];
# } else {
# return [500, "Can't get home directory for current user in path"];
# }
# }
# $val =~ s!\A~([^/]+)?!$home_dir!;
# }
# $val =~ s!(?<=.)/\z!!;
#
# if ($which eq 'path') {
# return [200, "OK", $val];
# } else {
# return [200, "OK", [glob $val]];
# }
#}
#
#sub _decode_hex {
# my ($self, $val) = @_;
# [200, "OK", pack("H*", $val)];
#}
#
#sub _decode_base64 {
# my ($self, $val) = @_;
# require MIME::Base64;
# [200, "OK", MIME::Base64::decode_base64($val)];
#}
#
#sub _decode_expr {
# require Config::IOD::Expr;
#
# my ($self, $val) = @_;
# no strict 'refs';
# local *{"Config::IOD::Expr::val"} = sub {
# my $arg = shift;
# if ($arg =~ /(.+)\.(.+)/) {
# return $self->{_res}{$1}{$2};
# } else {
# return $self->{_res}{ $self->{_cur_section} }{$arg};
# }
# };
# Config::IOD::Expr::_parse_expr($val);
#}
#
#sub _err {
# my ($self, $msg) = @_;
# die join(
# "",
# @{ $self->{_include_stack} } ? "$self->{_include_stack}[0] " : "",
# "line $self->{_linum}: ",
# $msg
# );
#}
#
#sub _push_include_stack {
# require Cwd;
#
# my ($self, $path) = @_;
#
# if (@{ $self->{_include_stack} }) {
# require File::Spec;
# my ($vol, $dir, $file) =
# File::Spec->splitpath($self->{_include_stack}[-1]);
# $path = File::Spec->rel2abs($path, File::Spec->catpath($vol, $dir));
# }
#
# my $abs_path = Cwd::abs_path($path) or return [400, "Invalid path name"];
# return [409, "Recursive", $abs_path]
# if grep { $_ eq $abs_path } @{ $self->{_include_stack} };
# push @{ $self->{_include_stack} }, $abs_path;
# return [200, "OK", $abs_path];
#}
#
#sub _pop_include_stack {
# my $self = shift;
#
# die "BUG: Overpopped _pop_include_stack"
# unless @{$self->{_include_stack}};
# pop @{ $self->{_include_stack} };
#}
#
#sub _init_read {
# my $self = shift;
#
# $self->{_include_stack} = [];
#}
#
#sub _read_file {
# my ($self, $filename) = @_;
# open my $fh, "<", $filename
# or die "Can't open file '$filename': $!";
# binmode($fh, ":utf8");
# local $/;
# return scalar <$fh>;
#}
#
#sub read_file {
# my $self = shift;
# my $filename = shift;
# $self->_init_read;
# my $res = $self->_push_include_stack($filename);
# die "Can't read '$filename': $res->[1]" unless $res->[0] == 200;
# $res =
# $self->_read_string($self->_read_file($filename), @_);
# $self->_pop_include_stack;
# $res;
#}
#
#sub read_string {
# my $self = shift;
# $self->_init_read;
# $self->_read_string(@_);
#}
#
#1;
#
#__END__
#
### Config/IOD/Reader.pm ###
#package Config::IOD::Reader;
#
#our $DATE = '2017-01-16';
#our $VERSION = '0.32';
#
#use 5.010001;
#use strict;
#use warnings;
#
#use parent qw(Config::IOD::Base);
#
#sub _merge {
# my ($self, $section) = @_;
#
# my $res = $self->{_res};
# for my $msect (@{ $self->{_merge} }) {
# if ($msect eq $section) {
# next;
# }
# if (!exists($res->{$msect})) {
# local $self->{_linum} = $self->{_linum}-1;
# $self->_err("Can't merge section '$msect' to '$section': ".
# "Section '$msect' not seen yet");
# }
# for my $k (keys %{ $res->{$msect} }) {
# $res->{$section}{$k} //= $res->{$msect}{$k};
# }
# }
#}
#
#sub _init_read {
# my $self = shift;
#
# $self->SUPER::_init_read;
# $self->{_res} = {};
# $self->{_merge} = undef;
# $self->{_num_seen_section_lines} = 0;
# $self->{_cur_section} = $self->{default_section};
# $self->{_arrayified} = {};
#}
#
#sub _read_string {
# my ($self, $str, $cb) = @_;
#
# my $res = $self->{_res};
# my $cur_section = $self->{_cur_section};
#
# my $directive_re = $self->{allow_bang_only} ?
# qr/^;?\s*!\s*(\w+)\s*/ :
# qr/^;\s*!\s*(\w+)\s*/;
#
# my $_raw_val;
#
# my @lines = split /^/, $str;
# local $self->{_linum} = 0;
# LINE:
# for my $line (@lines) {
# $self->{_linum}++;
#
# if ($line !~ /\S/) {
# next LINE;
# }
#
# if ($line =~ s/$directive_re//) {
# my $directive = $1;
# if ($self->{allow_directives}) {
# $self->_err("Directive '$directive' is not in ".
# "allow_directives list")
# unless grep { $_ eq $directive }
# @{$self->{allow_directives}};
# }
# if ($self->{disallow_directives}) {
# $self->_err("Directive '$directive' is in ".
# "disallow_directives list")
# if grep { $_ eq $directive }
# @{$self->{disallow_directives}};
# }
# my $args = $self->_parse_command_line($line);
# if (!defined($args)) {
# $self->_err("Invalid arguments syntax '$line'");
# }
#
# if ($cb) {
# $cb->(
# event => 'directive',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# directive => $directive,
# args => $args,
# );
# }
#
# if ($directive eq 'include') {
# my $path;
# if (! @$args) {
# $self->_err("Missing filename to include");
# } elsif (@$args > 1) {
# $self->_err("Extraneous arguments");
# } else {
# $path = $args->[0];
# }
# my $res = $self->_push_include_stack($path);
# if ($res->[0] != 200) {
# $self->_err("Can't include '$path': $res->[1]");
# }
# $path = $res->[2];
# $self->_read_string($self->_read_file($path, $cb));
# $self->_pop_include_stack;
# } elsif ($directive eq 'merge') {
# $self->{_merge} = @$args ? $args : undef;
# } elsif ($directive eq 'noop') {
# } else {
# if ($self->{ignore_unknown_directive}) {
# next LINE;
# } else {
# $self->_err("Unknown directive '$directive'");
# }
# }
# next LINE;
# }
#
# if ($line =~ /^\s*[;#]/) {
#
# if ($cb) {
# $cb->(
# event => 'comment',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# );
# }
#
# next LINE;
# }
#
# if ($line =~ /^\s*\[\s*(.+?)\s*\](?: \s*[;#].*)?/) {
# my $prev_section = $self->{_cur_section};
# $self->{_cur_section} = $cur_section = $1;
# $res->{$cur_section} //= {};
# $self->{_num_seen_section_lines}++;
#
# if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
# $self->_merge($prev_section);
# }
#
# if ($cb) {
# $cb->(
# event => 'section',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# section => $cur_section,
# );
# }
#
# next LINE;
# }
#
# if ($line =~ /^\s*([^=]+?)\s*=\s*(.*)/) {
# my $key = $1;
# my $val = $2;
#
# if ($val =~ /\A["!\\[\{~]/) {
# $_raw_val = $val if $cb;
# my ($err, $parse_res, $decoded_val) = $self->_parse_raw_value($val);
# $self->_err("Invalid value: " . $err) if $err;
# $val = $decoded_val;
# } else {
# $_raw_val = $val if $cb;
# $val =~ s/\s*[#;].*//;
# }
#
# if (exists $res->{$cur_section}{$key}) {
# if (!$self->{allow_duplicate_key}) {
# $self->_err("Duplicate key: $key (section $cur_section)");
# } elsif ($self->{_arrayified}{$cur_section}{$key}++) {
# push @{ $res->{$cur_section}{$key} }, $val;
# } else {
# $res->{$cur_section}{$key} = [
# $res->{$cur_section}{$key}, $val];
# }
# } else {
# $res->{$cur_section}{$key} = $val;
# }
#
# if ($cb) {
# $cb->(
# event => 'key',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# key => $key,
# val => $val,
# raw_val => $_raw_val,
# );
# }
#
# next LINE;
# }
#
# $self->_err("Invalid syntax");
# }
#
# if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
# $self->_merge($cur_section);
# }
#
# $res;
#}
#
#1;
#
#__END__
#
### Data/Check/Structure.pm ###
#package Data::Check::Structure;
#
#our $DATE = '2014-07-14';
#our $VERSION = '0.03';
#
#use 5.010001;
#use strict;
#use warnings;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# is_aoa
# is_aoaos
# is_aoh
# is_aohos
# is_aos
# is_hoa
# is_hoaos
# is_hoh
# is_hohos
# is_hos
# );
#
#sub is_aos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'ARRAY';
# for my $i (0..@$data-1) {
# last if defined($max) && $i >= $max;
# return 0 if ref($data->[$i]);
# }
# 1;
#}
#
#sub is_aoa {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'ARRAY';
# for my $i (0..@$data-1) {
# last if defined($max) && $i >= $max;
# return 0 unless ref($data->[$i]) eq 'ARRAY';
# }
# 1;
#}
#
#sub is_aoaos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'ARRAY';
# my $aos_opts = {max=>$max};
# for my $i (0..@$data-1) {
# last if defined($max) && $i >= $max;
# return 0 unless is_aos($data->[$i], $aos_opts);
# }
# 1;
#}
#
#sub is_aoh {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'ARRAY';
# for my $i (0..@$data-1) {
# last if defined($max) && $i >= $max;
# return 0 unless ref($data->[$i]) eq 'HASH';
# }
# 1;
#}
#
#sub is_aohos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'ARRAY';
# my $hos_opts = {max=>$max};
# for my $i (0..@$data-1) {
# last if defined($max) && $i >= $max;
# return 0 unless is_hos($data->[$i], $hos_opts);
# }
# 1;
#}
#
#sub is_hos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'HASH';
# my $i = 0;
# for my $k (keys %$data) {
# last if defined($max) && ++$i >= $max;
# return 0 if ref($data->{$k});
# }
# 1;
#}
#
#sub is_hoa {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'HASH';
# my $i = 0;
# for my $k (keys %$data) {
# last if defined($max) && ++$i >= $max;
# return 0 unless ref($data->{$k}) eq 'ARRAY';
# }
# 1;
#}
#
#sub is_hoaos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'HASH';
# my $i = 0;
# for my $k (keys %$data) {
# last if defined($max) && ++$i >= $max;
# return 0 unless is_aos($data->{$k});
# }
# 1;
#}
#
#sub is_hoh {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'HASH';
# my $i = 0;
# for my $k (keys %$data) {
# last if defined($max) && ++$i >= $max;
# return 0 unless ref($data->{$k}) eq 'HASH';
# }
# 1;
#}
#
#sub is_hohos {
# my ($data, $opts) = @_;
# $opts //= {};
# my $max = $opts->{max};
#
# return 0 unless ref($data) eq 'HASH';
# my $i = 0;
# for my $k (keys %$data) {
# last if defined($max) && ++$i >= $max;
# return 0 unless is_hos($data->{$k});
# }
# 1;
#}
#
#1;
#
#__END__
#
### Data/Sah/Normalize.pm ###
#package Data::Sah::Normalize;
#
#use 5.010001;
#use strict;
#use warnings;
#
#our $DATE = '2015-09-06';
#our $VERSION = '0.04';
#
#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};
#
# my $expr;
# if ($c =~ s/=\z//) {
# $expr++;
# 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'";
# 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";
# }
# }
#
# 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};
#
#
# $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 {
# 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 = {};
# }
#
# 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;
#
#__END__
#
### Getopt/Long/EvenLess.pm ###
#package Getopt::Long::EvenLess;
#
#our $DATE = '2017-01-11';
#our $VERSION = '0.10';
#
#
#our @EXPORT = qw(GetOptions);
#our @EXPORT_OK = qw(GetOptionsFromArray);
#
#my $config = {
# pass_through => 0,
#};
#
#sub Configure {
# my $old_config = { %$config };
#
# if (ref($_[0]) eq 'HASH') {
# for (keys %{$_[0]}) {
# $config->{$_} = $_[0]{$_};
# }
# } else {
# for (@_) {
# if ($_ eq 'pass_through') {
# $config->{pass_through} = 1;
# } elsif ($_ eq 'no_pass_through') {
# $config->{pass_through} = 0;
# } else {
# die "Unknown configuration '$_'";
# }
# }
# }
# $old_config;
#}
#
#sub import {
# my $pkg = shift;
# my $caller = caller;
# my @imp = @_ ? @_ : @EXPORT;
# for my $imp (@imp) {
# if (grep {$_ eq $imp} (@EXPORT, @EXPORT_OK)) {
# *{"$caller\::$imp"} = \&{$imp};
# } else {
# die "$imp is not exported by ".__PACKAGE__;
# }
# }
#}
#
#sub GetOptionsFromArray {
# my ($argv, %spec) = @_;
#
# my $success = 1;
#
# my %spec_by_opt_name;
# for (keys %spec) {
# my $orig = $_;
# s/=[fios]\@?\z//;
# s/\|.+//;
# $spec_by_opt_name{$_} = $orig;
# }
#
# my $code_find_opt = sub {
# my ($wanted, $short_mode) = @_;
# my @candidates;
# OPT_SPEC:
# for my $spec (keys %spec) {
# $spec =~ s/=[fios]\@?\z//;
# my @opts = split /\|/, $spec;
# for my $o (@opts) {
# next if $short_mode && length($o) > 1;
# if ($o eq $wanted) {
# @candidates = ($opts[0]);
# last OPT_SPEC;
# } elsif (index($o, $wanted) == 0) {
# push @candidates, $opts[0];
# next OPT_SPEC;
# }
# }
# }
# if (!@candidates) {
# unless ($config->{pass_through}) {
# warn "Unknown option: $wanted\n";
# $success = 0;
# }
# return undef;
# } elsif (@candidates > 1) {
# unless ($config->{pass_through}) {
# warn "Option $wanted is ambiguous (" .
# join(", ", @candidates) . ")\n";
# $success = 0;
# }
# return '';
# }
# return $candidates[0];
# };
#
# my $code_set_val = sub {
# my $name = shift;
#
# my $spec_key = $spec_by_opt_name{$name};
# my $handler = $spec{$spec_key};
#
# $handler->({name=>$name}, @_ ? $_[0] : 1);
# };
#
# my $i = -1;
# my @remaining;
# ELEM:
# while (++$i < @$argv) {
# if ($argv->[$i] eq '--') {
#
# push @remaining, @{$argv}[$i+1 .. @$argv-1];
# last ELEM;
#
# } elsif ($argv->[$i] =~ /\A--(.+?)(?:=(.*))?\z/) {
#
# my ($used_name, $val_in_opt) = ($1, $2);
# my $opt = $code_find_opt->($used_name);
# if (!defined($opt)) {
# push @remaining, $argv->[$i];
# next ELEM;
# } elsif (!length($opt)) {
# push @remaining, $argv->[$i];
# next ELEM;
# }
#
# my $spec = $spec_by_opt_name{$opt};
# if ($spec =~ /=[fios]\@?\z/) {
# if (defined $val_in_opt) {
# $code_set_val->($opt, $val_in_opt);
# } else {
# if ($i+1 >= @$argv) {
# warn "Option $used_name requires an argument\n";
# $success = 0;
# last ELEM;
# }
# $i++;
# $code_set_val->($opt, $argv->[$i]);
# }
# } else {
# $code_set_val->($opt);
# }
#
# } elsif ($argv->[$i] =~ /\A-(.*)/) {
#
# my $str = $1;
# my $remaining_pushed;
# SHORT_OPT:
# while ($str =~ s/(.)//) {
# my $used_name = $1;
# my $short_opt = $1;
# my $opt = $code_find_opt->($short_opt, 'short');
# if (!defined $opt) {
# push @remaining, "-" unless $remaining_pushed++;
# $remaining[-1] .= $short_opt;
# next SHORT_OPT;
# } elsif (!length $opt) {
# push @remaining, "-" unless $remaining_pushed++;
# $remaining[-1] .= $short_opt;
# }
#
# my $spec = $spec_by_opt_name{$opt};
# if ($spec =~ /=[fios]\@?\z/) {
# if (length $str) {
# $code_set_val->($opt, $str);
# next ELEM;
# } else {
# if ($i+1 >= @$argv) {
# unless ($config->{pass_through}) {
# warn "Option $used_name requires an argument\n";
# $success = 0;
# }
# last ELEM;
# }
# $i++;
# $code_set_val->($opt, $argv->[$i]);
# }
# } else {
# $code_set_val->($opt);
# }
# }
#
# } else {
#
# push @remaining, $argv->[$i];
# next;
#
# }
# }
#
# RETURN:
# splice @$argv, 0, ~~@$argv, @remaining;
# return $success;
#}
#
#sub GetOptions {
# GetOptionsFromArray(\@ARGV, @_);
#}
#
#1;
#
#__END__
#
### Local/_pci_check_args.pm ###
#sub _pci_check_args {
# my ($args) = @_;
# my $sc_name = $_pci_r->{subcommand_name};
# if ($sc_name eq "") {
# FILL_FROM_POS: {
# 1;
# if (@ARGV > 0) { if (exists $args->{"module"}) { return [400, "You specified --module but also argument #0"]; } else { $args->{"module"} = delete($ARGV[0]); } }
# }
# my @check_argv = @ARGV;
#
# $args->{"check_latest_version"} //= 1;
# $args->{"default_authority_scheme"} //= "cpan";
#
# return [400, "Missing required argument: module"] unless exists $args->{"module"};
# return [400, "Missing required value for argument: module"] if exists($args->{"module"}) && !defined($args->{"module"});
# _pci_err([500, "Extraneous command-line argument(s): ".join(", ", @check_argv)]) if @check_argv;
# [200];
# } else { _pci_err([500, "Unknown subcommand1: $sc_name"]); }
#}
#1;
### Local/_pci_clean_json.pm ###
#sub _pci_clean_json { require Clone::PP; require Scalar::Util; use feature 'state'; state $cleanser = sub {
#my $data = shift;
#state %refs;
#state $ctr_circ;
#state $process_array;
#state $process_hash;
#if (!$process_array) { $process_array = sub { my $a = shift; for my $e (@$a) { my $ref=ref($e);
# if ($ref && $refs{ $e }++) { if (++$ctr_circ <= 1) { $e = Clone::PP::clone($e); redo } else { $e = 'CIRCULAR'; $ref = '' } }
# elsif ($ref eq 'DateTime') { $e = $e->epoch; $ref = ref($e) }
# elsif ($ref eq 'Math::BigInt') { $e = $e->bstr; $ref = ref($e) }
# elsif ($ref eq 'Regexp') { $e = "$e"; $ref = "" }
# elsif ($ref eq 'SCALAR') { $e = ${ $e }; $ref = ref($e) }
# elsif ($ref eq 'Time::Moment') { $e = $e->epoch; $ref = ref($e) }
# elsif ($ref eq 'version') { $e = "$e"; $ref = "" }
# elsif (Scalar::Util::blessed($e)) { my $reftype = Scalar::Util::reftype($e); $e = $reftype eq "HASH" ? {%{ $e }} : $reftype eq "ARRAY" ? [@{ $e }] : $reftype eq "SCALAR" ? \(my $copy = ${ $e }) : $reftype eq "CODE" ? sub { goto &{ $e } } :(die "Cannot unbless object with type $ref") }
# my $reftype=Scalar::Util::reftype($e)//"";
# if ($reftype eq "ARRAY") { $process_array->($e) }
# elsif ($reftype eq "HASH") { $process_hash->($e) }
# elsif ($ref) { $e = $ref; $ref = "" }
#} } }
#if (!$process_hash) { $process_hash = sub { my $h = shift; for my $k (keys %$h) { my $ref=ref($h->{$k});
# if ($ref && $refs{ $h->{$k} }++) { if (++$ctr_circ <= 1) { $h->{$k} = Clone::PP::clone($h->{$k}); redo } else { $h->{$k} = 'CIRCULAR'; $ref = '' } }
# elsif ($ref eq 'DateTime') { $h->{$k} = $h->{$k}->epoch; $ref = ref($h->{$k}) }
# elsif ($ref eq 'Math::BigInt') { $h->{$k} = $h->{$k}->bstr; $ref = ref($h->{$k}) }
# elsif ($ref eq 'Regexp') { $h->{$k} = "$h->{$k}"; $ref = "" }
# elsif ($ref eq 'SCALAR') { $h->{$k} = ${ $h->{$k} }; $ref = ref($h->{$k}) }
# elsif ($ref eq 'Time::Moment') { $h->{$k} = $h->{$k}->epoch; $ref = ref($h->{$k}) }
# elsif ($ref eq 'version') { $h->{$k} = "$h->{$k}"; $ref = "" }
# elsif (Scalar::Util::blessed($h->{$k})) { my $reftype = Scalar::Util::reftype($h->{$k}); $h->{$k} = $reftype eq "HASH" ? {%{ $h->{$k} }} : $reftype eq "ARRAY" ? [@{ $h->{$k} }] : $reftype eq "SCALAR" ? \(my $copy = ${ $h->{$k} }) : $reftype eq "CODE" ? sub { goto &{ $h->{$k} } } :(die "Cannot unbless object with type $ref") }
# my $reftype=Scalar::Util::reftype($h->{$k})//"";
# if ($reftype eq "ARRAY") { $process_array->($h->{$k}) }
# elsif ($reftype eq "HASH") { $process_hash->($h->{$k}) }
# elsif ($ref) { $h->{$k} = $ref; $ref = "" }
#} } }
#%refs = (); $ctr_circ=0;
#for ($data) { my $ref=ref($_);
# if ($ref && $refs{ $_ }++) { if (++$ctr_circ <= 1) { $_ = Clone::PP::clone($_); redo } else { $_ = 'CIRCULAR'; $ref = '' } }
# elsif ($ref eq 'DateTime') { $_ = $_->epoch; $ref = ref($_) }
# elsif ($ref eq 'Math::BigInt') { $_ = $_->bstr; $ref = ref($_) }
# elsif ($ref eq 'Regexp') { $_ = "$_"; $ref = "" }
# elsif ($ref eq 'SCALAR') { $_ = ${ $_ }; $ref = ref($_) }
# elsif ($ref eq 'Time::Moment') { $_ = $_->epoch; $ref = ref($_) }
# elsif ($ref eq 'version') { $_ = "$_"; $ref = "" }
# elsif (Scalar::Util::blessed($_)) { my $reftype = Scalar::Util::reftype($_); $_ = $reftype eq "HASH" ? {%{ $_ }} : $reftype eq "ARRAY" ? [@{ $_ }] : $reftype eq "SCALAR" ? \(my $copy = ${ $_ }) : $reftype eq "CODE" ? sub { goto &{ $_ } } :(die "Cannot unbless object with type $ref") }
# my $reftype=Scalar::Util::reftype($_)//"";
# if ($reftype eq "ARRAY") { $process_array->($_) }
# elsif ($reftype eq "HASH") { $process_hash->($_) }
# elsif ($ref) { $_ = $ref; $ref = "" }
#}
#$data
#}
#;; $cleanser->(shift) }
#1;
### Perinci/CmdLine/Util/Config.pm ###
#package Perinci::CmdLine::Util::Config;
#
#our $DATE = '2017-01-13';
#our $VERSION = '1.71';
#
#use 5.010001;
#use strict;
#use warnings;
#
#our %SPEC;
#
#sub _get_my_home_dir {
# if ($^O eq 'MSWin32') {
# return $ENV{HOME} if $ENV{HOME};
# return $ENV{USERPROFILE} if $ENV{USERPROFILE};
# return join($ENV{HOMEDRIVE}, "\\", $ENV{HOMEPATH})
# if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
# } else {
# return $ENV{HOME} if $ENV{HOME};
# my @pw;
# eval { @pw = getpwuid($>) };
# return $pw[7] if @pw;
# }
# die "Can't get home directory";
#}
#
#$SPEC{get_default_config_dirs} = {
# v => 1.1,
# args => {},
#};
#sub get_default_config_dirs {
# my @dirs;
# my $home = _get_my_home_dir();
# if ($^O eq 'MSWin32') {
# push @dirs, $home;
# } else {
# push @dirs, "$home/.config", $home, "/etc";
# }
# \@dirs;
#}
#
#$SPEC{read_config} = {
# v => 1.1,
# args => {
# config_paths => {},
# config_filename => {},
# config_dirs => {},
# program_name => {},
# },
#};
#sub read_config {
# require Config::IOD::Reader;
#
# my %args = @_;
#
# my $config_dirs = $args{config_dirs} // get_default_config_dirs();
#
# my $paths;
#
# my @filenames;
# my %section_config_filename_map;
# if (my $names = $args{config_filename}) {
# for my $name (ref($names) eq 'ARRAY' ? @$names : ($names)) {
# if (ref($name) eq 'HASH') {
# $section_config_filename_map{$name->{filename}} = $name->{section};
# push @filenames, $name->{filename};
# } else {
# $section_config_filename_map{$name} = 'GLOBAL';
# push @filenames, $name;
# }
# }
# }
# unless (@filenames) {
# @filenames = (($args{program_name} // "prog") . ".conf");
# }
#
# if ($args{config_paths}) {
# $paths = $args{config_paths};
# } else {
# for my $dir (@$config_dirs) {
# for my $name (@filenames) {
# my $path = "$dir/" . $name;
# push @$paths, $path if -e $path;
# }
# }
# }
#
# my $reader = Config::IOD::Reader->new;
# my %res;
# my @read;
# my %section_read_order;
# for my $i (0..$#{$paths}) {
# my $path = $paths->[$i];
# my $filename = $path; $filename =~ s!.*[/\\]!!;
# my $wanted_section = $section_config_filename_map{$filename};
# my $j = 0;
# $section_read_order{GLOBAL} = [$i, $j++];
# my $hoh = $reader->read_file(
# $path,
# sub {
# my %args = @_;
# return unless $args{event} eq 'section';
# my $section = $args{section};
# $section_read_order{$section} = [$i, $j++];
# },
# );
# push @read, $path;
# for my $section (keys %$hoh) {
# my $hash = $hoh->{$section};
#
# my $s = $section; $s =~ s/\s*\S*=.*\z//;
# $s = 'GLOBAL' if $s eq '';
# next unless !defined($wanted_section) || $s eq $wanted_section;
#
# for (keys %$hash) {
# $res{$section}{$_} = $hash->{$_};
# }
# }
# }
# [200, "OK", \%res, {
# 'func.read_files' => \@read,
# 'func.section_read_order' => \%section_read_order,
# }];
#}
#
#$SPEC{get_args_from_config} = {
# v => 1.1,
# args => {
# r => {},
# config => {},
# args => {},
# subcommand_name => {},
# config_profile => {},
# common_opts => {},
# meta => {},
# meta_is_normalized => {},
# },
#};
#sub get_args_from_config {
# my %fargs = @_;
#
# my $r = $fargs{r};
# my $conf = $fargs{config};
# my $progn = $fargs{program_name};
# my $scn = $fargs{subcommand_name} // '';
# my $profile = $fargs{config_profile};
# my $args = $fargs{args} // {};
# my $copts = $fargs{common_opts};
# my $meta = $fargs{meta};
# my $found;
#
# unless ($fargs{meta_is_normalized}) {
# require Perinci::Sub::Normalize;
# $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
# }
#
# my $csro = $r->{_config_section_read_order} // {};
# my @sections = sort {
# my $csro_a = $csro->{$a} // [0,0];
# my $csro_b = $csro->{$b} // [0,0];
# $csro_a->[0] <=> $csro_b->[0] ||
# $csro_a->[1] <=> $csro_b->[1] ||
# $a cmp $b
# } keys %$conf;
#
# my %seen_profiles;
# for my $section0 (@sections) {
# my %keyvals;
# my $sect_name;
# for my $word (split /\s+/, $section0) {
# if ($word =~ /(.*?)=(.*)/) {
# $keyvals{$1} = $2;
# } else {
# $sect_name //= $word;
# }
# }
# $seen_profiles{$keyvals{profile}}++ if defined $keyvals{profile};
#
# my $sect_scn = $keyvals{subcommand} // '';
# my $sect_profile = $keyvals{profile};
#
# if (length $scn) {
# if (length($sect_scn) && $sect_scn ne $scn) {
# next;
# }
# } else {
# if (length $sect_scn) {
# next;
# }
# }
#
# if (defined $profile) {
# if (defined($sect_profile) && $sect_profile ne $profile) {
# next;
# }
# $found = 1 if defined($sect_profile) && $sect_profile eq $profile;
# } else {
# if (defined($sect_profile)) {
# next;
# }
# }
#
# if (defined($progn) && defined($keyvals{program})) {
# if ($progn ne $keyvals{program}) {
# next;
# }
# }
#
# if (defined(my $env = $keyvals{env})) {
# my ($var, $val);
# if (($var, $val) = $env =~ /\A(\w+)=(.*)\z/) {
# if (($ENV{$var} // '') ne $val) {
# next;
# }
# } elsif (($var, $val) = $env =~ /\A(\w+)!=(.*)\z/) {
# if (($ENV{$var} // '') eq $val) {
# next;
# }
# } elsif (($var, $val) = $env =~ /\A(\w+)\*=(.*)\z/) {
# if (index(($ENV{$var} // ''), $val) < 0) {
# next;
# }
# } else {
# if (!$ENV{$env}) {
# next;
# }
# }
# }
#
#
# my $as = $meta->{args} // {};
# for my $k (keys %{ $conf->{$section0} }) {
# my $v = $conf->{$section0}{$k};
# if ($copts->{$k} && $copts->{$k}{is_settable_via_config}) {
# my $sch = $copts->{$k}{schema};
# if ($sch) {
# require Data::Sah::Normalize;
# $sch = Data::Sah::Normalize::normalize_schema($sch);
# if (ref($v) ne 'ARRAY' && $sch->[0] eq 'array') {
# $v = [$v];
# }
# }
# $copts->{$k}{handler}->(undef, $v, $r);
# } else {
# $k =~ s/\.arg\z//;
#
# if (ref($v) ne 'ARRAY' && $as->{$k} && $as->{$k}{schema} &&
# $as->{$k}{schema}[0] eq 'array') {
# $v = [$v];
# }
# $args->{$k} = $v;
# }
# }
# }
#
# [200, "OK", $args, {'func.found'=>$found}];
#}
#
#1;
#
#__END__
#
### Perinci/Result/Format/Lite.pm ###
#package Perinci::Result::Format::Lite;
#
#our $DATE = '2017-05-31';
#our $VERSION = '0.25';
#
#use 5.010001;
#
#use List::Util qw(first max);
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(format);
#
#sub firstidx (&@) {
# my $f = shift;
# foreach my $i ( 0 .. $#_ )
# {
# local *_ = \$_[$i];
# return $i if $f->();
# }
# return -1;
#}
#
#sub _json {
# state $json = do {
# if (eval { require Cpanel::JSON::XS; 1 }) { Cpanel::JSON::XS->new->canonical(1)->convert_blessed->allow_nonref }
# elsif (eval { require JSON::Tiny::Subclassable; 1 }) { JSON::Tiny::Subclassable->new }
# elsif (eval { require JSON::PP; 1 }) { JSON::PP->new->canonical(1)->convert_blessed->allow_nonref }
# else { die "Can't find any JSON module" }
# };
# $json;
#};
#
#sub __cleanse {
# state $cleanser = do {
# eval { require Data::Clean::JSON; 1 };
# if ($@) {
# undef;
# } else {
# Data::Clean::JSON->get_cleanser;
# }
# };
# if ($cleanser) {
# $cleanser->clean_in_place($_[0]);
# } else {
# $_[0];
# }
#}
#
#sub __gen_table {
# my ($data, $header_row, $resmeta, $format) = @_;
#
# $resmeta //= {};
#
# my @columns;
# if ($header_row) {
# @columns = @{$data->[0]};
# } else {
# @columns = map {"col$_"} 0..@{$data->[0]}-1;
# }
#
# my $column_orders;
# SET_COLUMN_ORDERS: {
#
# my $tcos;
# if ($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS}) {
# $tcos = _json->encode($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS});
# } elsif (my $rfos = ($resmeta->{'cmdline.format_options'} //
# $resmeta->{format_options})) {
# my $rfo = $rfos->{'text-pretty'} // $rfos->{text} // $rfos->{any};
# if ($rfo) {
# $tcos = $rfo->{table_column_orders};
# }
# }
# if ($tcos) {
# COLS:
# for my $cols (@$tcos) {
# for my $col (@$cols) {
# next COLS unless first {$_ eq $col} @columns;
# }
# $column_orders = $cols;
# last SET_COLUMN_ORDERS;
# }
# }
#
# $column_orders = $resmeta->{'table.fields'};
# }
#
# if ($column_orders) {
# my @map0 = sort {
# my $idx_a = firstidx(sub {$_ eq $a->[1]},
# @$column_orders) // 9999;
# my $idx_b = firstidx(sub {$_ eq $b->[1]},
# @$column_orders) // 9999;
# $idx_a <=> $idx_b || $a->[1] cmp $b->[1];
# } map {[$_, $columns[$_]]} 0..$#columns;
# my @map;
# for (0..$#map0) {
# $map[$_] = $map0[$_][0];
# }
# my $newdata = [];
# for my $row (@$data) {
# my @newrow;
# for (0..$#map) { $newrow[$_] = $row->[$map[$_]] }
# push @$newdata, \@newrow;
# }
# $data = $newdata;
# my @newcolumns;
# for (@map) { push @newcolumns, $columns[$_] }
# @columns = @newcolumns;
# }
#
# my @field_idxs;
# {
# my $tff = $resmeta->{'table.fields'} or last;
# for my $i (0..$#columns) {
# $field_idxs[$i] = firstidx { $_ eq $columns[$i] } @$tff;
# }
# }
#
# {
# last unless $header_row && @$data;
# my $tff = $resmeta->{'table.fields'} or last;
# my $tfu = $resmeta->{'table.field_units'} or last;
# for my $i (0..$#columns) {
# my $field_idx = $field_idxs[$i];
# next unless $field_idx >= 0;
# next unless defined $tfu->[$field_idx];
# $data->[0][$i] .= " ($tfu->[$field_idx])";
# }
# }
#
# {
# my $tff = $resmeta->{'table.fields'} or last;
# my $tffmt = $resmeta->{'table.field_formats'} or last;
#
# my (@fmt_names, @fmt_opts);
# for my $i (0..$#columns) {
# my $field_idx = $field_idxs[$i];
# next unless $field_idx >= 0;
# next unless defined $tffmt->[$field_idx];
# if (ref($tffmt->[$field_idx]) eq 'ARRAY') {
# $fmt_names[$i] = $tffmt->[$field_idx][0];
# $fmt_opts [$i] = $tffmt->[$field_idx][1] // {};
# } else {
# $fmt_names[$i] = $tffmt->[$field_idx];
# $fmt_opts [$i] = {};
# }
# }
#
# my $nf;
#
# for my $i (0..$#{$data}) {
# next if $i==0 && $header_row;
# my $row = $data->[$i];
# for my $j (0..$#columns) {
# next unless defined $row->[$j];
# my $field_idx = $field_idxs[$j];
# next unless $field_idx >= 0;
# my $fmt_name = $fmt_names[$j];
# next unless $fmt_name;
# my $fmt_opts = $fmt_opts [$j];
# if ($fmt_name eq 'iso8601_datetime' || $fmt_name eq 'iso8601_date') {
# if ($row->[$j] =~ /\A[0-9]+\z/) {
# my @t = gmtime($row->[$j]);
# if ($fmt_name eq 'iso8601_datetime') {
# $row->[$j] = sprintf(
# "%04d-%02d-%02dT%02d:%02d:%02dZ",
# $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]);
# } else {
# $row->[$j] = sprintf(
# "%04d-%02d-%02d",
# $t[5]+1900, $t[4]+1, $t[3]);
# }
# }
# } elsif ($fmt_name eq 'boolstr') {
# $row->[$j] = $row->[$j] ? "yes" : "no";
# } elsif ($fmt_name eq 'sci2dec') {
# if ($row->[$j] =~ /\A(?:[+-]?)(?:\d+\.|\d*\.(\d+))[eE]([+-]?\d+)\z/) {
# my $n = length($1 || "") - $2; $n = 0 if $n < 0;
# $row->[$j] = sprintf("%.${n}f", $row->[$j]);
# }
# } elsif ($fmt_name eq 'percent') {
# my $fmt = $fmt_opts->{sprintf} // '%.2f%%';
# $row->[$j] = sprintf($fmt, $row->[$j] * 100);
# } elsif ($fmt_name eq 'number') {
# $nf //= do {
# require Number::Format;
# Number::Format->new(
# THOUSANDS_SEP => $fmt_opts->{thousands_sep} // ',',
# DECIMAL_POINT => $fmt_opts->{decimal_point} // '.',
# DECIMAL_FILL => $fmt_opts->{decimal_fill} // 1,
# );
# };
# $row->[$j] = $nf->format_number(
# $row->[$j], $fmt_opts->{precision} // 0);
# }
# }
# }
# }
#
# if ($format eq 'text-pretty') {
# {
# no warnings;
#
# my $tfa = $resmeta->{'table.field_aligns'} or last;
# last unless @$data;
#
# for my $colidx (0..$#columns) {
# my $field_idx = $field_idxs[$colidx];
# next unless $field_idx >= 0;
# my $align = $tfa->[$field_idx];
# next unless $align;
#
# my $maxw;
# my ($maxw_bd, $maxw_d, $maxw_ad);
# if ($align eq 'number') {
# my (@w_bd, @w_d, @w_ad);
# for my $i (0..$#{$data}) {
# my $row = $data->[$i];
# if (@$row > $colidx) {
# my $cell = $row->[$colidx];
# if ($header_row && $i == 0) {
# my $w = length($cell);
# push @w_bd, 0;
# push @w_bd, 0;
# push @w_ad, 0;
# } elsif ($cell =~ /\A([+-]?\d+)(\.?)(\d*)\z/) {
# push @w_bd, length($1);
# push @w_d , length($2);
# push @w_ad, length($3);
# } elsif ($cell =~ /\A([+-]?\d+\.?\d*)([eE])([+-]?\d+)\z/) {
# push @w_bd, length($1);
# push @w_d , length($2);
# push @w_ad, length($3);
# } else {
# push @w_bd, length($cell);
# push @w_bd, 0;
# push @w_ad, 0;
# }
# } else {
# push @w_bd, 0;
# push @w_d , 0;
# push @w_ad, 0;
# }
# }
# $maxw_bd = max(@w_bd);
# $maxw_d = max(@w_d);
# $maxw_ad = max(@w_ad);
# if ($header_row) {
# my $w = length($data->[0][$colidx]);
# if ($maxw_d == 0 && $maxw_ad == 0) {
# $maxw_bd = $w;
# }
# }
# }
#
# $maxw = max(map {
# @$_ > $colidx ? length($_->[$colidx]) : 0
# } @$data);
#
# for my $i (0..$#{$data}) {
# my $row = $data->[$i];
# for my $i (0..$#{$data}) {
# my $row = $data->[$i];
# next unless @$row > $colidx;
# my $cell = $row->[$colidx];
# next unless defined($cell);
# if ($align eq 'number') {
# my ($bd, $d, $ad);
# if ($header_row && $i == 0) {
# } elsif (($bd, $d, $ad) = $cell =~ /\A([+-]?\d+)(\.?)(\d*)\z/) {
# $cell = join(
# '',
# (' ' x ($maxw_bd - length($bd))), $bd,
# $d , (' ' x ($maxw_d - length($d ))),
# $ad, (' ' x ($maxw_ad - length($ad))),
# );
# } elsif (($bd, $d, $ad) = $cell =~ /\A([+-]?\d+\.?\d*)([eE])([+-]?\d+)\z/) {
# $cell = join(
# '',
# (' ' x ($maxw_bd - length($bd))), $bd,
# $d , (' ' x ($maxw_d - length($d ))),
# $ad, (' ' x ($maxw_ad - length($ad))),
# );
# }
# my $w = length($cell);
# $cell = (' ' x ($maxw - $w)) . $cell
# if $maxw > $w;
# } elsif ($align eq 'right') {
# $cell = (' ' x ($maxw - length($cell))) . $cell;
# } elsif ($align eq 'middle' || $align eq 'center') {
# my $w = length($cell);
# my $n = int(($maxw-$w)/2);
# $cell = (' ' x $n) . $cell . (' ' x ($maxw-$w-$n));
# } else {
# $cell .= (' ' x ($maxw - length($cell)));
#
# }
# $row->[$colidx] = $cell;
# }
# }
# }
# }
#
# my $fres;
# if (my $backend = $ENV{FORMAT_PRETTY_TABLE_BACKEND}) {
# require Text::Table::Any;
# $fres = Text::Table::Any::table(rows=>$data, header_row=>$header_row, backend=>$backend);
# } else {
# require Text::Table::Tiny;
# $fres = Text::Table::Tiny::table(rows=>$data, header_row=>$header_row);
# }
# $fres .= "\n" unless $fres =~ /\R\z/ || !length($fres);
# $fres;
# } elsif ($format eq 'csv') {
# no warnings 'uninitialized';
# join(
# "",
# map {
# my $row = $_;
# join(
# ",",
# map {
# my $cell = $_;
# $cell =~ s/(["\\])/\\$1/g;
# qq("$cell");
# } @$row)."\n";
# } @$data
# );
# } elsif ($format eq 'html') {
# no warnings 'uninitialized';
# require HTML::Entities;
#
# my $tfa = $resmeta->{'table.field_aligns'};
#
# my @res;
# push @res, "<table".($resmeta->{'table.html_class'} ?
# " class=\"".HTML::Entities::encode_entities(
# $resmeta->{'table.html_class'})."\"" : "").
# ">\n";
# for my $i (0..$#{$data}) {
# my $data_elem = $i == 0 ? "th" : "td";
# push @res, "<thead>\n" if $i == 0;
# push @res, "<tbody>\n" if $i == 1;
# push @res, " <tr>\n";
# my $row = $data->[$i];
# for my $j (0..$#{$row}) {
# my $field_idx = $field_idxs[$j];
# my $align;
# if ($field_idx >= 0 && $tfa->[$field_idx]) {
# $align = $tfa->[$field_idx];
# $align = "right" if $align eq 'number';
# $align = "middle" if $align eq 'center';
# }
# push @res, " <$data_elem",
# ($align ? " align=\"$align\"" : ""),
# ">", HTML::Entities::encode_entities($row->[$j]),
# "</$data_elem>\n";
# }
# push @res, " </tr>\n";
# push @res, "</thead>\n" if $i == 0;
# }
# push @res, "</tbody>\n";
# push @res, "</table>\n";
# join '', @res;
# } else {
# no warnings 'uninitialized';
# shift @$data if $header_row;
# join("", map {join("\t", @$_)."\n"} @$data);
# }
#}
#
#sub format {
# my ($res, $format, $is_naked, $cleanse) = @_;
#
# if ($format =~ /\A(text|text-simple|text-pretty|csv|html)\z/) {
# $format = $format eq 'text' ?
# ((-t STDOUT) ? 'text-pretty' : 'text-simple') : $format;
# no warnings 'uninitialized';
# if ($res->[0] !~ /^(2|304)/) {
# my $fres = "ERROR $res->[0]: $res->[1]";
# if (my $prev = $res->[3]{prev}) {
# $fres .= " ($prev->[0]: $prev->[1])";
# }
# return "$fres\n";
# } elsif ($res->[3] && $res->[3]{"x.hint.result_binary"}) {
# return $res->[2];
# } else {
# require Data::Check::Structure;
# my $data = $res->[2];
# my $max = 5;
# if (!ref($data)) {
# $data //= "";
# $data .= "\n" unless !length($data) || $data =~ /\n\z/;
# return $data;
# } elsif (ref($data) eq 'ARRAY' && !@$data) {
# return "";
# } elsif (Data::Check::Structure::is_aos($data, {max=>$max})) {
# return join("", map {"$_\n"} @$data);
# } elsif (Data::Check::Structure::is_aoaos($data, {max=>$max})) {
# my $header_row = 0;
# my $data = $data;
# if ($res->[3]{'table.fields'}) {
# $data = [$res->[3]{'table.fields'}, @$data];
# $header_row = 1;
# }
# return __gen_table($data, $header_row, $res->[3], $format);
# } elsif (Data::Check::Structure::is_hos($data, {max=>$max})) {
# $data = [map {[$_, $data->{$_}]} sort keys %$data];
# unshift @$data, ["key", "value"];
# return __gen_table($data, 1, $res->[3], $format);
# } elsif (Data::Check::Structure::is_aohos($data, {max=>$max})) {
# my @fieldnames;
# if ($res->[3] && $res->[3]{'table.fields'} &&
# $res->[3]{'table.hide_unknown_fields'}) {
# @fieldnames = @{ $res->[3]{'table.fields'} };
# } else {
# my %fieldnames;
# for my $row (@$data) {
# $fieldnames{$_}++ for keys %$row;
# }
# @fieldnames = sort keys %fieldnames;
# }
# my $newdata = [];
# for my $row (@$data) {
# push @$newdata, [map {$row->{$_}} @fieldnames];
# }
# unshift @$newdata, \@fieldnames;
# return __gen_table($newdata, 1, $res->[3], $format);
# } else {
# $format = 'json-pretty';
# }
# }
# }
#
# my $tff = $res->[3]{'table.fields'};
# $res = $res->[2] if $is_naked;
#
# unless ($format =~ /\Ajson(-pretty)?\z/) {
# warn "Unknown format '$format', fallback to json-pretty";
# $format = 'json-pretty';
# }
# __cleanse($res) if ($cleanse//1);
# if ($format =~ /json/) {
# if ($tff && _json->can("sort_by") &&
# eval { require Sort::ByExample; 1}) {
# my $cmp = Sort::ByExample->cmp($tff);
# _json->sort_by(sub { $cmp->($JSON::PP::a, $JSON::PP::b) });
# }
#
# if ($format eq 'json') {
# return _json->encode($res) . "\n";
# } else {
# _json->pretty(1);
# return _json->encode($res);
# }
# }
#}
#
#1;
#
#__END__
#
### Perinci/Sub/Normalize.pm ###
#package Perinci::Sub::Normalize;
#
#our $DATE = '2016-12-11';
#our $VERSION = '0.19';
#
#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" : "");
#
# if ($prop =~ /\A_/ || defined($attr) && $attr =~ /\A_|\._/) {
# unless ($opt_rip) {
# $nmeta->{$nk} = $meta->{$k};
# }
# next KEY;
# }
#
# my $prop_proplist = $proplist->{$prop};
#
# if (!$opt_aup && !$prop_proplist) {
# $modprefix //= $prefix;
# my $mod = "Perinci/Sub/Property$modprefix/$prop.pm";
# eval { require $mod };
# 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) {
# 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;
#
#__END__
#
### Sah/Schema/rinci/function_meta.pm ###
#package Sah::Schema::rinci::function_meta;
#
#our $DATE = '2016-12-26';
#our $VERSION = '1.1.82.2';
#
#use 5.010001;
#use strict;
#use warnings;
#
#use Data::Sah::Normalize ();
#use Sah::Schema::rinci::meta ();
#
#our $schema = [hash => {
# summary => 'Rinci function metadata',
#
# _ver => 1.1,
# _prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# entity_v => {},
# entity_date => {},
# links => {},
#
# is_func => {},
# is_meth => {},
# is_class_meth => {},
# args => {
# _value_prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# links => {},
#
# schema => {},
# filters => {},
# default => {},
# req => {},
# pos => {},
# greedy => {},
# partial => {},
# stream => {},
# is_password => {},
# cmdline_aliases => {
# _value_prop => {
# summary => {},
# description => {},
# schema => {},
# code => {},
# is_flag => {},
# },
# },
# cmdline_on_getopt => {},
# cmdline_prompt => {},
# completion => {},
# index_completion => {},
# element_completion => {},
# cmdline_src => {},
# meta => 'fix',
# element_meta => 'fix',
# deps => {
# _keys => {
# arg => {},
# all => {},
# any => {},
# none => {},
# },
# },
# },
# },
# args_as => {},
# args_rels => {},
# result => {
# _prop => {
# %Sah::Schema::rinci::meta::_dh_props,
#
# schema => {},
# statuses => {
# _value_prop => {
# 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];
#
#
#$schema = Data::Sah::Normalize::normalize_schema($schema);
#
#1;
#
#__END__
#
### Text/Table/Tiny.pm ###
#use 5.006;
#use strict;
#use warnings;
#package Text::Table::Tiny;
#$Text::Table::Tiny::VERSION = '0.04';
#use parent 'Exporter';
#use List::Util qw();
#
#our @EXPORT_OK = qw/ generate_table /;
#
#
#
#our $COLUMN_SEPARATOR = '|';
#our $ROW_SEPARATOR = '-';
#our $CORNER_MARKER = '+';
#our $HEADER_ROW_SEPARATOR = '=';
#our $HEADER_CORNER_MARKER = 'O';
#
#sub generate_table {
#
# my %params = @_;
# my $rows = $params{rows} or die "Must provide rows!";
#
# my $widths = _maxwidths($rows);
# my $max_index = _max_array_index($rows);
#
# my $format = _get_format($widths);
# my $row_sep = _get_row_separator($widths);
# my $head_row_sep = _get_header_row_separator($widths);
#
# my @table;
# push @table, $row_sep;
#
# my $data_begins = 0;
# if ( $params{header_row} ) {
# my $header_row = $rows->[0];
# $data_begins++;
# push @table, sprintf(
# $format,
# map { defined($header_row->[$_]) ? $header_row->[$_] : '' } (0..$max_index)
# );
# push @table, $params{separate_rows} ? $head_row_sep : $row_sep;
# }
#
# foreach my $row ( @{ $rows }[$data_begins..$#$rows] ) {
# push @table, sprintf(
# $format,
# map { defined($row->[$_]) ? $row->[$_] : '' } (0..$max_index)
# );
# push @table, $row_sep if $params{separate_rows};
# }
#
# push @table, $row_sep unless $params{separate_rows};
# return join("\n",grep {$_} @table);
#}
#
#sub _get_cols_and_rows ($) {
# my $rows = shift;
# return ( List::Util::max( map { scalar @$_ } @$rows), scalar @$rows);
#}
#
#sub _maxwidths {
# my $rows = shift;
# my $max_index = _max_array_index($rows);
# my $widths = [];
# for my $i (0..$max_index) {
# my $max = List::Util::max(map {defined $$_[$i] ? length($$_[$i]) : 0} @$rows);
# push @$widths, $max;
# }
# return $widths;
#}
#
#sub _max_array_index {
# my $rows = shift;
# return List::Util::max( map { $#$_ } @$rows );
#}
#
#sub _get_format {
# my $widths = shift;
# return "$COLUMN_SEPARATOR ".join(" $COLUMN_SEPARATOR ",map { "%-${_}s" } @$widths)." $COLUMN_SEPARATOR";
#}
#
#sub _get_row_separator {
# my $widths = shift;
# return "$CORNER_MARKER$ROW_SEPARATOR".join("$ROW_SEPARATOR$CORNER_MARKER$ROW_SEPARATOR",map { $ROW_SEPARATOR x $_ } @$widths)."$ROW_SEPARATOR$CORNER_MARKER";
#}
#
#sub _get_header_row_separator {
# my $widths = shift;
# return "$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR".join("$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR",map { $HEADER_ROW_SEPARATOR x $_ } @$widths)."$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER";
#}
#
#*table = \&generate_table;
#
#1;
#
#__END__
#
#