Acme-ID-CompanyName
view release on metacpan or search on metacpan
script/gen-generic-ind-company-names view on Meta::CPAN
my $_pci_metas = {""=>{args=>{add_prefixes=>{default=>1,schema=>["bool",{req=>1},{}]},add_suffixes=>{default=>1,schema=>["bool",{req=>1},{}]},desired_initials=>{schema=>["str",{match=>qr(\A[A-Za-z]+\z),min_len=>1,req=>1},{}]},num_names=>{cmdline_alia...
# This script is generated by Perinci::CmdLine::Inline version 0.551 on Fri May 7 20:03:14 2021.
# Rinci metadata taken from these modules: Acme::ID::CompanyName (no version)
# You probably should not manually edit this file.
our $DATE = '2021-05-07'; # DATE
our $VERSION = '0.007'; # VERSION
# PODNAME: gen-generic-ind-company-names
# ABSTRACT: Generate nice-sounding, generic Indonesian company names
# 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;
# load modules
### 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;
print STDERR "ERROR $res->[0]: $res->[1]\n";
exit $res->[0]-300;
}
sub _pci_json {
state $json = do {
if (eval { require JSON::XS; 1 }) { JSON::XS->new->canonical(1)->allow_nonref }
else { require JSON::PP; JSON::PP->new->canonical(1)->allow_nonref }
};
$json;
}
### begin code_before_parse_cmdline_options
### end code_before_parse_cmdline_options
### get arguments (from config file, env, command-line args
{
script/gen-generic-ind-company-names view on Meta::CPAN
#L<Data::Clone> -
#polymorphic data cloning (see its documentation for what that means).
#
#L<Clone::Any> - use whichever of the cloning methods is available.
#
#=head1 REPOSITORY
#
#L<https://github.com/neilbowers/Clone-PP>
#
#=head1 AUTHOR AND CREDITS
#
#Developed by Matthew Simon Cavalletto at Evolution Softworks.
#More free Perl software is available at C<www.evoscript.org>.
#
#
#=head1 COPYRIGHT AND LICENSE
#
#Copyright 2003 Matthew Simon Cavalletto. You may contact the author
#directly at C<evo@cpan.org> or C<simonm@cavalletto.org>.
#
#Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff.
#
#Interface based by Clone by Ray Finch with contributions from chocolateboy.
#Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy.
#
#You may use, modify, and distribute this software under the same terms as Perl.
#
#=cut
### Complete/Bash.pm ###
#package Complete::Bash;
#
#our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
#our $DATE = '2020-04-16'; # DATE
#our $DIST = 'Complete-Bash'; # DIST
#our $VERSION = '0.335'; # VERSION
#
#use 5.010001;
#use strict;
#use warnings;
#use Log::ger;
#
#require Exporter;
#our @ISA = qw(Exporter);
#our @EXPORT_OK = qw(
# point
# parse_cmdline
# join_wordbreak_words
# format_completion
# );
#
#our %SPEC;
#
#$SPEC{':package'} = {
# v => 1.1,
# summary => 'Completion routines for bash shell',
#};
#
#sub _expand_tilde {
# my ($user, $slash) = @_;
# my @ent;
# if (length $user) {
# @ent = getpwnam($user);
# } else {
# @ent = getpwuid($>);
# $user = $ent[0];
# }
# return $ent[7] . $slash if @ent;
# "~$user$slash"; # return as-is when failed
#}
#
#sub _add_unquoted {
# no warnings 'uninitialized';
#
# my ($word, $is_cur_word, $after_ws) = @_;
#
# #say "D:add_unquoted word=$word is_cur_word=$is_cur_word after_ws=$after_ws";
#
# $word =~ s!^(~)(\w*)(/|\z) | # 1) tilde 2) username 3) optional slash
# \\(.) | # 4) escaped char
# \$(\w+) # 5) variable name
# !
# $1 ? (not($after_ws) || $is_cur_word ? "$1$2$3" : _expand_tilde($2, $3)) :
# $4 ? $4 :
# ($is_cur_word ? "\$$5" : $ENV{$5})
# !egx;
# $word;
#}
#
#sub _add_double_quoted {
# no warnings 'uninitialized';
#
# my ($word, $is_cur_word) = @_;
#
# $word =~ s!\\(.) | # 1) escaped char
# \$(\w+) # 2) variable name
# !
# $1 ? $1 :
# ($is_cur_word ? "\$$2" : $ENV{$2})
# !egx;
# $word;
#}
#
#sub _add_single_quoted {
# my $word = shift;
# $word =~ s/\\(.)/$1/g;
# $word;
#}
#
#$SPEC{point} = {
# v => 1.1,
# summary => 'Return line with point marked by a marker',
# description => <<'_',
#
#This is a utility function useful for testing/debugging. `parse_cmdline()`
#expects a command-line and a cursor position (`$line`, `$point`). This routine
#expects `$line` with a marker character (by default it's the caret, `^`) and
#return (`$line`, `$point`) to feed to `parse_cmdline()`.
#
#Example:
#
# point("^foo") # => ("foo", 0)
script/gen-generic-ind-company-names view on Meta::CPAN
#Optional. Known options:
#
#* `truncate_current_word` (bool). If set to 1, will truncate current word to the
# position of cursor, for example (`^` marks the position of cursor):
# `--vers^oo` to `--vers` instead of `--versoo`. This is more convenient when
# doing tab completion.
#
#_
# schema => 'hash*',
# pos => 2,
# },
# },
# result => {
# schema => ['array*', len=>2],
# description => <<'_',
#
#Return a 2-element array: `[$words, $cword]`. `$words` is array of str,
#equivalent to `COMP_WORDS` provided by bash to shell functions. `$cword` is an
#integer, roughly equivalent to `COMP_CWORD` provided by bash to shell functions.
#The word to be completed is at `$words->[$cword]`.
#
#Note that COMP_LINE includes the command name. If you want the command-line
#arguments only (like in `@ARGV`), you need to strip the first element from
#`$words` and reduce `$cword` by 1.
#
#
#_
# },
# result_naked => 1,
# links => [
# ],
#};
#sub parse_cmdline {
# no warnings 'uninitialized';
# my ($line, $point, $opts) = @_;
#
# $line //= $ENV{COMP_LINE};
# $point //= $ENV{COMP_POINT} // 0;
#
# die "$0: COMP_LINE not set, make sure this script is run under ".
# "bash completion (e.g. through complete -C)\n" unless defined $line;
#
# log_trace "[compbash] parse_cmdline(): input: line=<$line> point=<$point>"
# if $ENV{COMPLETE_BASH_TRACE};
#
# my @words;
# my $cword;
# my $pos = 0;
# my $pos_min_ws = 0;
# my $after_ws = 1; # XXX what does this variable mean?
# my $chunk;
# my $add_blank;
# my $is_cur_word;
# $line =~ s!( # 1) everything
# (")((?: \\\\|\\"|[^"])*)(?:"|\z)(\s*) | # 2) open " 3) content 4) space after
# (')((?: \\\\|\\'|[^'])*)(?:'|\z)(\s*) | # 5) open ' 6) content 7) space after
# ((?: \\\\|\\"|\\'|\\=|\\\s|[^"'@><=|&\(:\s])+)(\s*) | # 8) unquoted word 9) space after
# ([\@><=|&\(:]+) | # 10) non-whitespace word-breaking characters
# \s+
# )!
# $pos += length($1);
# #say "D: \$1=<$1> \$2=<$3> \$3=<$3> \$4=<$4> \$5=<$5> \$6=<$6> \$7=<$7> \$8=<$8> \$9=<$9> \$10=<$10>";
# #say "D:<$1> pos=$pos, point=$point, cword=$cword, after_ws=$after_ws";
#
# if ($2 || $5 || defined($8)) {
# # double-quoted/single-quoted/unquoted chunk
#
# if (not(defined $cword)) {
# $pos_min_ws = $pos - length($2 ? $4 : $5 ? $7 : $9);
# #say "D:pos_min_ws=$pos_min_ws";
# if ($point <= $pos_min_ws) {
# $cword = @words - ($after_ws ? 0 : 1);
# } elsif ($point < $pos) {
# $cword = @words + 1 - ($after_ws ? 0 : 1);
# $add_blank = 1;
# }
# }
#
# if ($after_ws) {
# $is_cur_word = defined($cword) && $cword==@words;
# } else {
# $is_cur_word = defined($cword) && $cword==@words-1;
# }
# #say "D:is_cur_word=$is_cur_word";
# $chunk =
# $2 ? _add_double_quoted($3, $is_cur_word) :
# $5 ? _add_single_quoted($6) :
# _add_unquoted($8, $is_cur_word, $after_ws);
# if ($opts && $opts->{truncate_current_word} &&
# $is_cur_word && $pos > $point) {
# $chunk = substr(
# $chunk, 0, length($chunk)-($pos_min_ws-$point));
# #say "D:truncating current word to <$chunk>";
# }
# if ($after_ws) {
# push @words, $chunk;
# } else {
# $words[-1] .= $chunk;
# }
# if ($add_blank) {
# push @words, '';
# $add_blank = 0;
# }
# $after_ws = ($2 ? $4 : $5 ? $7 : $9) ? 1:0;
#
# } elsif ($10) {
# # non-whitespace word-breaking characters
# push @words, $10;
# $after_ws = 1;
# } else {
# # whitespace
# $after_ws = 1;
# }
# !egx;
#
# $cword //= @words;
# $words[$cword] //= '';
#
# log_trace "[compbash] parse_cmdline(): result: words=%s, cword=%s", \@words, $cword
# if $ENV{COMPLETE_BASH_TRACE};
#
# [\@words, $cword];
#}
#
#$SPEC{join_wordbreak_words} = {
# v => 1.1,
# summary => 'Post-process parse_cmdline() result by joining some words',
# description => <<'_',
#
#`parse_cmdline()`, like bash, splits some characters that are considered as
#word-breaking characters:
#
# "'@><=;|&(:
#
#So if command-line is:
#
# command --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 = [];
script/gen-generic-ind-company-names view on Meta::CPAN
# [{word=>"-a" , summary=>"Show hidden files"},
# {word=>"-l" , summary=>"Show details"},
# {word=>"--sort", summary=>"Specify sort order"}],
#
# When summaries are not shown, user will just be seeing something like:
#
# -a
# -l
# --sort
#
# But when summaries are shown, user will see:
#
# -a -- Show hidden files
# -l -- Show details
# --sort -- Specify sort order
#
# which is quite helpful.
#
#* workaround_with_wordbreaks
#
# Boolean. Default is true. See source code for more details.
#
#_
#
# },
# },
# result => {
# summary => 'Formatted string (or array, if `as` is set to `array`)',
# schema => ['any*' => of => ['str*', 'array*']],
# },
# result_naked => 1,
#};
#sub format_completion {
# my ($hcomp, $opts) = @_;
#
# $opts //= {};
#
# $hcomp = {words=>$hcomp} unless ref($hcomp) eq 'HASH';
# my $words = $hcomp->{words};
# my $as = $opts->{as} // 'string';
# # 'escmode' key is deprecated (Complete 0.11-) and will be removed later
# my $esc_mode = $opts->{esc_mode} // $ENV{COMPLETE_BASH_DEFAULT_ESC_MODE} //
# 'default';
# my $path_sep = $hcomp->{path_sep};
#
# # we keep the original words (before formatted with summaries) when we want
# # to use fzf instead of passing to bash directly
# my @words;
# my @summaries;
# my @res;
# my $has_summary;
#
# my $code_return_message = sub {
# # display a message instead of list of words. we send " " (ASCII space)
# # which bash does not display, so we can display a line of message while
# # the user does not get the message as the completion. I've also tried
# # \000 to \037 instead of space (\040) but nothing works better.
# my $msg = shift;
# if ($msg =~ /\A /) {
# $msg =~ s/\A +//;
# $msg = " (empty message)" unless length $msg;
# }
# return (sprintf("%-"._terminal_width()."s", $msg), " ");
# };
#
# FORMAT_MESSAGE:
# # display a message instead of list of words. we send " " (ASCII space)
# # which bash does not display, so we can display a line of message while the
# # user does not get the message as the completion. I've also tried \000 to
# # \037 instead of space (\040) but nothing works better.
# if (defined $hcomp->{message}) {
# @res = $code_return_message->($hcomp->{message});
# goto RETURN_RES;
# }
#
# WORKAROUND_PREVENT_BASH_FROM_INSERTING_SPACE:
# {
# 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")) {
# #@res = $code_return_message->("Cannot find fzf to filter ".
# # scalar(@words)." items");
# goto RETURN_RES;
# }
#
# require IPC::Open2;
# local *CHLD_OUT;
# local *CHLD_IN;
# my $pid = IPC::Open2::open2(
# \*CHLD_OUT, \*CHLD_IN, "fzf", "-m", "-d:", "--with-nth=2..")
# or do {
# @res = $code_return_message->("Cannot open fzf to filter ".
# scalar(@words)." items");
# goto RETURN_RES;
# };
#
# print CHLD_IN map { "$_:$res[$_]\n" } 0..$#res;
# close CHLD_IN;
#
# my @res_words;
# while (<CHLD_OUT>) {
# my ($index) = /\A([0-9]+)\:/ or next;
# push @res_words, $words[$index];
# }
# if (@res_words) {
# @res = join(" ", @res_words);
# } else {
# @res = ();
# }
# waitpid($pid, 0);
# }
#
# RETURN_RES:
# #use Data::Dump; warn Data::Dump::dump(\@res);
# if ($as eq 'array') {
# return \@res;
# } else {
# return join("", map {($_, "\n")} @res);
# }
#}
#
#1;
## ABSTRACT: Completion routines for bash shell
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
script/gen-generic-ind-company-names view on Meta::CPAN
#
#Usage:
#
# point($cmdline, $marker) -> any
#
#Return line with point marked by a marker.
#
#This is a utility function useful for testing/debugging. C<parse_cmdline()>
#expects a command-line and a cursor position (C<$line>, C<$point>). This routine
#expects C<$line> with a marker character (by default it's the caret, C<^>) and
#return (C<$line>, C<$point>) to feed to C<parse_cmdline()>.
#
#Example:
#
# point("^foo") # => ("foo", 0)
# point("fo^o") # => ("foo", 2)
#
#This function is not exported by default, but exportable.
#
#Arguments ('*' denotes required arguments):
#
#=over 4
#
#=item * B<$cmdline> => I<str>
#
#Command-line which contains a marker character.
#
#=item * B<$marker> => I<str> (default: "^")
#
#Marker character.
#
#
#=back
#
#Return value: (any)
#
#=head1 ENVIRONMENT
#
#=head2 COMPLETE_BASH_DEFAULT_ESC_MODE
#
#Str. To provide default for the C<esc_mode> option in L</format_completion>.
#
#=head2 COMPLETE_BASH_FZF
#
#Bool. Whether to pass large completion answer to fzf instead of directly passing
#it to bash and letting bash page it with a simpler more-like internal pager. By
#default, large is defined as having at least 100 items (same bash's
#C<completion-query-items> setting). This can be configured via
#L</COMPLETE_BASH_FZF_ITEMS>.
#
#=head2 COMPLETE_BASH_FZF_ITEMS
#
#Uint. Default 100. The minimum number of items to trigger passing completion
#answer to fzf. See also: L</COMPLETE_BASH_FZF>.
#
#=head2 COMPLETE_BASH_MAX_COLUMNS
#
#Uint.
#
#Bash will show completion entries in one or several columns, depending on the
#terminal width and the length of the entries (much like a standard non-long
#`ls`). If you prefer completion entries to be shown in a single column no matter
#how wide your terminal is, or how short the entries are, you can set the value
#of this variable to 1. If you prefer a maximum of two columns, set to 2, and so
#on. L</format_completion> will pad the entries with sufficient spaces to limit
#the number of columns.
#
#=head2 COMPLETE_BASH_SHOW_SUMMARIES
#
#Bool. Will set the default for C<show_summaries> option in
#L</format_completion>.
#
#=head2 COMPLETE_BASH_SUMMARY_ALIGN
#
#String. Either C<left> (the default) or C<right>.
#
#The C<left> align looks something like this:
#
# --bar Summary about the bar option
# --baz Summary about the baz option
# --foo Summary about the foo option
# --schapen Summary about the schapen option
#
#The C<right> align will make the completion answer look like what you see in the
#B<fish> shell:
#
# --bar Summary about the bar option
# --baz Summary about the baz option
# --foo Summary about the foo option
# --schapen Summary about the schapen option
#
#=head2 COMPLETE_BASH_TRACE
#
#Bool. If set to true, will produce more log statements to L<Log::ger>.
#
#=head1 HOMEPAGE
#
#Please visit the project's homepage at L<https://metacpan.org/release/Complete-Bash>.
#
#=head1 SOURCE
#
#Source repository is at L<https://github.com/perlancar/perl-Complete-Bash>.
#
#=head1 BUGS
#
#Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Bash>
#
#When submitting a bug or request, please include a test-file or a
#patch to an existing test-file that illustrates the bug or desired
#feature.
#
#=head1 SEE ALSO
#
#L<Complete>, the convention that this module follows.
#
#Some higher-level modules that use this module (so you don't have to use this
#module directly): L<Getopt::Long::Complete> (via L<Complete::Getopt::Long>),
#L<Getopt::Long::Subcommand>, L<Perinci::CmdLine> (via
#L<Perinci::Sub::Complete>).
#
#Other modules related to bash shell tab completion: L<Bash::Completion>,
script/gen-generic-ind-company-names view on Meta::CPAN
# 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;
#
# my ($self, $val) = @_;
# 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} }) {
script/gen-generic-ind-company-names view on Meta::CPAN
# 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;
# } elsif ($_ eq 'auto_abbrev') {
# $config->{auto_abbrev} = 1;
# } elsif ($_ eq 'no_auto_abbrev') {
# $config->{auto_abbrev} = 0;
# } elsif ($_ =~ /\A(no_ignore_case|no_getopt_compat|gnu_compat|bundling|permute)\z/) {
# # 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);
# }
#
# } 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) {
# # unknown short option
# push @remaining, "-" unless $remaining_pushed++;
# $remaining[-1] .= $short_opt;
# next SHORT_OPT;
# } elsif (!length $opt) {
# # ambiguous short option
# push @remaining, "-" unless $remaining_pushed++;
# $remaining[-1] .= $short_opt;
# }
#
# my $spec = $spec_by_opt_name{$opt};
# # check whether option requires an argument
# if ($spec =~ /=[fios][@%]?\z/) {
# if (length $str) {
# # argument is taken from $str
# $code_set_val->($opt, $str);
# next ELEM;
# } else {
# if ($i+1 >= @$argv) {
# # we are the last element
# unless ($config->{pass_through}) {
# warn "Option $used_name requires an argument\n";
# $success = 0;
# }
# last ELEM;
# }
# # take the next element as argument
# $i++;
# $code_set_val->($opt, $argv->[$i]);
# }
# } else {
# $code_set_val->($opt);
# }
# }
#
# } else { # argument
#
# push @remaining, $argv->[$i];
# next;
#
# }
# }
#
# RETURN:
# splice @$argv, 0, ~~@$argv, @remaining; # replace with remaining elements
# return $success;
#}
#
#sub GetOptions {
# GetOptionsFromArray(\@ARGV, @_);
#}
#
#1;
## ABSTRACT: Like Getopt::Long::Less, but with even less features
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Getopt::Long::EvenLess - Like Getopt::Long::Less, but with even less features
#
#=head1 VERSION
#
#This document describes version 0.112 of Getopt::Long::EvenLess (from Perl distribution Getopt-Long-EvenLess), released on 2019-02-02.
#
#=head1 DESCRIPTION
#
#This module (GLEL for short) is a reimplementation of L<Getopt::Long> (GL for
#short), but with much less features. It's an even more stripped down version of
#L<Getopt::Long::Less> (GLL for short) and is perhaps less convenient to use for
script/gen-generic-ind-company-names view on Meta::CPAN
#=cut
### 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->{"num_names"}) { return [400, "You specified --num-names but also argument #0"]; } else { $args->{"num_names"} = delete($ARGV[0]); } }
# }
# my @check_argv = @ARGV;
# # fill from cmdline_src
#
# # fill defaults from "default" property and check against schema
# no warnings ('void');
# require Scalar::Util::Numeric::PP;
# my $_sahv_dpath;
# my $_sahv_err;
# $args->{"add_prefixes"} //= 1;
# if (exists $args->{"add_prefixes"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"add_prefixes"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'bool'
# ((!ref($args->{"add_prefixes"})) ? 1 : (($_sahv_err //= "Not of type boolean value"),0))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
# $args->{"add_suffixes"} //= 1;
# if (exists $args->{"add_suffixes"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"add_suffixes"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'bool'
# ((!ref($args->{"add_suffixes"})) ? 1 : (($_sahv_err //= "Not of type boolean value"),0))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
# if (exists $args->{"desired_initials"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"desired_initials"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'str'
# ((!ref($args->{"desired_initials"})) ? 1 : (($_sahv_err //= "Not of type text"),0))
#
# &&
#
# (# clause: match
# (($args->{"desired_initials"} =~ qr((?:(?-)\A[A-Za-z]+\z))) ? 1 : (($_sahv_err //= "Must match regex pattern qr(\\A[A-Za-z]+\\z)"),0)))
#
# &&
#
# (# clause: min_len
# ((length($args->{"desired_initials"}) >= 1) ? 1 : (($_sahv_err //= "Length must be at least 1"),0)))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
# $args->{"num_names"} //= 1;
# if (exists $args->{"num_names"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"num_names"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'int'
# ((Scalar::Util::Numeric::PP::isint($args->{"num_names"})) ? 1 : (($_sahv_err //= "Not of type integer"),0))
#
# &&
#
# (# clause: min
# (($args->{"num_names"} >= 0) ? 1 : (($_sahv_err //= "Must be at least 0"),0)))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
# $args->{"num_words"} //= 3;
# if (exists $args->{"num_words"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"num_words"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'int'
# ((Scalar::Util::Numeric::PP::isint($args->{"num_words"})) ? 1 : (($_sahv_err //= "Not of type integer"),0))
#
# &&
#
# (# clause: min
# (($args->{"num_words"} >= 1) ? 1 : (($_sahv_err //= "Must be at least 1"),0)))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
# $args->{"type"} //= "PT";
# if (exists $args->{"type"}) {
# $_sahv_dpath = [];
# # req #0
# ((defined($args->{"type"})) ? 1 : (($_sahv_err //= "Required but not specified"),0))
#
# &&
#
# # check type 'str'
# ((!ref($args->{"type"})) ? 1 : (($_sahv_err //= "Not of type text"),0))
# ; if ($_sahv_err) { return [400, "Argument validation failed: $_sahv_err"] }
# } # if date arg exists
#
# # check required args
# return [400, "Missing required value for argument: add_prefixes"] if exists($args->{"add_prefixes"}) && !defined($args->{"add_prefixes"});
# return [400, "Missing required value for argument: add_suffixes"] if exists($args->{"add_suffixes"}) && !defined($args->{"add_suffixes"});
# return [400, "Missing required value for argument: desired_initials"] if exists($args->{"desired_initials"}) && !defined($args->{"desired_initials"});
# return [400, "Missing required value for argument: num_names"] if exists($args->{"num_names"}) && !defined($args->{"num_names"});
# return [400, "Missing required value for argument: num_words"] if exists($args->{"num_words"}) && !defined($args->{"num_words"});
# return [400, "Missing required value for argument: type"] if exists($args->{"type"}) && !defined($args->{"type"});
# _pci_err([500, "Extraneous command-line argument(s): ".join(", ", @check_argv)]) if @check_argv;
# [200];
# } else { _pci_err([500, "Unknown subcommand1: $sc_name"]); }
#}
script/gen-generic-ind-company-names view on Meta::CPAN
# args => {
# r => {},
# config => {},
# args => {schema=>'hash'},
# plugins => {schema=>'array'},
# 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 $plugins = $fargs{plugins} // [];
# 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 {
# # sort according to the order the section is seen in the file
# 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 debugging message
# 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};
# my $sect_plugin = $keyvals{plugin};
#
# # if there is a subcommand name, use section with no subcommand=... or
# # the matching subcommand
# if (length $scn) {
# if (length($sect_scn) && $sect_scn ne $scn) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "subcommand does not match '$scn'",
# );
# next;
# }
# } else {
# if (length $sect_scn) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "only for a certain subcommand",
# );
# next;
# }
# }
#
# # if user chooses a profile, only use section with no profile=... or the
# # matching profile
# if (defined $profile) {
# if (defined($sect_profile) && $sect_profile ne $profile) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "profile does not match '$profile'",
# );
# next;
# }
# $found = 1 if defined($sect_profile) && $sect_profile eq $profile;
# } else {
# if (defined($sect_profile)) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "only for a certain profile",
# );
# next;
# }
# }
#
# # only use section marked with program=... if the program name matches
# if (defined($progn) && defined($keyvals{program})) {
# if ($progn ne $keyvals{program}) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "program does not match '$progn'",
# );
# next;
# }
# }
#
# # if user specifies env=... then apply filtering by ENV variable
# if (defined(my $env = $keyvals{env})) {
# my ($var, $val);
# if (($var, $val) = $env =~ /\A(\w+)=(.*)\z/) {
# if (($ENV{$var} // '') ne $val) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "env $var has non-matching value '".
# ($ENV{$var} // '')."'",
# );
# next;
# }
# } elsif (($var, $val) = $env =~ /\A(\w+)!=(.*)\z/) {
# if (($ENV{$var} // '') eq $val) {
# log_trace(
# "[pericmd] Skipped config section '%s' (%s)",
# $section0, "env $var has that value",
# );
# next;
# }
script/gen-generic-ind-company-names view on Meta::CPAN
# # 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];
# 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 {
# # assumed left
# $cell .= (' ' x ($maxw - length($cell)));
#
# }
# $row->[$colidx] = $cell;
# }
# }
# } # for $colidx
# } # END align columns
#
# my $fres;
# my $backend = $ENV{FORMAT_PRETTY_TABLE_BACKEND};
# $backend //= "Text::Table::Org" if $ENV{INSIDE_EMACS};
# if ($backend) {
# require Text::Table::Any;
# $fres = Text::Table::Any::table(rows=>$data, header_row=>$header_row, backend=>$backend);
# } else {
# require Text::Table::Sprintf;
# $fres = Text::Table::Sprintf::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 = 1000;
# 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})) {
# # collect all mentioned fields
# 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;
#
# if ($format eq 'perl') {
# my $use_color = $ENV{COLOR} // (-t STDOUT);
# if ($use_color && eval { require Data::Dump::Color; 1 }) {
# return Data::Dump::Color::dump($res);
# } elsif (eval { require Data::Dump; 1 }) {
# return Data::Dump::dump($res);
# } else {
# no warnings 'once';
# require Data::Dumper;
# local $Data::Dumper::Terse = 1;
# local $Data::Dumper::Indent = 1;
# local $Data::Dumper::Useqq = 1;
# local $Data::Dumper::Deparse = 1;
# local $Data::Dumper::Quotekeys = 0;
# local $Data::Dumper::Sortkeys = 1;
( run in 0.348 second using v1.01-cache-2.11-cpan-140bd7fdf52 )