Acme-ID-CompanyName
view release on metacpan or search on metacpan
script/gen-generic-ind-company-names view on Meta::CPAN
### Clone/PP.pm ###
#package Clone::PP;
#
#use 5.006;
#use strict;
#use warnings;
#use vars qw($VERSION @EXPORT_OK);
#use Exporter;
#
#$VERSION = 1.07;
#
#@EXPORT_OK = qw( clone );
#sub import { goto &Exporter::import } # lazy Exporter
#
## These methods can be temporarily overridden to work with a given class.
#use vars qw( $CloneSelfMethod $CloneInitMethod );
#$CloneSelfMethod ||= 'clone_self';
#$CloneInitMethod ||= 'clone_init';
#
## Used to detect looped networks and avoid infinite recursion.
#use vars qw( %CloneCache );
#
## Generic cloning function
#sub clone {
# my $source = shift;
#
# return undef if not defined($source);
#
# # Optional depth limit: after a given number of levels, do shallow copy.
# my $depth = shift;
# return $source if ( defined $depth and $depth -- < 1 );
#
# # Maintain a shared cache during recursive calls, then clear it at the end.
# local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
#
# return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
#
# # Non-reference values are copied shallowly
# my $ref_type = ref $source or return $source;
#
# # Extract both the structure type and the class name of referent
# my $class_name;
# if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
# $class_name = $ref_type;
# $ref_type = $1;
# # Some objects would prefer to clone themselves; check for clone_self().
# return $CloneCache{ $source } = $source->$CloneSelfMethod()
# if $source->can($CloneSelfMethod);
# }
#
# # To make a copy:
# # - Prepare a reference to the same type of structure;
# # - Store it in the cache, to avoid looping if it refers to itself;
# # - Tie in to the same class as the original, if it was tied;
# # - Assign a value to the reference by cloning each item in the original;
#
# my $copy;
# if ($ref_type eq 'HASH') {
# $CloneCache{ $source } = $copy = {};
# if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied }
# %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source;
# } elsif ($ref_type eq 'ARRAY') {
# $CloneCache{ $source } = $copy = [];
# if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied }
# @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source;
# } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
# $CloneCache{ $source } = $copy = \( my $var = "" );
# if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied }
# $$copy = clone($$source, $depth);
# } else {
# # Shallow copy anything else; this handles a reference to code, glob, regex
# $CloneCache{ $source } = $copy = $source;
# }
#
# # - Bless it into the same class as the original, if it was blessed;
# # - If it has a post-cloning initialization method, call it.
# if ( $class_name ) {
# bless $copy, $class_name;
# $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
# }
#
# return $copy;
#}
#
#1;
#
#__END__
#
#=head1 NAME
#
#Clone::PP - Recursively copy Perl datatypes
#
#=head1 SYNOPSIS
#
# use Clone::PP qw(clone);
#
# $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] };
# $copy = clone( $item );
#
# $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ];
# $copy = clone( $item );
#
# $item = Foo->new();
# $copy = clone( $item );
#
#Or as an object method:
#
# require Clone::PP;
# push @Foo::ISA, 'Clone::PP';
#
# $item = Foo->new();
# $copy = $item->clone();
#
#=head1 DESCRIPTION
#
#This module provides a general-purpose clone function to make deep
#copies of Perl data structures. It calls itself recursively to copy
#nested hash, array, scalar and reference types, including tied
#variables and objects.
#
#The clone() function takes a scalar argument to copy. To duplicate
#arrays or hashes, pass them in by reference:
#
# my $copy = clone(\@array); my @copy = @{ clone(\@array) };
# my $copy = clone(\%hash); my %copy = %{ clone(\%hash) };
script/gen-generic-ind-company-names view on Meta::CPAN
# if ($summary_align eq 'right') {
# # if we are aligning summary to the right, we want to fill column
# # width width
# if ($max_columns <= 0) {
# $max_columns = _num_columns(
# $terminal_width, ($max_entry_width + 2 + $max_summ_width));
# }
# $column_width = _column_width($terminal_width, $max_columns);
# my $new_max_summ_width = $column_width - 2 - $max_entry_width;
# $max_summ_width = $new_max_summ_width
# if $max_summ_width < $new_max_summ_width;
# #warn "max_columns=$max_columns, column_width=$column_width, max_summ_width=$max_summ_width\n";
# }
#
# for (0..$#words) {
# my $summary = $summaries[$_];
# if (length $summary) {
# $res[$_] = sprintf(
# "%-${max_entry_width}s |%".
# ($summary_align eq 'right' ? $max_summ_width : '')."s",
# $words[$_], $summary);
# }
# }
# } # FORMAT_SUMMARIES
#
# MAX_COLUMNS: {
# last unless $max_columns > 0;
# my $max_entry_width = 0;
# for (@res) {
# $max_entry_width = length if $max_entry_width < length;
# }
# last if $max_entry_width >= $column_width;
# for (@res) {
# $_ .= " " x ($column_width - length) if $column_width > length;
# }
# }
#
# PASS_TO_FZF: {
# last unless $ENV{COMPLETE_BASH_FZF};
# my $items = $ENV{COMPLETE_BASH_FZF_ITEMS} // 100;
# last unless @words >= $items;
#
# require File::Which;
# unless (File::Which::which("fzf")) {
# #@res = $code_return_message->("Cannot find fzf to filter ".
# # scalar(@words)." items");
# goto RETURN_RES;
# }
#
# require IPC::Open2;
# local *CHLD_OUT;
# local *CHLD_IN;
# my $pid = IPC::Open2::open2(
# \*CHLD_OUT, \*CHLD_IN, "fzf", "-m", "-d:", "--with-nth=2..")
# or do {
# @res = $code_return_message->("Cannot open fzf to filter ".
# scalar(@words)." items");
# goto RETURN_RES;
# };
#
# print CHLD_IN map { "$_:$res[$_]\n" } 0..$#res;
# close CHLD_IN;
#
# my @res_words;
# while (<CHLD_OUT>) {
# my ($index) = /\A([0-9]+)\:/ or next;
# push @res_words, $words[$index];
# }
# if (@res_words) {
# @res = join(" ", @res_words);
# } else {
# @res = ();
# }
# waitpid($pid, 0);
# }
#
# RETURN_RES:
# #use Data::Dump; warn Data::Dump::dump(\@res);
# if ($as eq 'array') {
# return \@res;
# } else {
# return join("", map {($_, "\n")} @res);
# }
#}
#
#1;
## ABSTRACT: Completion routines for bash shell
#
#__END__
#
#=pod
#
#=encoding UTF-8
#
#=head1 NAME
#
#Complete::Bash - Completion routines for bash shell
#
#=head1 VERSION
#
#This document describes version 0.335 of Complete::Bash (from Perl distribution Complete-Bash), released on 2020-04-16.
#
#=head1 DESCRIPTION
#
#This module provides routines related to tab completion in bash shell.
#
#=head2 About programmable completion in bash
#
#Bash allows completion to come from various sources. The simplest is from a list
#of words (C<-W>):
#
# % complete -W "one two three four" somecmd
# % somecmd t<Tab>
# two three
#
#Another source is from a bash function (C<-F>). The function will receive input
#in two variables: C<COMP_WORDS> (array, command-line chopped into words) and
#C<COMP_CWORD> (integer, index to the array of words indicating the cursor
#position). It must set an array variable C<COMPREPLY> that contains the list of
#possible completion:
#
# % _foo()
# {
# local cur
# COMPREPLY=()
# cur=${COMP_WORDS[COMP_CWORD]}
# COMPREPLY=($( compgen -W '--help --verbose --version' -- $cur ) )
# }
# % complete -F _foo foo
# % foo <Tab>
# --help --verbose --version
#
#And yet another source is an external command (C<-C>) including, from a Perl
#script. The command receives two environment variables: C<COMP_LINE> (string,
#raw command-line) and C<COMP_POINT> (integer, cursor location). Program must
#split C<COMP_LINE> into words, find the word to be completed, complete that, and
#return the list of words one per-line to STDOUT. An example:
#
# % cat foo-complete
# #!/usr/bin/perl
# use Complete::Bash qw(parse_cmdline format_completion);
# use Complete::Util qw(complete_array_elem);
script/gen-generic-ind-company-names view on Meta::CPAN
# $sc = "|";
# } elsif (!$expr && $c =~ s/(?<=.)\&\z//) {
# die "$errp, syntax should be CLAUSE&"
# unless $c =~ $clause_name_re;
# $sc = "&";
# } elsif (!$expr && $c =~ /\A([^.]+)(?:\.(.+))?\((\w+)\)\z/) {
# my ($c2, $a, $lang) = ($1, $2, $3);
# die "$errp, syntax should be CLAUSE(LANG) or C.ATTR(LANG)"
# unless $c2 =~ $clause_name_re &&
# (!defined($a) || $a =~ $attr_re);
# $sc = "(LANG)";
# $cn = $c2 . (defined($a) ? ".$a" : "") . ".alt.lang.$lang";
# } elsif ($c !~ $clause_re &&
# $c !~ $clause_attr_on_empty_clause_re) {
# die "$errp, please use letter/digit/underscore only";
# }
# }
#
# # XXX can't disregard merge prefix when checking conflict
# if ($sc eq '!') {
# die "Conflict between clause shortcuts '!$c' and '$c'"
# if exists $clset0->{$c};
# die "Conflict between clause shortcuts '!$c' and '$c|'"
# if exists $clset0->{"$c|"};
# die "Conflict between clause shortcuts '!$c' and '$c&'"
# if exists $clset0->{"$c&"};
# $clset->{$c} = $v;
# $clset->{"$c.op"} = "not";
# } elsif ($sc eq '&') {
# die "Conflict between clause shortcuts '$c&' and '$c'"
# if exists $clset0->{$c};
# die "Conflict between clause shortcuts '$c&' and '$c|'"
# if exists $clset0->{"$c|"};
# die "Clause 'c&' value must be an array"
# unless ref($v) eq 'ARRAY';
# $clset->{$c} = $v;
# $clset->{"$c.op"} = "and";
# } elsif ($sc eq '|') {
# die "Conflict between clause shortcuts '$c|' and '$c'"
# if exists $clset0->{$c};
# die "Clause 'c|' value must be an array"
# unless ref($v) eq 'ARRAY';
# $clset->{$c} = $v;
# $clset->{"$c.op"} = "or";
# } elsif ($sc eq '(LANG)') {
# die "Conflict between clause '$c' and '$cn'"
# if exists $clset0->{$cn};
# $clset->{$cn} = $v;
# } else {
# $clset->{$c} = $v;
# }
#
# }
# $clset->{req} = 1 if $opts->{has_req};
#
# # XXX option to recursively normalize clset, any's of, all's of, ...
# #if ($clset->{clset}) {
# # local $opts->{has_req};
# # if ($clset->{'clset.op'} && $clset->{'clset.op'} =~ /and|or/) {
# # # multiple clause sets
# # $clset->{clset} = map { $self->normalize_clset($_, $opts) }
# # @{ $clset->{clset} };
# # } else {
# # $clset->{clset} = $self->normalize_clset($_, $opts);
# # }
# #}
#
# $clset;
#}
#
#sub normalize_schema($) {
# my $s = shift;
#
# my $ref = ref($s);
# if (!defined($s)) {
#
# die "Schema is missing";
#
# } elsif (!$ref) {
#
# my $has_req = $s =~ s/\*\z//;
# $s =~ $type_re or die "Invalid type syntax $s, please use ".
# "letter/digit/underscore only";
# return [$s, $has_req ? {req=>1} : {}, {}];
#
# } elsif ($ref eq 'ARRAY') {
#
# my $t = $s->[0];
# my $has_req = $t && $t =~ s/\*\z//;
# if (!defined($t)) {
# die "For array form, at least 1 element is needed for type";
# } elsif (ref $t) {
# die "For array form, first element must be a string";
# }
# $t =~ $type_re or die "Invalid type syntax $s, please use ".
# "letter/digit/underscore only";
#
# my $clset0;
# my $extras;
# if (defined($s->[1])) {
# if (ref($s->[1]) eq 'HASH') {
# $clset0 = $s->[1];
# $extras = $s->[2];
# die "For array form, there should not be more than 3 elements"
# if @$s > 3;
# } else {
# # flattened clause set [t, c=>1, c2=>2, ...]
# die "For array in the form of [t, c1=>1, ...], there must be ".
# "3 elements (or 5, 7, ...)"
# unless @$s % 2;
# $clset0 = { @{$s}[1..@$s-1] };
# }
# } else {
# $clset0 = {};
# }
#
# # check clauses and parse shortcuts (!c, c&, c|, c=)
# my $clset = normalize_clset($clset0, {has_req=>$has_req});
# if (defined $extras) {
# die "For array form with 3 elements, extras must be hash"
# unless ref($extras) eq 'HASH';
script/gen-generic-ind-company-names view on Meta::CPAN
#
# if ($name_routines && !defined &subname) {
# if (eval { require Sub::Name; 1 }) {
# *subname = \&Sub::Name::subname;
# } else {
# *subname = sub {};
# }
# }
#
# if ($target eq 'package') {
##IFUNBUILT
## no warnings 'redefine';
##END IFUNBUILT
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# #print "D:installing $name to package $target_arg\n";
# *{"$target_arg\::$name"} = $code;
# subname("$target_arg\::$name", $code) if $name_routines;
# }
# } elsif ($target eq 'object') {
##IFUNBUILT
## no warnings 'redefine';
##END IFUNBUILT
# my $pkg = ref $target_arg;
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_method\z/;
# *{"$pkg\::$name"} = $code;
# subname("$pkg\::$name", $code) if $name_routines;
# }
# } elsif ($target eq 'hash') {
# for my $r (@$routines) {
# my ($code, $name, $lnum, $type) = @$r;
# next unless $type =~ /_sub\z/;
# $target_arg->{$name} = $code;
# }
# }
#}
#
#sub add_target {
# my ($target_type, $target_name, $per_target_conf, $replace) = @_;
# $replace = 1 unless defined $replace;
#
# if ($target_type eq 'package') {
# unless ($replace) { return if $Package_Targets{$target_name} }
# $Package_Targets{$target_name} = $per_target_conf;
# } elsif ($target_type eq 'object') {
# my ($addr) = "$target_name" =~ $re_addr;
# unless ($replace) { return if $Object_Targets{$addr} }
# $Object_Targets{$addr} = [$target_name, $per_target_conf];
# } elsif ($target_type eq 'hash') {
# my ($addr) = "$target_name" =~ $re_addr;
# unless ($replace) { return if $Hash_Targets{$addr} }
# $Hash_Targets{$addr} = [$target_name, $per_target_conf];
# }
#}
#
#sub _set_default_null_routines {
# $default_null_routines ||= [
# (map {(
# [$sub0, "log_$_", $Levels{$_}, 'logger_sub'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "log_is_$_", $Levels{$_}, 'level_checker_sub'],
# [$sub0, $_, $Levels{$_}, 'logger_method'],
# [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "is_$_", $Levels{$_}, 'level_checker_method'],
# )} keys %Levels),
# ];
#}
#
#sub get_logger {
# my ($package, %per_target_conf) = @_;
#
# my $caller = caller(0);
# $per_target_conf{category} = $caller
# if !defined($per_target_conf{category});
# my $obj = []; $obj =~ $re_addr;
# my $pkg = "Log::ger::Obj$1"; bless $obj, $pkg;
# add_target(object => $obj, \%per_target_conf);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(object => $obj, \%per_target_conf);
# } else {
# # if we haven't added any hooks etc, skip init_target() process and use
# # this preconstructed routines as shortcut, to save startup overhead
# _set_default_null_routines();
# install_routines(object => $obj, $default_null_routines, 0);
# }
# $obj; # XXX add DESTROY to remove from list of targets
#}
#
#sub _import_to {
# my ($package, $target_pkg, %per_target_conf) = @_;
#
# $per_target_conf{category} = $target_pkg
# if !defined($per_target_conf{category});
# add_target(package => $target_pkg, \%per_target_conf);
# if (keys %Global_Hooks) {
# require Log::ger::Heavy;
# init_target(package => $target_pkg, \%per_target_conf);
# } else {
# # if we haven't added any hooks etc, skip init_target() process and use
# # this preconstructed routines as shortcut, to save startup overhead
# _set_default_null_routines();
# install_routines(package => $target_pkg, $default_null_routines, 0);
# }
#}
#
#sub import {
# my ($package, %per_target_conf) = @_;
#
# my $caller = caller(0);
# $package->_import_to($caller, %per_target_conf);
#}
#
#1;
## ABSTRACT: A lightweight, flexible logging framework
#
#__END__
#
#=pod
#
script/gen-generic-ind-company-names view on Meta::CPAN
#);
#
#our %SPEC;
#
## from PERLANCAR::File::HomeDir 0.03, with minor modification
#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";
#}
#
#$SPEC{get_default_config_dirs} = {
# v => 1.1,
# args => {},
#};
#sub get_default_config_dirs {
# my @dirs;
# #local $PERLANCAR::File::HomeDir::DIE_ON_FAILURE = 1;
# my $home = _get_my_home_dir();
# if ($^O eq 'MSWin32') {
# push @dirs, $home;
# } else {
# push @dirs, "$home/.config", $home, "/etc";
# }
# \@dirs;
#}
#
#$SPEC{read_config} = {
# v => 1.1,
# args => {
# config_paths => {},
# config_filename => {},
# config_dirs => {},
# program_name => {},
# # TODO: hook_file
# hook_section => {},
# # TODO: hook_param?
# },
#};
#sub read_config {
# require Config::IOD::Reader;
#
# my %args = @_;
#
# my $config_dirs = $args{config_dirs} // get_default_config_dirs();
#
# my $paths;
#
# my @filenames;
# my %section_config_filename_map;
# if (my $names = $args{config_filename}) {
# for my $name (ref($names) eq 'ARRAY' ? @$names : ($names)) {
# if (ref($name) eq 'HASH') {
# $section_config_filename_map{$name->{filename}} = $name->{section};
# push @filenames, $name->{filename};
# } else {
# $section_config_filename_map{$name} = 'GLOBAL';
# push @filenames, $name;
# }
# }
# }
# unless (@filenames) {
# @filenames = (($args{program_name} // "prog") . ".conf");
# }
#
# if ($args{config_paths}) {
# $paths = $args{config_paths};
# } else {
# for my $dir (@$config_dirs) {
# for my $name (@filenames) {
# my $path = "$dir/" . $name;
# push @$paths, $path if -e $path;
# }
# }
# }
#
# my $reader = Config::IOD::Reader->new;
# my %res;
# my @read;
# my %section_read_order;
# FILE:
# for my $i (0..$#{$paths}) {
# my $path = $paths->[$i];
# my $filename = $path; $filename =~ s!.*[/\\]!!;
# my $wanted_section = $section_config_filename_map{$filename};
# log_trace "[pericmd] Reading config file '%s' ...", $path;
# my $j = 0;
# $section_read_order{GLOBAL} = [$i, $j++];
# my @file_sections = ("GLOBAL");
# my $hoh = $reader->read_file(
# $path,
# sub {
# my %args = @_;
# return unless $args{event} eq 'section';
# my $section = $args{section};
# push @file_sections, $section
# unless grep {$section eq $_} @file_sections;
# $section_read_order{$section} = [$i, $j++];
# },
# );
# push @read, $path;
# SECTION:
# for my $section (@file_sections) {
# $res{$section} //= {};
# my $hash = $hoh->{$section};
#
# my $s = $section; $s =~ s/\s*\S*=.*\z//; # strip key=value pairs
# $s = 'GLOBAL' if $s eq '';
#
# if ($args{hook_section}) {
# my $res = $args{hook_section}->($section, $hash);
# if ($res->[0] == 204) {
# log_trace "[pericmd] Skipped config section '$section' ".
# "in file '$path': hook_section returns 204";
# next SECTION;
# } elsif ($res->[0] >= 400 && $res->[0] <= 599) {
# return [$res->[0], "Error when reading config file '$path'".
# ": $res->[1]"];
# }
# }
#
# next unless !defined($wanted_section) || $s eq $wanted_section;
#
# for (keys %$hash) {
# $res{$section}{$_} = $hash->{$_};
# }
# }
# }
# [200, "OK", \%res, {
# 'func.read_files' => \@read,
# 'func.section_read_order' => \%section_read_order,
# }];
#}
#
#$SPEC{get_args_from_config} = {
# v => 1.1,
# description => <<'_',
#
#`config` is a HoH (hashes of hashrefs) produced by reading an INI (IOD)
#configuration file using modules like <pm:Config::IOD::Reader>.
#
#Hashref argument `args` will be set by parameters in `config`, while `plugins`
#will be set by parameters in `[plugin=...]` sections in `config`. For example,
#with this configuration:
#
script/gen-generic-ind-company-names view on Meta::CPAN
#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'};
# }
#
# # reorder each row according to requested column order
# 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/) {
script/gen-generic-ind-company-names view on Meta::CPAN
# 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;
# local $Data::Dumper::Trailingcomma = 1;
# return Data::Dumper::Dumper($res);
# }
# }
#
# unless ($format =~ /\Ajson(-pretty)?\z/) {
# warn "Unknown format '$format', fallback to json-pretty";
# $format = 'json-pretty';
# }
# __cleanse($res) if ($cleanse//1);
# if ($format =~ /json/) {
# if ($tff && _json->can("sort_by") &&
# eval { require Sort::ByExample; 1}) {
# my $cmp = Sort::ByExample->cmp($tff);
# _json->sort_by(sub { $cmp->($JSON::PP::a, $JSON::PP::b) });
# }
#
# if ($format eq 'json') {
# return _json->encode($res) . "\n";
# } else {
# _json->pretty(1);
# return _json->encode($res);
# }
# }
#}
#
#1;
## ABSTRACT: Format enveloped result
#
#__END__
#
#=pod
#
script/gen-generic-ind-company-names view on Meta::CPAN
#
# my $style = $param{style};
# croak "unknown style '$style'" if not exists($charsets{ $style });
# my $char = $charsets{$style};
#
# if ($style eq 'classic') {
# $char->{TLC} = $char->{TRC} = $char->{TT} = $char->{LT} = $char->{RT} = $char->{HC} = $char->{BLC} = $char->{BT} = $char->{BRC} = $CORNER_MARKER;
# $char->{HR} = $ROW_SEPARATOR;
# $char->{VR} = $COLUMN_SEPARATOR;
# $char->{FLT} = $char->{FRT} = $char->{FHC} = $HEADER_CORNER_MARKER;
# $char->{FHR} = $HEADER_ROW_SEPARATOR;
# }
#
# my $header;
# my @align;
# if (defined $param{align}) {
# @align = is_arrayref($param{align})
# ? @{ $param{align} }
# : ($param{align}) x int(@widths)
# ;
# }
# else {
# @align = ('l') x int(@widths);
# }
#
# $header = shift @rows if $param{header_row};
#
# my $table = _top_border(\%param, \@widths, $char)
# ._header_row(\%param, $header, \@widths, \@align, $char)
# ._header_rule(\%param, \@widths, $char)
# ._body(\%param, \@rows, \@widths, \@align, $char)
# ._bottom_border(\%param, \@widths, $char);
# chop($table);
#
# return $table;
#}
#
#sub _top_border
#{
# my ($param, $widths, $char) = @_;
#
# return '' if $param->{top_and_tail};
# return _rule_row($param, $widths, $char->{TLC}, $char->{HR}, $char->{TT}, $char->{TRC});
#}
#
#sub _bottom_border
#{
# my ($param, $widths, $char) = @_;
#
# return '' if $param->{top_and_tail};
# return _rule_row($param, $widths, $char->{BLC}, $char->{HR}, $char->{BT}, $char->{BRC});
#}
#
#sub _rule_row
#{
# my ($param, $widths, $le, $hr, $cross, $re) = @_;
# my $pad = $param->{compact} ? '' : $hr;
#
# return $param->{indent}
# .$le
# .join($cross, map { $pad.($hr x $_).$pad } @$widths)
# .$re
# ."\n"
# ;
#}
#
#sub _header_row
#{
# my ($param, $row, $widths, $align, $char) = @_;
# return '' unless $param->{header_row};
#
# return _text_row($param, $row, $widths, $align, $char);
#}
#
#sub _header_rule
#{
# my ($param, $widths, $char) = @_;
# return '' unless $param->{header_row};
# my $fancy = $param->{separate_rows} ? 'F' : '';
#
# return _rule_row($param, $widths, $char->{"${fancy}LT"}, $char->{"${fancy}HR"}, $char->{"${fancy}HC"}, $char->{"${fancy}RT"});
#}
#
#sub _body
#{
# my ($param, $rows, $widths, $align, $char) = @_;
# my $divider = $param->{separate_rows} ? _rule_row($param, $widths, $char->{LT}, $char->{HR}, $char->{HC}, $char->{RT}) : '';
#
# return join($divider, map { _text_row($param, $_, $widths, $align, $char) } @$rows);
#}
#
#sub _text_row
#{
# my ($param, $row, $widths, $align, $char) = @_;
# my @columns = @$row;
# my $text = $param->{indent}.$char->{VR};
#
# for (my $i = 0; $i < @$widths; $i++) {
# $text .= _format_column($columns[$i] // '', $widths->[$i], $align->[$i] // 'l', $param, $char);
# $text .= $char->{VR};
# }
# $text .= "\n";
#
# return $text;
#}
#
#sub _format_column
#{
# my ($text, $width, $align, $param, $char) = @_;
# my $pad = $param->{compact} ? '' : ' ';
#
# if ($align eq 'r' || $align eq 'right') {
# return $pad.' ' x ($width - tty_width($text)).$text.$pad;
# }
# elsif ($align eq 'c' || $align eq 'center' || $align eq 'centre') {
# my $total_spaces = $width - tty_width($text);
# my $left_spaces = int($total_spaces / 2);
# my $right_spaces = $left_spaces;
# $right_spaces++ if $total_spaces % 2 == 1;
# return $pad.(' ' x $left_spaces).$text.(' ' x $right_spaces).$pad;
# }
# else {
# return $pad.$text.' ' x ($width - tty_width($text)).$pad;
# }
#}
#
#sub _calculate_widths
#{
# my $rows = shift;
# my @widths;
# foreach my $row (@$rows) {
# my @columns = @$row;
# for (my $i = 0; $i < @columns; $i++) {
# next unless defined($columns[$i]);
#
# my $width = tty_width($columns[$i]);
#
# $widths[$i] = $width if !defined($widths[$i])
# || $width > $widths[$i];
# }
# }
# return @widths;
#}
#
## Back-compat: 'table' is an alias for 'generate_table', but isn't exported
#*table = \&generate_table;
#
#1;
#
( run in 0.536 second using v1.01-cache-2.11-cpan-97f6503c9c8 )