Acme-ID-CompanyName
view release on metacpan or search on metacpan
script/gen-generic-ind-company-names view on Meta::CPAN
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 { print "gen-generic-ind-company-names - Generate nice-sounding, generic Indonesian company names\n\nUsage:\n gen-generic-ind-company-names --help (or -h, -?)\n gen-generic-ind-company-names --version (or -v)\n gen-generic-in...
'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; },
'page-result:s' => sub { $_pci_r->{page_result} = 1; },
'version|v' => sub { no warnings 'once'; require Acme::ID::CompanyName; print "gen-generic-ind-company-names version ", "0.007", ($Acme::ID::CompanyName::DATE ? " ($Acme::ID::CompanyName::DATE)" : ''), "\n"; print " Generated by Perinci::CmdLine...
};
my $go_spec2 = {
'add-prefixes' => sub { $_pci_args{'add_prefixes'} = $_[1];
},
'add-suffixes' => sub { $_pci_args{'add_suffixes'} = $_[1];
},
'config-path=s@' => sub { },
'config-profile=s' => sub { },
'desired-initials=s' => sub { $_pci_args{'desired_initials'} = $_[1];
},
'format=s' => sub { },
'help|h|?' => sub { },
'json' => sub { },
'n=s' => sub { $_pci_args{'num_names'} = $_[1];
},
'naked-res' => sub { },
'no-add-prefixes' => sub { $_pci_args{'add_prefixes'} = 0;
},
'no-add-suffixes' => sub { $_pci_args{'add_suffixes'} = 0;
},
'no-config' => sub { },
'no-env' => sub { },
'no-naked-res|nonaked-res' => sub { },
'noadd-prefixes' => sub { $_pci_args{'add_prefixes'} = 0;
},
'noadd-suffixes' => sub { $_pci_args{'add_suffixes'} = 0;
},
'num-names=s' => sub { $_pci_args{'num_names'} = $_[1];
},
'num-words=s' => sub { $_pci_args{'num_words'} = $_[1];
},
'page-result:s' => sub { },
't=s' => sub { $_pci_args{'type'} = $_[1];
},
'type=s' => sub { $_pci_args{'type'} = $_[1];
},
'version|v' => sub { },
'w=s' => sub { $_pci_args{'num_words'} = $_[1];
},
};
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{"GEN_GENERIC_IND_COMPANY_NAMES_OPT"};
last unless defined $env;
require Complete::Bash;
my ($words, undef) = @{ Complete::Bash::parse_cmdline($env, 0) };
unshift @ARGV, @$words;
}
if ($_pci_r->{read_config}) {
require Perinci::CmdLine::Util::Config;
my $res = Perinci::CmdLine::Util::Config::read_config(
config_paths => $_pci_r->{config_paths},
config_filename => "gen-generic-ind-company-names.conf",
config_dirs => undef // ["$ENV{HOME}/.config", $ENV{HOME}, "/etc"],
program_name => "gen-generic-ind-company-names",
);
_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 => "gen-generic-ind-company-names",
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
{
require Local::_pci_check_args; my $res = _pci_check_args(\%_pci_args);
_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 = "";
require Acme::ID::CompanyName;
eval { $_pci_r->{res} = Acme::ID::CompanyName::gen_generic_ind_company_names(%_pci_args) };
if ($@) { die if $ENV{PERINCI_CMDLINE_INLINE_DEBUG_DIE}; $_pci_r->{res} = [500, "Function died: $@"] }
$_pci_r->{res} = [200, "OK (envelope added by Perinci::CmdLine::Inline)", $_pci_r->{res}];
}
}
### format & display result
{
my $fh;
if ($_pci_r->{page_result} // $ENV{PAGE_RESULT} // $_pci_r->{res}[3]{"cmdline.page_result"}) {
my $pager = $_pci_r->{pager} // $_pci_r->{res}[3]{"cmdline.pager"} // $ENV{PAGER} // "less -FRSX";
open $fh, "| $pager";
} else {
$fh = \*STDOUT;
}
my $fres;
script/gen-generic-ind-company-names view on Meta::CPAN
1
Can also be specified as the 1st command-line argument.
=item B<--num-words>=I<s>, B<-w>
Default value:
3
=item B<--type>=I<s>, B<-t>
Just a string to be prepended before the name.
Default value:
"PT"
=back
=head2 Configuration options
=over
=item B<--config-path>=I<s>
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]
=item B<--page-result>
Filter output through a pager.
=item B<--view-result>
View output using a viewer.
=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 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/gen-generic-ind-company-names.conf>, F<~/gen-generic-ind-company-names.conf>, or F</etc/gen-generic-ind-company-names.conf>.
All found files will be read and merged.
To disable searching for configuration files, pass C<--no-config>.
script/gen-generic-ind-company-names view on Meta::CPAN
feature.
=head1 AUTHOR
perlancar <perlancar@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2021, 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__
Data::Section::Seekable v1
Clone/PP.pm,20,6331,0;0
Complete/Bash.pm,6376,39632,1;193
Config/IOD/Base.pm,46035,23603,2;1432
Config/IOD/Reader.pm,69667,17366,3;2242
Data/Check/Structure.pm,87065,9787,4;2801
Data/Sah/Normalize.pm,96882,9038,5;3157
Getopt/Long/EvenLess.pm,105952,11364,6;3431
Local/_pci_check_args.pm,117349,5682,7;3813
Local/_pci_clean_json.pm,123064,4414,8;3933
Log/ger.pm,127497,11284,9;3995
Perinci/CmdLine/Util/Config.pm,138820,18532,10;4340
Perinci/Result/Format/Lite.pm,157390,23138,11;4941
Perinci/Sub/Normalize.pm,180561,7303,12;5548
Sah/Schema/rinci/function_meta.pm,187906,7198,13;5783
Scalar/Util/Numeric/PP.pm,195138,3106,14;6051
Text/Table/Tiny.pm,198271,15445,15;6192
### 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
#
script/gen-generic-ind-company-names view on Meta::CPAN
# 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 --module=Data::Dump bob@example.org
#
#then they will be parsed as:
#
# ["command", "--module", "=", "Data", "::", "Dump", "bob", '@', "example.org"]
#
#Normally in Perl applications, we want `:`, `@` to be part of word. So this
#routine will convert the above into:
#
# ["command", "--module=Data::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;
# }
# }
# log_trace "[compbash] join_wordbreak_words(): result: words=%s, cword=%d", $new_words, $cword
# if $ENV{COMPLETE_BASH_TRACE};
# [$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:
#
#_
# 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:
#
#* as
#
# 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
#
# Escaping mode for entries. Either `default` (most nonalphanumeric characters
# will be escaped), `shellvar` (like `default`, but dollar sign `$` will also 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).
#
#* word
script/gen-generic-ind-company-names view on Meta::CPAN
# }
#
# WORKAROUND_PREVENT_BASH_FROM_INSERTING_SPACE:
# {
# last unless @$words == 1;
# if (defined $path_sep) {
# my $re = qr/\Q$path_sep\E\z/;
# my $word;
# if (ref $words->[0] eq 'HASH') {
# $words = [$words->[0], {word=>"$words->[0]{word} "}] if
# $words->[0]{word} =~ $re;
# } else {
# $words = [$words->[0], "$words->[0] "]
# if $words->[0] =~ $re;
# }
# last;
# }
#
# if ($hcomp->{is_partial} ||
# ref $words->[0] eq 'HASH' && $words->[0]{is_partial}) {
# if (ref $words->[0] eq 'HASH') {
# $words = [$words->[0], {word=>"$words->[0]{word} "}];
# } else {
# $words = [$words->[0], "$words->[0] "];
# }
# last;
# }
# }
#
# 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).
# {
# last unless $opts->{workaround_with_wordbreaks} // 1;
# last unless 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') {
# # escape $ also
# $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")) {
script/gen-generic-ind-company-names view on Meta::CPAN
#
#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) 2020, 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
### Config/IOD/Base.pm ###
#package Config::IOD::Base;
#
#our $DATE = '2019-01-17'; # DATE
#our $VERSION = '0.342'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
##use Carp; # avoided to shave a bit of startup time
#
#use constant +{
# COL_V_ENCODING => 0, # either "!j"... or '"', '[', '{', '~'
# 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_directive} //= 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{expr_vars} //= {};
# $attrs{ignore_unknown_directive} //= 0;
# # allow_encodings
# # disallow_encodings
# # allow_directives
# # disallow_directives
# bless \%attrs, $class;
#}
#
## borrowed from Parse::CommandLine. differences: returns arrayref. return undef
## on error (instead of dying).
#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;
#}
#
## return ($err, $res, $decoded_val)
#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; $res = [
# "!$enc", # COL_V_ENCODING
# $ws1, # COL_V_WS1
# $1, # COL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] if $needs_res;
#
# # canonicalize shorthands
# $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') {
#
# # XXX imperfect regex for simplicity, comment should not contain
# # "]", '"', or '}' or it will be gobbled up as value by greedy regex
# # quantifier
# $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};
# # XXX imperfect regex, expression can't contain # and ; because it
# # will be assumed as comment
# $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; $res = [
# '"', # COL_V_ENCODING
# '', # COL_V_WS1
# $1, # VOL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] 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}) {
#
# # XXX imperfect regex for simplicity, comment should not contain "]" or
# # it will be gobbled up as value by greedy regex quantifier
# $val =~ /\A
# \[(.*)\]
# (?:
# (\s*)
# ([#;])(.*)
# )?
# \z/x or return ("Invalid syntax in bracketed array value");
# my $res; $res = [
# '[', # COL_V_ENCODING
# '', # COL_V_WS1
# $1, # VOL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] 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}) {
#
# # XXX imperfect regex for simplicity, comment should not contain "}" or
# # it will be gobbled up as value by greedy regex quantifier
# $val =~ /\A
# \{(.*)\}
# (?:
# (\s*)
# ([#;])(.*)
# )?
# \z/x or return ("Invalid syntax in braced hash value");
# my $res; $res = [
# '{', # COL_V_ENCODING
# '', # COL_V_WS1
# $1, # VOL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] 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; $res = [
# '~', # COL_V_ENCODING
# '', # COL_V_WS1
# $1, # VOL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] 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"); # shouldn't happen, regex should match any string
# my $res; $res = [
# '', # COL_V_ENCODING
# '', # COL_V_WS1
# $1, # VOL_V_VALUE
# $2, # COL_V_WS2
# $3, # COL_V_COMMENT_CHAR
# $4, # COL_V_COMMENT
# ] if $needs_res;
# return (undef, $res, $1);
#
# }
# # should not be reached
#}
#
#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;
# }
#}
#
## borrowed from PERLANCAR::File::HomeDir 0.04
#sub _get_my_home_dir {
# if ($^O eq 'MSWin32') {
# # File::HomeDir always uses exists($ENV{x}) first, does it want to avoid
# # accidentally creating env vars?
# 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";
#}
#
## borrowed from PERLANCAR::File::HomeDir 0.05, with some modifications
#sub _get_user_home_dir {
# my ($name) = @_;
#
# if ($^O eq 'MSWin32') {
# # not yet implemented
# return undef;
# } else {
# # IF and only if we have getpwuid support, and the name of the user is
# # our own, shortcut to my_home. This is needed to handle HOME
# # environment settings.
# 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_user_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;
script/gen-generic-ind-company-names view on Meta::CPAN
# no strict 'refs';
# local *{"Config::IOD::Expr::_Compiled::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) = @_;
#
# # included file's path is based on the main (topmost) file
# 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} = [];
#
# # set expr variables
# {
# last unless $self->{enable_expr};
# no strict 'refs';
# my $pkg = \%{"Config::IOD::Expr::_Compiled::"};
# undef ${"Config::IOD::Expr::_Compiled::$_"} for keys %$pkg;
# my $vars = $self->{expr_vars};
# ${"Config::IOD::Expr::_Compiled::$_"} = $vars->{$_} for keys %$vars;
# }
#}
#
#sub _read_file {
# my ($self, $filename) = @_;
# open my $fh, "<", $filename
# or die "Can't open file '$filename': $!";
# binmode($fh, ":encoding(utf8)");
# local $/;
# my $res = scalar <$fh>;
# close $fh;
# $res;
#}
#
#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;
## ABSTRACT: Base class for Config::IOD and Config::IOD::Reader
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Config::IOD::Base - Base class for Config::IOD and Config::IOD::Reader
#
#=head1 VERSION
#
#This document describes version 0.342 of Config::IOD::Base (from Perl distribution Config-IOD-Reader), released on 2019-01-17.
#
#=head1 EXPRESSION
#
#=for BEGIN_BLOCK: expression
#
#Expression allows you to do things like:
#
# [section1]
# foo=1
# bar="monkey"
#
# [section2]
# baz =!e 1+1
# qux =!e "grease" . val("section1.bar")
# quux=!e val("qux") . " " . val('baz')
#
#And the result will be:
#
# {
# section1 => {foo=>1, bar=>"monkey"},
# section2 => {baz=>2, qux=>"greasemonkey", quux=>"greasemonkey 2"},
# }
#
#For safety, you'll need to set C<enable_expr> attribute to 1 first to enable
#this feature.
#
#The syntax of the expression (the C<expr> encoding) is not officially specified
#yet in the L<IOD> specification. It will probably be Expr (see
#L<Language::Expr::Manual::Syntax>). At the moment, this module implements a very
#limited subset that is compatible (lowest common denominator) with Perl syntax
#and uses C<eval()> to evaluate the expression. However, only the limited subset
#is allowed (checked by Perl 5.10 regular expression).
#
#The supported terms:
#
# number
# string (double-quoted and single-quoted)
# undef literal
# simple variable ($abc, no namespace, no array/hash sigil, no special variables)
# function call (only the 'val' function is supported)
# grouping (parenthesis)
#
#The supported operators are:
#
# + - .
# * / % x
# **
# unary -, unary +, !, ~
#
#The C<val()> function refers to the configuration key. If the argument contains
#".", it will be assumed as C<SECTIONNAME.KEYNAME>, otherwise it will access the
#current section's key. Since parsing is done in a single pass, you can only
#refer to the already mentioned key.
#
#Code will be compiled using Perl's C<eval()> in the
#C<Config::IOD::Expr::_Compiled> namespace, with C<no strict>, C<no warnings>.
#
#=for END_BLOCK: expression
#
#=head1 ATTRIBUTES
#
#=for BEGIN_BLOCK: attributes
#
#=head2 default_section => str (default: C<GLOBAL>)
#
#If a key line is specified before any section line, this is the section that the
#key will be put in.
#
#=head2 enable_directive => bool (default: 1)
#
#If set to false, then directives will not be parsed. Lines such as below will be
#considered a regular comment:
#
# ;!include foo.ini
#
#and lines such as below will be considered a syntax error (B<regardless> of the
#C<allow_bang_only> setting):
#
# !include foo.ini
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_encoding => bool (default: 1)
#
#If set to false, then encoding notation will be ignored and key value will be
#parsed as verbatim. Example:
#
# name = !json null
#
#With C<enable_encoding> turned off, value will not be undef but will be string
#with the value of (as Perl literal) C<"!json null">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_quoting => bool (default: 1)
#
#If set to false, then quotes on key value will be ignored and key value will be
#parsed as verbatim. Example:
#
# name = "line 1\nline2"
#
#With C<enable_quoting> turned off, value will not be a two-line string, but will
#be a one line string with the value of (as Perl literal) C<"line 1\\nline2">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_bracket => bool (default: 1)
#
#If set to false, then JSON literal array will be parsed as verbatim. Example:
#
# name = [1,2,3]
#
#With C<enable_bracket> turned off, value will not be a three-element array, but
#will be a string with the value of (as Perl literal) C<"[1,2,3]">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_brace => bool (default: 1)
#
#If set to false, then JSON literal object (hash) will be parsed as verbatim.
#Example:
#
# name = {"a":1,"b":2}
#
#With C<enable_brace> turned off, value will not be a hash with two pairs, but
#will be a string with the value of (as Perl literal) C<'{"a":1,"b":2}'>.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_tilde => bool (default: 1)
#
#If set to true (the default), then value that starts with C<~> (tilde) will be
#assumed to use !path encoding, unless an explicit encoding has been otherwise
#specified.
#
#Example:
#
# log_dir = ~/logs ; ~ will be resolved to current user's home directory
#
#With C<enable_tilde> turned off, value will still be literally C<~/logs>.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 allow_encodings => array
#
#If defined, set list of allowed encodings. Note that if C<disallow_encodings> is
#also set, an encoding must also not be in that list.
#
#Also note that, for safety reason, if you want to enable C<expr> encoding,
#you'll also need to set C<enable_expr> to 1.
script/gen-generic-ind-company-names view on Meta::CPAN
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
#
#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 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
### Config/IOD/Reader.pm ###
#package Config::IOD::Reader;
#
#our $DATE = '2019-01-17'; # DATE
#our $VERSION = '0.342'; # VERSION
#
#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) {
# # ignore merging self
# next;
# #local $self->{_linum} = $self->{_linum}-1;
# #$self->_err("Can't merge section '$msect' to '$section': ".
# # "Same section");
# }
# 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; # only to provide to callback
#
# my @lines = split /^/, $str;
# local $self->{_linum} = 0;
# LINE:
# for my $line (@lines) {
# $self->{_linum}++;
#
# # blank line
# if ($line !~ /\S/) {
# next LINE;
# }
#
# # directive line
# if ($self->{enable_directive} && $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), $cb);
# $self->_pop_include_stack;
# } elsif ($directive eq 'merge') {
# $self->{_merge} = @$args ? $args : undef;
# } elsif ($directive eq 'noop') {
# } else {
# if ($self->{ignore_unknown_directive}) {
# # assume a regular comment
# next LINE;
# } else {
# $self->_err("Unknown directive '$directive'");
# }
# }
# next LINE;
# }
#
# # comment line
# if ($line =~ /^\s*[;#]/) {
#
# if ($cb) {
# $cb->(
# event => 'comment',
# linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
# );
# }
#
# next LINE;
# }
#
# # section 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}++;
#
# # previous section exists? do merging for previous section
# 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;
# }
#
# # key line
# if ($line =~ /^\s*([^=]+?)\s*=\s*(.*)/) {
# my $key = $1;
# my $val = $2;
#
# # the common case is that value are not decoded or
# # quoted/bracketed/braced, so we avoid calling _parse_raw_value here
# # to avoid overhead
# 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;
script/gen-generic-ind-company-names view on Meta::CPAN
# 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;
## ABSTRACT: Read IOD/INI configuration files
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Config::IOD::Reader - Read IOD/INI configuration files
#
#=head1 VERSION
#
#This document describes version 0.342 of Config::IOD::Reader (from Perl distribution Config-IOD-Reader), released on 2019-01-17.
#
#=head1 SYNOPSIS
#
# use Config::IOD::Reader;
# my $reader = Config::IOD::Reader->new(
# # list of known attributes, with their default values
# # default_section => 'GLOBAL',
# # enable_directive => 1,
# # enable_encoding => 1,
# # enable_quoting => 1,
# # enable_backet => 1,
# # enable_brace => 1,
# # allow_encodings => undef, # or ['base64','json',...]
# # disallow_encodings => undef, # or ['base64','json',...]
# # allow_directives => undef, # or ['include','merge',...]
# # disallow_directives => undef, # or ['include','merge',...]
# # allow_bang_only => 1,
# # enable_expr => 0,
# # allow_duplicate_key => 1,
# # ignore_unknown_directive => 0,
# );
# my $config_hash = $reader->read_file('config.iod');
#
#=head1 DESCRIPTION
#
#This module reads L<IOD> configuration files (IOD is an INI-like format with
#more precise specification, some extra features, and 99% compatible with typical
#INI format). It is a minimalist alternative to the more fully-featured
#L<Config::IOD>. It cannot write IOD files and is optimized for low startup
#overhead.
#
#=head1 EXPRESSION
#
#Expression allows you to do things like:
#
# [section1]
# foo=1
# bar="monkey"
#
# [section2]
# baz =!e 1+1
# qux =!e "grease" . val("section1.bar")
# quux=!e val("qux") . " " . val('baz')
#
#And the result will be:
#
# {
# section1 => {foo=>1, bar=>"monkey"},
# section2 => {baz=>2, qux=>"greasemonkey", quux=>"greasemonkey 2"},
# }
#
#For safety, you'll need to set C<enable_expr> attribute to 1 first to enable
#this feature.
#
#The syntax of the expression (the C<expr> encoding) is not officially specified
#yet in the L<IOD> specification. It will probably be Expr (see
#L<Language::Expr::Manual::Syntax>). At the moment, this module implements a very
#limited subset that is compatible (lowest common denominator) with Perl syntax
#and uses C<eval()> to evaluate the expression. However, only the limited subset
#is allowed (checked by Perl 5.10 regular expression).
#
#The supported terms:
#
# number
# string (double-quoted and single-quoted)
# undef literal
# simple variable ($abc, no namespace, no array/hash sigil, no special variables)
# function call (only the 'val' function is supported)
# grouping (parenthesis)
#
#The supported operators are:
#
# + - .
# * / % x
# **
# unary -, unary +, !, ~
#
#The C<val()> function refers to the configuration key. If the argument contains
#".", it will be assumed as C<SECTIONNAME.KEYNAME>, otherwise it will access the
#current section's key. Since parsing is done in a single pass, you can only
#refer to the already mentioned key.
#
#Code will be compiled using Perl's C<eval()> in the
#C<Config::IOD::Expr::_Compiled> namespace, with C<no strict>, C<no warnings>.
#
#=head1 ATTRIBUTES
#
#=head2 default_section => str (default: C<GLOBAL>)
#
#If a key line is specified before any section line, this is the section that the
#key will be put in.
#
#=head2 enable_directive => bool (default: 1)
#
#If set to false, then directives will not be parsed. Lines such as below will be
#considered a regular comment:
#
# ;!include foo.ini
#
#and lines such as below will be considered a syntax error (B<regardless> of the
#C<allow_bang_only> setting):
#
# !include foo.ini
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_encoding => bool (default: 1)
#
#If set to false, then encoding notation will be ignored and key value will be
#parsed as verbatim. Example:
#
# name = !json null
#
#With C<enable_encoding> turned off, value will not be undef but will be string
#with the value of (as Perl literal) C<"!json null">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_quoting => bool (default: 1)
#
#If set to false, then quotes on key value will be ignored and key value will be
#parsed as verbatim. Example:
#
# name = "line 1\nline2"
#
#With C<enable_quoting> turned off, value will not be a two-line string, but will
#be a one line string with the value of (as Perl literal) C<"line 1\\nline2">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_bracket => bool (default: 1)
#
#If set to false, then JSON literal array will be parsed as verbatim. Example:
#
# name = [1,2,3]
#
#With C<enable_bracket> turned off, value will not be a three-element array, but
#will be a string with the value of (as Perl literal) C<"[1,2,3]">.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_brace => bool (default: 1)
#
#If set to false, then JSON literal object (hash) will be parsed as verbatim.
#Example:
#
# name = {"a":1,"b":2}
#
#With C<enable_brace> turned off, value will not be a hash with two pairs, but
#will be a string with the value of (as Perl literal) C<'{"a":1,"b":2}'>.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 enable_tilde => bool (default: 1)
#
#If set to true (the default), then value that starts with C<~> (tilde) will be
#assumed to use !path encoding, unless an explicit encoding has been otherwise
#specified.
#
#Example:
#
# log_dir = ~/logs ; ~ will be resolved to current user's home directory
#
#With C<enable_tilde> turned off, value will still be literally C<~/logs>.
#
#B<NOTE: Turning this setting off violates IOD specification.>
#
#=head2 allow_encodings => array
#
#If defined, set list of allowed encodings. Note that if C<disallow_encodings> is
#also set, an encoding must also not be in that list.
#
#Also note that, for safety reason, if you want to enable C<expr> encoding,
#you'll also need to set C<enable_expr> to 1.
script/gen-generic-ind-company-names view on Meta::CPAN
# my $ref = ref($data->{$k});
# do { $errstr = "not hoh: value for key '$k' not hash ($ref)"; return 0 } unless $ref eq 'HASH';
# }
# $errstr = '';
# 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;
# do { $errstr = "not hohos: value for key '$k'".($errstr ? ": $errstr" : " not hos"); return 0 } unless is_hos($data->{$k});
# }
# $errstr = '';
# 1;
#}
#
#1;
## ABSTRACT: Check structure of data
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Data::Check::Structure - Check structure of data
#
#=head1 VERSION
#
#This document describes version 0.050 of Data::Check::Structure (from Perl distribution Data-Check-Structure), released on 2020-11-08.
#
#=head1 SYNOPSIS
#
#=head1 DESCRIPTION
#
#This small module provides several simple routines to check the structure of
#data, e.g. whether data is an array of arrays ("aoa"), array of scalars ("aos"),
#and so on.
#
#=head1 FUNCTIONS
#
#None exported by default, but they are exportable.
#
#=head2 is_aos($data[, \%opts]) => bool
#
#Check that data is an array of scalars. Examples:
#
# is_aos([]); # true
# is_aos(['a', 'b']); # true
# is_aos(['a', []]); # false
# is_aos([1,2,3, []], {max=>3}); # true
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_aoa($data[, \%opts]) => bool
#
#Check that data is an array of arrays. Examples:
#
# is_aoa([]); # true
# is_aoa([[1], [2]]); # true
# is_aoa([[1], 'a']); # false
# is_aoa([[1],[],[], 'a'], {max=>3}); # true
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_aoaos($data[, \%opts]) => bool
#
#Check that data is an array of arrays of scalars. Examples:
#
# is_aoaos([]); # true
# is_aoaos([[1], [2]]); # true
# is_aoaos([[1], [{}]]); # false
# is_aoaos([[1],[],[], [{}]], {max=>3}); # true
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_aoh($data[, \%opts]) => bool
#
#Check that data is an array of hashes. Examples:
#
# is_aoh([]); # true
# is_aoh([{}, {a=>1}]); # true
# is_aoh([{}, 'a']); # false
# is_aoh([{},{},{a=>1}, 'a'], {max=>3}); # true
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_aohos($data[, \%opts]) => bool
#
#Check that data is an array of hashes of scalars. Examples:
#
# is_aohos([]); # true
# is_aohos([{a=>1}, {}]); # true
# is_aohos([{a=>1}, {b=>[]}]); # false
# is_aohos([{a=>1},{},{}, {b=>[]}], {max=>3}); # true
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_hos($data[, \%opts]) => bool
#
#Check that data is a hash of scalars. Examples:
#
# is_hos({}); # true
# is_hos({a=>1, b=>2}); # true
# is_hos({a=>1, b=>[]}); # false
# is_hos({a=>1, b=>2, c=>3, d=>[]}, {max=>3}); # true (or false, depending on random hash key ordering)
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_hoa($data[, \%opts]) => bool
#
#Check that data is a hash of arrays. Examples:
#
# is_hoa({}) ); # true
# is_hoa({a=>[]}) ); # true
# is_hoa({a=>1}) ); # false
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_hoaos($data[, \%opts]) => bool
#
#Check that data is a hash of arrays of scalars. Examples:
#
# is_hoaos({}) ); # true
# is_hoaos({a=>[]}) ); # true
# is_hoaos({a=>[1]}) ); # true
# is_hoaos({a=>1}) ); # false
# is_hoaos({a=>[{}]}) ); # false
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_hoh($data[, \%opts]) => bool
#
#Check that data is a hash of hashes. Examples:
#
# is_hoh({}) ); # true
# is_hoh({a=>{}}) ); # true
# is_hoh({a=>1}) ); # false
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head2 is_hohos($data[, \%opts]) => bool
#
#Check that data is a hash of hashes of scalrs. Examples:
#
# is_hohos({}) ); # true
# is_hohos({a=>{}}) ); # true
# is_hohos({a=>{b=>1}}) ); # true
# is_hohos({a=>1}) ); # false
# is_hohos({a=>{b=>[]}}) ); # false
#
#Known options: C<max> (maximum number of items to check, undef means check all
#items).
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Data-Check-Structure>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Data-Check-Structure>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Check-Structure>
#
#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) 2020, 2017, 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/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/;
script/gen-generic-ind-company-names view on Meta::CPAN
# # ignore, already behaves that way
# } 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) {
# # perfect match, we immediately go with this one
# @candidates = ($opts[0]);
# last OPT_SPEC;
# } elsif ($config->{auto_abbrev} && index($o, $wanted) == 0) {
# # prefix match, collect candidates first
# push @candidates, $opts[0];
# next OPT_SPEC;
# }
# }
# }
# if (!@candidates) {
# unless ($config->{pass_through}) {
# warn "Unknown option: $wanted\n";
# $success = 0;
# }
# return undef; # means unknown
# } elsif (@candidates > 1) {
# unless ($config->{pass_through}) {
# warn "Option $wanted is ambiguous (" .
# join(", ", @candidates) . ")\n";
# $success = 0;
# }
# return ''; # means ambiguous
# }
# return $candidates[0];
# };
#
# my $code_set_val = sub {
# my $name = shift;
#
# my $spec_key = $spec_by_opt_name{$name};
# my $destination = $spec{$spec_key};
#
# $destination->({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)) {
# # unknown option
# push @remaining, $argv->[$i];
# next ELEM;
# } elsif (!length($opt)) {
# push @remaining, $argv->[$i];
# next ELEM; # ambiguous
# }
#
# my $spec = $spec_by_opt_name{$opt};
# # check whether option requires an argument
# if ($spec =~ /=[fios][@%]?\z/) {
# if (defined $val_in_opt) {
# # argument is taken after =
# $code_set_val->($opt, $val_in_opt);
# } else {
# if ($i+1 >= @$argv) {
# # we are the last element
# warn "Option $used_name requires an argument\n";
# $success = 0;
# last ELEM;
# }
# $i++;
# $code_set_val->($opt, $argv->[$i]);
# }
# } else {
# $code_set_val->($opt);
script/gen-generic-ind-company-names view on Meta::CPAN
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "env $var has that value",
# );
# next;
# }
# } elsif (($var, $val) = $env =~ /\A(\w+)\*=(.*)\z/) {
# if (index(($ENV{$var} // ''), $val) < 0) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "env $var has value '".
# ($ENV{$var} // '')."' which does not contain the ".
# "requested string"
# );
# next;
# }
# } else {
# if (!$ENV{$env}) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "env $env is not set/true",
# );
# next;
# }
# }
# }
#
# log_trace("[pericmd] Reading config section '%s'", $section0);
#
# if (defined $sect_plugin) {
# # TODO: check against metadata in plugin
# my $event;
# my $prio;
# my $plugin_args = {};
# for my $k (keys %{ $conf->{$section0} }) {
# my $v = $conf->{$section0}{$k};
# if ($k eq '-event') { $event = $v }
# elsif ($k eq '-prio') { $prio = $v }
# else { $plugin_args->{$k} = $v }
# }
# push @$plugins, $sect_plugin .
# (defined $event || defined $prio ?
# '@'.($event // '') . (defined $prio ? "\@$prio" : "") : '');
# push @$plugins, $plugin_args;
# } else {
# 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::Resolve;
# my $rsch = Data::Sah::Resolve::resolve_schema($sch);
# # since IOD might return a scalar or an array (depending on
# # whether there is a single param=val or multiple param=
# # lines), we need to arrayify the value if the argument is
# # expected to be an array.
# if (ref($v) ne 'ARRAY' && $rsch->[0] eq 'array') {
# $v = [$v];
# }
# }
# $copts->{$k}{handler}->(undef, $v, $r);
# } else {
# # when common option clashes with function argument name,
# # user can use NAME.arg to refer to function argument.
# $k =~ s/\.arg\z//;
#
# # since IOD might return a scalar or an array (depending on
# # whether there is a single param=val or multiple param=
# # lines), we need to arrayify the value if the argument is
# # expected to be an array.
# if (ref($v) ne 'ARRAY' && $as->{$k} && $as->{$k}{schema}) {
# require Data::Sah::Resolve;
# my $rsch = Data::Sah::Resolve::resolve_schema($as->{$k}{schema});
# if ($rsch->[0] eq 'array') {
# $v = [$v];
# }
# }
# $args->{$k} = $v;
# }
# } # for params in section
# } # if for plugin
# }
# log_trace("[pericmd] Seen config profiles: %s",
# [sort keys %seen_profiles]);
#
# [200, "OK", $args, {'func.found'=>$found}];
#}
#
#1;
## ABSTRACT: Utility routines related to config files
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Perinci::CmdLine::Util::Config - Utility routines related to config files
#
#=head1 VERSION
#
#This document describes version 1.724 of Perinci::CmdLine::Util::Config (from Perl distribution Perinci-CmdLine-Util-Config), released on 2020-10-21.
#
#=head1 FUNCTIONS
#
#
#=head2 get_args_from_config
#
#Usage:
#
# get_args_from_config(%args) -> [status, msg, payload, meta]
#
#C<config> is a HoH (hashes of hashrefs) produced by reading an INI (IOD)
#configuration file using modules like L<Config::IOD::Reader>.
#
#Hashref argument C<args> will be set by parameters in C<config>, while C<plugins>
#will be set by parameters in C<[plugin=...]> sections in C<config>. For example,
#with this configuration:
#
script/gen-generic-ind-company-names view on Meta::CPAN
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-CmdLine-Util-Config>
#
#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) 2020, 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
### Perinci/Result/Format/Lite.pm ###
#package Perinci::Result::Format::Lite;
#
#our $DATE = '2021-03-08'; # DATE
#our $VERSION = '0.279'; # VERSION
#
#use 5.010001;
##IFUNBUILT
## use strict;
## use warnings;
##END IFUNBUILT
#
#use List::Util qw(first max);
#
#use Exporter qw(import);
#our @EXPORT_OK = qw(format);
#
## copy-pasted from List::MoreUtils::PP
#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 //= {};
#
# # column names
# my @columns;
# if ($header_row) {
# @columns = @{$data->[0]};
# } else {
# @columns = map {"col$_"} 0..@{$data->[0]}-1;
# }
#
# my $column_orders; # e.g. [col2, col1, col3, ...]
# SET_COLUMN_ORDERS: {
#
# # find column orders from 'table_column_orders' in result metadata (or
# # from env)
# 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) {
# # find an entry in tcos that @columns contains all the columns of
# COLS:
# for my $cols (@$tcos) {
# for my $col (@$cols) {
# next COLS unless first {$_ eq $col} @columns;
# }
# $column_orders = $cols;
# last SET_COLUMN_ORDERS;
# }
# }
#
# if ($resmeta->{'table.field_orders'}) {
# $column_orders = $resmeta->{'table.field_orders'};
# last SET_COLUMN_ORDERS;
# }
#
# # find column orders from table spec
# $column_orders = $resmeta->{'table.fields'};
# }
#
script/gen-generic-ind-company-names view on Meta::CPAN
# if ($column_orders) {
# require Sort::BySpec;
# my $cmp = Sort::BySpec::cmp_by_spec(spec => $column_orders);
# # 0->2, 1->0, ... (map column position from unordered to ordered)
# my @map0 = sort { $cmp->($a->[1], $b->[1]) }
# map {[$_, $columns[$_]]} 0..$#columns;
# #use DD; dd \@map0;
# my @map;
# for (0..$#map0) {
# $map[$_] = $map0[$_][0];
# }
# #use DD; dd \@map;
# 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; # map column to index in table.fields
# {
# my $tff = $resmeta->{'table.fields'} or last;
# for my $i (0..$#columns) {
# $field_idxs[$i] = firstidx { $_ eq $columns[$i] } @$tff;
# }
# }
#
# # determine field labels
# {
# last unless $header_row && @$data;
# my $tff = $resmeta->{'table.fields'} or last;
# my $tfl = $resmeta->{'table.field_labels'};
# my $tfu = $resmeta->{'table.field_units'};
# for my $i (0..$#columns) {
# my $field_idx = $field_idxs[$i];
# next unless $field_idx >= 0;
# if ($tfl && defined $tfl->[$field_idx]) {
# $data->[0][$i] = $tfl->[$field_idx];
# } elsif ($tfu && defined $tfu->[$field_idx]) {
# # add field units as label suffix to header (" (UNIT)")
# $data->[0][$i] .= " ($tfu->[$field_idx])";
# }
# }
# }
#
# FORMAT_CELLS:
# {
# my $tffmt = $resmeta->{'table.field_formats'};
# my $tffmt_code = $resmeta->{'table.field_format_code'};
# my $tffmt_default = $resmeta->{'table.default_field_format'};
# last unless $tffmt || $tffmt_code || $tffmt_default;
#
# my (@fmt_names, @fmt_opts); # key: column index
# for my $i (0..$#columns) {
# my $field_idx = $field_idxs[$i];
# my $fmt = $tffmt_code ? $tffmt_code->($columns[$i]) : undef;
# $fmt //= $tffmt->[$field_idx] if $field_idx >= 0;
# $fmt //= $tffmt_default;
# if (ref $fmt eq 'ARRAY') {
# $fmt_names[$i] = $fmt->[0];
# $fmt_opts [$i] = $fmt->[1] // {};
# } else {
# $fmt_names[$i] = $fmt;
# $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 $fmt_name = $fmt_names[$j];
# #say "D:j=$j fmt_name=$fmt_name";
# 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]+(\.[0-9]*)?\z/) {
# my $frac = $1 ? "0$1"+0 : 0;
# my @t = gmtime($row->[$j]);
# if ($fmt_name eq 'iso8601_datetime') {
# $row->[$j] = sprintf(
# "%04d-%02d-%02dT%02d:%02d:".($frac ? "%06.3f" : "%02d")."Z",
# $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]+$frac);
# } 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 'filesize') {
# require Format::Human::Bytes;
# $row->[$j] = Format::Human::Bytes::base2($row->[$j], 0);
# } 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') {
# require Number::Format::BigFloat;
# $row->[$j] = Number::Format::BigFloat::format_number(
# $row->[$j], {
# thousands_sep => $fmt_opts->{thousands_sep} // ',',
# decimal_point => $fmt_opts->{decimal_point} // '.',
# decimal_digits => $fmt_opts->{precision} // 0,
# # XXX decimal_fill
# });
# }
# }
# }
# }
#
# if ($format eq 'text-pretty') {
# ALIGN_COLUMNS:
# {
# # XXX we just want to turn off 'uninitialized' and 'negative repeat
# # count does nothing' from the operator x
# no warnings;
#
# my $tfa = $resmeta->{'table.field_aligns'};
# my $tfa_code = $resmeta->{'table.field_align_code'};
# my $tfa_default = $resmeta->{'table.default_field_align'};
# last unless $tfa || $tfa_code || $tfa_default;
# last unless @$data;
#
# for my $colidx (0..$#columns) {
# my $field_idx = $field_idxs[$colidx];
# my $align = $tfa_code ? $tfa_code->($columns[$colidx]) : undef;
# $align //= $tfa->[$field_idx] if $field_idx >= 0;
# $align //= $tfa_default;
# next unless $align;
#
# # determine max widths
# my $maxw;
# my ($maxw_bd, $maxw_d, $maxw_ad); # before digit, digit, after d
# 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/) {
# # decimal notation number
# push @w_bd, length($1);
# push @w_d , length($2);
# push @w_ad, length($3);
# } elsif ($cell =~ /\A([+-]?\d+\.?\d*)([eE])([+-]?\d+)\z/) {
# # scientific notation number
# push @w_bd, length($1);
# push @w_d , length($2);
# push @w_ad, length($3);
# } else {
# # not a number
# 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);
#
# # do the alignment
# for my $i (0..$#{$data}) {
# my $row = $data->[$i];
# for my $i (0..$#{$data}) {
# my $row = $data->[$i];
script/gen-generic-ind-company-names view on Meta::CPAN
# 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
#
( run in 1.351 second using v1.01-cache-2.11-cpan-d80b1682f3f )