#!perl ### code_after_shebang # Note: This script is a CLI for Riap function /App/genpw/base64/genpw # and generated automatically using Perinci::CmdLine::Gen version 0.484 # PERICMD_INLINE_SCRIPT: {"code_after_shebang":"...","config_dirs":null,"config_filename":"genpw-base64.conf","env_name":"GENPW_BASE64_OPT","include":null,"log":null,"pack_deps":1,"pod":0,"read_config":"0","read_env":"0","script_name":"genpw-base64","script_summary":null,"script_version":"0.001","shebang":"perl","skip_format":0,"subcommands":null,"url":"/App/genpw/base64/genpw","use_cleanser":1,"validate_args":1} my $_pci_metas = {""=>{args=>{len=>{cmdline_aliases=>{l=>{}},schema=>["posint",{req=>1},{}],summary=>"If no pattern is supplied, will generate random alphanum characters with this exact length"},max_len=>{schema=>["posint",{req=>1},{}],summary=>"If no pattern is supplied, will generate random alphanum characters with this maximum length"},min_len=>{schema=>["posint",{req=>1},{}],summary=>"If no pattern is supplied, will generate random alphanum characters with this minimum length"},num=>{cmdline_aliases=>{n=>{}},default=>1,pos=>0,schema=>["int",{min=>1,req=>1},{}]}},description=>"\n",examples=>[],result=>{},summary=>"Generate random password using base64 characters",v=>1.1}}; # This script is generated by Perinci::CmdLine::Inline version 0.541 on Tue Feb 20 21:29:36 2018. # Rinci metadata taken from these modules: App::genpw::base64 (no version) # You probably should not manually edit this file. our $DATE = '2018-02-20'; # DATE our $VERSION = '0.001'; # VERSION # PODNAME: genpw-base64 # ABSTRACT: Generate random password using base64 characters # 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 = ; $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; # 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=>0,read_env=>0,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; } ### get arguments (from config file, env, command-line args { my %mentioned_args; require Getopt::Long::EvenLess; my $go_spec1 = { 'format=s' => sub { $_pci_r->{format} = $_[1]; }, 'help|h|?' => sub { print "genpw-base64 - Generate random password using base64 characters\n\nUsage:\n genpw-base64 --help (or -h, -?)\n genpw-base64 --version (or -v)\n genpw-base64 [options] [num]\n\nMain options:\n --len=s, -l If no pattern is supplied, will generate random alphanum characters with this\n\t\t exact length\n --max-len=s If no pattern is supplied, will generate random alphanum characters with this\n\t\t maximum length\n --min-len=s If no pattern is supplied, will generate random alphanum characters with this\n\t\t minimum length\n --num=s, -n (=arg[0]) [1]\n\nOutput options:\n --format=s Choose output format, e.g. json, text\n --json Set output format to json\n\nOther options:\n --help, -h, -? Display help message and exit\n --naked-res When outputing as JSON, strip result envelope\n --no-naked-res, --nonaked-res When outputing as JSON, don't strip result envelope\n --version, -v Display program's version and exit\n"; exit 0; }, 'json' => sub { $_pci_r->{format} = (-t STDOUT) ? "json-pretty" : "json"; }, 'naked-res' => sub { $_pci_r->{naked_res} = 1; }, 'no-naked-res|nonaked-res' => sub { $_pci_r->{naked_res} = 0; }, 'version|v' => sub { no warnings 'once'; require App::genpw::base64; print "genpw-base64 version ", "0.001", ($App::genpw::base64::DATE ? " ($App::genpw::base64::DATE)" : ''), "\n"; print " Generated by Perinci::CmdLine::Inline version 0.541 (2017-08-16)\n"; exit 0 }, }; my $go_spec2 = { 'format=s' => sub { }, 'help|h|?' => sub { }, 'json' => sub { }, 'l=s' => sub { $_pci_args{'len'} = $_[1]; }, 'len=s' => sub { $_pci_args{'len'} = $_[1]; }, 'max-len=s' => sub { $_pci_args{'max_len'} = $_[1]; }, 'min-len=s' => sub { $_pci_args{'min_len'} = $_[1]; }, 'n=s' => sub { $_pci_args{'num'} = $_[1]; }, 'naked-res' => sub { }, 'no-naked-res|nonaked-res' => sub { }, 'num=s' => sub { $_pci_args{'num'} = $_[1]; }, 'version|v' => sub { }, }; my $old_conf = Getopt::Long::EvenLess::Configure("pass_through"); Getopt::Long::EvenLess::GetOptions(%$go_spec1); Getopt::Long::EvenLess::Configure($old_conf); 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 App::genpw::base64; eval { $_pci_r->{res} = App::genpw::base64::genpw(%_pci_args) }; if ($@) { $_pci_r->{res} = [500, "Function died: $@"] } } } ### format & display result { my $fres; my $save_res; if (exists $_pci_r->{res}[3]{"cmdline.result"}) { $save_res = $_pci_r->{res}[2]; $_pci_r->{res}[2] = $_pci_r->{res}[3]{"cmdline.result"} } my $is_success = $_pci_r->{res}[0] =~ /\A2/ || $_pci_r->{res}[0] == 304; my $is_stream = $_pci_r->{res}[3]{stream} // $_pci_meta_result_stream // 0; if ($is_success && (0 || $_pci_meta_skip_format || $_pci_r->{res}[3]{"cmdline.skip_format"})) { $fres = $_pci_r->{res}[2] } elsif ($is_success && $is_stream) {} else { require Local::_pci_clean_json; require Perinci::Result::Format::Lite; $is_stream=0; _pci_clean_json($_pci_r->{res}); $fres = Perinci::Result::Format::Lite::format($_pci_r->{res}, ($_pci_r->{format} // $_pci_r->{res}[3]{"cmdline.default_format"} // "text"), $_pci_r->{naked_res}, 0) } my $use_utf8 = $_pci_r->{res}[3]{"x.hint.result_binary"} ? 0 : 0; if ($use_utf8) { binmode STDOUT, ":encoding(utf8)" } if ($is_stream) { my $code = $_pci_r->{res}[2]; if (ref($code) ne "CODE") { die "Result is a stream but no coderef provided" } if ($_pci_meta_result_type_is_simple) { while(defined(my $l=$code->())) { print $l; print "\n" unless $_pci_meta_result_type eq "buf"; } } else { while (defined(my $rec=$code->())) { print _pci_json()->encode($rec),"\n" } } } else { print $fres; } if (defined $save_res) { $_pci_r->{res}[2] = $save_res } } ### exit { my $status = $_pci_r->{res}[0]; my $exit_code = $_pci_r->{res}[3]{"cmdline.exit_code"} // ($status =~ /200|304/ ? 0 : ($status-300)); exit($exit_code); } =pod =encoding UTF-8 =head1 NAME genpw-base64 - Generate random password using base64 characters =head1 VERSION This document describes version 0.001 of main (from Perl distribution App-genpw-base64), released on 2018-02-20. =head1 SYNOPSIS Usage: % genpw-base64 [options] [num] =head1 DESCRIPTION =head1 OPTIONS C<*> marks required options. =head2 Main options =over =item B<--len>=I, B<-l> If no pattern is supplied, will generate random alphanum characters with this exact length. =item B<--max-len>=I If no pattern is supplied, will generate random alphanum characters with this maximum length. =item B<--min-len>=I If no pattern is supplied, will generate random alphanum characters with this minimum length. =item B<--num>=I, B<-n> Default value: 1 =back =head2 Output options =over =item B<--format>=I Choose output format, e.g. json, text. Default value: undef =item B<--json> Set output format to json. =item B<--naked-res> When outputing as JSON, strip result envelope. Default value: 0 By default, when outputing as JSON, the full enveloped result is returned, e.g.: [200,"OK",[1,2,3],{"func.extra"=>4}] The reason is so you can get the status (1st element), status message (2nd element) as well as result metadata/extra result (4th element) instead of just the result (3rd element). However, sometimes you want just the result, e.g. when you want to pipe the result for more post-processing. In this case you can use `--naked-res` so you just get: [1,2,3] =back =head2 Other options =over =item B<--help>, B<-h>, B<-?> Display help message and exit. =item B<--version>, B<-v> Display program's version and exit. =back =head1 COMPLETION The script comes with a companion shell completer script (L<_genpw-base64>) for this script. =head2 bash To activate bash completion for this script, put: complete -C _genpw-base64 genpw-base64 in your bash startup (e.g. F<~/.bashrc>). Your next shell session will then recognize tab completion for the command. Or, you can also directly execute the line above in your shell to activate immediately. It is recommended, however, that you install modules using L which can activate shell completion for scripts immediately. =head2 tcsh To activate tcsh completion for this script, put: complete genpw-base64 'p/*/`genpw-base64`/' in your tcsh startup (e.g. F<~/.tcshrc>). Your next shell session will then recognize tab completion for the command. Or, you can also directly execute the line above in your shell to activate immediately. It is also recommended to install L (see above). =head2 other shells For fish and zsh, install L as described above. =head1 HOMEPAGE Please visit the project's homepage at L. =head1 SOURCE Source repository is at L. =head1 BUGS Please report any bugs or feature requests on the bugtracker website L 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 =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2018 by perlancar@cpan.org. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __DATA__ Data::Section::Seekable v1 Clone/PP.pm,20,1884,0;0 Data/Check/Structure.pm,1936,3504,1;71 Getopt/Long/EvenLess.pm,5472,6010,2;233 Local/_pci_check_args.pm,11515,1106,3;441 Local/_pci_clean_json.pm,12654,3724,4;462 Perinci/Result/Format/Lite.pm,16416,18347,5;515 Text/Table/Tiny.pm,34790,2733,6;996 ### 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 } # #use vars qw( $CloneSelfMethod $CloneInitMethod ); #$CloneSelfMethod ||= 'clone_self'; #$CloneInitMethod ||= 'clone_init'; # #use vars qw( %CloneCache ); # #sub clone { # my $source = shift; # # return undef if not defined($source); # # my $depth = shift; # return $source if ( defined $depth and $depth -- < 1 ); # # local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} ); # # return $CloneCache{ $source } if ( defined $CloneCache{ $source } ); # # my $ref_type = ref $source or return $source; # # my $class_name; # if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { # $class_name = $ref_type; # $ref_type = $1; # return $CloneCache{ $source } = $source->$CloneSelfMethod() # if $source->can($CloneSelfMethod); # } # # # my $copy; # if ($ref_type eq 'HASH') { # $CloneCache{ $source } = $copy = {}; # if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied } # %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source; # } elsif ($ref_type eq 'ARRAY') { # $CloneCache{ $source } = $copy = []; # if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied } # @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source; # } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { # $CloneCache{ $source } = $copy = \( my $var = "" ); # if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied } # $$copy = clone($$source, $depth); # } else { # $CloneCache{ $source } = $copy = $source; # } # # if ( $class_name ) { # bless $copy, $class_name; # $copy->$CloneInitMethod() if $copy->can($CloneInitMethod); # } # # return $copy; #} # #1; # #__END__ # ### Data/Check/Structure.pm ### #package Data::Check::Structure; # #our $DATE = '2017-07-18'; #our $VERSION = '0.04'; # #use strict; # #use Exporter 'import'; #our @EXPORT_OK = qw( # is_aoa # is_aoaos # is_aoh # is_aohos # is_aos # is_hoa # is_hoaos # is_hoh # is_hohos # is_hos # ); # #sub is_aos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'ARRAY'; # for my $i (0..@$data-1) { # last if defined($max) && $i >= $max; # return 0 if ref($data->[$i]); # } # 1; #} # #sub is_aoa { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'ARRAY'; # for my $i (0..@$data-1) { # last if defined($max) && $i >= $max; # return 0 unless ref($data->[$i]) eq 'ARRAY'; # } # 1; #} # #sub is_aoaos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'ARRAY'; # my $aos_opts = {max=>$max}; # for my $i (0..@$data-1) { # last if defined($max) && $i >= $max; # return 0 unless is_aos($data->[$i], $aos_opts); # } # 1; #} # #sub is_aoh { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'ARRAY'; # for my $i (0..@$data-1) { # last if defined($max) && $i >= $max; # return 0 unless ref($data->[$i]) eq 'HASH'; # } # 1; #} # #sub is_aohos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'ARRAY'; # my $hos_opts = {max=>$max}; # for my $i (0..@$data-1) { # last if defined($max) && $i >= $max; # return 0 unless is_hos($data->[$i], $hos_opts); # } # 1; #} # #sub is_hos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'HASH'; # my $i = 0; # for my $k (keys %$data) { # last if defined($max) && ++$i >= $max; # return 0 if ref($data->{$k}); # } # 1; #} # #sub is_hoa { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'HASH'; # my $i = 0; # for my $k (keys %$data) { # last if defined($max) && ++$i >= $max; # return 0 unless ref($data->{$k}) eq 'ARRAY'; # } # 1; #} # #sub is_hoaos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'HASH'; # my $i = 0; # for my $k (keys %$data) { # last if defined($max) && ++$i >= $max; # return 0 unless is_aos($data->{$k}); # } # 1; #} # #sub is_hoh { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'HASH'; # my $i = 0; # for my $k (keys %$data) { # last if defined($max) && ++$i >= $max; # return 0 unless ref($data->{$k}) eq 'HASH'; # } # 1; #} # #sub is_hohos { # my ($data, $opts) = @_; # $opts ||= {}; # my $max = $opts->{max}; # # return 0 unless ref($data) eq 'HASH'; # my $i = 0; # for my $k (keys %$data) { # last if defined($max) && ++$i >= $max; # return 0 unless is_hos($data->{$k}); # } # 1; #} # #1; # #__END__ # ### Getopt/Long/EvenLess.pm ### #package Getopt::Long::EvenLess; # #our $DATE = '2017-08-09'; #our $VERSION = '0.111'; # # #our @EXPORT = qw(GetOptions); #our @EXPORT_OK = qw(GetOptionsFromArray); # #my $config = { # pass_through => 0, # auto_abbrev => 1, #}; # #sub Configure { # my $old_config = { %$config }; # # if (ref($_[0]) eq 'HASH') { # for (keys %{$_[0]}) { # $config->{$_} = $_[0]{$_}; # } # } else { # for (@_) { # if ($_ eq 'pass_through') { # $config->{pass_through} = 1; # } elsif ($_ eq 'no_pass_through') { # $config->{pass_through} = 0; # } 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/) { # } else { # die "Unknown configuration '$_'"; # } # } # } # $old_config; #} # #sub import { # my $pkg = shift; # my $caller = caller; # my @imp = @_ ? @_ : @EXPORT; # for my $imp (@imp) { # if (grep {$_ eq $imp} (@EXPORT, @EXPORT_OK)) { # *{"$caller\::$imp"} = \&{$imp}; # } else { # die "$imp is not exported by ".__PACKAGE__; # } # } #} # #sub GetOptionsFromArray { # my ($argv, %spec) = @_; # # my $success = 1; # # my %spec_by_opt_name; # for (keys %spec) { # my $orig = $_; # s/=[fios][@%]?\z//; # s/\|.+//; # $spec_by_opt_name{$_} = $orig; # } # # my $code_find_opt = sub { # my ($wanted, $short_mode) = @_; # my @candidates; # OPT_SPEC: # for my $spec (keys %spec) { # $spec =~ s/=[fios][@%]?\z//; # my @opts = split /\|/, $spec; # for my $o (@opts) { # next if $short_mode && length($o) > 1; # if ($o eq $wanted) { # @candidates = ($opts[0]); # last OPT_SPEC; # } elsif ($config->{auto_abbrev} && index($o, $wanted) == 0) { # push @candidates, $opts[0]; # next OPT_SPEC; # } # } # } # if (!@candidates) { # unless ($config->{pass_through}) { # warn "Unknown option: $wanted\n"; # $success = 0; # } # return undef; # } elsif (@candidates > 1) { # unless ($config->{pass_through}) { # warn "Option $wanted is ambiguous (" . # join(", ", @candidates) . ")\n"; # $success = 0; # } # return ''; # } # return $candidates[0]; # }; # # my $code_set_val = sub { # my $name = shift; # # my $spec_key = $spec_by_opt_name{$name}; # my $handler = $spec{$spec_key}; # # $handler->({name=>$name}, @_ ? $_[0] : 1); # }; # # my $i = -1; # my @remaining; # ELEM: # while (++$i < @$argv) { # if ($argv->[$i] eq '--') { # # push @remaining, @{$argv}[$i+1 .. @$argv-1]; # last ELEM; # # } elsif ($argv->[$i] =~ /\A--(.+?)(?:=(.*))?\z/) { # # my ($used_name, $val_in_opt) = ($1, $2); # my $opt = $code_find_opt->($used_name); # if (!defined($opt)) { # push @remaining, $argv->[$i]; # next ELEM; # } elsif (!length($opt)) { # push @remaining, $argv->[$i]; # next ELEM; # } # # my $spec = $spec_by_opt_name{$opt}; # if ($spec =~ /=[fios][@%]?\z/) { # if (defined $val_in_opt) { # $code_set_val->($opt, $val_in_opt); # } else { # if ($i+1 >= @$argv) { # warn "Option $used_name requires an argument\n"; # $success = 0; # last ELEM; # } # $i++; # $code_set_val->($opt, $argv->[$i]); # } # } else { # $code_set_val->($opt); # } # # } elsif ($argv->[$i] =~ /\A-(.*)/) { # # my $str = $1; # my $remaining_pushed; # SHORT_OPT: # while ($str =~ s/(.)//) { # my $used_name = $1; # my $short_opt = $1; # my $opt = $code_find_opt->($short_opt, 'short'); # if (!defined $opt) { # push @remaining, "-" unless $remaining_pushed++; # $remaining[-1] .= $short_opt; # next SHORT_OPT; # } elsif (!length $opt) { # push @remaining, "-" unless $remaining_pushed++; # $remaining[-1] .= $short_opt; # } # # my $spec = $spec_by_opt_name{$opt}; # if ($spec =~ /=[fios][@%]?\z/) { # if (length $str) { # $code_set_val->($opt, $str); # next ELEM; # } else { # if ($i+1 >= @$argv) { # unless ($config->{pass_through}) { # warn "Option $used_name requires an argument\n"; # $success = 0; # } # last ELEM; # } # $i++; # $code_set_val->($opt, $argv->[$i]); # } # } else { # $code_set_val->($opt); # } # } # # } else { # # push @remaining, $argv->[$i]; # next; # # } # } # # RETURN: # splice @$argv, 0, ~~@$argv, @remaining; # return $success; #} # #sub GetOptions { # GetOptionsFromArray(\@ARGV, @_); #} # #1; # #__END__ # ### Local/_pci_check_args.pm ### #sub _pci_check_args { # my ($args) = @_; # my $sc_name = $_pci_r->{subcommand_name}; # if ($sc_name eq "") { # FILL_FROM_POS: { # 1; # if (@ARGV > 0) { if (exists $args->{"num"}) { return [400, "You specified --num but also argument #0"]; } else { $args->{"num"} = delete($ARGV[0]); } } # } # my @check_argv = @ARGV; # # $args->{"num"} //= 1; # # return [400, "Missing required value for argument: len"] if exists($args->{"len"}) && !defined($args->{"len"}); # return [400, "Missing required value for argument: max_len"] if exists($args->{"max_len"}) && !defined($args->{"max_len"}); # return [400, "Missing required value for argument: min_len"] if exists($args->{"min_len"}) && !defined($args->{"min_len"}); # return [400, "Missing required value for argument: num"] if exists($args->{"num"}) && !defined($args->{"num"}); # _pci_err([500, "Extraneous command-line argument(s): ".join(", ", @check_argv)]) if @check_argv; # [200]; # } else { _pci_err([500, "Unknown subcommand1: $sc_name"]); } #} #1; ### Local/_pci_clean_json.pm ### #sub _pci_clean_json { require Clone::PP; require Scalar::Util; use feature 'state'; state $cleanser = sub { #my $data = shift; #state %refs; #state $ctr_circ; #state $process_array; #state $process_hash; #if (!$process_array) { $process_array = sub { my $a = shift; for my $e (@$a) { my $ref=ref($e); # if ($ref && $refs{ $e }++) { if (++$ctr_circ <= 1) { $e = Clone::PP::clone($e); redo } else { $e = 'CIRCULAR'; $ref = '' } } # elsif ($ref eq 'DateTime') { $e = $e->epoch; $ref = ref($e) } # elsif ($ref eq 'Math::BigInt') { $e = $e->bstr; $ref = ref($e) } # elsif ($ref eq 'Regexp') { $e = "$e"; $ref = "" } # elsif ($ref eq 'SCALAR') { $e = ${ $e }; $ref = ref($e) } # elsif ($ref eq 'Time::Moment') { $e = $e->epoch; $ref = ref($e) } # elsif ($ref eq 'version') { $e = "$e"; $ref = "" } # elsif (Scalar::Util::blessed($e)) { my $reftype = Scalar::Util::reftype($e); $e = $reftype eq "HASH" ? {%{ $e }} : $reftype eq "ARRAY" ? [@{ $e }] : $reftype eq "SCALAR" ? \(my $copy = ${ $e }) : $reftype eq "CODE" ? sub { goto &{ $e } } :(die "Cannot unbless object with type $ref") } # my $reftype=Scalar::Util::reftype($e)//""; # if ($reftype eq "ARRAY") { $process_array->($e) } # elsif ($reftype eq "HASH") { $process_hash->($e) } # elsif ($ref) { $e = $ref; $ref = "" } #} } } #if (!$process_hash) { $process_hash = sub { my $h = shift; for my $k (keys %$h) { my $ref=ref($h->{$k}); # if ($ref && $refs{ $h->{$k} }++) { if (++$ctr_circ <= 1) { $h->{$k} = Clone::PP::clone($h->{$k}); redo } else { $h->{$k} = 'CIRCULAR'; $ref = '' } } # elsif ($ref eq 'DateTime') { $h->{$k} = $h->{$k}->epoch; $ref = ref($h->{$k}) } # elsif ($ref eq 'Math::BigInt') { $h->{$k} = $h->{$k}->bstr; $ref = ref($h->{$k}) } # elsif ($ref eq 'Regexp') { $h->{$k} = "$h->{$k}"; $ref = "" } # elsif ($ref eq 'SCALAR') { $h->{$k} = ${ $h->{$k} }; $ref = ref($h->{$k}) } # elsif ($ref eq 'Time::Moment') { $h->{$k} = $h->{$k}->epoch; $ref = ref($h->{$k}) } # elsif ($ref eq 'version') { $h->{$k} = "$h->{$k}"; $ref = "" } # elsif (Scalar::Util::blessed($h->{$k})) { my $reftype = Scalar::Util::reftype($h->{$k}); $h->{$k} = $reftype eq "HASH" ? {%{ $h->{$k} }} : $reftype eq "ARRAY" ? [@{ $h->{$k} }] : $reftype eq "SCALAR" ? \(my $copy = ${ $h->{$k} }) : $reftype eq "CODE" ? sub { goto &{ $h->{$k} } } :(die "Cannot unbless object with type $ref") } # my $reftype=Scalar::Util::reftype($h->{$k})//""; # if ($reftype eq "ARRAY") { $process_array->($h->{$k}) } # elsif ($reftype eq "HASH") { $process_hash->($h->{$k}) } # elsif ($ref) { $h->{$k} = $ref; $ref = "" } #} } } #%refs = (); $ctr_circ=0; #for ($data) { my $ref=ref($_); # if ($ref && $refs{ $_ }++) { if (++$ctr_circ <= 1) { $_ = Clone::PP::clone($_); redo } else { $_ = 'CIRCULAR'; $ref = '' } } # elsif ($ref eq 'DateTime') { $_ = $_->epoch; $ref = ref($_) } # elsif ($ref eq 'Math::BigInt') { $_ = $_->bstr; $ref = ref($_) } # elsif ($ref eq 'Regexp') { $_ = "$_"; $ref = "" } # elsif ($ref eq 'SCALAR') { $_ = ${ $_ }; $ref = ref($_) } # elsif ($ref eq 'Time::Moment') { $_ = $_->epoch; $ref = ref($_) } # elsif ($ref eq 'version') { $_ = "$_"; $ref = "" } # elsif (Scalar::Util::blessed($_)) { my $reftype = Scalar::Util::reftype($_); $_ = $reftype eq "HASH" ? {%{ $_ }} : $reftype eq "ARRAY" ? [@{ $_ }] : $reftype eq "SCALAR" ? \(my $copy = ${ $_ }) : $reftype eq "CODE" ? sub { goto &{ $_ } } :(die "Cannot unbless object with type $ref") } # my $reftype=Scalar::Util::reftype($_)//""; # if ($reftype eq "ARRAY") { $process_array->($_) } # elsif ($reftype eq "HASH") { $process_hash->($_) } # elsif ($ref) { $_ = $ref; $ref = "" } #} #$data #} #;; $cleanser->(shift) } #1; ### Perinci/Result/Format/Lite.pm ### #package Perinci::Result::Format::Lite; # #our $DATE = '2018-01-31'; #our $VERSION = '0.271'; # #use 5.010001; # #use List::Util qw(first max); # #use Exporter qw(import); #our @EXPORT_OK = qw(format); # #sub firstidx (&@) { # my $f = shift; # foreach my $i ( 0 .. $#_ ) # { # local *_ = \$_[$i]; # return $i if $f->(); # } # return -1; #} # #sub _json { # state $json = do { # if (eval { require Cpanel::JSON::XS; 1 }) { Cpanel::JSON::XS->new->canonical(1)->convert_blessed->allow_nonref } # elsif (eval { require JSON::Tiny::Subclassable; 1 }) { JSON::Tiny::Subclassable->new } # elsif (eval { require JSON::PP; 1 }) { JSON::PP->new->canonical(1)->convert_blessed->allow_nonref } # else { die "Can't find any JSON module" } # }; # $json; #}; # #sub __cleanse { # state $cleanser = do { # eval { require Data::Clean::JSON; 1 }; # if ($@) { # undef; # } else { # Data::Clean::JSON->get_cleanser; # } # }; # if ($cleanser) { # $cleanser->clean_in_place($_[0]); # } else { # $_[0]; # } #} # #sub __gen_table { # my ($data, $header_row, $resmeta, $format) = @_; # # $resmeta //= {}; # # my @columns; # if ($header_row) { # @columns = @{$data->[0]}; # } else { # @columns = map {"col$_"} 0..@{$data->[0]}-1; # } # # my $column_orders; # SET_COLUMN_ORDERS: { # # my $tcos; # if ($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS}) { # $tcos = _json->encode($ENV{FORMAT_PRETTY_TABLE_COLUMN_ORDERS}); # } elsif (my $rfos = ($resmeta->{'cmdline.format_options'} // # $resmeta->{format_options})) { # my $rfo = $rfos->{'text-pretty'} // $rfos->{text} // $rfos->{any}; # if ($rfo) { # $tcos = $rfo->{table_column_orders}; # } # } # if ($tcos) { # COLS: # for my $cols (@$tcos) { # for my $col (@$cols) { # next COLS unless first {$_ eq $col} @columns; # } # $column_orders = $cols; # last SET_COLUMN_ORDERS; # } # } # # if ($resmeta->{'table.field_orders'}) { # $column_orders = $resmeta->{'table.field_orders'}; # last SET_COLUMN_ORDERS; # } # # $column_orders = $resmeta->{'table.fields'}; # } # # if ($column_orders) { # require Sort::BySpec; # my $cmp = Sort::BySpec::cmp_by_spec(spec => $column_orders); # my @map0 = sort { $cmp->($a->[1], $b->[1]) } # map {[$_, $columns[$_]]} 0..$#columns; # my @map; # for (0..$#map0) { # $map[$_] = $map0[$_][0]; # } # my $newdata = []; # for my $row (@$data) { # my @newrow; # for (0..$#map) { $newrow[$_] = $row->[$map[$_]] } # push @$newdata, \@newrow; # } # $data = $newdata; # my @newcolumns; # for (@map) { push @newcolumns, $columns[$_] } # @columns = @newcolumns; # } # # my @field_idxs; # { # my $tff = $resmeta->{'table.fields'} or last; # for my $i (0..$#columns) { # $field_idxs[$i] = firstidx { $_ eq $columns[$i] } @$tff; # } # } # # { # last unless $header_row && @$data; # my $tff = $resmeta->{'table.fields'} or last; # my $tfu = $resmeta->{'table.field_units'} or last; # for my $i (0..$#columns) { # my $field_idx = $field_idxs[$i]; # next unless $field_idx >= 0; # next unless defined $tfu->[$field_idx]; # $data->[0][$i] .= " ($tfu->[$field_idx])"; # } # } # # { # my $tff = $resmeta->{'table.fields'} or last; # my $tffmt = $resmeta->{'table.field_formats'} or last; # # my (@fmt_names, @fmt_opts); # for my $i (0..$#columns) { # my $field_idx = $field_idxs[$i]; # next unless $field_idx >= 0; # next unless defined $tffmt->[$field_idx]; # if (ref($tffmt->[$field_idx]) eq 'ARRAY') { # $fmt_names[$i] = $tffmt->[$field_idx][0]; # $fmt_opts [$i] = $tffmt->[$field_idx][1] // {}; # } else { # $fmt_names[$i] = $tffmt->[$field_idx]; # $fmt_opts [$i] = {}; # } # } # # my $nf; # # for my $i (0..$#{$data}) { # next if $i==0 && $header_row; # my $row = $data->[$i]; # for my $j (0..$#columns) { # next unless defined $row->[$j]; # my $field_idx = $field_idxs[$j]; # next unless $field_idx >= 0; # my $fmt_name = $fmt_names[$j]; # next unless $fmt_name; # my $fmt_opts = $fmt_opts [$j]; # if ($fmt_name eq 'iso8601_datetime' || $fmt_name eq 'iso8601_date') { # if ($row->[$j] =~ /\A[0-9]+\z/) { # my @t = gmtime($row->[$j]); # if ($fmt_name eq 'iso8601_datetime') { # $row->[$j] = sprintf( # "%04d-%02d-%02dT%02d:%02d:%02dZ", # $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]); # } else { # $row->[$j] = sprintf( # "%04d-%02d-%02d", # $t[5]+1900, $t[4]+1, $t[3]); # } # } # } elsif ($fmt_name eq 'boolstr') { # $row->[$j] = $row->[$j] ? "yes" : "no"; # } elsif ($fmt_name eq 'sci2dec') { # if ($row->[$j] =~ /\A(?:[+-]?)(?:\d+\.|\d*\.(\d+))[eE]([+-]?\d+)\z/) { # my $n = length($1 || "") - $2; $n = 0 if $n < 0; # $row->[$j] = sprintf("%.${n}f", $row->[$j]); # } # } elsif ($fmt_name eq 'percent') { # my $fmt = $fmt_opts->{sprintf} // '%.2f%%'; # $row->[$j] = sprintf($fmt, $row->[$j] * 100); # } elsif ($fmt_name eq 'number') { # 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, # }); # } # } # } # } # # if ($format eq 'text-pretty') { # { # no warnings; # # my $tfa = $resmeta->{'table.field_aligns'} or last; # last unless @$data; # # for my $colidx (0..$#columns) { # my $field_idx = $field_idxs[$colidx]; # next unless $field_idx >= 0; # my $align = $tfa->[$field_idx]; # next unless $align; # # my $maxw; # my ($maxw_bd, $maxw_d, $maxw_ad); # if ($align eq 'number') { # my (@w_bd, @w_d, @w_ad); # for my $i (0..$#{$data}) { # my $row = $data->[$i]; # if (@$row > $colidx) { # my $cell = $row->[$colidx]; # if ($header_row && $i == 0) { # my $w = length($cell); # push @w_bd, 0; # push @w_bd, 0; # push @w_ad, 0; # } elsif ($cell =~ /\A([+-]?\d+)(\.?)(\d*)\z/) { # push @w_bd, length($1); # push @w_d , length($2); # push @w_ad, length($3); # } elsif ($cell =~ /\A([+-]?\d+\.?\d*)([eE])([+-]?\d+)\z/) { # push @w_bd, length($1); # push @w_d , length($2); # push @w_ad, length($3); # } else { # push @w_bd, length($cell); # push @w_bd, 0; # push @w_ad, 0; # } # } else { # push @w_bd, 0; # push @w_d , 0; # push @w_ad, 0; # } # } # $maxw_bd = max(@w_bd); # $maxw_d = max(@w_d); # $maxw_ad = max(@w_ad); # if ($header_row) { # my $w = length($data->[0][$colidx]); # if ($maxw_d == 0 && $maxw_ad == 0) { # $maxw_bd = $w; # } # } # } # # $maxw = max(map { # @$_ > $colidx ? length($_->[$colidx]) : 0 # } @$data); # # for my $i (0..$#{$data}) { # my $row = $data->[$i]; # for my $i (0..$#{$data}) { # my $row = $data->[$i]; # next unless @$row > $colidx; # my $cell = $row->[$colidx]; # next unless defined($cell); # if ($align eq 'number') { # my ($bd, $d, $ad); # if ($header_row && $i == 0) { # } elsif (($bd, $d, $ad) = $cell =~ /\A([+-]?\d+)(\.?)(\d*)\z/) { # $cell = join( # '', # (' ' x ($maxw_bd - length($bd))), $bd, # $d , (' ' x ($maxw_d - length($d ))), # $ad, (' ' x ($maxw_ad - length($ad))), # ); # } elsif (($bd, $d, $ad) = $cell =~ /\A([+-]?\d+\.?\d*)([eE])([+-]?\d+)\z/) { # $cell = join( # '', # (' ' x ($maxw_bd - length($bd))), $bd, # $d , (' ' x ($maxw_d - length($d ))), # $ad, (' ' x ($maxw_ad - length($ad))), # ); # } # my $w = length($cell); # $cell = (' ' x ($maxw - $w)) . $cell # if $maxw > $w; # } elsif ($align eq 'right') { # $cell = (' ' x ($maxw - length($cell))) . $cell; # } elsif ($align eq 'middle' || $align eq 'center') { # my $w = length($cell); # my $n = int(($maxw-$w)/2); # $cell = (' ' x $n) . $cell . (' ' x ($maxw-$w-$n)); # } else { # $cell .= (' ' x ($maxw - length($cell))); # # } # $row->[$colidx] = $cell; # } # } # } # } # # my $fres; # if (my $backend = $ENV{FORMAT_PRETTY_TABLE_BACKEND}) { # require Text::Table::Any; # $fres = Text::Table::Any::table(rows=>$data, header_row=>$header_row, backend=>$backend); # } else { # require Text::Table::Tiny; # $fres = Text::Table::Tiny::table(rows=>$data, header_row=>$header_row); # } # $fres .= "\n" unless $fres =~ /\R\z/ || !length($fres); # $fres; # } elsif ($format eq 'csv') { # no warnings 'uninitialized'; # join( # "", # map { # my $row = $_; # join( # ",", # map { # my $cell = $_; # $cell =~ s/(["\\])/\\$1/g; # qq("$cell"); # } @$row)."\n"; # } @$data # ); # } elsif ($format eq 'html') { # no warnings 'uninitialized'; # require HTML::Entities; # # my $tfa = $resmeta->{'table.field_aligns'}; # # my @res; # push @res, "{'table.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, "\n" if $i == 0; # push @res, "\n" if $i == 1; # push @res, " \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]), # "\n"; # } # push @res, " \n"; # push @res, "\n" if $i == 0; # } # push @res, "\n"; # push @res, "\n"; # join '', @res; # } else { # no warnings 'uninitialized'; # shift @$data if $header_row; # join("", map {join("\t", @$_)."\n"} @$data); # } #} # #sub format { # my ($res, $format, $is_naked, $cleanse) = @_; # # if ($format =~ /\A(text|text-simple|text-pretty|csv|html)\z/) { # $format = $format eq 'text' ? # ((-t STDOUT) ? 'text-pretty' : 'text-simple') : $format; # no warnings 'uninitialized'; # if ($res->[0] !~ /^(2|304)/) { # my $fres = "ERROR $res->[0]: $res->[1]"; # if (my $prev = $res->[3]{prev}) { # $fres .= " ($prev->[0]: $prev->[1])"; # } # return "$fres\n"; # } elsif ($res->[3] && $res->[3]{"x.hint.result_binary"}) { # return $res->[2]; # } else { # require Data::Check::Structure; # my $data = $res->[2]; # my $max = 5; # if (!ref($data)) { # $data //= ""; # $data .= "\n" unless !length($data) || $data =~ /\n\z/; # return $data; # } elsif (ref($data) eq 'ARRAY' && !@$data) { # return ""; # } elsif (Data::Check::Structure::is_aos($data, {max=>$max})) { # return join("", map {"$_\n"} @$data); # } elsif (Data::Check::Structure::is_aoaos($data, {max=>$max})) { # my $header_row = 0; # my $data = $data; # if ($res->[3]{'table.fields'}) { # $data = [$res->[3]{'table.fields'}, @$data]; # $header_row = 1; # } # return __gen_table($data, $header_row, $res->[3], $format); # } elsif (Data::Check::Structure::is_hos($data, {max=>$max})) { # $data = [map {[$_, $data->{$_}]} sort keys %$data]; # unshift @$data, ["key", "value"]; # return __gen_table($data, 1, $res->[3], $format); # } elsif (Data::Check::Structure::is_aohos($data, {max=>$max})) { # my @fieldnames; # if ($res->[3] && $res->[3]{'table.fields'} && # $res->[3]{'table.hide_unknown_fields'}) { # @fieldnames = @{ $res->[3]{'table.fields'} }; # } else { # my %fieldnames; # for my $row (@$data) { # $fieldnames{$_}++ for keys %$row; # } # @fieldnames = sort keys %fieldnames; # } # my $newdata = []; # for my $row (@$data) { # push @$newdata, [map {$row->{$_}} @fieldnames]; # } # unshift @$newdata, \@fieldnames; # return __gen_table($newdata, 1, $res->[3], $format); # } else { # $format = 'json-pretty'; # } # } # } # # my $tff = $res->[3]{'table.fields'}; # $res = $res->[2] if $is_naked; # # 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 { # 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; # #__END__ # ### Text/Table/Tiny.pm ### #use 5.006; #use strict; #use warnings; #package Text::Table::Tiny; #$Text::Table::Tiny::VERSION = '0.04'; #use parent 'Exporter'; #use List::Util qw(); # #our @EXPORT_OK = qw/ generate_table /; # # # #our $COLUMN_SEPARATOR = '|'; #our $ROW_SEPARATOR = '-'; #our $CORNER_MARKER = '+'; #our $HEADER_ROW_SEPARATOR = '='; #our $HEADER_CORNER_MARKER = 'O'; # #sub generate_table { # # my %params = @_; # my $rows = $params{rows} or die "Must provide rows!"; # # my $widths = _maxwidths($rows); # my $max_index = _max_array_index($rows); # # my $format = _get_format($widths); # my $row_sep = _get_row_separator($widths); # my $head_row_sep = _get_header_row_separator($widths); # # my @table; # push @table, $row_sep; # # my $data_begins = 0; # if ( $params{header_row} ) { # my $header_row = $rows->[0]; # $data_begins++; # push @table, sprintf( # $format, # map { defined($header_row->[$_]) ? $header_row->[$_] : '' } (0..$max_index) # ); # push @table, $params{separate_rows} ? $head_row_sep : $row_sep; # } # # foreach my $row ( @{ $rows }[$data_begins..$#$rows] ) { # push @table, sprintf( # $format, # map { defined($row->[$_]) ? $row->[$_] : '' } (0..$max_index) # ); # push @table, $row_sep if $params{separate_rows}; # } # # push @table, $row_sep unless $params{separate_rows}; # return join("\n",grep {$_} @table); #} # #sub _get_cols_and_rows ($) { # my $rows = shift; # return ( List::Util::max( map { scalar @$_ } @$rows), scalar @$rows); #} # #sub _maxwidths { # my $rows = shift; # my $max_index = _max_array_index($rows); # my $widths = []; # for my $i (0..$max_index) { # my $max = List::Util::max(map {defined $$_[$i] ? length($$_[$i]) : 0} @$rows); # push @$widths, $max; # } # return $widths; #} # #sub _max_array_index { # my $rows = shift; # return List::Util::max( map { $#$_ } @$rows ); #} # #sub _get_format { # my $widths = shift; # return "$COLUMN_SEPARATOR ".join(" $COLUMN_SEPARATOR ",map { "%-${_}s" } @$widths)." $COLUMN_SEPARATOR"; #} # #sub _get_row_separator { # my $widths = shift; # return "$CORNER_MARKER$ROW_SEPARATOR".join("$ROW_SEPARATOR$CORNER_MARKER$ROW_SEPARATOR",map { $ROW_SEPARATOR x $_ } @$widths)."$ROW_SEPARATOR$CORNER_MARKER"; #} # #sub _get_header_row_separator { # my $widths = shift; # return "$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR".join("$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR",map { $HEADER_ROW_SEPARATOR x $_ } @$widths)."$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER"; #} # #*table = \&generate_table; # #1; # #__END__ # #