]> Dogcows Code - chaz/graphql-client/blob - graphql
Release 0.604
[chaz/graphql-client] / graphql
1 #!/usr/bin/env perl
2 # ABSTRACT: Command-line GraphQL client
3 # PODNAME: graphql
4
5
6
7 # This chunk of stuff was generated by App::FatPacker. To find the original
8 # file's code, look for the end of this BEGIN block or the string 'FATPACK'
9 BEGIN {
10 my %fatpacked;
11
12 $fatpacked{"Carp/Assert.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARP_ASSERT';
13 package Carp::Assert;require 5.006;use strict qw(subs vars);use warnings;use Exporter;use vars qw(@ISA $VERSION %EXPORT_TAGS);BEGIN {$VERSION='0.21';@ISA=qw(Exporter);%EXPORT_TAGS=(NDEBUG=>[qw(assert affirm should shouldnt DEBUG)],);$EXPORT_TAGS{DEBUG}=$EXPORT_TAGS{NDEBUG};Exporter::export_tags(qw(NDEBUG DEBUG))}sub REAL_DEBUG () {1}sub NDEBUG () {0}sub noop {undef}sub noop_affirm (&;$) {undef};sub import {my$env_ndebug=exists$ENV{PERL_NDEBUG}? $ENV{PERL_NDEBUG}: $ENV{'NDEBUG'};if(grep(/^:NDEBUG$/,@_)or $env_ndebug){my$caller=caller;for my$func (grep!/^DEBUG$/,@{$EXPORT_TAGS{'NDEBUG'}}){if($func eq 'affirm'){*{$caller.'::'.$func}=\&noop_affirm}else {*{$caller.'::'.$func}=\&noop}}*{$caller.'::DEBUG'}=\&NDEBUG}else {*DEBUG=*REAL_DEBUG;Carp::Assert->_export_to_level(1,@_)}}sub _export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub unimport {*DEBUG=*NDEBUG;push @_,':NDEBUG';goto&import}sub _fail_msg {my($name)=shift;my$msg='Assertion';$msg .= " ($name)" if defined$name;$msg .= " failed!\n";return$msg}sub assert ($;$) {unless($_[0]){require Carp;Carp::confess(_fail_msg($_[1]))}return undef}sub affirm (&;$) {unless(eval {&{$_[0]}}){my$name=$_[1];if(!defined$name){eval {require B::Deparse;$name=B::Deparse->new->coderef2text($_[0])};$name='code display non-functional on this version of Perl, sorry' if $@}require Carp;Carp::confess(_fail_msg($name))}return undef}sub should ($$) {unless($_[0]eq $_[1]){require Carp;&Carp::confess(_fail_msg("'$_[0]' should be '$_[1]'!"))}return undef}sub shouldnt ($$) {unless($_[0]ne $_[1]){require Carp;&Carp::confess(_fail_msg("'$_[0]' shouldn't be that!"))}return undef}sub shouldn't ($$) {my$env_ndebug=exists$ENV{PERL_NDEBUG}? $ENV{PERL_NDEBUG}: $ENV{'NDEBUG'};if($env_ndebug){return undef}else {shouldnt($_[0],$_[1])}}return q|You don't just EAT the largest turnip in the world!|;
14 CARP_ASSERT
15
16 $fatpacked{"Dist/CheckConflicts.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIST_CHECKCONFLICTS';
17 package Dist::CheckConflicts;BEGIN {$Dist::CheckConflicts::AUTHORITY='cpan:DOY'}$Dist::CheckConflicts::VERSION='0.11';use strict;use warnings;use 5.006;use base 'Exporter';our@EXPORT=our@EXPORT_OK=(qw(conflicts check_conflicts calculate_conflicts dist));use Carp;use Module::Runtime 0.009 'module_notional_filename','require_module';my%CONFLICTS;my%HAS_CONFLICTS;my%DISTS;sub import {my$pkg=shift;my$for=caller;my ($conflicts,$alsos,$dist);($conflicts,@_)=_strip_opt('-conflicts'=>@_);($alsos,@_)=_strip_opt('-also'=>@_);($dist,@_)=_strip_opt('-dist'=>@_);my%conflicts=%{$conflicts || {}};for my$also (@{$alsos || []}){eval {require_module($also)}or next;if (!exists$CONFLICTS{$also}){$also .= '::Conflicts';eval {require_module($also)}or next}if (!exists$CONFLICTS{$also}){next}my%also_confs=$also->conflicts;for my$also_conf (keys%also_confs){$conflicts{$also_conf}=$also_confs{$also_conf}if!exists$conflicts{$also_conf}|| $conflicts{$also_conf}lt $also_confs{$also_conf}}}$CONFLICTS{$for}=\%conflicts;$DISTS{$for}=$dist || $for;if (grep {$_ eq ':runtime'}@_){for my$conflict (keys%conflicts){$HAS_CONFLICTS{$conflict}||= [];push @{$HAS_CONFLICTS{$conflict}},$for}for my$conflict (keys%conflicts){if (exists$INC{module_notional_filename($conflict)}){_check_version([$for],$conflict)}}@INC=grep {!(ref($_)eq 'ARRAY' && @$_ > 1 && $_->[1]==\%CONFLICTS)}@INC;unshift@INC,[sub {my ($sub,$file)=@_;(my$mod=$file)=~ s{\.pm$}{};$mod =~ s{/}{::}g;return unless$mod =~ /[\w:]+/;return unless defined$HAS_CONFLICTS{$mod};{local$HAS_CONFLICTS{$mod};require$file}_check_version($HAS_CONFLICTS{$mod},$mod);my$called;return sub {return 0 if$called;$_="1;";$called=1;return 1}},\%CONFLICTS,]}$pkg->export_to_level(1,@_)}sub _strip_opt {my ($opt,@args)=@_;my$val;for my$idx (0 .. $#args - 1){if (defined$args[$idx]&& $args[$idx]eq $opt){$val=(splice@args,$idx,2)[1];last}}return ($val,@args)}sub _check_version {my ($fors,$mod)=@_;for my$for (@$fors){my$conflict_ver=$CONFLICTS{$for}{$mod};my$version=do {no strict 'refs';${${$mod .'::'}{VERSION}}};if ($version le $conflict_ver){warn <<EOF;return}}}sub conflicts {my$package=shift;return %{$CONFLICTS{$package }}}sub dist {my$package=shift;return$DISTS{$package }}sub check_conflicts {my$package=shift;my$dist=$package->dist;my@conflicts=$package->calculate_conflicts;return unless@conflicts;my$err="Conflicts detected for $dist:\n";for my$conflict (@conflicts){$err .= " $conflict->{package} is version " ."$conflict->{installed}, but must be greater than version " ."$conflict->{required}\n"}die$err}sub calculate_conflicts {my$package=shift;my%conflicts=$package->conflicts;my@ret;CONFLICT: for my$conflict (keys%conflicts){my$success=do {local$SIG{__WARN__}=sub {};eval {require_module($conflict)}};my$error=$@;my$file=module_notional_filename($conflict);next if not $success and $error =~ /Can't locate \Q$file\E in \@INC/;warn "Warning: $conflict did not compile" if not $success;my$installed=$success ? $conflict->VERSION : 'unknown';push@ret,{package=>$conflict,installed=>$installed,required=>$conflicts{$conflict},}if not $success or $installed le $conflicts{$conflict}}return sort {$a->{package}cmp $b->{package}}@ret}1;
18 Conflict detected for $DISTS{$for}:
19 $mod is version $version, but must be greater than version $conflict_ver
20 EOF
21 DIST_CHECKCONFLICTS
22
23 $fatpacked{"Exporter/Easiest.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_EASIEST';
24 package Exporter::Easiest;$Exporter::Easiest::VERSION='0.18';use 5.006;use strict;use warnings;no strict 'refs';require Exporter::Easy;sub import {my$pkg=shift;my$callpkg=caller(0);@_=($callpkg,parse_spec(@_));goto&Exporter::Easy::set_export_vars}sub parse_spec {my@spec=grep {/\S/}map {split(/\s+/)}@_;my%spec;my$key="";while (@spec){my$new_key=shift@spec;my$arrow=shift@spec;$arrow="" unless defined($arrow);die "Expected '=>' not '$arrow' after $new_key" unless ($arrow eq '=>');if ($new_key =~ s/^://){push(@{$spec{TAGS}},$new_key,suck_list(\@spec))}else {$key=$new_key;if(($key =~ /^(VARS|ISA)$/ and $spec[0]=~ /^\d+$/)or ($key eq 'ALL')){$spec{$key}=shift@spec}else {$spec{$key}=suck_list(\@spec)}}}return%spec}sub suck_list {my$list=shift;my@sucked;while (@$list){if ($#$list and ($list->[1]eq '=>')){last}else {push(@sucked,shift(@$list))}}return \@sucked}
25 EXPORTER_EASIEST
26
27 $fatpacked{"Exporter/Easy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_EASY';
28 package Exporter::Easy;$Exporter::Easy::VERSION='0.18';use 5.006;use strict;use warnings;require Exporter;use vars;sub import {my$pkg=shift;unshift(@_,scalar caller);goto&set_export_vars}sub set_export_vars {my ($callpkg,%args)=@_;my%could_export;my@will_export;my@fail;my@ok_only;my%tags;@_=();if ($args{OK_ONLY}and $args{OK}){nice_die("Can't use OK_ONLY and OK together")}my$isa=exists$args{ISA}? delete$args{ISA}: 1;my$vars=exists$args{VARS}? delete$args{VARS}: 1;if (my$tag_data=delete$args{'TAGS'}){nice_die("TAGS must be a reference to an array")unless ref($tag_data)eq 'ARRAY';add_tags($tag_data,\%tags);@could_export{map {@$_}values%tags}=()}if (my$export=delete$args{'EXPORT'}){nice_die("EXPORT must be a reference to an array")unless ref($export)eq 'ARRAY';@will_export=eval {expand_tags($export,\%tags)};nice_die("$@while building the EXPORT list in $callpkg")if $@}if (my$ok=delete$args{'OK'}){nice_die("OK must be a reference to a array")unless ref($ok)eq 'ARRAY';my@ok=eval {expand_tags($ok,\%tags)};nice_die("$@while building the \@EXPORT_OK")if $@;@could_export{@ok}=()}my$ok_only=delete$args{'OK_ONLY'};if ($ok_only){die("OK_ONLY must be a reference to a array")unless ref($ok_only)eq 'ARRAY';@ok_only=eval {expand_tags($ok_only,\%tags)};nice_die("$@while building the OK_ONLY list")if $@;@could_export{@ok_only}=()}if (my$fail=delete$args{'FAIL'}){die "FAIL must be a reference to an array" unless ref($fail)eq 'ARRAY';@fail=eval {expand_tags($fail,\%tags)};nice_die("$@while building \@EXPORT_FAIL")if $@;@could_export{@fail}=()}my@could_export=keys%could_export;if (defined(my$all=delete$args{'ALL'})){nice_die("No name supplied for ALL")unless length($all);nice_die("Cannot use '$all' for ALL, already exists")if exists$tags{$all};my%all;@all{@could_export,@will_export}=();$tags{$all}=[keys%all]}if ($vars){if (my$ref=ref($vars)){nice_die("VARS was a reference to a ".$ref." instead of an array")unless$ref eq 'ARRAY';@_=('vars',grep /^(?:\$|\@|\%)/,eval {expand_tags($vars,\%tags)});nice_die("$@while building the \@EXPORT")if $@}else {@_=('vars',grep /^(?:\$|\@|\%)/,@will_export,@could_export)}}if (%args){nice_die("Attempt to use unknown keys: ",join(", ",keys%args))}no strict 'refs';if ($isa){push(@{"$callpkg\::ISA"},"Exporter")}@{"$callpkg\::EXPORT"}=@will_export if@will_export;%{"$callpkg\::EXPORT_TAGS"}=%tags if%tags;@{"$callpkg\::EXPORT_OK"}=$ok_only ? @ok_only : @could_export;@{"$callpkg\::EXPORT_FAIL"}=@fail if@fail;if (@_ > 1){goto&vars::import}}sub nice_die {my$msg=shift;my$level=shift || 1;my ($pkg,$file,$line)=caller(1);die "$msg at $file line $line\n"}sub add_tags($;$) {my$tag_data=shift;my$tags=shift || {};my@tag_data=@$tag_data;while (@tag_data){my$tag_name=shift@tag_data || die "No name for tag";die "Tag name cannot be a reference, maybe you left out a comma" if (ref$tag_name);die "Tried to redefine tag '$tag_name'" if (exists$tags->{$tag_name});my$tag_list=shift@tag_data || die "No values for tag '$tag_name'";die "Tag values for '$tag_name' is not a reference to an array" unless ref($tag_list)eq 'ARRAY';my@symbols=eval {expand_tags($tag_list,$tags)};die "$@while building tag '$tag_name'" if $@;$tags->{$tag_name}=\@symbols}return$tags}sub expand_tags($$) {my ($string_list,$so_far)=@_;my%this_tag;for my$sym (@$string_list){my@symbols;my$remove=0;if ($sym =~ s/^!//){$remove=1}if ($sym =~ s/^://){my$sub_tag=$so_far->{$sym};die "Tried to use an unknown tag '$sym'" unless defined($sub_tag);if ($remove){delete@this_tag{@$sub_tag}}else {@this_tag{@$sub_tag}=()}}else {if ($remove){delete$this_tag{$sym}}else {$this_tag{$sym}=undef}}}return keys%this_tag}1;
29 EXPORTER_EASY
30
31 $fatpacked{"Exporter/Shiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_SHINY';
32 package Exporter::Shiny;use 5.006001;use strict;use warnings;use Exporter::Tiny ();our$AUTHORITY='cpan:TOBYINK';our$VERSION='1.002001';sub import {my$me=shift;my$caller=caller;(my$nominal_file=$caller)=~ s(::)(/)g;$INC{"$nominal_file\.pm"}||= __FILE__;if (@_==2 and $_[0]eq -setup){my (undef,$opts)=@_;@_=@{delete($opts->{exports})|| []};if (%$opts){Exporter::Tiny::_croak('Unsupported Sub::Exporter-style options: %s',join(q[, ],sort keys %$opts),)}}ref($_)&& Exporter::Tiny::_croak('Expected sub name, got ref %s',$_)for @_;no strict qw(refs);push @{"$caller\::ISA"},'Exporter::Tiny';push @{"$caller\::EXPORT_OK"},@_}1;
33 EXPORTER_SHINY
34
35 $fatpacked{"Exporter/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_TINY';
36 package Exporter::Tiny;use 5.006001;use strict;use warnings;no warnings qw(void once uninitialized numeric redefine);our$AUTHORITY='cpan:TOBYINK';our$VERSION='1.002001';our@EXPORT_OK=qw<mkopt mkopt_hash _croak _carp>;sub _croak ($;@) {require Carp;my$fmt=shift;@_=sprintf($fmt,@_);goto \&Carp::croak}sub _carp ($;@) {require Carp;my$fmt=shift;@_=sprintf($fmt,@_);goto \&Carp::carp}my$_process_optlist=sub {my$class=shift;my ($global_opts,$opts,$want,$not_want)=@_;while (@$opts){my$opt=shift @{$opts};my ($name,$value)=@$opt;($name =~ m{\A\!(/.+/[msixpodual]+)\z})? do {my@not=$class->_exporter_expand_regexp($1,$value,$global_opts);++$not_want->{$_->[0]}for@not}: ($name =~ m{\A\!(.+)\z})? (++$not_want->{$1}): ($name =~ m{\A[:-](.+)\z})? push(@$opts,$class->_exporter_expand_tag($1,$value,$global_opts)): ($name =~ m{\A/.+/[msixpodual]+\z})? push(@$opts,$class->_exporter_expand_regexp($name,$value,$global_opts)): push(@$want,$opt)}};sub import {my$class=shift;my$global_opts=+{@_ && ref($_[0])eq q(HASH) ? %{+shift}: ()};$global_opts->{into}=caller unless exists$global_opts->{into};my@want;my%not_want;$global_opts->{not}=\%not_want;my@args=do {no strict qw(refs);@_ ? @_ : @{"$class\::EXPORT"}};my$opts=mkopt(\@args);$class->$_process_optlist($global_opts,$opts,\@want,\%not_want);my$permitted=$class->_exporter_permitted_regexp($global_opts);$class->_exporter_validate_opts($global_opts);for my$wanted (@want){next if$not_want{$wanted->[0]};my%symbols=$class->_exporter_expand_sub(@$wanted,$global_opts,$permitted);$class->_exporter_install_sub($_,$wanted->[1],$global_opts,$symbols{$_})for keys%symbols}}sub unimport {my$class=shift;my$global_opts=+{@_ && ref($_[0])eq q(HASH) ? %{+shift}: ()};$global_opts->{into}=caller unless exists$global_opts->{into};$global_opts->{is_unimport}=1;my@want;my%not_want;$global_opts->{not}=\%not_want;my@args=do {our%TRACKED;@_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}})};my$opts=mkopt(\@args);$class->$_process_optlist($global_opts,$opts,\@want,\%not_want);my$permitted=$class->_exporter_permitted_regexp($global_opts);$class->_exporter_validate_unimport_opts($global_opts);my$expando=$class->can('_exporter_expand_sub');$expando=undef if$expando==\&_exporter_expand_sub;for my$wanted (@want){next if$not_want{$wanted->[0]};if ($wanted->[1]){_carp("Passing options to unimport '%s' makes no sense",$wanted->[0])unless (ref($wanted->[1])eq 'HASH' and not keys %{$wanted->[1]})}my%symbols=defined($expando)? $class->$expando(@$wanted,$global_opts,$permitted): ($wanted->[0]=>sub {"dummy"});$class->_exporter_uninstall_sub($_,$wanted->[1],$global_opts)for keys%symbols}}sub _exporter_validate_opts {1}sub _exporter_validate_unimport_opts {1}sub _exporter_merge_opts {my$class=shift;my ($tag_opts,$global_opts,@stuff)=@_;$tag_opts={}unless ref($tag_opts)eq q(HASH);_croak('Cannot provide an -as option for tags')if exists$tag_opts->{-as}&& ref$tag_opts->{-as}ne 'CODE';my$optlist=mkopt(\@stuff);for my$export (@$optlist){next if defined($export->[1])&& ref($export->[1])ne q(HASH);my%sub_opts=(%{$export->[1]or {}},%$tag_opts);$sub_opts{-prefix}=sprintf('%s%s',$tag_opts->{-prefix},$export->[1]{-prefix})if exists($export->[1]{-prefix})&& exists($tag_opts->{-prefix});$sub_opts{-suffix}=sprintf('%s%s',$export->[1]{-suffix},$tag_opts->{-suffix})if exists($export->[1]{-suffix})&& exists($tag_opts->{-suffix});$export->[1]=\%sub_opts}return @$optlist}sub _exporter_expand_tag {no strict qw(refs);my$class=shift;my ($name,$value,$globals)=@_;my$tags=\%{"$class\::EXPORT_TAGS"};return$class->_exporter_merge_opts($value,$globals,$tags->{$name}->($class,@_))if ref($tags->{$name})eq q(CODE);return$class->_exporter_merge_opts($value,$globals,@{$tags->{$name}})if exists$tags->{$name};return$class->_exporter_merge_opts($value,$globals,@{"$class\::EXPORT"},@{"$class\::EXPORT_OK"})if$name eq 'all';return$class->_exporter_merge_opts($value,$globals,@{"$class\::EXPORT"})if$name eq 'default';$globals->{$name}=$value || 1;return}sub _exporter_expand_regexp {no strict qw(refs);our%TRACKED;my$class=shift;my ($name,$value,$globals)=@_;my$compiled=eval("qr$name");my@possible=$globals->{is_unimport}? keys(%{$TRACKED{$class}{$globals->{into}}}): @{"$class\::EXPORT_OK"};$class->_exporter_merge_opts($value,$globals,grep /$compiled/,@possible)}sub _exporter_permitted_regexp {no strict qw(refs);my$class=shift;my$re=join "|",map quotemeta,sort {length($b)<=> length($a)or $a cmp $b}@{"$class\::EXPORT"},@{"$class\::EXPORT_OK"};qr{^(?:$re)$}ms}sub _exporter_expand_sub {my$class=shift;my ($name,$value,$globals,$permitted)=@_;$permitted ||= $class->_exporter_permitted_regexp($globals);no strict qw(refs);my$sigil="&";if ($name =~ /\A([&\$\%\@\*])(.+)\z/){$sigil=$1;$name=$2;if ($sigil eq '*'){_croak("Cannot export symbols with a * sigil")}}my$sigilname=$sigil eq '&' ? $name : "$sigil$name";if ($sigilname =~ $permitted){my$generatorprefix={'&'=>"_generate_",'$'=>"_generateScalar_",'@'=>"_generateArray_",'%'=>"_generateHash_",}->{$sigil};my$generator=$class->can("$generatorprefix$name");return$sigilname=>$class->$generator($sigilname,$value,$globals)if$generator;my$sub=$class->can($name);return$sigilname=>$sub if$sub;if ($sigil ne '&'){my$evalled=eval "\\${sigil}${class}::${name}";return$sigilname=>$evalled if$evalled}}$class->_exporter_fail(@_)}sub _exporter_fail {my$class=shift;my ($name,$value,$globals)=@_;return if$globals->{is_unimport};_croak("Could not find sub '%s' exported by %s",$name,$class)}sub _exporter_install_sub {my$class=shift;my ($name,$value,$globals,$sym)=@_;my$into=$globals->{into};my$installer=$globals->{installer}|| $globals->{exporter};$name=ref$globals->{as}? $globals->{as}->($name): ref$value->{-as}? $value->{-as}->($name): exists$value->{-as}? $value->{-as}: $name;return unless defined$name;my$sigil="&";unless (ref($name)){if ($name =~ /\A([&\$\%\@\*])(.+)\z/){$sigil=$1;$name=$2;if ($sigil eq '*'){_croak("Cannot export symbols with a * sigil")}}my ($prefix)=grep defined,$value->{-prefix},$globals->{prefix},q();my ($suffix)=grep defined,$value->{-suffix},$globals->{suffix},q();$name="$prefix$name$suffix"}my$sigilname=$sigil eq '&' ? $name : "$sigil$name";return ($$name=$sym)if ref($name)eq q(SCALAR);return ($into->{$sigilname}=$sym)if ref($into)eq q(HASH);no strict qw(refs);our%TRACKED;if (ref($sym)eq 'CODE' and exists &{"$into\::$name"}and \&{"$into\::$name"}!=$sym){my ($level)=grep defined,$value->{-replace},$globals->{replace},q(0);my$action={carp=>\&_carp,0=>\&_carp,''=>\&_carp,warn=>\&_carp,nonfatal=>\&_carp,croak=>\&_croak,fatal=>\&_croak,die=>\&_croak,}->{$level}|| sub {};$action=sub {}if$TRACKED{$class}{$into}{$sigilname};$action->($action==\&_croak ? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s" : "Overwriting existing sub '%s::%s' with sub '%s' exported by %s",$into,$name,$_[0],$class,)}$TRACKED{$class}{$into}{$sigilname}=$sym;no warnings qw(prototype);$installer ? $installer->($globals,[$sigilname,$sym]): (*{"$into\::$name"}=$sym)}sub _exporter_uninstall_sub {our%TRACKED;my$class=shift;my ($name,$value,$globals,$sym)=@_;my$into=$globals->{into};ref$into and return;no strict qw(refs);my$sigil="&";if ($name =~ /\A([&\$\%\@\*])(.+)\z/){$sigil=$1;$name=$2;if ($sigil eq '*'){_croak("Cannot export symbols with a * sigil")}}my$sigilname=$sigil eq '&' ? $name : "$sigil$name";if ($sigil ne '&'){_croak("Unimporting non-code symbols not supported yet")}my$our_coderef=$TRACKED{$class}{$into}{$name};my$cur_coderef=exists(&{"$into\::$name"})? \&{"$into\::$name"}: -1;return unless$our_coderef==$cur_coderef;my$stash=\%{"$into\::"};my$old=delete$stash->{$name};my$full_name=join('::',$into,$name);for my$type (qw(SCALAR HASH ARRAY IO)){next unless defined(*{$old}{$type});*$full_name=*{$old}{$type}}delete$TRACKED{$class}{$into}{$name}}sub mkopt {my$in=shift or return [];my@out;$in=[map(($_=>ref($in->{$_})? $in->{$_}: ()),sort keys %$in)]if ref($in)eq q(HASH);for (my$i=0;$i < @$in;$i++){my$k=$in->[$i];my$v;($i==$#$in)? ($v=undef): !defined($in->[$i+1])? (++$i,($v=undef)): !ref($in->[$i+1])? ($v=undef): ($v=$in->[++$i]);push@out,[$k=>$v ]}\@out}sub mkopt_hash {my$in=shift or return;my%out=map +($_->[0]=>$_->[1]),@{mkopt($in)};\%out}1;
37 EXPORTER_TINY
38
39 $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG';
40 use 5.004;use strict;use warnings;package Getopt::Long;use vars qw($VERSION);$VERSION=2.51;use vars qw($VERSION_STRING);$VERSION_STRING="2.51";use Exporter;use vars qw(@ISA @EXPORT @EXPORT_OK);@ISA=qw(Exporter);sub GetOptions(@);sub GetOptionsFromArray(@);sub GetOptionsFromString(@);sub Configure(@);sub HelpMessage(@);sub VersionMessage(@);BEGIN {@EXPORT=qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);@EXPORT_OK=qw(&HelpMessage &VersionMessage &Configure &GetOptionsFromArray &GetOptionsFromString)}use vars@EXPORT,@EXPORT_OK;use vars qw($error $debug $major_version $minor_version);use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough);use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);my$bundling_values;sub config(@);sub ConfigDefaults();sub ParseOptionSpec($$);sub OptCtl($);sub FindOption($$$$$);sub ValidValue ($$$$$);my$requested_version=0;sub ConfigDefaults() {if (defined$ENV{"POSIXLY_CORRECT"}){$genprefix="(--|-)";$autoabbrev=0;$bundling=0;$getopt_compat=0;$order=$REQUIRE_ORDER}else {$genprefix="(--|-|\\+)";$autoabbrev=1;$bundling=0;$getopt_compat=1;$order=$PERMUTE}$debug=0;$error=0;$ignorecase=1;$passthrough=0;$gnu_compat=0;$longprefix="(--)";$bundling_values=0}sub import {my$pkg=shift;my@syms=();my@config=();my$dest=\@syms;for (@_){if ($_ eq ':config'){$dest=\@config;next}push(@$dest,$_)}local$Exporter::ExportLevel=1;push(@syms,qw(&GetOptions))if@syms;$requested_version=0;$pkg->SUPER::import(@syms);Configure(@config)if@config}($REQUIRE_ORDER,$PERMUTE,$RETURN_IN_ORDER)=(0..2);($major_version,$minor_version)=$VERSION =~ /^(\d+)\.(\d+)/;ConfigDefaults();package Getopt::Long::Parser;my$default_config=do {Getopt::Long::Configure ()};sub new {my$that=shift;my$class=ref($that)|| $that;my%atts=@_;my$self={caller_pkg=>(caller)[0]};bless ($self,$class);if (defined$atts{config}){my$save=Getopt::Long::Configure ($default_config,@{$atts{config}});$self->{settings}=Getopt::Long::Configure ($save);delete ($atts{config})}else {$self->{settings}=$default_config}if (%atts){die(__PACKAGE__.": unhandled attributes: ".join(" ",sort(keys(%atts)))."\n")}$self}sub configure {my ($self)=shift;my$save=Getopt::Long::Configure ($self->{settings},@_);$self->{settings}=Getopt::Long::Configure ($save)}sub getoptions {my ($self)=shift;return$self->getoptionsfromarray(\@ARGV,@_)}sub getoptionsfromarray {my ($self)=shift;my$save=Getopt::Long::Configure ($self->{settings});my$ret=0;$Getopt::Long::caller=$self->{caller_pkg};eval {local ($SIG{__DIE__})='DEFAULT';$ret=Getopt::Long::GetOptionsFromArray (@_)};Getopt::Long::Configure ($save);die ($@)if $@;return$ret}package Getopt::Long;use constant CTL_TYPE=>0;use constant CTL_CNAME=>1;use constant CTL_DEFAULT=>2;use constant CTL_DEST=>3;use constant CTL_DEST_SCALAR=>0;use constant CTL_DEST_ARRAY=>1;use constant CTL_DEST_HASH=>2;use constant CTL_DEST_CODE=>3;use constant CTL_AMIN=>4;use constant CTL_AMAX=>5;use constant PAT_INT=>"[-+]?_*[0-9][0-9_]*";use constant PAT_XINT=>"(?:"."[-+]?_*[1-9][0-9_]*"."|"."0x_*[0-9a-f][0-9a-f_]*"."|"."0b_*[01][01_]*"."|"."0[0-7_]*".")";use constant PAT_FLOAT=>"[-+]?"."(?=[0-9.])"."[0-9_]*"."(\.[0-9_]+)?"."([eE][-+]?[0-9_]+)?";sub GetOptions(@) {unshift(@_,\@ARGV);goto&GetOptionsFromArray}sub GetOptionsFromString(@) {my ($string)=shift;require Text::ParseWords;my$args=[Text::ParseWords::shellwords($string)];$caller ||= (caller)[0];my$ret=GetOptionsFromArray($args,@_);return ($ret,$args)if wantarray;if (@$args){$ret=0;warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n")}$ret}sub GetOptionsFromArray(@) {my ($argv,@optionlist)=@_;my$argend='--';my%opctl=();my$pkg=$caller || (caller)[0];my@ret=();my%linkage;my$userlinkage;my$opt;my$prefix=$genprefix;$error='';if ($debug){local ($^W)=0;print STDERR ("Getopt::Long $Getopt::Long::VERSION_STRING ","called from package \"$pkg\".","\n ","argv: ",defined($argv)? UNIVERSAL::isa($argv,'ARRAY')? "(@$argv)" : $argv : "<undef>","\n ","autoabbrev=$autoabbrev,"."bundling=$bundling,","bundling_values=$bundling_values,","getopt_compat=$getopt_compat,","gnu_compat=$gnu_compat,","order=$order,","\n ","ignorecase=$ignorecase,","requested_version=$requested_version,","passthrough=$passthrough,","genprefix=\"$genprefix\",","longprefix=\"$longprefix\".","\n")}$userlinkage=undef;if (@optionlist && ref($optionlist[0])and UNIVERSAL::isa($optionlist[0],'HASH')){$userlinkage=shift (@optionlist);print STDERR ("=> user linkage: $userlinkage\n")if$debug}if (@optionlist && $optionlist[0]=~ /^\W+$/ &&!($optionlist[0]eq '<>' && @optionlist > 0 && ref($optionlist[1]))){$prefix=shift (@optionlist);$prefix =~ s/(\W)/\\$1/g;$prefix="([" .$prefix ."])";print STDERR ("=> prefix=\"$prefix\"\n")if$debug}%opctl=();while (@optionlist){my$opt=shift (@optionlist);unless (defined($opt)){$error .= "Undefined argument in option spec\n";next}$opt=$+ if$opt =~ /^$prefix+(.*)$/s;if ($opt eq '<>'){if ((defined$userlinkage)&&!(@optionlist > 0 && ref($optionlist[0]))&& (exists$userlinkage->{$opt})&& ref($userlinkage->{$opt})){unshift (@optionlist,$userlinkage->{$opt})}unless (@optionlist > 0 && ref($optionlist[0])&& ref($optionlist[0])eq 'CODE'){$error .= "Option spec <> requires a reference to a subroutine\n";shift (@optionlist)if@optionlist && ref($optionlist[0]);next}$linkage{'<>'}=shift (@optionlist);next}my ($name,$orig)=ParseOptionSpec ($opt,\%opctl);unless (defined$name){$error .= $orig;shift (@optionlist)if@optionlist && ref($optionlist[0]);next}if (defined$userlinkage){unless (@optionlist > 0 && ref($optionlist[0])){if (exists$userlinkage->{$orig}&& ref($userlinkage->{$orig})){print STDERR ("=> found userlinkage for \"$orig\": ","$userlinkage->{$orig}\n")if$debug;unshift (@optionlist,$userlinkage->{$orig})}else {next}}}if (@optionlist > 0 && ref($optionlist[0])){print STDERR ("=> link \"$orig\" to $optionlist[0]\n")if$debug;my$rl=ref($linkage{$orig}=shift (@optionlist));if ($rl eq "ARRAY"){$opctl{$name}[CTL_DEST]=CTL_DEST_ARRAY}elsif ($rl eq "HASH"){$opctl{$name}[CTL_DEST]=CTL_DEST_HASH}elsif ($rl eq "SCALAR" || $rl eq "REF"){}elsif ($rl eq "CODE"){}else {$error .= "Invalid option linkage for \"$opt\"\n"}}else {my$ov=$orig;$ov =~ s/\W/_/g;if ($opctl{$name}[CTL_DEST]==CTL_DEST_ARRAY){print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")if$debug;eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;")}elsif ($opctl{$name}[CTL_DEST]==CTL_DEST_HASH){print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")if$debug;eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;")}else {print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")if$debug;eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;")}}if ($opctl{$name}[CTL_TYPE]eq 'I' && ($opctl{$name}[CTL_DEST]==CTL_DEST_ARRAY || $opctl{$name}[CTL_DEST]==CTL_DEST_HASH)){$error .= "Invalid option linkage for \"$opt\"\n"}}$error .= "GetOptionsFromArray: 1st parameter is not an array reference\n" unless$argv && UNIVERSAL::isa($argv,'ARRAY');die ($error)if$error;$error=0;if (defined($auto_version)? $auto_version : ($requested_version >= 2.3203)){if (!defined($opctl{version})){$opctl{version}=['','version',0,CTL_DEST_CODE,undef];$linkage{version}=\&VersionMessage}$auto_version=1}if (defined($auto_help)? $auto_help : ($requested_version >= 2.3203)){if (!defined($opctl{help})&&!defined($opctl{'?'})){$opctl{help}=$opctl{'?'}=['','help',0,CTL_DEST_CODE,undef];$linkage{help}=\&HelpMessage}$auto_help=1}if ($debug){my ($arrow,$k,$v);$arrow="=> ";while (($k,$v)=each(%opctl)){print STDERR ($arrow,"\$opctl{$k} = $v ",OptCtl($v),"\n");$arrow=" "}}my$goon=1;while ($goon && @$argv > 0){$opt=shift (@$argv);print STDERR ("=> arg \"",$opt,"\"\n")if$debug;if (defined($opt)&& $opt eq $argend){push (@ret,$argend)if$passthrough;last}my$tryopt=$opt;my$found;my$key;my$arg;my$ctl;($found,$opt,$ctl,$arg,$key)=FindOption ($argv,$prefix,$argend,$opt,\%opctl);if ($found){next unless defined$opt;my$argcnt=0;while (defined$arg){print STDERR ("=> cname for \"$opt\" is ")if$debug;$opt=$ctl->[CTL_CNAME];print STDERR ("\"$ctl->[CTL_CNAME]\"\n")if$debug;if (defined$linkage{$opt}){print STDERR ("=> ref(\$L{$opt}) -> ",ref($linkage{$opt}),"\n")if$debug;if (ref($linkage{$opt})eq 'SCALAR' || ref($linkage{$opt})eq 'REF'){if ($ctl->[CTL_TYPE]eq '+'){print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")if$debug;if (defined ${$linkage{$opt}}){${$linkage{$opt}}+= $arg}else {${$linkage{$opt}}=$arg}}elsif ($ctl->[CTL_DEST]==CTL_DEST_ARRAY){print STDERR ("=> ref(\$L{$opt}) auto-vivified"," to ARRAY\n")if$debug;my$t=$linkage{$opt};$$t=$linkage{$opt}=[];print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")if$debug;push (@{$linkage{$opt}},$arg)}elsif ($ctl->[CTL_DEST]==CTL_DEST_HASH){print STDERR ("=> ref(\$L{$opt}) auto-vivified"," to HASH\n")if$debug;my$t=$linkage{$opt};$$t=$linkage{$opt}={};print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")if$debug;$linkage{$opt}->{$key}=$arg}else {print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")if$debug;${$linkage{$opt}}=$arg}}elsif (ref($linkage{$opt})eq 'ARRAY'){print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")if$debug;push (@{$linkage{$opt}},$arg)}elsif (ref($linkage{$opt})eq 'HASH'){print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")if$debug;$linkage{$opt}->{$key}=$arg}elsif (ref($linkage{$opt})eq 'CODE'){print STDERR ("=> &L{$opt}(\"$opt\"",$ctl->[CTL_DEST]==CTL_DEST_HASH ? ", \"$key\"" : "",", \"$arg\")\n")if$debug;my$eval_error=do {local $@;local$SIG{__DIE__}='DEFAULT';eval {&{$linkage{$opt}}(Getopt::Long::CallBack->new (name=>$opt,ctl=>$ctl,opctl=>\%opctl,linkage=>\%linkage,prefix=>$prefix,),$ctl->[CTL_DEST]==CTL_DEST_HASH ? ($key): (),$arg)};$@};print STDERR ("=> die($eval_error)\n")if$debug && $eval_error ne '';if ($eval_error =~ /^!/){if ($eval_error =~ /^!FINISH\b/){$goon=0}}elsif ($eval_error ne ''){warn ($eval_error);$error++}}else {print STDERR ("Invalid REF type \"",ref($linkage{$opt}),"\" in linkage\n");die("Getopt::Long -- internal error!\n")}}elsif ($ctl->[CTL_DEST]==CTL_DEST_ARRAY){if (defined$userlinkage->{$opt}){print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")if$debug;push (@{$userlinkage->{$opt}},$arg)}else {print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")if$debug;$userlinkage->{$opt}=[$arg]}}elsif ($ctl->[CTL_DEST]==CTL_DEST_HASH){if (defined$userlinkage->{$opt}){print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")if$debug;$userlinkage->{$opt}->{$key}=$arg}else {print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")if$debug;$userlinkage->{$opt}={$key=>$arg}}}else {if ($ctl->[CTL_TYPE]eq '+'){print STDERR ("=> \$L{$opt} += \"$arg\"\n")if$debug;if (defined$userlinkage->{$opt}){$userlinkage->{$opt}+= $arg}else {$userlinkage->{$opt}=$arg}}else {print STDERR ("=>\$L{$opt} = \"$arg\"\n")if$debug;$userlinkage->{$opt}=$arg}}$argcnt++;last if$argcnt >= $ctl->[CTL_AMAX]&& $ctl->[CTL_AMAX]!=-1;undef($arg);if ($argcnt < $ctl->[CTL_AMIN]){if (@$argv){if (ValidValue($ctl,$argv->[0],1,$argend,$prefix)){$arg=shift(@$argv);if ($ctl->[CTL_TYPE]=~ /^[iIo]$/){$arg =~ tr/_//d;$arg=$ctl->[CTL_TYPE]eq 'o' && $arg =~ /^0/ ? oct($arg): 0+$arg}($key,$arg)=$arg =~ /^([^=]+)=(.*)/ if$ctl->[CTL_DEST]==CTL_DEST_HASH;next}warn("Value \"$$argv[0]\" invalid for option $opt\n");$error++}else {warn("Insufficient arguments for option $opt\n");$error++}}if (@$argv && ValidValue($ctl,$argv->[0],0,$argend,$prefix)){$arg=shift(@$argv);if ($ctl->[CTL_TYPE]=~ /^[iIo]$/){$arg =~ tr/_//d;$arg=$ctl->[CTL_TYPE]eq 'o' && $arg =~ /^0/ ? oct($arg): 0+$arg}($key,$arg)=$arg =~ /^([^=]+)=(.*)/ if$ctl->[CTL_DEST]==CTL_DEST_HASH;next}}}elsif ($order==$PERMUTE){my$cb;if (defined ($cb=$linkage{'<>'})){print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")if$debug;my$eval_error=do {local $@;local$SIG{__DIE__}='DEFAULT';eval {&$cb($tryopt)};$@};print STDERR ("=> die($eval_error)\n")if$debug && $eval_error ne '';if ($eval_error =~ /^!/){if ($eval_error =~ /^!FINISH\b/){$goon=0}}elsif ($eval_error ne ''){warn ($eval_error);$error++}}else {print STDERR ("=> saving \"$tryopt\" ","(not an option, may permute)\n")if$debug;push (@ret,$tryopt)}next}else {unshift (@$argv,$tryopt);return ($error==0)}}if (@ret && ($order==$PERMUTE || $passthrough)){print STDERR ("=> restoring \"",join('" "',@ret),"\"\n")if$debug;unshift (@$argv,@ret)}return ($error==0)}sub OptCtl ($) {my ($v)=@_;my@v=map {defined($_)? ($_): ("<undef>")}@$v;"[".join(",","\"$v[CTL_TYPE]\"","\"$v[CTL_CNAME]\"","\"$v[CTL_DEFAULT]\"",("\$","\@","\%","\&")[$v[CTL_DEST]|| 0],$v[CTL_AMIN]|| '',$v[CTL_AMAX]|| '',)."]"}sub ParseOptionSpec ($$) {my ($opt,$opctl)=@_;if ($opt !~ m;^
41 (
42 # Option name
43 (?: \w+[-\w]* )
44 # Aliases
45 (?: \| (?: . [^|!+=:]* )? )*
46 )?
47 (
48 # Either modifiers ...
49 [!+]
50 |
51 # ... or a value/dest/repeat specification
52 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
53 |
54 # ... or an optional-with-default spec
55 : (?: -?\d+ | \+ ) [@%]?
56 )?
57 $;x){return (undef,"Error in option spec: \"$opt\"\n")}my ($names,$spec)=($1,$2);$spec='' unless defined$spec;my$orig;my@names;if (defined$names){@names=split (/\|/,$names);$orig=$names[0]}else {@names=('');$orig=''}my$entry;if ($spec eq '' || $spec eq '+' || $spec eq '!'){$entry=[$spec,$orig,undef,CTL_DEST_SCALAR,0,0]}elsif ($spec =~ /^:(-?\d+|\+)([@%])?$/){my$def=$1;my$dest=$2;my$type=$def eq '+' ? 'I' : 'i';$dest ||= '$';$dest=$dest eq '@' ? CTL_DEST_ARRAY : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;$entry=[$type,$orig,$def eq '+' ? undef : $def,$dest,0,1]}else {my ($mand,$type,$dest)=$spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;return (undef,"Cannot repeat while bundling: \"$opt\"\n")if$bundling && defined($4);my ($mi,$cm,$ma)=($5,$6,$7);return (undef,"{0} is useless in option spec: \"$opt\"\n")if defined($mi)&&!$mi &&!defined($ma)&&!defined($cm);$type='i' if$type eq 'n';$dest ||= '$';$dest=$dest eq '@' ? CTL_DEST_ARRAY : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;$mi=$mand eq '=' ? 1 : 0 unless defined$mi;$mand=$mi ? '=' : ':';$ma=$mi ? $mi : 1 unless defined$ma || defined$cm;return (undef,"Max must be greater than zero in option spec: \"$opt\"\n")if defined($ma)&&!$ma;return (undef,"Max less than min in option spec: \"$opt\"\n")if defined($ma)&& $ma < $mi;$entry=[$type,$orig,undef,$dest,$mi,$ma||-1]}my$dups='';for (@names){$_=lc ($_)if$ignorecase > (($bundling && length($_)==1)? 1 : 0);if (exists$opctl->{$_}){$dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"}if ($spec eq '!'){$opctl->{"no$_"}=$entry;$opctl->{"no-$_"}=$entry;$opctl->{$_}=[@$entry];$opctl->{$_}->[CTL_TYPE]=''}else {$opctl->{$_}=$entry}}if ($dups && $^W){for (split(/\n+/,$dups)){warn($_."\n")}}($names[0],$orig)}sub FindOption ($$$$$) {my ($argv,$prefix,$argend,$opt,$opctl)=@_;print STDERR ("=> find \"$opt\"\n")if$debug;return (0)unless defined($opt);return (0)unless$opt =~ /^($prefix)(.*)$/s;return (0)if$opt eq "-" &&!defined$opctl->{''};$opt=substr($opt,length($1));my$starter=$1;print STDERR ("=> split \"$starter\"+\"$opt\"\n")if$debug;my$optarg;my$rest;if (($starter=~/^$longprefix$/ || ($getopt_compat && ($bundling==0 || $bundling==2)))&& (my$oppos=index($opt,'=',1))> 0){my$optorg=$opt;$opt=substr($optorg,0,$oppos);$optarg=substr($optorg,$oppos + 1);print STDERR ("=> option \"",$opt,"\", optarg = \"$optarg\"\n")if$debug}my$tryopt=$opt;if (($bundling || $bundling_values)&& $starter eq '-'){$tryopt=$ignorecase ? lc($opt): $opt;if ($bundling==2 && length($tryopt)> 1 && defined ($opctl->{$tryopt})){print STDERR ("=> $starter$tryopt overrides unbundling\n")if$debug}elsif ($bundling_values){$tryopt=$opt;$rest=length ($tryopt)> 0 ? substr ($tryopt,1): '';$tryopt=substr ($tryopt,0,1);$tryopt=lc ($tryopt)if$ignorecase > 1;print STDERR ("=> $starter$tryopt unbundled from ","$starter$tryopt$rest\n")if$debug;$optarg=$rest eq '' ? undef : $rest;$rest=undef}else {$tryopt=$opt;$rest=length ($tryopt)> 0 ? substr ($tryopt,1): '';$tryopt=substr ($tryopt,0,1);$tryopt=lc ($tryopt)if$ignorecase > 1;print STDERR ("=> $starter$tryopt unbundled from ","$starter$tryopt$rest\n")if$debug;$rest=undef unless$rest ne ''}}elsif ($autoabbrev && $opt ne ""){my@names=sort(keys (%$opctl));$opt=lc ($opt)if$ignorecase;$tryopt=$opt;my$pat=quotemeta ($opt);my@hits=grep (/^$pat/,@names);print STDERR ("=> ",scalar(@hits)," hits (@hits) with \"$pat\" ","out of ",scalar(@names),"\n")if$debug;unless ((@hits <= 1)|| (grep ($_ eq $opt,@hits)==1)){my%hit;for (@hits){my$hit=$opctl->{$_}->[CTL_CNAME]if defined$opctl->{$_}->[CTL_CNAME];$hit="no" .$hit if$opctl->{$_}->[CTL_TYPE]eq '!';$hit{$hit}=1}if (keys(%hit)==2){if ($auto_version && exists($hit{version})){delete$hit{version}}elsif ($auto_help && exists($hit{help})){delete$hit{help}}}unless (keys(%hit)==1){return (0)if$passthrough;warn ("Option ",$opt," is ambiguous (",join(", ",@hits),")\n");$error++;return (1,undef)}@hits=keys(%hit)}if (@hits==1 && $hits[0]ne $opt){$tryopt=$hits[0];$tryopt=lc ($tryopt)if$ignorecase > (($bundling && length($tryopt)==1)? 1 : 0);print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")if$debug}}elsif ($ignorecase){$tryopt=lc ($opt)}my$ctl=$opctl->{$tryopt};unless (defined$ctl){return (0)if$passthrough;if ($bundling==1 && length($starter)==1){$opt=substr($opt,0,1);unshift (@$argv,$starter.$rest)if defined$rest}if ($opt eq ""){warn ("Missing option after ",$starter,"\n")}else {warn ("Unknown option: ",$opt,"\n")}$error++;return (1,undef)}$opt=$tryopt;print STDERR ("=> found ",OptCtl($ctl)," for \"",$opt,"\"\n")if$debug;my$type=$ctl->[CTL_TYPE];my$arg;if ($type eq '' || $type eq '!' || $type eq '+'){if (defined$optarg){return (0)if$passthrough;warn ("Option ",$opt," does not take an argument\n");$error++;undef$opt;undef$optarg if$bundling_values}elsif ($type eq '' || $type eq '+'){$arg=1}else {$opt =~ s/^no-?//i;$arg=0}unshift (@$argv,$starter.$rest)if defined$rest;return (1,$opt,$ctl,$arg)}my$mand=$ctl->[CTL_AMIN];if ($gnu_compat){my$optargtype=0;if (defined($optarg)){$optargtype=(length($optarg)==0)? 1 : 2}elsif (defined$rest || @$argv > 0){$optargtype=3}if(($optargtype==0)&&!$mand){if ($type eq 'I'){my@c=@$ctl;$c[CTL_TYPE]='+';return (1,$opt,\@c,1)}my$val =defined($ctl->[CTL_DEFAULT])? $ctl->[CTL_DEFAULT]: $type eq 's' ? '' : 0;return (1,$opt,$ctl,$val)}return (1,$opt,$ctl,$type eq 's' ? '' : 0)if$optargtype==1}if (defined$optarg ? ($optarg eq ''):!(defined$rest || @$argv > 0)){if ($mand){return (0)if$passthrough;warn ("Option ",$opt," requires an argument\n");$error++;return (1,undef)}if ($type eq 'I'){my@c=@$ctl;$c[CTL_TYPE]='+';return (1,$opt,\@c,1)}return (1,$opt,$ctl,defined($ctl->[CTL_DEFAULT])? $ctl->[CTL_DEFAULT]: $type eq 's' ? '' : 0)}$arg=(defined$rest ? $rest : (defined$optarg ? $optarg : shift (@$argv)));my$key;if ($ctl->[CTL_DEST]==CTL_DEST_HASH && defined$arg){($key,$arg)=($arg =~ /^([^=]*)=(.*)$/s)? ($1,$2): ($arg,defined($ctl->[CTL_DEFAULT])? $ctl->[CTL_DEFAULT]: ($mand ? undef : ($type eq 's' ? "" : 1)));if (!defined$arg){warn ("Option $opt, key \"$key\", requires a value\n");$error++;unshift (@$argv,$starter.$rest)if defined$rest;return (1,undef)}}my$key_valid=$ctl->[CTL_DEST]==CTL_DEST_HASH ? "[^=]+=" : "";if ($type eq 's'){return (1,$opt,$ctl,$arg,$key)if$mand;return (1,$opt,$ctl,$arg,$key)if$ctl->[CTL_DEST]==CTL_DEST_HASH;return (1,$opt,$ctl,$arg,$key)if defined$optarg || defined$rest;return (1,$opt,$ctl,$arg,$key)if$arg eq "-";if ($arg eq $argend || $arg =~ /^$prefix.+/){unshift (@$argv,$arg);$arg=''}}elsif ($type eq 'i' || $type eq 'I' || $type eq 'o'){my$o_valid=$type eq 'o' ? PAT_XINT : PAT_INT;if ($bundling && defined$rest && $rest =~ /^($key_valid)($o_valid)(.*)$/si){($key,$arg,$rest)=($1,$2,$+);chop($key)if$key;$arg=($type eq 'o' && $arg =~ /^0/)? oct($arg): 0+$arg;unshift (@$argv,$starter.$rest)if defined$rest && $rest ne ''}elsif ($arg =~ /^$o_valid$/si){$arg =~ tr/_//d;$arg=($type eq 'o' && $arg =~ /^0/)? oct($arg): 0+$arg}else {if (defined$optarg || $mand){if ($passthrough){unshift (@$argv,defined$rest ? $starter.$rest : $arg)unless defined$optarg;return (0)}warn ("Value \"",$arg,"\" invalid for option ",$opt," (",$type eq 'o' ? "extended " : '',"number expected)\n");$error++;unshift (@$argv,$starter.$rest)if defined$rest;return (1,undef)}else {unshift (@$argv,defined$rest ? $starter.$rest : $arg);if ($type eq 'I'){my@c=@$ctl;$c[CTL_TYPE]='+';return (1,$opt,\@c,1)}$arg=defined($ctl->[CTL_DEFAULT])? $ctl->[CTL_DEFAULT]: 0}}}elsif ($type eq 'f'){my$o_valid=PAT_FLOAT;if ($bundling && defined$rest && $rest =~ /^($key_valid)($o_valid)(.*)$/s){$arg =~ tr/_//d;($key,$arg,$rest)=($1,$2,$+);chop($key)if$key;unshift (@$argv,$starter.$rest)if defined$rest && $rest ne ''}elsif ($arg =~ /^$o_valid$/){$arg =~ tr/_//d}else {if (defined$optarg || $mand){if ($passthrough){unshift (@$argv,defined$rest ? $starter.$rest : $arg)unless defined$optarg;return (0)}warn ("Value \"",$arg,"\" invalid for option ",$opt," (real number expected)\n");$error++;unshift (@$argv,$starter.$rest)if defined$rest;return (1,undef)}else {unshift (@$argv,defined$rest ? $starter.$rest : $arg);$arg=0.0}}}else {die("Getopt::Long internal error (Can't happen)\n")}return (1,$opt,$ctl,$arg,$key)}sub ValidValue ($$$$$) {my ($ctl,$arg,$mand,$argend,$prefix)=@_;if ($ctl->[CTL_DEST]==CTL_DEST_HASH){return 0 unless$arg =~ /[^=]+=(.*)/;$arg=$1}my$type=$ctl->[CTL_TYPE];if ($type eq 's'){return (1)if$mand;return (1)if$arg eq "-";return 0 if$arg eq $argend || $arg =~ /^$prefix.+/;return 1}elsif ($type eq 'i' || $type eq 'I' || $type eq 'o'){my$o_valid=$type eq 'o' ? PAT_XINT : PAT_INT;return$arg =~ /^$o_valid$/si}elsif ($type eq 'f'){my$o_valid=PAT_FLOAT;return$arg =~ /^$o_valid$/}die("ValidValue: Cannot happen\n")}sub Configure (@) {my (@options)=@_;my$prevconfig=[$error,$debug,$major_version,$minor_version,$caller,$autoabbrev,$getopt_compat,$ignorecase,$bundling,$order,$gnu_compat,$passthrough,$genprefix,$auto_version,$auto_help,$longprefix,$bundling_values ];if (ref($options[0])eq 'ARRAY'){($error,$debug,$major_version,$minor_version,$caller,$autoabbrev,$getopt_compat,$ignorecase,$bundling,$order,$gnu_compat,$passthrough,$genprefix,$auto_version,$auto_help,$longprefix,$bundling_values)=@{shift(@options)}}my$opt;for$opt (@options){my$try=lc ($opt);my$action=1;if ($try =~ /^no_?(.*)$/s){$action=0;$try=$+}if (($try eq 'default' or $try eq 'defaults')&& $action){ConfigDefaults ()}elsif (($try eq 'posix_default' or $try eq 'posix_defaults')){local$ENV{POSIXLY_CORRECT};$ENV{POSIXLY_CORRECT}=1 if$action;ConfigDefaults ()}elsif ($try eq 'auto_abbrev' or $try eq 'autoabbrev'){$autoabbrev=$action}elsif ($try eq 'getopt_compat'){$getopt_compat=$action;$genprefix=$action ? "(--|-|\\+)" : "(--|-)"}elsif ($try eq 'gnu_getopt'){if ($action){$gnu_compat=1;$bundling=1;$getopt_compat=0;$genprefix="(--|-)";$order=$PERMUTE;$bundling_values=0}}elsif ($try eq 'gnu_compat'){$gnu_compat=$action;$bundling=0;$bundling_values=1}elsif ($try =~ /^(auto_?)?version$/){$auto_version=$action}elsif ($try =~ /^(auto_?)?help$/){$auto_help=$action}elsif ($try eq 'ignorecase' or $try eq 'ignore_case'){$ignorecase=$action}elsif ($try eq 'ignorecase_always' or $try eq 'ignore_case_always'){$ignorecase=$action ? 2 : 0}elsif ($try eq 'bundling'){$bundling=$action;$bundling_values=0 if$action}elsif ($try eq 'bundling_override'){$bundling=$action ? 2 : 0;$bundling_values=0 if$action}elsif ($try eq 'bundling_values'){$bundling_values=$action;$bundling=0 if$action}elsif ($try eq 'require_order'){$order=$action ? $REQUIRE_ORDER : $PERMUTE}elsif ($try eq 'permute'){$order=$action ? $PERMUTE : $REQUIRE_ORDER}elsif ($try eq 'pass_through' or $try eq 'passthrough'){$passthrough=$action}elsif ($try =~ /^prefix=(.+)$/ && $action){$genprefix=$1;$genprefix="(" .quotemeta($genprefix).")";eval {'' =~ /$genprefix/};die("Getopt::Long: invalid pattern \"$genprefix\"\n")if $@}elsif ($try =~ /^prefix_pattern=(.+)$/ && $action){$genprefix=$1;$genprefix="(" .$genprefix .")" unless$genprefix =~ /^\(.*\)$/;eval {'' =~ m"$genprefix"};die("Getopt::Long: invalid pattern \"$genprefix\"\n")if $@}elsif ($try =~ /^long_prefix_pattern=(.+)$/ && $action){$longprefix=$1;$longprefix="(" .$longprefix .")" unless$longprefix =~ /^\(.*\)$/;eval {'' =~ m"$longprefix"};die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n")if $@}elsif ($try eq 'debug'){$debug=$action}else {die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")}}$prevconfig}sub config (@) {Configure (@_)}sub VersionMessage(@) {my$pa=setup_pa_args("version",@_);my$v=$main::VERSION;my$fh=$pa->{-output}|| (($pa->{-exitval}eq "NOEXIT" || $pa->{-exitval}< 2)? \*STDOUT : \*STDERR);print$fh (defined($pa->{-message})? $pa->{-message}: (),$0,defined$v ? " version $v" : (),"\n","(",__PACKAGE__,"::","GetOptions"," version ",defined($Getopt::Long::VERSION_STRING)? $Getopt::Long::VERSION_STRING : $VERSION,";"," Perl version ",$] >= 5.006 ? sprintf("%vd",$^V): $],")\n");exit($pa->{-exitval})unless$pa->{-exitval}eq "NOEXIT"}sub HelpMessage(@) {eval {require Pod::Usage;import Pod::Usage;1}|| die("Cannot provide help: cannot load Pod::Usage\n");pod2usage(setup_pa_args("help",@_))}sub setup_pa_args($@) {my$tag=shift;@_=()if @_==2 && $_[0]eq $tag;my$pa;if (@_ > 1){$pa={@_ }}else {$pa=shift || {}}if (UNIVERSAL::isa($pa,'HASH')){$pa->{-message}=$pa->{-msg};delete($pa->{-msg})}elsif ($pa =~ /^-?\d+$/){$pa={-exitval=>$pa }}else {$pa={-message=>$pa }}$pa->{-verbose}=0 unless exists($pa->{-verbose});$pa->{-exitval}=0 unless exists($pa->{-exitval});$pa}sub VERSION {$requested_version=$_[1]if @_ > 1;shift->SUPER::VERSION(@_)}package Getopt::Long::CallBack;sub new {my ($pkg,%atts)=@_;bless {%atts },$pkg}sub name {my$self=shift;''.$self->{name}}use overload '""'=>\&name,fallback=>1;1;
58 GETOPT_LONG
59
60 $fatpacked{"GraphQL/Client.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT';
61 package GraphQL::Client;use warnings;use strict;use Module::Load qw(load);use Scalar::Util qw(reftype);use namespace::clean;our$VERSION='0.604';sub _croak {require Carp;goto&Carp::croak}sub _throw {GraphQL::Client::Error->throw(@_)}sub new {my$class=shift;bless {@_},$class}sub execute {my$self=shift;my ($query,$variables,$operation_name,$options)=@_;if ((reftype($operation_name)|| '')eq 'HASH'){$options=$operation_name;$operation_name=undef}my$request={query=>$query,($variables && %$variables)? (variables=>$variables): (),$operation_name ? (operationName=>$operation_name): (),};return$self->_handle_result($self->transport->execute($request,$options))}sub _handle_result {my$self=shift;my ($result)=@_;my$handle_result=sub {my$result=shift;my$resp=$result->{response};if (my$exception=$result->{error}){unshift @{$resp->{errors}},{message=>"$exception",}}if ($self->unpack){if ($resp->{errors}){_throw$resp->{errors}[0]{message},{type=>'graphql',response=>$resp,details=>$result->{details},}}return$resp->{data}}return$resp};if (eval {$result->isa('Future')}){return$result->transform(done=>sub {my$result=shift;my$resp=eval {$handle_result->($result)};if (my$err=$@){Future::Exception->throw("$err",$err->{type},$err->{response},$err->{details})}return$resp},)}else {return$handle_result->($result)}}sub url {my$self=shift;$self->{url}}sub transport_class {my$self=shift;$self->{transport_class}}sub transport {my$self=shift;$self->{transport}//= do {my$class=$self->_autodetermine_transport_class;eval {load$class};if ((my$err=$@)||!$class->can('execute')){$err ||= "Loaded $class, but it doesn't look like a proper transport.\n";warn$err if$ENV{GRAPHQL_CLIENT_DEBUG};_croak "Failed to load transport for \"${class}\""}$class->new(%$self)}}sub unpack {my$self=shift;$self->{unpack}//= 0}sub _url_protocol {my$self=shift;my$url=$self->url;my ($protocol)=$url =~ /^([^+:]+)/;return$protocol}sub _autodetermine_transport_class {my$self=shift;my$class=$self->transport_class;return _expand_class($class)if$class;my$protocol=$self->_url_protocol;_croak 'Failed to determine transport from URL' if!$protocol;$class=lc($protocol);$class =~ s/[^a-z]/_/g;return _expand_class($class)}sub _expand_class {my$class=shift;$class="GraphQL::Client::$class" unless$class =~ s/^\+//;$class}{package GraphQL::Client::Error;use warnings;use strict;use overload '""'=>\&error,fallback=>1;sub new {bless {%{$_[2]|| {}},error=>$_[1]|| 'Something happened'},$_[0]}sub error {"$_[0]->{error}"}sub type {"$_[0]->{type}"}sub throw {my$self=shift;die$self if ref$self;die$self->new(@_)}}1;
62 GRAPHQL_CLIENT
63
64 $fatpacked{"GraphQL/Client/CLI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_CLI';
65 package GraphQL::Client::CLI;use warnings;use strict;use Encode qw(decode);use Getopt::Long 2.39 qw(GetOptionsFromArray);use GraphQL::Client;use JSON::MaybeXS;use Text::ParseWords;use namespace::clean;our$VERSION='0.604';my$JSON=JSON::MaybeXS->new(canonical=>1);sub _croak {require Carp;goto&Carp::croak}sub new {my$class=shift;bless {},$class}sub main {my$self=shift;$self=$self->new if!ref$self;my$options=eval {$self->_get_options(@_)};if (my$err=$@){print STDERR$err;_pod2usage(2)}if ($options->{version}){print "graphql $VERSION\n";exit 0}if ($options->{help}){_pod2usage(-exitval=>0,-verbose=>99,-sections=>[qw(NAME SYNOPSIS OPTIONS)])}if ($options->{manual}){_pod2usage(-exitval=>0,-verbose=>2)}my$url=$options->{url};if (!$url){print STDERR "The <URL> or --url option argument is required.\n";_pod2usage(2)}my$variables=$options->{variables};my$query=$options->{query};my$operation_name=$options->{operation_name};my$unpack=$options->{unpack};my$outfile=$options->{outfile};my$format=$options->{format};my$transport=$options->{transport};my$client=GraphQL::Client->new(url=>$url);eval {$client->transport};if (my$err=$@){warn$err if$ENV{GRAPHQL_CLIENT_DEBUG};print STDERR "Could not construct a transport for URL: $url\n";print STDERR "Is this URL correct?\n";_pod2usage(2)}if ($query eq '-'){print STDERR "Interactive mode engaged! Waiting for a query on <STDIN>...\n" if -t STDIN;binmode(STDIN,'encoding(UTF-8)');$query=do {local $/;<STDIN>}}my$resp=$client->execute($query,$variables,$operation_name,$transport);my$err=$resp->{errors};$unpack=0 if$err;my$data=$unpack ? $resp->{data}: $resp;if ($outfile){open(my$out,'>',$outfile)or die "Open $outfile failed: $!";*STDOUT=$out}if (my$filter=$options->{filter}){eval {require JSON::Path::Evaluator}or die "Missing dependency: JSON::Path\n";my@values=JSON::Path::Evaluator::evaluate_jsonpath($data,$filter);if (@values==1){$data=$values[0]}else {$data=\@values}}binmode(STDOUT,'encoding(UTF-8)');_print_data($data,$format);exit($unpack && $err ? 1 : 0)}sub _get_options {my$self=shift;my@args=@_;unshift@args,shellwords($ENV{GRAPHQL_CLIENT_OPTIONS}|| '');@args=map {decode('UTF-8',$_)}@args if grep {/\P{ASCII}/}@args;my%options=(format=>'json:pretty',unpack=>0,);GetOptionsFromArray(\@args,'version'=>\$options{version},'help|h|?'=>\$options{help},'manual|man'=>\$options{manual},'url|u=s'=>\$options{url},'query|mutation=s'=>\$options{query},'variables|vars|V=s'=>\$options{variables},'variable|var|d=s%'=>\$options{variables},'operation-name|n=s'=>\$options{operation_name},'transport|t=s%'=>\$options{transport},'format|f=s'=>\$options{format},'filter|p=s'=>\$options{filter},'unpack!'=>\$options{unpack},'output|o=s'=>\$options{outfile},)or _pod2usage(2);$options{url}=shift@args if!$options{url};$options{query}=shift@args if!$options{query};$options{query}||= '-';my$transport=eval {_expand_vars($options{transport})};die "Two or more --transport keys are incompatible.\n" if $@;if (ref$options{variables}){$options{variables}=eval {_expand_vars($options{variables})};die "Two or more --variable keys are incompatible.\n" if $@}elsif ($options{variables}){$options{variables}=eval {$JSON->decode($options{variables})};die "The --variables JSON does not parse.\n" if $@}return \%options}sub _stringify {my ($item)=@_;if (ref($item)eq 'ARRAY'){my$first=@$item && $item->[0];return join(',',@$item)if!ref($first);return join(',',map {$JSON->encode($_)}@$item)}return$JSON->encode($item)if ref($item)eq 'HASH';return$item}sub _print_data {my ($data,$format)=@_;$format=lc($format || 'json:pretty');if ($format eq 'json' || $format eq 'json:pretty'){my%opts=(allow_nonref=>1,canonical=>1);$opts{pretty}=1 if$format eq 'json:pretty';print JSON::MaybeXS->new(%opts)->encode($data)}elsif ($format eq 'yaml'){eval {require YAML}or die "Missing dependency: YAML\n";print YAML::Dump($data)}elsif ($format eq 'csv' || $format eq 'tsv' || $format eq 'table'){my$sep=$format eq 'tsv' ? "\t" : ',';my$unpacked=$data;$unpacked=$data->{data}if ref$data eq 'HASH' && $data->{data};my@columns;my$rows=[];if (ref$unpacked eq 'HASH'){if (keys %$unpacked==1){my ($val)=values %$unpacked;if (ref$val eq 'ARRAY'){my$first=$val->[0];if ($first && ref$first eq 'HASH'){@columns=sort keys %$first;$rows=[map {[map {_stringify($_)}@{$_}{@columns}]}@$val ]}elsif ($first){@columns=keys %$unpacked;$rows=[map {[map {_stringify($_)}$_]}@$val]}}}}elsif (ref$unpacked eq 'ARRAY'){my$first=$unpacked->[0];if ($first && ref$first eq 'HASH'){@columns=sort keys %$first;$rows=[map {[map {_stringify($_)}@{$_}{@columns}]}@$unpacked ]}elsif ($first){@columns=qw(column);$rows=[map {[map {_stringify($_)}$_]}@$unpacked]}}if (@columns){if ($format eq 'table'){eval {require Text::Table::Any}or die "Missing dependency: Text::Table::Any\n";my$table=Text::Table::Any::table(header_row=>1,rows=>[[@columns],@$rows],backend=>$ENV{PERL_TEXT_TABLE},);print$table}else {eval {require Text::CSV}or die "Missing dependency: Text::CSV\n";my$csv=Text::CSV->new({binary=>1,sep=>$sep,eol=>$/});$csv->print(*STDOUT,[@columns]);for my$row (@$rows){$csv->print(*STDOUT,$row)}}}else {_print_data($data);print STDERR sprintf("Error: Response could not be formatted as %s.\n",uc($format));exit 3}}elsif ($format eq 'string'){if (!ref$data){print$data,"\n"}elsif (ref$data eq 'ARRAY'){print join("\n",@$data)}else {_print_data($data);print STDERR sprintf("Error: Response could not be formatted as %s.\n",$format);exit 3}}elsif ($format eq 'perl'){eval {require Data::Dumper}or die "Missing dependency: Data::Dumper\n";print Data::Dumper::Dumper($data)}else {_print_data($data);print STDERR "Error: Format not supported: $format\n";exit 3}}sub _parse_path {my$path=shift;my@path;my@segments=map {split(/\./,$_)}split(/(\[[^\.\]]+\])\.?/,$path);for my$segment (@segments){if ($segment =~ /\[([^\.\]]+)\]/){$path[-1]{type}='ARRAY' if@path;push@path,{name=>$1,index=>1,}}else {$path[-1]{type}='HASH' if@path;push@path,{name=>$segment,}}}return \@path}sub _expand_vars {my$vars=shift;my$root={};while (my ($key,$value)=each %$vars){my$parsed_path=_parse_path($key);my$curr=$root;for my$segment (@$parsed_path){my$name=$segment->{name};my$type=$segment->{type}|| '';my$next=$type eq 'HASH' ? {}: $type eq 'ARRAY' ? []: $value;if (ref$curr eq 'HASH'){_croak 'Conflicting keys' if$segment->{index};if (defined$curr->{$name}){_croak 'Conflicting keys' if$type ne ref$curr->{$name};$next=$curr->{$name}}else {$curr->{$name}=$next}}elsif (ref$curr eq 'ARRAY'){_croak 'Conflicting keys' if!$segment->{index};if (defined$curr->[$name]){_croak 'Conflicting keys' if$type ne ref$curr->[$name];$next=$curr->[$name]}else {$curr->[$name]=$next}}else {_croak 'Conflicting keys'}$curr=$next}}return$root}sub _pod2usage {eval {require Pod::Usage};if ($@){my$ref=$VERSION eq '999.999' ? 'master' : "v$VERSION";my$exit=(@_==1 && $_[0]=~ /^\d+$/ && $_[0])// (@_ % 2==0 && {@_}->{'-exitval'})// 2;print STDERR <<END;exit$exit}else {goto&Pod::Usage::pod2usage}}1;
66 Online documentation is available at:
67
68 https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
69
70 Tip: To enable inline documentation, install the Pod::Usage module.
71
72 END
73 GRAPHQL_CLIENT_CLI
74
75 $fatpacked{"GraphQL/Client/http.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_HTTP';
76 package GraphQL::Client::http;use 5.010;use warnings;use strict;use HTTP::AnyUA::Util qw(www_form_urlencode);use HTTP::AnyUA;use namespace::clean;our$VERSION='0.604';sub _croak {require Carp;goto&Carp::croak}sub new {my$class=shift;my$self=@_ % 2==0 ? {@_}: $_[0];bless$self,$class}sub execute {my$self=shift;my ($request,$options)=@_;my$url=delete$options->{url}|| $self->url;my$method=delete$options->{method}|| $self->method;$request && ref($request)eq 'HASH' or _croak q{Usage: $http->execute(\%request)};$request->{query}or _croak q{Request must have a query};$url or _croak q{URL must be provided};my$data={%$request};if ($method eq 'GET' || $method eq 'HEAD'){$data->{variables}=$self->json->encode($data->{variables})if$data->{variables};my$params=www_form_urlencode($data);my$sep=$url =~ /^[^#]+\?/ ? '&' : '?';$url =~ s/#/${sep}${params}#/ or $url .= "${sep}${params}"}else {my$encoded_data=$self->json->encode($data);$options->{content}=$encoded_data;$options->{headers}{'content-length'}=length$encoded_data;$options->{headers}{'content-type'}='application/json;charset=UTF-8'}return$self->_handle_response($self->any_ua->request($method,$url,$options))}sub _handle_response {my$self=shift;my ($resp)=@_;if (eval {$resp->isa('Future')}){return$resp->followed_by(sub {my$f=shift;if (my ($exception,$category,@other)=$f->failure){if (ref$exception eq 'HASH'){my$resp=$exception;return Future->done($self->_handle_error($resp))}return Future->done({error=>$exception,response=>undef,details=>{exception_details=>[$category,@other],},})}my$resp=$f->get;return Future->done($self->_handle_success($resp))})}else {return$self->_handle_error($resp)if!$resp->{success};return$self->_handle_success($resp)}}sub _handle_error {my$self=shift;my ($resp)=@_;my$data=eval {$self->json->decode($resp->{content})};my$content=$resp->{content}// 'No content';my$reason=$resp->{reason}// '';my$message="HTTP transport returned $resp->{status} ($reason): $content";chomp$message;return {error=>$message,response=>$data,details=>{http_response=>$resp,},}}sub _handle_success {my$self=shift;my ($resp)=@_;my$data=eval {$self->json->decode($resp->{content})};if (my$exception=$@){return {error=>"HTTP transport failed to decode response: $exception",response=>undef,details=>{http_response=>$resp,},}}return {response=>$data,details=>{http_response=>$resp,},}}sub ua {my$self=shift;$self->{ua}//= do {require HTTP::Tiny;HTTP::Tiny->new(agent=>$ENV{GRAPHQL_CLIENT_HTTP_USER_AGENT}// "perl-graphql-client/$VERSION",)}}sub any_ua {my$self=shift;$self->{any_ua}//= HTTP::AnyUA->new(ua=>$self->ua)}sub url {my$self=shift;$self->{url}}sub method {my$self=shift;$self->{method}// 'POST'}sub json {my$self=shift;$self->{json}//= do {require JSON::MaybeXS;JSON::MaybeXS->new(utf8=>1)}}1;
77 GRAPHQL_CLIENT_HTTP
78
79 $fatpacked{"GraphQL/Client/https.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_HTTPS';
80 package GraphQL::Client::https;use warnings;use strict;use parent 'GraphQL::Client::http';our$VERSION='0.604';sub new {my$class=shift;GraphQL::Client::http->new(@_)}1;
81 GRAPHQL_CLIENT_HTTPS
82
83 $fatpacked{"HTTP/AnyUA.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA';
84 package HTTP::AnyUA;use 5.010;use warnings;use strict;our$VERSION='0.904';use HTTP::AnyUA::Util;use Module::Loader;use Scalar::Util;our$BACKEND_NAMESPACE;our$MIDDLEWARE_NAMESPACE;our@BACKENDS;our%REGISTERED_BACKENDS;BEGIN {$BACKEND_NAMESPACE=__PACKAGE__ .'::Backend';$MIDDLEWARE_NAMESPACE=__PACKAGE__ .'::Middleware'}sub _debug_log {print STDERR join(' ',@_),"\n" if$ENV{PERL_HTTP_ANYUA_DEBUG}}sub _croak {require Carp;Carp::croak(@_)}sub _usage {_croak("Usage: @_\n")}sub new {my$class=shift;unshift @_,'ua' if @_ % 2;my%args=@_;$args{ua}or _usage(q{HTTP::AnyUA->new(ua => $user_agent, %attr)});my$self;my@attr=qw(ua backend response_is_future);for my$attr (@attr){$self->{$attr}=$args{$attr}if defined$args{$attr}}bless$self,$class;$self->_debug_log('Created with user agent',$self->ua);$self->ua;$self->response_is_future($args{response_is_future})if defined$args{response_is_future};return$self}sub ua {shift->{ua}or _croak 'User agent is required'}sub response_is_future {my$self=shift;my$val=shift;if (defined$val){$self->_debug_log('Set response_is_future to',$val ? 'ON' : 'OFF');$self->_check_response_is_future($val);$self->{response_is_future}=$val;$self->_module_loader->load('Future')if$self->{response_is_future}}elsif (!defined$self->{response_is_future}&& $self->{backend}){$self->{response_is_future}=$self->backend->response_is_future;$self->_module_loader->load('Future')if$self->{response_is_future}}return$self->{response_is_future}|| ''}sub backend {my$self=shift;return$self->{backend}if defined$self->{backend};$self->{backend}=$self->_build_backend;$self->_check_response_is_future($self->response_is_future);return$self->{backend}}sub request {my ($self,$method,$url,$args)=@_;$args ||= {};@_==3 || (@_==4 && ref$args eq 'HASH')or _usage(q{$any_ua->request($method, $url, \%options)});my$resp=eval {$self->backend->request(uc($method)=>$url,$args)};if (my$err=$@){return$self->_wrap_internal_exception($err)}return$self->_wrap_response($resp)}for my$sub_name (qw{get head put post delete}){my%swap=(SUBNAME=>$sub_name,METHOD=>uc($sub_name));my$code=q[
85 sub {{SUBNAME}} {
86 my ($self, $url, $args) = @_;
87 @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
88 or _usage(q{$any_ua->{{SUBNAME}}($url, \%options)});
89 return $self->request('{{METHOD}}', $url, $args);
90 }
91 ];$code =~ s/\{\{([A-Z_]+)\}\}/$swap{$1}/ge;eval$code}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or _usage(q{$any_ua->post_form($url, $formdata, \%options)});my$headers=HTTP::AnyUA::Util::normalize_headers($args->{headers});delete$args->{headers};return$self->request(POST=>$url,{%$args,content=>HTTP::AnyUA::Util::www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded',},})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or _usage(q{$any_ua->mirror($url, $filepath, \%options)});$args->{headers}=HTTP::AnyUA::Util::normalize_headers($args->{headers});if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= HTTP::AnyUA::Util::http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen(my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY())or return$self->_wrap_internal_exception(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print$fh $_[0]};my$resp=$self->request(GET=>$url,$args);my$finish=sub {my$resp=shift;close$fh or return HTTP::AnyUA::Util::internal_exception(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($resp->{success}){rename($tempfile,$file)or return HTTP::AnyUA::Util::internal_exception(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$resp->{headers}{'last-modified'};if ($lm and my$mtime=HTTP::AnyUA::Util::parse_http_date($lm)){utime($mtime,$mtime,$file)}}unlink($tempfile);$resp->{success}||= $resp->{status}eq '304';return$resp};if ($self->response_is_future){return$resp->followed_by(sub {my$future=shift;my@resp=$future->is_done ? $future->get : $future->failure;my$resp=$finish->(@resp);if ($resp->{success}){return Future->done(@resp)}else {return Future->fail(@resp)}})}else {return$finish->($resp)}}sub apply_middleware {my$self=shift;my$class=shift;if (!ref$class){$class="${MIDDLEWARE_NAMESPACE}::${class}" unless$class =~ s/^\+//;$self->_module_loader->load($class)}$self->{backend}=$class->wrap($self->backend,@_);$self->_check_response_is_future($self->response_is_future);return$self}sub register_backend {my ($class,$ua_type,$backend_class)=@_;@_==3 or _usage(q{HTTP::AnyUA->register_backend($ua_type, $backend_package)});if ($backend_class){$backend_class="${BACKEND_NAMESPACE}::${backend_class}" unless$backend_class =~ s/^\+//;$REGISTERED_BACKENDS{$ua_type}=$backend_class}else {delete$REGISTERED_BACKENDS{$ua_type}}}sub _wrap_response {my$self=shift;my$resp=shift;if ($self->response_is_future &&!$self->backend->response_is_future){if ($resp->{success}){$self->_debug_log('Wrapped successful response in a Future');$resp=Future->done($resp)}else {$self->_debug_log('Wrapped failed response in a Future');$resp=Future->fail($resp)}}return$resp}sub _wrap_internal_exception {shift->_wrap_response(HTTP::AnyUA::Util::internal_exception(@_))}sub _module_loader {shift->{_module_loader}||= Module::Loader->new}sub _build_backend {my$self=shift;my$ua=shift || $self->ua or _croak 'User agent is required';my$ua_type=Scalar::Util::blessed($ua);my@classes;if ($ua_type){push@classes,$REGISTERED_BACKENDS{$ua_type}if$REGISTERED_BACKENDS{$ua_type};push@classes,"${BACKEND_NAMESPACE}::${ua_type}";if (!@BACKENDS){@BACKENDS=sort$self->_module_loader->find_modules($BACKEND_NAMESPACE);$self->_debug_log('Found backends to try (' .join(', ',@BACKENDS).')')}for my$backend_type (@BACKENDS){my$plugin=$backend_type;$plugin =~ s/^\Q${BACKEND_NAMESPACE}\E:://;push@classes,$backend_type if$ua->isa($plugin)}}else {push@classes,$REGISTERED_BACKENDS{$ua}if$REGISTERED_BACKENDS{$ua};push@classes,"${BACKEND_NAMESPACE}::${ua}"}for my$class (@classes){if (eval {$self->_module_loader->load($class);1}){$self->_debug_log("Found usable backend (${class})");return$class->new($self->ua)}else {$self->_debug_log($@)}}_croak 'Cannot find a usable backend that supports the given user agent'}sub _check_response_is_future {my$self=shift;my$val=shift;if (!$val && $self->{backend}&& $self->backend->response_is_future){_croak 'Cannot disable response_is_future with a non-blocking user agent'}}1;
92 HTTP_ANYUA
93
94 $fatpacked{"HTTP/AnyUA/Backend.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND';
95 package HTTP::AnyUA::Backend;use warnings;use strict;our$VERSION='0.904';sub new {my$class=shift;my$ua=shift or die 'User agent is required';bless {ua=>$ua},$class}sub request {die 'Not yet implemented'}sub ua {shift->{ua}}sub response_is_future {0}1;
96 HTTP_ANYUA_BACKEND
97
98 $fatpacked{"HTTP/AnyUA/Backend/AnyEvent/HTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_ANYEVENT_HTTP';
99 package HTTP::AnyUA::Backend::AnyEvent::HTTP;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';use Future;use HTTP::AnyUA::Util;my$future_class;BEGIN {$future_class='Future';eval 'use AnyEvent::Future';$future_class='AnyEvent::Future' if!$@}sub options {@_==2 ? $_[0]->{options}=pop : $_[0]->{options}}sub response_is_future {1}sub request {my$self=shift;my ($method,$url,$args)=@_;my%opts=$self->_munge_request($method,$url,$args);my$future=$future_class->new;require AnyEvent::HTTP;AnyEvent::HTTP::http_request($method=>$url,%opts,sub {my$resp=$self->_munge_response(@_,$args->{data_callback});if ($resp->{success}){$future->done($resp)}else {$future->fail($resp)}});return$future}sub _munge_request {my$self=shift;my$method=shift;my$url=shift;my$args=shift || {};my%opts=%{$self->options || {}};if (my$headers=$args->{headers}){my%headers;for my$header (keys %$headers){my$value=$headers->{$header};$value=join(', ',@$value)if ref($value)eq 'ARRAY';$headers{$header}=$value}$opts{headers}=\%headers}my@url_parts=HTTP::AnyUA::Util::split_url($url);if (my$auth=$url_parts[4]and!$opts{headers}{'authorization'}){require MIME::Base64;$opts{headers}{'authorization'}='Basic ' .MIME::Base64::encode_base64($auth,'')}my$content=HTTP::AnyUA::Util::coderef_content_to_string($args->{content});$opts{body}=$content if$content;if (my$data_cb=$args->{data_callback}){$opts{on_body}=sub {my$data=shift;$data_cb->($data,$self->_munge_response(undef,@_));1}}return%opts}sub _munge_response {my$self=shift;my$data=shift;my$headers=shift;my$data_cb=shift;my%headers=%$headers;my$code=delete$headers{Status};my$reason=delete$headers{Reason};my$url=delete$headers{URL};my$resp={success=>200 <= $code && $code <= 299,url=>$url,status=>$code,reason=>$reason,headers=>\%headers,};my$version=delete$headers{HTTPVersion};$resp->{protocol}="HTTP/$version" if$version;$resp->{content}=$data if$data &&!$data_cb;my@redirects;my$redirect=delete$headers{Redirect};while ($redirect){my$next=delete$redirect->[1]{Redirect};unshift@redirects,$self->_munge_response(@$redirect);$redirect=$next}$resp->{redirects}=\@redirects if@redirects;if (590 <= $code && $code <= 599){HTTP::AnyUA::Util::internal_exception($reason,$resp)}return$resp}1;
100 HTTP_ANYUA_BACKEND_ANYEVENT_HTTP
101
102 $fatpacked{"HTTP/AnyUA/Backend/Furl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_FURL';
103 package HTTP::AnyUA::Backend::Furl;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';use HTTP::AnyUA::Util;sub request {my$self=shift;my ($method,$url,$args)=@_;local$args->{content}=HTTP::AnyUA::Util::coderef_content_to_string($args->{content});my$request=HTTP::AnyUA::Util::native_to_http_request(@_);my$ua_resp=$self->ua->request($request);return$self->_munge_response($ua_resp,$args->{data_callback})}sub _munge_response {my$self=shift;my$ua_resp=shift;my$data_cb=shift;my$resp={success=>!!$ua_resp->is_success,url=>$ua_resp->request->uri->as_string,status=>$ua_resp->code,reason=>$ua_resp->message,headers=>HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers),};$resp->{protocol}=$ua_resp->protocol if$ua_resp->protocol;if ($resp->{headers}{'x-internal-response'}){HTTP::AnyUA::Util::internal_exception($ua_resp->content,$resp)}elsif ($data_cb){$data_cb->($ua_resp->content,$resp)}else {$resp->{content}=$ua_resp->content}return$resp}1;
104 HTTP_ANYUA_BACKEND_FURL
105
106 $fatpacked{"HTTP/AnyUA/Backend/HTTP/AnyUA.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_HTTP_ANYUA';
107 package HTTP::AnyUA::Backend::HTTP::AnyUA;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';sub response_is_future {my$self=shift;return$self->ua->response_is_future}sub request {my$self=shift;return$self->ua->request(@_)}1;
108 HTTP_ANYUA_BACKEND_HTTP_ANYUA
109
110 $fatpacked{"HTTP/AnyUA/Backend/HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_HTTP_TINY';
111 package HTTP::AnyUA::Backend::HTTP::Tiny;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';sub request {my$self=shift;return$self->ua->request(@_)}1;
112 HTTP_ANYUA_BACKEND_HTTP_TINY
113
114 $fatpacked{"HTTP/AnyUA/Backend/LWP/UserAgent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_LWP_USERAGENT';
115 package HTTP::AnyUA::Backend::LWP::UserAgent;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';use HTTP::AnyUA::Util;sub request {my$self=shift;my ($method,$url,$args)=@_;my$r=HTTP::AnyUA::Util::native_to_http_request(@_);my$ua_resp=$self->ua->request($r);return$self->_munge_response($ua_resp,$args->{data_callback})}sub _munge_response {my$self=shift;my$ua_resp=shift;my$data_cb=shift;my$recurse=shift;my$resp={success=>!!$ua_resp->is_success,url=>$ua_resp->request->uri->as_string,status=>$ua_resp->code,reason=>$ua_resp->message,headers=>HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers),};$resp->{protocol}=$ua_resp->protocol if$ua_resp->protocol;if (!$recurse){for my$redirect ($ua_resp->redirects){push @{$resp->{redirects}||= []},$self->_munge_response($redirect,undef,1)}}my$content_ref=$ua_resp->content_ref;if (($resp->{headers}{'client-warning'}|| '')eq 'Internal response'){HTTP::AnyUA::Util::internal_exception($$content_ref,$resp)}elsif ($data_cb){$data_cb->($$content_ref,$resp)}else {$resp->{content}=$$content_ref}return$resp}1;
116 HTTP_ANYUA_BACKEND_LWP_USERAGENT
117
118 $fatpacked{"HTTP/AnyUA/Backend/Mojo/UserAgent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_MOJO_USERAGENT';
119 package HTTP::AnyUA::Backend::Mojo::UserAgent;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';use Future;use Scalar::Util;my$future_class;BEGIN {$future_class='Future';eval 'use Future::Mojo';$future_class='Future::Mojo' if!$@}sub response_is_future {1}sub request {my$self=shift;my ($method,$url,$args)=@_;my$future=$future_class->new;my$tx=$self->_munge_request(@_);$self->ua->start($tx=>sub {my$ua=shift;my$tx=shift;my$resp=$self->_munge_response($tx,$args->{data_callback});if ($resp->{success}){$future->done($resp)}else {$future->fail($resp)}});return$future}sub _munge_request {my$self=shift;my$method=shift;my$url=shift;my$args=shift;my$headers=$args->{headers}|| {};my$content=$args->{content};my@content;my$content_length;if ($content){for my$header (keys %$headers){if (lc($header)eq 'content-length'){$content_length=$headers->{$header};last}}$content=HTTP::AnyUA::Util::coderef_content_to_string($content)if!$content_length;push@content,$content if ref($content)ne 'CODE'}my$tx=$self->ua->build_tx($method=>$url=>$headers=>@content);if (ref($content)eq 'CODE'){$tx->req->headers->content_length($content_length);my$drain;$drain=sub {my$body=shift;my$chunk=$content->()|| '';undef$drain if!$chunk;$body->write($chunk,$drain)};$tx->req->content->$drain}if (my$data_cb=$args->{data_callback}){my$tx_copy=$tx;Scalar::Util::weaken($tx_copy);$tx->res->content->unsubscribe('read')->on(read=>sub {my ($content,$bytes)=@_;my$resp=$self->_munge_response($tx_copy,undef);$data_cb->($bytes,$resp)})}return$tx}sub _munge_response {my$self=shift;my$tx=shift;my$data_cb=shift;my$recurse=shift;my$resp={success=>!!$tx->res->is_success,url=>$tx->req->url->to_string,status=>$tx->res->code,reason=>$tx->res->message,headers=>{},};my$headers=$tx->res->headers->to_hash;for my$header (keys %$headers){$resp->{headers}{lc($header)}=delete$headers->{$header}}my$version=$tx->res->version;$resp->{protocol}="HTTP/$version" if$version;if (!$recurse){for my$redirect (@{$tx->redirects}){push @{$resp->{redirects}||= []},$self->_munge_response($redirect,undef,1)}}my$err=$tx->error;if ($err &&!$err->{code}){return HTTP::AnyUA::Util::internal_exception($err->{message},$resp)}my$body=$tx->res->body;$resp->{content}=$body if$body &&!$data_cb;return$resp}1;
120 HTTP_ANYUA_BACKEND_MOJO_USERAGENT
121
122 $fatpacked{"HTTP/AnyUA/Backend/Net/Curl/Easy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_BACKEND_NET_CURL_EASY';
123 package HTTP::AnyUA::Backend::Net::Curl::Easy;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Backend';use HTTP::AnyUA::Util;use Scalar::Util;sub request {my$self=shift;my ($method,$url,$args)=@_;my$ua=$self->ua;$ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(),0);$ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(),0);$ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(),undef);$ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(),undef);$ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(),0);if ($method eq 'GET'){$ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(),1)}elsif ($method eq 'HEAD'){$ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(),1)}if (my$content=$args->{content}){if (ref($content)eq 'CODE'){my$content_length;for my$header (keys %{$args->{headers}|| {}}){if (lc($header)eq 'content-length'){$content_length=$args->{headers}{$header};last}}if ($content_length){my$chunk;$ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(),sub {my$ua=shift;my$maxlen=shift;if (!$chunk){$chunk=$content->();return 0 if!$chunk}my$part=substr($chunk,0,$maxlen,'');return \$part});$ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(),$content_length)}else {$content=HTTP::AnyUA::Util::coderef_content_to_string($content)}}if (ref($content)ne 'CODE'){$ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(),$content);$ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(),length$content)}}$ua->setopt(Net::Curl::Easy::CURLOPT_URL(),$url);$ua->setopt(Net::Curl::Easy::CURLOPT_CUSTOMREQUEST(),$method);my@headers;for my$header (keys %{$args->{headers}|| {}}){my$value=$args->{headers}{$header};my@values=ref($value)eq 'ARRAY' ? @$value : $value;for my$v (@values){push@headers,"${header}: $v"}}$ua->setopt(Net::Curl::Easy::CURLOPT_HTTPHEADER(),\@headers)if@headers;my@hdrdata;$ua->setopt(Net::Curl::Easy::CURLOPT_HEADERFUNCTION(),sub {my$ua=shift;my$data=shift;my$size=length$data;my%headers=_parse_header($data);if ($headers{Status}){push@hdrdata,{}}my$resp_headers=$hdrdata[-1];for my$key (keys%headers){if (!$resp_headers->{$key}){$resp_headers->{$key}=$headers{$key}}else {if (ref($resp_headers->{$key})ne 'ARRAY'){$resp_headers->{$key}=[$resp_headers->{$key}]}push @{$resp_headers->{$key}},$headers{$key}}}return$size});my$resp_body='';my$data_cb=$args->{data_callback};my$copy=$self;Scalar::Util::weaken($copy);$ua->setopt(Net::Curl::Easy::CURLOPT_WRITEFUNCTION(),sub {my$ua=shift;my$data=shift;my$fh=shift;my$size=length$data;if ($data_cb){my$resp=$copy->_munge_response(undef,undef,[@hdrdata],$data_cb);$data_cb->($data,$resp)}else {print$fh $data}return$size});open(my$fileb,'>',\$resp_body);$ua->setopt(Net::Curl::Easy::CURLOPT_WRITEDATA(),$fileb);eval {$ua->perform};my$ret=$@;return$self->_munge_response($ret,$resp_body,[@hdrdata],$data_cb)}sub _munge_response {my$self=shift;my$error=shift;my$body=shift;my$hdrdata=shift;my$data_cb=shift;my%headers=%{pop @$hdrdata || {}};my$code=delete$headers{Status}|| $self->ua->getinfo(Net::Curl::Easy::CURLINFO_RESPONSE_CODE())|| 599;my$reason=delete$headers{Reason};my$url=$self->ua->getinfo(Net::Curl::Easy::CURLINFO_EFFECTIVE_URL());my$resp={success=>200 <= $code && $code <= 299,url=>$url,status=>$code,reason=>$reason,headers=>\%headers,};my$version=delete$headers{HTTPVersion}|| _http_version($self->ua->getinfo(Net::Curl::Easy::CURLINFO_HTTP_VERSION()));$resp->{protocol}="HTTP/$version" if$version;if ($error){my$err=$self->ua->strerror($error);return HTTP::AnyUA::Util::internal_exception($err,$resp)}$resp->{content}=$body if$body &&!$data_cb;return$resp}sub _http_version {my$version=shift;return$version==Net::Curl::Easy::CURL_HTTP_VERSION_1_0()? '1.0' : $version==Net::Curl::Easy::CURL_HTTP_VERSION_1_1()? '1.1' : $version==Net::Curl::Easy::CURL_HTTP_VERSION_2_0()? '2.0' : ''}sub _parse_header {my$data=shift;$data =~ s/[\x0A\x0D]*$//;if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x){return (HTTPVersion=>$1,Status=>$2,Reason=>$3,)}my ($key,$val)=split(/:\s*/,$data,2);return if!$key;return (lc($key)=>$val)}1;
124 HTTP_ANYUA_BACKEND_NET_CURL_EASY
125
126 $fatpacked{"HTTP/AnyUA/Middleware.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_MIDDLEWARE';
127 package HTTP::AnyUA::Middleware;use warnings;use strict;our$VERSION='0.904';sub _croak {require Carp;Carp::croak(@_)}sub _usage {_croak("Usage: @_\n")}sub new {my$class=shift;my$backend=shift or die 'Backend is required';my$self=bless {backend=>$backend},$class;$self->init(@_);return$self}sub init {}sub wrap {my$self=shift;my$backend=shift or _usage($self .q{->wrap($backend, %args)});if (ref$self){$self->{backend}=$backend}else {$self=$self->new($backend,@_)}return$self}sub request {shift->backend->request(@_)}sub backend {shift->{backend}}sub ua {shift->backend->ua(@_)}sub response_is_future {shift->backend->response_is_future(@_)}1;
128 HTTP_ANYUA_MIDDLEWARE
129
130 $fatpacked{"HTTP/AnyUA/Middleware/ContentLength.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_MIDDLEWARE_CONTENTLENGTH';
131 package HTTP::AnyUA::Middleware::ContentLength;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Middleware';use HTTP::AnyUA::Util;sub request {my$self=shift;my ($method,$url,$args)=@_;$args->{headers}=HTTP::AnyUA::Util::normalize_headers($args->{headers});if (!defined$args->{headers}{'content-length'}&& $args->{content}&&!ref$args->{content}){$args->{headers}{'content-length'}=length$args->{content}}return$self->backend->request($method,$url,$args)}1;
132 HTTP_ANYUA_MIDDLEWARE_CONTENTLENGTH
133
134 $fatpacked{"HTTP/AnyUA/Middleware/RequestHeaders.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_MIDDLEWARE_REQUESTHEADERS';
135 package HTTP::AnyUA::Middleware::RequestHeaders;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Middleware';use HTTP::AnyUA::Util;sub init {my$self=shift;my%args=@_;$self->{override}=!!$args{override};$self->{headers}=HTTP::AnyUA::Util::normalize_headers($args{headers})}sub request {my$self=shift;my ($method,$url,$args)=@_;if ($self->override){$args->{headers}={%{HTTP::AnyUA::Util::normalize_headers($args->{headers})},%{$self->headers},}}else {$args->{headers}={%{$self->headers},%{HTTP::AnyUA::Util::normalize_headers($args->{headers})},}}return$self->backend->request($method,$url,$args)}sub headers {shift->{headers}}sub override {shift->{override}}1;
136 HTTP_ANYUA_MIDDLEWARE_REQUESTHEADERS
137
138 $fatpacked{"HTTP/AnyUA/Middleware/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_MIDDLEWARE_RUNTIME';
139 package HTTP::AnyUA::Middleware::Runtime;use warnings;use strict;our$VERSION='0.904';use parent 'HTTP::AnyUA::Middleware';use Time::HiRes;sub request {my$self=shift;my ($method,$url,$args)=@_;my$start=[Time::HiRes::gettimeofday];my$resp=$self->backend->request($method,$url,$args);my$handle_response=sub {my$resp=shift;$resp->{runtime}=sprintf('%.6f',Time::HiRes::tv_interval($start));return$resp};if ($self->response_is_future){$resp=$resp->transform(done=>$handle_response,fail=>$handle_response,)}else {$resp=$handle_response->($resp)}return$resp}1;
140 HTTP_ANYUA_MIDDLEWARE_RUNTIME
141
142 $fatpacked{"HTTP/AnyUA/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA_UTIL';
143 package HTTP::AnyUA::Util;use warnings;use strict;our$VERSION='0.904';use Exporter qw(import);our@EXPORT_OK=qw(http_headers_to_native native_to_http_request coderef_content_to_string normalize_headers internal_exception http_date parse_http_date uri_escape www_form_urlencode);sub _croak {require Carp;Carp::croak(@_)}sub _usage {_croak("Usage: @_\n")}sub coderef_content_to_string {my$content=shift;return$content if!$content;if (ref($content)eq 'CODE'){my$body='';while (my$chunk=$content->()){$body .= $chunk}$content=$body}return$content}sub native_to_http_request {my$method=shift;my$url=shift;my$args=shift || {};my$headers=[];my$content=$args->{content};for my$header (keys %{$args->{headers}|| {}}){my$value=$args->{headers}{$header};my@values=ref($value)eq 'ARRAY' ? @$value : ($value);for my$v (@values){push @$headers,($header=>$v)}}require HTTP::Request;return HTTP::Request->new($method,$url,$headers,$content)}sub http_headers_to_native {my$http_headers=shift;my$native;for my$header ($http_headers->header_field_names){my@values=$http_headers->header($header);$native->{lc($header)}=@values==1 ? $values[0]: [@values]}return$native}sub normalize_headers {my$headers_in=shift;my$headers={};if (defined$headers_in){while (my ($key,$value)=each %{$headers_in || {}}){$headers->{lc($key)}=$value}}return$headers}sub internal_exception {my$e=shift or _usage(q{internal_exception($exception)});my$resp=shift || {};$e="$e";$resp->{headers}{'client-original-status'}=$resp->{status}if$resp->{status};$resp->{headers}{'client-original-reason'}=$resp->{reason}if$resp->{reason};$resp->{success}='';$resp->{status}=599;$resp->{reason}='Internal Exception';$resp->{content}=$e;$resp->{headers}{'content-type'}='text/plain';$resp->{headers}{'content-length'}=length$e;return$resp}sub split_url {my$url=shift or _usage(q{split_url($url)});my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW='Sun|Mon|Tue|Wed|Thu|Fri|Sat';my$MoY='Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';sub http_date {my$time=shift or _usage(q{http_date($time)});my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($time);return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT',substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub parse_http_date {my$str=shift or _usage(q{parse_http_date($str)});my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}require Time::Local;return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf('%%%02X',$_)}0..255;$escapes{' '}='+';my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub uri_escape {my$str=shift or _usage(q{uri_escape($str)});if ($] ge '5.008'){utf8::encode($str)}else {$str=pack('U*',unpack('C*',$str))if (length$str==do {use bytes;length$str});$str=pack('C*',unpack('C*',$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}sub www_form_urlencode {my$data=shift;($data && ref$data)or _usage(q{www_form_urlencode($dataref)});(ref$data eq 'HASH' || ref$data eq 'ARRAY')or _croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or _croak("form data reference must have an even number of terms\n");my@terms;while (@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join('=',map {uri_escape($_)}$key,$value)}}return join('&',ref($data)eq 'ARRAY' ? @terms : sort@terms)}1;
144 HTTP_ANYUA_UTIL
145
146 $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
147 package HTTP::Tiny;use strict;use warnings;our$VERSION='0.076';sub _croak {require Carp;Carp::croak(@_)}my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[0]->{$accessor}=$_[1]}: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub timeout {my ($self,$timeout)=@_;if (@_ > 1){$self->{timeout}=$timeout;if ($self->{handle}){$self->{handle}->timeout($timeout)}}return$self->{timeout}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>defined$args{timeout}? $args{timeout}: 60,keep_alive=>1,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){local$ENV{HTTP_PROXY}if$ENV{REQUEST_METHOD};$self->{http_proxy}=$ENV{http_proxy}|| $ENV{HTTP_PROXY}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (exists$args->{headers}){my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}$args->{headers}=$headers}if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= $self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or _croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||= $response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||= {};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e=$@){if (ref$e eq 'HASH' && exists$e->{status}){$e->{redirects}=delete$args->{_redirects}if @{$args->{_redirects}|| []};return$e}$e="$e";$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,},(@{$args->{_redirects}|| []}? (redirects=>delete$args->{_redirects}): ()),}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or _croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or _croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",(ref$data eq 'ARRAY')? (@terms): (sort@terms))}sub can_ssl {my ($self)=@_;my($ok,$reason)=(1,'');local@INC=@INC;pop@INC if$INC[-1]eq '.';unless (eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)}){$ok=0;$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/}unless (eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}){$ok=0;$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/}if (ref($self)&& ($self->{verify_SSL}|| $self->{SSL_options}{SSL_verify_mode})){my$handle=HTTP::Tiny::Handle->new(SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},);unless (eval {$handle->_find_CA_file;1}){$ok=0;$reason .= "$@"}}wantarray ? ($ok,$reason): $ok}sub connected {my ($self)=@_;if ($self->{handle}&& $self->{handle}{fh}){my$socket=$self->{handle}{fh};if ($socket->connected){return wantarray ? ($socket->peerhost,$socket->peerport): join(':',$socket->peerhost,$socket->peerport)}}return}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .$class->VERSION}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$peer=$args->{peer}|| $host;if ('CODE' eq ref$peer){$peer=$peer->($host)}my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port,$peer)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$scheme,$host,$port,$peer);$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};my@redir_args=$self->_maybe_redirect($request,$response,$args);my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$cb_args=@redir_args ? +{}: $args;my$data_cb=$self->_prepare_data_cb($response,$cb_args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;if (@redir_args){push @{$args->{_redirects}},$response;return$self->_request(@redir_args,$args)}$response->{redirects}=delete$args->{_redirects}if @{$args->{_redirects}};return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port,$peer)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port,$peer)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){_croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){_croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {_croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port,$p_host);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){_croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v;$request->{header_case}{lc$k}=$k}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="Basic " .MIME::Base64::encode_base64($auth,"");return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){_croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});$args->{_redirects}||= [];if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and @{$args->{_redirects}}< $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW="Sun|Mon|Tue|Wed|Thu|Fri|Sat";my$MoY="Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";sub _http_date {my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($_[1]);return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub _parse_http_date {my ($self,$str)=@_;require Time::Local;my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/g;return$str}package HTTP::Tiny::Handle;use strict;use warnings;use Errno qw[EINTR EPIPE];use IO::Socket qw[SOCK_STREAM];use Socket qw[SOL_SOCKET SO_KEEPALIVE];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';sub BUFSIZE () {32768}my$Printable=sub {local $_=shift;s/\r/\\r/g;s/\n/\\n/g;s/\t/\\t/g;s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;$_};my$Token=qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;my$Field_Content=qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;sub new {my ($class,%args)=@_;return bless {rbuf=>'',timeout=>60,max_line_size=>16384,max_header_lines=>64,verify_SSL=>0,SSL_options=>{},%args },$class}sub timeout {my ($self,$timeout)=@_;if (@_ > 1){$self->{timeout}=$timeout;if ($self->{fh}&& $self->{fh}->can('timeout')){$self->{fh}->timeout($timeout)}}return$self->{timeout}}sub connect {@_==5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ ."\n");my ($self,$scheme,$host,$port,$peer)=@_;if ($scheme eq 'https'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$peer,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},)or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);if ($self->{keep_alive}){unless (defined($self->{fh}->setsockopt(SOL_SOCKET,SO_KEEPALIVE,1))){CORE::close($self->{fh});die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/)}}$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{peer}=$peer;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||= {};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers header_case/});$self->write_body($request)if$request->{cb};return}my@rfc_request_headers=qw(Accept Accept-Charset Accept-Encoding Accept-Language Authorization Cache-Control Connection Content-Length Expect From Host If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer Transfer-Encoding Upgrade User-Agent Via);my@other_request_headers=qw(Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin X-XSS-Protection);my%HeaderCase=map {lc($_)=>$_}@rfc_request_headers,@other_request_headers;sub write_header_lines {(@_ >= 2 && @_ <= 4 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ ."\n");my($self,$headers,$header_case,$prefix_data)=@_;$header_case ||= {};my$buf=(defined$prefix_data ? $prefix_data : '');my%seen;for my$k (qw/host cache-control expect max-forwards pragma range te/){next unless exists$headers->{$k};$seen{$k}++;my$field_name=$HeaderCase{$k};my$v=$headers->{$k};for (ref$v eq 'ARRAY' ? @$v : $v){$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}while (my ($k,$v)=each %$headers){my$field_name=lc$k;next if$seen{$field_name};if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {if (exists$header_case->{$field_name}){$field_name=$header_case->{$field_name}}else {$field_name =~ s/\b(\w)/\u$1/g}$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){s/\x0D?\x0A\s+/ /g;die(qq/Invalid HTTP header field value ($field_name): / .$Printable->($_)."\n")unless $_ eq '' || /\A $Field_Content \z/xo;$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||= $response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}return length($self->{rbuf})==0}my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1));return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return 1}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");if (ref$request->{trailer_cb}eq 'CODE'){$self->write_header_lines($request->{trailer_cb}->())}else {$self->write("\x0D\x0A")}return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ ."\n");my ($self,$method,$request_uri,$headers,$header_case)=@_;return$self->write_header_lines($headers,$header_case,"$method $request_uri HTTP/1.1\x0D\x0A")}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _assert_ssl {my($ok,$reason)=HTTP::Tiny->can_ssl();die$reason unless$ok}sub can_reuse {my ($self,$scheme,$host,$port,$peer)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| $peer ne $self->{peer}|| eval {$self->can_read(0)}|| $@ ;return 1}sub _find_CA_file {my$self=shift();my$ca_file=defined($self->{SSL_options}->{SSL_ca_file})? $self->{SSL_options}->{SSL_ca_file}: $ENV{SSL_CERT_FILE};if (defined$ca_file){unless (-r $ca_file){die qq/SSL_ca_file '$ca_file' not found or not readable\n/}return$ca_file}local@INC=@INC;pop@INC if$INC[-1]eq '.';return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA;1};for my$ca_bundle ("/etc/ssl/certs/ca-certificates.crt","/etc/pki/tls/certs/ca-bundle.crt","/etc/ssl/ca-bundle.pem","/etc/openssl/certs/ca-certificates.crt","/etc/ssl/cert.pem","/usr/local/share/certs/ca-root-nss.crt","/etc/pki/tls/cacert.pem","/etc/certs/ca-certificates.crt",){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _get_tid {no warnings 'reserved';return threads->can("tid")? threads->tid : 0}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1;
148 sub $sub_name {
149 my (\$self, \$url, \$args) = \@_;
150 \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
151 or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
152 return \$self->request('$req_method', \$url, \$args || {});
153 }
154 HERE
155 HTTP_TINY
156
157 $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
158 package JSON::PP;use 5.005;use strict;use Exporter ();BEGIN {@JSON::PP::ISA=('Exporter')}use overload ();use JSON::PP::Boolean;use Carp ();$JSON::PP::VERSION='4.04';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant P_ALLOW_TAGS=>19;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;use constant USE_B=>$ENV{PERL_JSON_PP_USE_B}|| 0;BEGIN {if (USE_B){require B}}BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown allow_tags);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if (OLD_PERL){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$property_id='P_' .uc($name);eval qq/
159 sub $name {
160 my \$enable = defined \$_[1] ? \$_[1] : 1;
161
162 if (\$enable) {
163 \$_[0]->{PROPS}->[$property_id] = 1;
164 }
165 else {
166 \$_[0]->{PROPS}->[$property_id] = 0;
167 }
168
169 \$_[0];
170 }
171
172 sub get_$name {
173 \$_[0]->{PROPS}->[$property_id] ? 1 : '';
174 }
175 /}}my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent_length=>3,};$self->{PROPS}[P_ALLOW_NONREF]=1;bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub boolean_values {my$self=shift;if (@_){my ($false,$true)=@_;$self->{false}=$false;$self->{true}=$true;return ($false,$true)}else {delete$self->{false};delete$self->{true};return}}sub get_boolean_values {my$self=shift;if (exists$self->{true}and exists$self->{false}){return @$self{qw/false true/}}return}sub filter_json_object {if (defined $_[1]and ref $_[1]eq 'CODE'){$_[0]->{cb_object}=$_[1]}else {delete $_[0]->{cb_object}}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_==1 or @_ > 3){Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)")}if (defined $_[2]and ref $_[2]eq 'CODE'){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}else {delete $_[0]->{cb_sk_object}->{$_[1]};delete $_[0]->{cb_sk_object}unless %{$_[0]->{cb_sk_object}|| {}}}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");$_[0]->allow_bignum}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$allow_tags;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$props=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed,$allow_tags)=@{$props}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED,P_ALLOW_TAGS];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$props->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($props->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($allow_tags and $obj->can('FREEZE')){my$obj_class=ref$obj || $obj;$obj=bless$obj,$obj_class;my@results=$obj->FREEZE('JSON');if (@results and ref$results[0]){if (refaddr($obj)eq refaddr($results[0])){encode_error(sprintf("%s::FREEZE method returned same object as was passed instead of a new one",ref$obj))}}return '("'.$obj_class.'")['.join(',',@results).']'}if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));if ($allow_blessed){return$self->blessed_to_json($obj)if ($as_nonblessed);return 'null'}encode_error(sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)",$obj))}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,$self->string_to_json($k).$del .(ref$obj->{$k}? $self->object_to_json($obj->{$k}): $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{}' unless@res;return '{' .$pre .join(",$pre",@res).$post .'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,ref($v)? $self->object_to_json($v): $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[]' unless@res;return '[' .$pre .join(",$pre",@res).$post .']'}sub _looks_like_number {my$value=shift;if (USE_B){my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return 1 if$flags & (B::SVp_IOK()| B::SVp_NOK())and!($flags & B::SVp_POK());return}else {no warnings 'numeric';return if utf8::is_utf8($value);return unless length((my$dummy="")& $value);return unless 0 + $value eq $value;return 1 if$value * 0==0;return -1}}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$type=ref($value);if (!$type){if (_looks_like_number($value)){return$value}return$self->string_to_json($value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}else {if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bignum;my$singlequote;my$loose;my$allow_barekey;my$allow_tags;my$alt_true;my$alt_false;sub _detect_utf_encoding {my$text=shift;my@octets=unpack('C4',$text);return 'unknown' unless defined$octets[3];return ($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown'}sub PP_decode_json {my ($self,$want_offset);($self,$text,$want_offset)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$props=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bignum,$allow_barekey,$singlequote,$allow_tags)=@{$props}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE,P_ALLOW_TAGS];($alt_true,$alt_false)=@$self{qw/true false/};if ($utf8){$encoding=_detect_utf_encoding($text);if ($encoding ne 'UTF-8' and $encoding ne 'unknown'){require Encode;Encode::from_to($text,$encoding,'utf-8')}else {utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}white();decode_error("malformed JSON string, neither array, object, number, string or atom")unless defined$ch;my$result=value();if (!$props->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();return ($result,$consumed)if$want_offset;decode_error("garbage after JSON object")if defined$ch;$result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return tag()if($ch eq '(');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);my$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){if (!$relaxed or $ch ne "\t"){$at--;decode_error('invalid character encountered while parsing JSON string')}}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){next_chr()}elsif($relaxed and $ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}$at-- if defined$ch and $ch ne '';decode_error(", or ] expected while parsing array")}sub tag {decode_error('malformed JSON string, neither array, object, number, string or atom')unless$allow_tags;next_chr();white();my$tag=value();return unless defined$tag;decode_error('malformed JSON string, (tag) must be a string')if ref$tag;white();if (!defined$ch or $ch ne ')'){decode_error(') expected after tag')}next_chr();white();my$val=value();return unless defined$val;decode_error('malformed JSON string, tag value must be an array')unless ref$val eq 'ARRAY';if (!eval {$tag->can('THAW')}){decode_error('cannot decode perl-object (package does not exist)')if $@;decode_error('cannot decode perl-object (package does not have a THAW method)')}$tag->THAW('JSON',@$val)}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at-- if defined$ch and $ch ne '';decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return defined$alt_true ? $alt_true : $JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return defined$alt_false ? $alt_false : $JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;my$is_dec;my$is_exp;if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}if($ch eq '0'){my$peek=substr($text,$at,1);if($peek =~ /^[0-9a-dfA-DF]/){decode_error("malformed number (leading zero must not be followed by another digit)")}$n .= $ch;next_chr}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';$is_dec=1;next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;$is_exp=1;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($is_dec or $is_exp){if ($allow_bignum){require Math::BigFloat;return Math::BigFloat->new($v)}}else {if (length$v > $max_intsize){if ($allow_bignum){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}}return$is_dec ? $v/1.0 : 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?:
176 [\x00-\x7F]
177 |[\xC2-\xDF][\x80-\xBF]
178 |[\xE0][\xA0-\xBF][\x80-\xBF]
179 |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
180 |[\xED][\x80-\x9F][\x80-\xBF]
181 |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
182 |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
183 |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
184 |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
185 )$/x)? $is_valid_utf8 : ''}sub decode_error {my$error=shift;my$no_rep=shift;my$str=defined$text ? substr($text,$at): '';my$mess='';my$type='U*';if (OLD_PERL){my$type=$] < 5.006 ? 'C*' : utf8::is_utf8($str)? 'U*' : 'C*' }for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==0){return$o}elsif (@val==1){return$val[0]}else {Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar")}}my@val=$cb_object->($o)if ($cb_object);if (@val==0){return$o}elsif (@val==1){return$val[0]}else {Carp::croak("filter_json_object callbacks must not return more than one scalar")}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if (!OLD_PERL){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode;if ($] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q|
186 sub join {
187 return '' if (@_ < 2);
188 my $j = shift;
189 my $str = shift;
190 for (@_) { $str .= $j . $_; }
191 return $str;
192 }
193 |}}sub JSON::PP::incr_parse {local$Carp::CarpLevel=1;($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_parse(@_)}sub JSON::PP::incr_skip {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_skip}sub JSON::PP::incr_reset {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_reset}eval q{
194 sub JSON::PP::incr_text : lvalue {
195 $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
196
197 if ( $_[0]->{_incr_parser}->{incr_pos} ) {
198 Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
199 }
200 $_[0]->{_incr_parser}->{incr_text};
201 }
202 } if ($] >= 5.006)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};require B;my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {blessed $_[0]and ($_[0]->isa("JSON::PP::Boolean")or $_[0]->isa("Types::Serialiser::BooleanBase")or $_[0]->isa("JSON::XS::Boolean"))}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;use constant INCR_M_TFN=>6;use constant INCR_M_NUM=>7;$JSON::PP::IncrParser::VERSION='1.01';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_pos=>0,incr_mode=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}if (defined wantarray){my$max_size=$coder->get_max_size;my$p=$self->{incr_pos};my@ret;{do {unless ($self->{incr_nest}<= 0 and $self->{incr_mode}==INCR_M_JSON){$self->_incr_parse($coder);if ($max_size and $self->{incr_pos}> $max_size){Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size")}unless ($self->{incr_nest}<= 0 and $self->{incr_mode}==INCR_M_JSON){if ($self->{incr_mode}==INCR_M_WS and $self->{incr_pos}){$self->{incr_pos}=0;$self->{incr_text}=''}last}}my ($obj,$offset)=$coder->PP_decode_json($self->{incr_text},0x00000001);push@ret,$obj;use bytes;$self->{incr_text}=substr($self->{incr_text},$offset || 0);$self->{incr_pos}=0;$self->{incr_nest}=0;$self->{incr_mode}=0;last unless wantarray}while (wantarray)}if (wantarray){return@ret}else {return defined$ret[0]? $ret[0]: undef}}}sub _incr_parse {my ($self,$coder)=@_;my$text=$self->{incr_text};my$len=length$text;my$p=$self->{incr_pos};INCR_PARSE: while ($len > $p){my$s=substr($text,$p,1);last INCR_PARSE unless defined$s;my$mode=$self->{incr_mode};if ($mode==INCR_M_WS){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if (ord($s)> 0x20){if ($s eq '#'){$self->{incr_mode}=INCR_M_C0;redo INCR_PARSE}else {$self->{incr_mode}=INCR_M_JSON;redo INCR_PARSE}}$p++}}elsif ($mode==INCR_M_BS){$p++;$self->{incr_mode}=INCR_M_STR;redo INCR_PARSE}elsif ($mode==INCR_M_C0 or $mode==INCR_M_C1){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if ($s eq "\n"){$self->{incr_mode}=$self->{incr_mode}==INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;last}$p++}next}elsif ($mode==INCR_M_TFN){while ($len > $p){$s=substr($text,$p++,1);next if defined$s and $s =~ /[rueals]/;last}$p--;$self->{incr_mode}=INCR_M_JSON;last INCR_PARSE unless$self->{incr_nest};redo INCR_PARSE}elsif ($mode==INCR_M_NUM){while ($len > $p){$s=substr($text,$p++,1);next if defined$s and $s =~ /[0-9eE.+\-]/;last}$p--;$self->{incr_mode}=INCR_M_JSON;last INCR_PARSE unless$self->{incr_nest};redo INCR_PARSE}elsif ($mode==INCR_M_STR){while ($len > $p){$s=substr($text,$p,1);last INCR_PARSE unless defined$s;if ($s eq '"'){$p++;$self->{incr_mode}=INCR_M_JSON;last INCR_PARSE unless$self->{incr_nest};redo INCR_PARSE}elsif ($s eq '\\'){$p++;if (!defined substr($text,$p,1)){$self->{incr_mode}=INCR_M_BS;last INCR_PARSE}}$p++}}elsif ($mode==INCR_M_JSON){while ($len > $p){$s=substr($text,$p++,1);if ($s eq "\x00"){$p--;last INCR_PARSE}elsif ($s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20"){if (!$self->{incr_nest}){$p--;last INCR_PARSE}next}elsif ($s eq 't' or $s eq 'f' or $s eq 'n'){$self->{incr_mode}=INCR_M_TFN;redo INCR_PARSE}elsif ($s =~ /^[0-9\-]$/){$self->{incr_mode}=INCR_M_NUM;redo INCR_PARSE}elsif ($s eq '"'){$self->{incr_mode}=INCR_M_STR;redo INCR_PARSE}elsif ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}next}elsif ($s eq ']' or $s eq '}'){if (--$self->{incr_nest}<= 0){last INCR_PARSE}}elsif ($s eq '#'){$self->{incr_mode}=INCR_M_C1;redo INCR_PARSE}}}}$self->{incr_pos}=$p;$self->{incr_parsing}=$p ? 1 : 0}sub incr_text {if ($_[0]->{incr_pos}){Carp::croak("incr_text cannot be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_pos});$self->{incr_pos}=0;$self->{incr_mode}=0;$self->{incr_nest}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_pos}=0;$self->{incr_mode}=0;$self->{incr_nest}=0}1;
203 JSON_PP
204
205 $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
206 package JSON::PP::Boolean;use strict;require overload;local $^W;overload::import('overload',"0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);$JSON::PP::Boolean::VERSION='4.04';1;
207 JSON_PP_BOOLEAN
208
209 $fatpacked{"LV.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LV';
210 use 5.006;use strict;use warnings;package LV;our$AUTHORITY='cpan:TOBYINK';our$VERSION='0.006';BEGIN {*_subname=eval {require Sub::Name}? \&Sub::Name::subname : sub {$_[1]}};use Exporter ();our@ISA=qw(Exporter);our@EXPORT=qw(lvalue);our@EXPORT_OK=qw(get set);sub get (&;@) {my$caller=(caller(1))[3];get=>_subname("$caller~get",shift),@_}sub set (&;@) {my$caller=(caller(1))[3];set=>_subname("$caller~set",shift),@_}{my$i;sub implementation {return$i}sub _set_implementation {my$module=shift;*lvalue=$module->can('lvalue')or do {require Carp;Carp::croak("$module does not appear to be an LV backend")};$i=$module}}if ($ENV{PERL_LV_IMPLEMENTATION}){my$module=sprintf('LV::Backend::%s',$ENV{PERL_LV_IMPLEMENTATION});eval "require $module; 1" or do {require Carp;Carp::croak("Could not load LV backend $module")};_set_implementation($module)}else {my@implementations=qw(LV::Backend::Sentinel LV::Backend::Magic LV::Backend::Tie);for my$module (@implementations){if (eval "require $module; 1"){_set_implementation($module);last}}}unless (__PACKAGE__->can('lvalue')){require Carp;Carp::croak("No suitable backend found for lv")}1;
211 LV
212
213 $fatpacked{"LV/Backend/Magic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LV_BACKEND_MAGIC';
214 use 5.008;use strict;use warnings;package LV::Backend::Magic;our$AUTHORITY='cpan:TOBYINK';our$VERSION='0.006';use Carp;use Variable::Magic qw(wizard cast);my$wiz=wizard(data=>sub {$_[1]},set=>sub {$_[1]{set}->(${$_[0]});0},get=>sub {${$_[1]{var}}=$_[1]{get}->();0},);sub lvalue :lvalue {my%args=@_;unless ($args{set}&& $args{get}){my$caller=(caller(1))[3];$args{get}||= sub {require Carp;Carp::croak("$caller is writeonly")};$args{set}||= sub {require Carp;Carp::croak("$caller is readonly")}}$args{var}=\(my$var);cast($var,$wiz,\%args);$var}1;
215 LV_BACKEND_MAGIC
216
217 $fatpacked{"LV/Backend/Sentinel.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LV_BACKEND_SENTINEL';
218 use 5.008;use strict;use warnings;package LV::Backend::Sentinel;our$AUTHORITY='cpan:TOBYINK';our$VERSION='0.006';use Sentinel;sub lvalue :lvalue {my%args=@_;unless ($args{set}&& $args{get}){my$caller=(caller(1))[3];$args{get}||= sub {require Carp;Carp::croak("$caller is writeonly")};$args{set}||= sub {require Carp;Carp::croak("$caller is readonly")}}sentinel(%args)}1;
219 LV_BACKEND_SENTINEL
220
221 $fatpacked{"LV/Backend/Tie.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LV_BACKEND_TIE';
222 use 5.006;use strict;use warnings;package LV::Backend::Tie;our$AUTHORITY='cpan:TOBYINK';our$VERSION='0.006';sub lvalue :lvalue {my%args=@_;tie(my$var,'LV::Backend::Tie::TiedScalar',$args{get},$args{set});$var}package LV::Backend::Tie::TiedScalar;our$AUTHORITY='cpan:TOBYINK';our$VERSION='0.006';our@CARP_NOT=qw(LV LV::Backend::Tie);sub TIESCALAR {my$class=shift;my ($get,$set)=@_;unless ($set && $get){my$caller=(caller(2))[3];$get ||= sub {require Carp;Carp::croak("$caller is writeonly")};$set ||= sub {require Carp;Carp::croak("$caller is readonly")}}bless [$get,$set]=>$class}sub FETCH {&{shift->[0]}}sub STORE {&{shift->[1]}}1;
223 LV_BACKEND_TIE
224
225 $fatpacked{"Module/Implementation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_IMPLEMENTATION';
226 package Module::Implementation;$Module::Implementation::VERSION='0.09';use strict;use warnings;use Module::Runtime 0.012 qw(require_module);use Try::Tiny;unless (exists$Module::Implementation::{VERSION}&& ${$Module::Implementation::{VERSION}}){$Module::Implementation::{VERSION}=\42}my%Implementation;sub build_loader_sub {my$caller=caller();return _build_loader($caller,@_)}sub _build_loader {my$package=shift;my%args=@_;my@implementations=@{$args{implementations}};my@symbols=@{$args{symbols}|| []};my$implementation;my$env_var=uc$package;$env_var =~ s/::/_/g;$env_var .= '_IMPLEMENTATION';return sub {my ($implementation,$loaded)=_load_implementation($package,$ENV{$env_var},\@implementations,);$Implementation{$package}=$implementation;_copy_symbols($loaded,$package,\@symbols);return$loaded}}sub implementation_for {my$package=shift;return$Implementation{$package}}sub _load_implementation {my$package=shift;my$env_value=shift;my$implementations=shift;if ($env_value){die "$env_value is not a valid implementation for $package" unless grep {$_ eq $env_value}@{$implementations};my$requested="${package}::$env_value";($requested)=$requested =~ /^(.+)$/;try {require_module($requested)}catch {require Carp;Carp::croak("Could not load $requested: $_")};return ($env_value,$requested)}else {my$err;for my$possible (@{$implementations}){my$try="${package}::$possible";my$ok;try {require_module($try);$ok=1}catch {$err .= $_ if defined $_};return ($possible,$try)if$ok}require Carp;if (defined$err && length$err){Carp::croak("Could not find a suitable $package implementation: $err")}else {Carp::croak('Module::Runtime failed to load a module but did not throw a real error. This should never happen. Something is very broken')}}}sub _copy_symbols {my$from_package=shift;my$to_package=shift;my$symbols=shift;for my$sym (@{$symbols}){my$type=$sym =~ s/^([\$\@\%\&\*])// ? $1 : '&';my$from="${from_package}::$sym";my$to="${to_package}::$sym";{no strict 'refs';no warnings 'once';*{$to}=$type eq '&' ? \&{$from}: $type eq '$' ? \${$from}: $type eq '@' ? \@{$from}: $type eq '%' ? \%{$from}: $type eq '*' ? *{$from}: die "Can't copy symbol from $from_package to $to_package: $type$sym"}}}1;
227 MODULE_IMPLEMENTATION
228
229 $fatpacked{"Module/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_RUNTIME';
230 package Module::Runtime;BEGIN {require 5.006}BEGIN {${^WARNING_BITS}=""}our$VERSION="0.016";our@EXPORT_OK=qw($module_name_rx is_module_name is_valid_module_name check_module_name module_notional_filename require_module use_module use_package_optimistically $top_module_spec_rx $sub_module_spec_rx is_module_spec is_valid_module_spec check_module_spec compose_module_name);my%export_ok=map {($_=>undef)}@EXPORT_OK;sub import {my$me=shift;my$callpkg=caller(0);my$errs="";for(@_){if(exists$export_ok{$_}){if(/\A\$(.*)\z/s){*{$callpkg."::".$1}=\$$1}else {*{$callpkg."::".$_}=\&$_}}else {$errs .= "\"$_\" is not exported by the $me module\n"}}if($errs ne ""){die "${errs}Can't continue after import errors "."at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n"}}sub _is_string($) {my($arg)=@_;return defined($arg)&& ref(\$arg)eq "SCALAR"}our$module_name_rx=qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;my$qual_module_spec_rx=qr#(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;my$unqual_top_module_spec_rx=qr#[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;our$top_module_spec_rx=qr/$qual_module_spec_rx|$unqual_top_module_spec_rx/o;my$unqual_sub_module_spec_rx=qr#[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*#;our$sub_module_spec_rx=qr/$qual_module_spec_rx|$unqual_sub_module_spec_rx/o;sub is_module_name($) {_is_string($_[0])&& $_[0]=~ /\A$module_name_rx\z/o}*is_valid_module_name=\&is_module_name;sub check_module_name($) {unless(&is_module_name){die +(_is_string($_[0])? "`$_[0]'" : "argument")." is not a module name\n"}}sub module_notional_filename($) {&check_module_name;my($name)=@_;$name =~ s!::!/!g;return$name.".pm"}BEGIN {*_WORK_AROUND_HINT_LEAKAGE="$]" < 5.011 &&!("$]" >= 5.009004 && "$]" < 5.010001)? sub(){1}: sub(){0};*_WORK_AROUND_BROKEN_MODULE_STATE="$]" < 5.009 ? sub(){1}: sub(){0}}BEGIN {if(_WORK_AROUND_BROKEN_MODULE_STATE){eval q{
231 sub Module::Runtime::__GUARD__::DESTROY {
232 delete $INC{$_[0]->[0]} if @{$_[0]};
233 }
234 1;
235 };die $@ if $@ ne ""}}sub require_module($) {local %^H if _WORK_AROUND_HINT_LEAKAGE;if(_WORK_AROUND_BROKEN_MODULE_STATE){my$notional_filename=&module_notional_filename;my$guard=bless([$notional_filename ],"Module::Runtime::__GUARD__");my$result=CORE::require($notional_filename);pop @$guard;return$result}else {return scalar(CORE::require(&module_notional_filename))}}sub use_module($;$) {my($name,$version)=@_;require_module($name);$name->VERSION($version)if @_ >= 2;return$name}sub use_package_optimistically($;$) {my($name,$version)=@_;my$fn=module_notional_filename($name);eval {local$SIG{__DIE__};require_module($name)};die $@ if $@ ne "" && ($@ !~ /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/s || $@ =~ /^Compilation\ failed\ in\ require
236 \ at\ \Q@{[__FILE__]}\E\ line/xm);$name->VERSION($version)if @_ >= 2;return$name}sub is_module_spec($$) {my($prefix,$spec)=@_;return _is_string($spec)&& $spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o : qr/\A$top_module_spec_rx\z/o)}*is_valid_module_spec=\&is_module_spec;sub check_module_spec($$) {unless(&is_module_spec){die +(_is_string($_[1])? "`$_[1]'" : "argument")." is not a module specification\n"}}sub compose_module_name($$) {my($prefix,$spec)=@_;check_module_name($prefix)if defined$prefix;&check_module_spec;if($spec =~ s#\A(?:/|::)##){}else {$spec=$prefix."::".$spec if defined$prefix}$spec =~ s#/#::#g;return$spec}1;
237 MODULE_RUNTIME
238
239 $fatpacked{"Number/Compare.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NUMBER_COMPARE';
240 package Number::Compare;use strict;use Carp qw(croak);use vars qw/$VERSION/;$VERSION='0.03';sub new {my$referent=shift;my$class=ref$referent || $referent;my$expr=$class->parse_to_perl(shift);bless eval "sub { \$_[0] $expr }",$class}sub parse_to_perl {shift;my$test=shift;$test =~ m{^
241 ([<>]=?)? # comparison
242 (.*?) # value
243 ([kmg]i?)? # magnitude
244 $}ix or croak "don't understand '$test' as a test";my$comparison=$1 || '==';my$target=$2;my$magnitude=$3 || '';$target *= 1000 if lc$magnitude eq 'k';$target *= 1024 if lc$magnitude eq 'ki';$target *= 1000000 if lc$magnitude eq 'm';$target *= 1024*1024 if lc$magnitude eq 'mi';$target *= 1000000000 if lc$magnitude eq 'g';$target *= 1024*1024*1024 if lc$magnitude eq 'gi';return "$comparison $target"}sub test {$_[0]->($_[1])}1;
245 NUMBER_COMPARE
246
247 $fatpacked{"Proc/Find/Parents.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROC_FIND_PARENTS';
248 package Proc::Find::Parents;our$DATE='2018-01-17';our$VERSION='0.631';use 5.010001;use strict;use warnings;require Exporter;our@ISA=qw(Exporter);our@EXPORT_OK=qw(get_parent_processes);sub get_parent_processes {my ($pid,$opts)=@_;$pid //= $$;$opts //= {};my%proc;if (($opts->{method}// 'proctable')eq 'pstree'){my@lines=`pstree -pAl`;return undef unless@lines;my@p;for (@lines){my$i=0;while (/(?: (\s*(?:\|-?|`-)) | (.+?)\((\d+)\) )
249 (?: -[+-]- )?/gx){unless ($1){my$p={name=>$2,pid=>$3};$p[$i]=$p;$p->{ppid}=$p[$i-1]{pid}if$i > 0;$proc{$3}=$p}$i++}}}else {eval {require Proc::ProcessTable};return undef if $@;state$pt=Proc::ProcessTable->new;for my$p (@{$pt->table}){$proc{$p->{pid}}={name=>$p->{fname},cmdline=>$p->{cmndline},pid=>$p->{pid},ppid=>$p->{ppid},uid=>$p->{uid},gid=>$p->{gid},pgrp=>$p->{pgrp},sess=>$p->{sess},sgid=>$p->{sgid},euid=>$p->{euid},egid=>$p->{egid},ttydev=>$p->{ttydev},ttynum=>$p->{ttynum},}}}my@p=();my$cur_pid=$pid;while (1){return if!$proc{$cur_pid};$proc{$cur_pid}{name}=$1 if$proc{$cur_pid}{name}=~ /\A\{(.+)\}\z/;push@p,$proc{$cur_pid};$cur_pid=$proc{$cur_pid}{ppid};last unless$cur_pid}shift@p;\@p}1;
250 PROC_FIND_PARENTS
251
252 $fatpacked{"Readonly.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'READONLY';
253 package Readonly;use 5.005;use strict;package Readonly;our$VERSION='2.05';$VERSION=eval$VERSION;sub croak {require Carp;goto&Carp::croak}use vars qw/$XSokay/;sub _ARRAY (\@);sub _HASH (\%);if ($] < 5.008){*is_sv_readonly=sub ($) {0};*make_sv_readonly =sub ($) {die "make_sv_readonly called but not overridden"};$Readonly::XS::MAGIC_COOKIE=$Readonly::XS::MAGIC_COOKIE ="Do NOT use or require Readonly::XS unless you're me.";eval 'use Readonly::XS'}else {*is_sv_readonly=sub ($) {Internals::SvREADONLY($_[0])};*make_sv_readonly =sub ($) {Internals::SvREADONLY($_[0],1)};$XSokay=1}sub _SCALAR ($) {my ($r_var)=@_;if ($XSokay){Internals::SvREADONLY($r_var,0)if is_sv_readonly($r_var)}else {return if tied($r_var)!~ 'Readonly::Scalar';my$r_scalar;{my$obj=tied $$r_var;$r_scalar=$obj}untie$r_var;$r_var=$r_scalar}}sub _ARRAY (\@) {my ($r_var)=@_;return if!tied(@$r_var);return if tied(@$r_var)!~ 'Readonly::Array';my$r_array;{my$obj=tied @$r_var;$r_array=$obj}untie @$r_var;@$r_var=@$r_array;for (@$r_var){my$_reftype=ref $_;if ($_reftype eq 'SCALAR'){_SCALAR($_)}elsif ($_reftype eq 'ARRAY'){_ARRAY(@$_)}elsif ($_reftype eq 'HASH'){_HASH(%$_)}}}sub _HASH (\%) {my ($r_var)=@_;return if!tied(%$r_var);return if tied(%$r_var)!~ 'Readonly::Hash';my$r_hash;{my$obj=tied %$r_var;$r_hash=$obj}untie %$r_var;%$r_var=%$r_hash;for (values %$r_var){my$_reftype=ref $_;if ($_reftype eq 'SCALAR'){_SCALAR($_)}elsif ($_reftype eq 'ARRAY'){_ARRAY(@$_)}elsif ($_reftype eq 'HASH'){_HASH(%$_)}}}use vars qw/$MODIFY $REASSIGN $ODDHASH/;$MODIFY='Modification of a read-only value attempted';$REASSIGN='Attempt to reassign a readonly';$ODDHASH='May not store an odd number of values in a hash';package Readonly::Scalar;sub STORABLE_freeze {my ($self,$cloning)=@_;Readonly::_SCALAR($$self)if$cloning}sub TIESCALAR {my$whence =(caller 2)[3];Readonly::croak "Invalid tie" unless$whence && $whence =~ /^Readonly::(?:Scalar1?|Readonly)$/;my$class=shift;Readonly::croak "No value specified for readonly scalar" unless @_;Readonly::croak "Too many values specified for readonly scalar" unless @_==1;my$value=shift;return bless \$value,$class}sub FETCH {my$self=shift;return $$self}*STORE=*STORE=sub {Readonly::croak$Readonly::MODIFY};*UNTIE=*UNTIE =sub {Readonly::croak$Readonly::MODIFY if caller()ne 'Readonly'};package Readonly::Array;sub STORABLE_freeze {my ($self,$cloning)=@_;Readonly::_ARRAY(@$self)if$cloning}sub TIEARRAY {my$whence =(caller 1)[3];Readonly::croak "Invalid tie" unless$whence =~ /^Readonly::Array1?$/;my$class=shift;my@self=@_;return bless \@self,$class}sub FETCH {my$self=shift;my$index=shift;return$self->[$index]}sub FETCHSIZE {my$self=shift;return scalar @$self}BEGIN {eval q{
254 sub EXISTS
255 {
256 my $self = shift;
257 my $index = shift;
258 return exists $self->[$index];
259 }
260 } if $] >= 5.006}*STORE=*STORESIZE=*EXTEND=*PUSH=*POP=*UNSHIFT=*SHIFT=*SPLICE =*CLEAR=*STORE=*STORESIZE=*EXTEND=*PUSH=*POP=*UNSHIFT =*SHIFT=*SPLICE=*CLEAR=sub {Readonly::croak$Readonly::MODIFY};*UNTIE=*UNTIE =sub {Readonly::croak$Readonly::MODIFY if caller()ne 'Readonly'};package Readonly::Hash;sub STORABLE_freeze {my ($self,$cloning)=@_;Readonly::_HASH(%$self)if$cloning}sub TIEHASH {my$whence =(caller 1)[3];Readonly::croak "Invalid tie" unless$whence =~ /^Readonly::Hash1?$/;my$class=shift;Readonly::croak$Readonly::ODDHASH unless (@_ % 2==0);my%self=@_;return bless \%self,$class}sub FETCH {my$self=shift;my$key=shift;return$self->{$key}}sub EXISTS {my$self=shift;my$key=shift;return exists$self->{$key}}sub FIRSTKEY {my$self=shift;my$dummy=keys %$self;return scalar each %$self}sub NEXTKEY {my$self=shift;return scalar each %$self}*STORE=*DELETE=*CLEAR=*STORE=*DELETE=*CLEAR =sub {Readonly::croak$Readonly::MODIFY};*UNTIE=*UNTIE =sub {Readonly::croak$Readonly::MODIFY if caller()ne 'Readonly'};package Readonly;use Exporter;use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;push@ISA,'Exporter';push@EXPORT,qw/Readonly/;push@EXPORT_OK,qw/Scalar Array Hash Scalar1 Array1 Hash1/;sub Scalar ($$);sub Array (\@;@);sub Hash (\%;@);sub _is_badtype {my$type=$_[0];return lc$type if$type =~ s/^Readonly:://;return}sub Scalar1 ($$) {croak "$REASSIGN scalar" if is_sv_readonly($_[0]);my$badtype=_is_badtype(ref tied $_[0]);croak "$REASSIGN $badtype" if$badtype;if ($XSokay){$_[0]=$_[1];make_sv_readonly($_[0]);return}my$tieobj=eval {tie $_[0],'Readonly::Scalar',$_[1]};if ($@){croak "$REASSIGN scalar" if substr($@,0,43)eq $MODIFY;die $@}return$tieobj}sub Array1 (\@;@) {my$badtype=_is_badtype(ref tied $_[0]);croak "$REASSIGN $badtype" if$badtype;my$aref=shift;return tie @$aref,'Readonly::Array',@_}sub Hash1 (\%;@) {my$badtype=_is_badtype(ref tied $_[0]);croak "$REASSIGN $badtype" if$badtype;my$href=shift;if (@_==1 && ref $_[0]eq 'HASH'){return tie %$href,'Readonly::Hash',%{$_[0]}}croak$ODDHASH unless (@_ % 2==0);return tie %$href,'Readonly::Hash',@_}sub Scalar ($$) {croak "$REASSIGN scalar" if is_sv_readonly($_[0]);my$badtype=_is_badtype(ref tied $_[0]);croak "$REASSIGN $badtype" if$badtype;my$value=$_[1];for ($value){if (ref eq 'SCALAR'){Scalar my$v=>$$_;$_=\$v}elsif (ref eq 'ARRAY'){Array my@v=>@$_;$_=\@v}elsif (ref eq 'HASH'){Hash my%v=>$_;$_=\%v}}if ($XSokay){$_[0]=$value;make_sv_readonly($_[0]);return}my$tieobj=eval {tie $_[0],'Readonly::Scalar',$value};if ($@){croak "$REASSIGN scalar" if substr($@,0,43)eq $MODIFY;die $@}return$tieobj}sub Array (\@;@) {my$badtype=_is_badtype(ref tied @{$_[0]});croak "$REASSIGN $badtype" if$badtype;my$aref=shift;my@values=@_;for (@values){if (ref eq 'SCALAR'){Scalar my$v=>$$_;$_=\$v}elsif (ref eq 'ARRAY'){Array my@v=>@$_;$_=\@v}elsif (ref eq 'HASH'){Hash my%v=>$_;$_=\%v}}return tie @$aref,'Readonly::Array',@values}sub Hash (\%;@) {my$badtype=_is_badtype(ref tied %{$_[0]});croak "$REASSIGN $badtype" if$badtype;my$href=shift;my@values=@_;if (@_==1 && ref $_[0]eq 'HASH'){@values=%{$_[0]}}croak$ODDHASH unless (@values % 2==0);for (@values){if (ref eq 'SCALAR'){Scalar my$v=>$$_;$_=\$v}elsif (ref eq 'ARRAY'){Array my@v=>@$_;$_=\@v}elsif (ref eq 'HASH'){Hash my%v=>$_;$_=\%v}}return tie %$href,'Readonly::Hash',@values}sub Clone(\[$@%]) {require Storable;my$retval=Storable::dclone($_[0]);$retval=$$retval if ref$retval eq 'REF';my$reftype=ref$retval;if ($reftype eq 'SCALAR'){_SCALAR($retval);return $$retval}elsif ($reftype eq 'ARRAY'){_ARRAY(@$retval)}elsif ($reftype eq 'HASH'){_HASH(%$retval);return %$retval if wantarray}return$retval}eval q{sub Readonly} .($] < 5.008 ? '' : '(\[$@%]@)').<<'SUB_READONLY';1;
261 {
262 if (ref $_[0] eq 'SCALAR')
263 {
264 croak $MODIFY if is_sv_readonly ${$_[0]};
265 my $badtype = _is_badtype (ref tied ${$_[0]});
266 croak "$REASSIGN $badtype" if $badtype;
267 croak "Readonly scalar must have only one value" if @_ > 2;
268
269 # Because of problems with handling \$ prototypes declarations like
270 # Readonly my @a = ... and Readonly my %h = ... are also caught here
271 croak 'Invalid initialization by assignment'
272 if @_ == 1 && defined ${$_[0]};
273
274 my $tieobj = eval {tie ${$_[0]}, 'Readonly::Scalar', $_[1]};
275 # Tie may have failed because user tried to tie a constant, or we screwed up somehow.
276 if ($@)
277 {
278 croak $MODIFY if $@ =~ /^$MODIFY at/; # Point the finger at the user.
279 die "$@\n"; # Not a modify read-only message; must be our fault.
280 }
281 return $tieobj;
282 }
283 elsif (ref $_[0] eq 'ARRAY')
284 {
285 my $aref = shift;
286 return Array @$aref, @_;
287 }
288 elsif (ref $_[0] eq 'HASH')
289 {
290 my $href = shift;
291 croak $ODDHASH if @_%2 != 0 && !(@_ == 1 && ref $_[0] eq 'HASH');
292 return Hash %$href, @_;
293 }
294 elsif (ref $_[0])
295 {
296 croak "Readonly only supports scalar, array, and hash variables.";
297 }
298 else
299 {
300 croak "First argument to Readonly must be a reference.";
301 }
302 }
303 SUB_READONLY
304 READONLY
305
306 $fatpacked{"Sub/Exporter/Progressive.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_EXPORTER_PROGRESSIVE';
307 package Sub::Exporter::Progressive;$Sub::Exporter::Progressive::VERSION='0.001013';use strict;use warnings;sub _croak {require Carp;&Carp::croak}sub import {my ($self,@args)=@_;my$inner_target=caller;my$export_data=sub_export_options($inner_target,@args);my$full_exporter;no strict 'refs';no warnings 'once';@{"${inner_target}::EXPORT_OK"}=@{$export_data->{exports}};@{"${inner_target}::EXPORT"}=@{$export_data->{defaults}};%{"${inner_target}::EXPORT_TAGS"}=%{$export_data->{tags}};*{"${inner_target}::import"}=sub {use strict;my ($self,@args)=@_;if (grep {length ref $_ or $_ !~ / \A [:-]? \w+ \z /xm}@args){_croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed' unless eval {require Sub::Exporter};$full_exporter ||= Sub::Exporter::build_exporter($export_data->{original});goto$full_exporter}elsif (defined((my ($num)=grep {m/^\d/}@args)[0])){_croak "cannot export symbols with a leading digit: '$num'"}else {require Exporter;s/ \A - /:/xm for@args;@_=($self,@args);goto \&Exporter::import}};return}my$too_complicated=<<'DEATH';sub sub_export_options {my ($inner_target,$setup,$options)=@_;my@exports;my@defaults;my%tags;if (($setup||'')eq '-setup'){my%options=%$options;OPTIONS: for my$opt (keys%options){if ($opt eq 'exports'){_croak$too_complicated if ref$options{exports}ne 'ARRAY';@exports=@{$options{exports}};_croak$too_complicated if grep {length ref $_}@exports}elsif ($opt eq 'groups'){%tags=%{$options{groups}};for my$tagset (values%tags){_croak$too_complicated if grep {length ref $_ or $_ =~ / \A - (?! all \b ) /x}@{$tagset}}@defaults=@{$tags{default}|| []}}else {_croak$too_complicated}}@{$_}=map {/ \A [:-] all \z /x ? @exports : $_}@{$_}for \@defaults,values%tags;$tags{all}||= [@exports ];my%exports=map {$_=>1}@exports;my@errors=grep {not $exports{$_}}@defaults;_croak join(', ',@errors)." is not exported by the $inner_target module\n" if@errors}return {exports=>\@exports,defaults=>\@defaults,original=>$options,tags=>\%tags,}}1;
308 You are using Sub::Exporter::Progressive, but the features your program uses from
309 Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well
310 just use vanilla Sub::Exporter
311 DEATH
312 SUB_EXPORTER_PROGRESSIVE
313
314 $fatpacked{"Text/CSV.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_CSV';
315 package Text::CSV;use strict;use Exporter;use Carp ();use vars qw($VERSION $DEBUG @ISA @EXPORT_OK);@ISA=qw(Exporter);@EXPORT_OK=qw(csv);BEGIN {$VERSION='2.00';$DEBUG=0}my$Module_XS='Text::CSV_XS';my$Module_PP='Text::CSV_PP';my$XS_Version='1.02';my$Is_Dynamic=0;my@PublicMethods=qw/version error_diag error_input known_attributes csv PV IV NV/;unless ($Text::CSV::Worker){$Text::CSV::DEBUG and Carp::carp("Check used worker module...");if (exists$ENV{PERL_TEXT_CSV}){if ($ENV{PERL_TEXT_CSV}eq '0' or $ENV{PERL_TEXT_CSV}eq 'Text::CSV_PP'){_load_pp()or Carp::croak $@}elsif ($ENV{PERL_TEXT_CSV}eq '1' or $ENV{PERL_TEXT_CSV}=~ /Text::CSV_XS\s*,\s*Text::CSV_PP/){_load_xs()or _load_pp()or Carp::croak $@}elsif ($ENV{PERL_TEXT_CSV}eq '2' or $ENV{PERL_TEXT_CSV}eq 'Text::CSV_XS'){_load_xs()or Carp::croak $@}else {Carp::croak "The value of environmental variable 'PERL_TEXT_CSV' is invalid."}}else {_load_xs()or _load_pp()or Carp::croak $@}}sub new {my$proto=shift;my$class=ref($proto)|| $proto;unless ($proto){return eval qq| $Text::CSV::Worker\::new( \$proto ) |}if (my$obj=$Text::CSV::Worker->new(@_)){$obj->{_MODULE}=$Text::CSV::Worker;bless$obj,$class;return$obj}else {return}}sub require_xs_version {$XS_Version}sub module {my$proto=shift;return!ref($proto)? $Text::CSV::Worker : ref($proto->{_MODULE})? ref($proto->{_MODULE}): $proto->{_MODULE}}*backend=*module;sub is_xs {return $_[0]->module eq $Module_XS}sub is_pp {return $_[0]->module eq $Module_PP}sub is_dynamic {$Is_Dynamic}sub _load_xs {_load($Module_XS,$XS_Version)}sub _load_pp {_load($Module_PP)}sub _load {my ($module,$version)=@_;$version ||= '';$Text::CSV::DEBUG and Carp::carp "Load $module.";eval qq| use $module $version |;return if $@;push@Text::CSV::ISA,$module;$Text::CSV::Worker=$module;local $^W;no strict qw(refs);for my$method (@PublicMethods){*{"Text::CSV::$method"}=\&{"$module\::$method"}}return 1}1;
316 TEXT_CSV
317
318 $fatpacked{"Text/CSV_PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_CSV_PP';
319 package Text::CSV_PP;require 5.006001;use strict;use Exporter ();use vars qw($VERSION @ISA @EXPORT_OK);use Carp;$VERSION='2.00';@ISA=qw(Exporter);@EXPORT_OK=qw(csv);sub PV {0}sub IV {1}sub NV {2}sub IS_QUOTED () {0x0001}sub IS_BINARY () {0x0002}sub IS_ERROR () {0x0004}sub IS_MISSING () {0x0010}sub HOOK_ERROR () {0x0001}sub HOOK_AFTER_PARSE () {0x0002}sub HOOK_BEFORE_PRINT () {0x0004}sub useIO_EOF () {0x0010}my$ERRORS={1000=>"INI - constructor failed",1001=>"INI - sep_char is equal to quote_char or escape_char",1002=>"INI - allow_whitespace with escape_char or quote_char SP or TAB",1003=>"INI - \\r or \\n in main attr not allowed",1004=>"INI - callbacks should be undef or a hashref",1005=>"INI - EOL too long",1006=>"INI - SEP too long",1007=>"INI - QUOTE too long",1008=>"INI - SEP undefined",1010=>"INI - the header is empty",1011=>"INI - the header contains more than one valid separator",1012=>"INI - the header contains an empty field",1013=>"INI - the header contains nun-unique fields",1014=>"INI - header called on undefined stream",1500=>"PRM - Invalid/unsupported arguments(s)",1501=>"PRM - The key attribute is passed as an unsupported type",1502=>"PRM - The value attribute is passed without the key attribute",1503=>"PRM - The value attribute is passed as an unsupported type",2010=>"ECR - QUO char inside quotes followed by CR not part of EOL",2011=>"ECR - Characters after end of quoted field",2012=>"EOF - End of data in parsing input stream",2013=>"ESP - Specification error for fragments RFC7111",2014=>"ENF - Inconsistent number of fields",2021=>"EIQ - NL char inside quotes, binary off",2022=>"EIQ - CR char inside quotes, binary off",2023=>"EIQ - QUO character not allowed",2024=>"EIQ - EOF cannot be escaped, not even inside quotes",2025=>"EIQ - Loose unescaped escape",2026=>"EIQ - Binary character inside quoted field, binary off",2027=>"EIQ - Quoted field not terminated",2030=>"EIF - NL char inside unquoted verbatim, binary off",2031=>"EIF - CR char is first char of field, not part of EOL",2032=>"EIF - CR char inside unquoted, not part of EOL",2034=>"EIF - Loose unescaped quote",2035=>"EIF - Escaped EOF in unquoted field",2036=>"EIF - ESC error",2037=>"EIF - Binary character in unquoted field, binary off",2110=>"ECB - Binary character in Combine, binary off",2200=>"EIO - print to IO failed. See errno",3001=>"EHR - Unsupported syntax for column_names ()",3002=>"EHR - getline_hr () called before column_names ()",3003=>"EHR - bind_columns () and column_names () fields count mismatch",3004=>"EHR - bind_columns () only accepts refs to scalars",3006=>"EHR - bind_columns () did not pass enough refs for parsed fields",3007=>"EHR - bind_columns needs refs to writable scalars",3008=>"EHR - unexpected error in bound fields",3009=>"EHR - print_hr () called before column_names ()",3010=>"EHR - print_hr () called with invalid arguments",4001=>"PRM - The key does not exist as field in the data",0=>"",};BEGIN {if ($] < 5.006){$INC{'bytes.pm'}=1 unless$INC{'bytes.pm'};no strict 'refs';*{"utf8::is_utf8"}=sub {0};*{"utf8::decode"}=sub {}}elsif ($] < 5.008){no strict 'refs';*{"utf8::is_utf8"}=sub {0};*{"utf8::decode"}=sub {};*{"utf8::encode"}=sub {}}elsif (!defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}eval q| require Scalar::Util |;if ($@){eval q| require B |;if ($@){Carp::croak $@}else {my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*Scalar::Util::reftype=sub (\$) {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*Scalar::Util::readonly=sub (\$) {my$b=B::svref_2object($_[0]);$b->FLAGS & 0x00800000}}}}sub version {return$VERSION}my%def_attr=(eol=>'',sep_char=>',',quote_char=>'"',escape_char=>'"',binary=>0,decode_utf8=>1,auto_diag=>0,diag_verbose=>0,strict=>0,blank_is_undef=>0,empty_is_undef=>0,allow_whitespace=>0,allow_loose_quotes=>0,allow_loose_escapes=>0,allow_unquoted_escape=>0,always_quote=>0,quote_empty=>0,quote_space=>1,quote_binary=>1,escape_null=>1,keep_meta_info=>0,verbatim=>0,formula=>0,undef_str=>undef,types=>undef,callbacks=>undef,_EOF=>0,_RECNO=>0,_STATUS=>undef,_FIELDS=>undef,_FFLAGS=>undef,_STRING=>undef,_ERROR_INPUT=>undef,_COLUMN_NAMES=>undef,_BOUND_COLUMNS=>undef,_AHEAD=>undef,ENCODING=>undef,);my%attr_alias=(quote_always=>"always_quote",verbose_diag=>"diag_verbose",quote_null=>"escape_null",escape=>"escape_char",);my$last_new_error=Text::CSV_PP->SetDiag(0);my$last_error;sub _unhealthy_whitespace {my ($self,$aw)=@_;$aw or return 0;my$quo=$self->{quote};defined$quo && length ($quo)or $quo=$self->{quote_char};my$esc=$self->{escape_char};defined$quo && $quo =~ m/^[ \t]/ and return 1002;defined$esc && $esc =~ m/^[ \t]/ and return 1002;return 0}sub _check_sanity {my$self=shift;my$eol=$self->{eol};my$sep=$self->{sep};defined$sep && length ($sep)or $sep=$self->{sep_char};my$quo=$self->{quote};defined$quo && length ($quo)or $quo=$self->{quote_char};my$esc=$self->{escape_char};$sep ne "" or return 1008;length ($sep)> 16 and return 1006;$sep =~ m/[\r\n]/ and return 1003;if (defined$quo){$quo eq $sep and return 1001;length ($quo)> 16 and return 1007;$quo =~ m/[\r\n]/ and return 1003}if (defined$esc){$esc eq $sep and return 1001;$esc =~ m/[\r\n]/ and return 1003}if (defined$eol){length ($eol)> 16 and return 1005}return _unhealthy_whitespace ($self,$self->{allow_whitespace})}sub known_attributes {sort grep!m/^_/=>"sep","quote",keys%def_attr}sub new {$last_new_error=Text::CSV_PP->SetDiag(1000,'usage: my $csv = Text::CSV_PP->new ([{ option => value, ... }]);');my$proto=shift;my$class=ref ($proto)|| $proto or return;@_ > 0 && ref $_[0]ne "HASH" and return;my$attr=shift || {};my%attr=map {my$k=m/^[a-zA-Z]\w+$/ ? lc $_ : $_;exists$attr_alias{$k}and $k=$attr_alias{$k};$k=>$attr->{$_}}keys %$attr;my$sep_aliased=0;if (exists$attr{sep}){$attr{sep_char}=delete$attr{sep};$sep_aliased=1}my$quote_aliased=0;if (exists$attr{quote}){$attr{quote_char}=delete$attr{quote};$quote_aliased=1}exists$attr{formula_handling}and $attr{formula}=delete$attr{formula_handling};exists$attr{formula}and $attr{formula}=_supported_formula (undef,$attr{formula});for (keys%attr){if (m/^[a-z]/ && exists$def_attr{$_}){defined$attr{$_}&& m/_char$/ and utf8::decode ($attr{$_});next}$last_new_error=Text::CSV_PP->SetDiag(1000,"INI - Unknown attribute '$_'");$attr{auto_diag}and error_diag ();return}if ($sep_aliased){my@b=unpack "U0C*",$attr{sep_char};if (@b > 1){$attr{sep}=$attr{sep_char};$attr{sep_char}="\0"}else {$attr{sep}=undef}}if ($quote_aliased and defined$attr{quote_char}){my@b=unpack "U0C*",$attr{quote_char};if (@b > 1){$attr{quote}=$attr{quote_char};$attr{quote_char}="\0"}else {$attr{quote}=undef}}my$self={%def_attr,%attr };if (my$ec=_check_sanity ($self)){$last_new_error=Text::CSV_PP->SetDiag($ec);$attr{auto_diag}and error_diag ();return}if (defined$self->{callbacks}&& ref$self->{callbacks}ne "HASH"){Carp::carp "The 'callbacks' attribute is set but is not a hash: ignored\n";$self->{callbacks}=undef}$last_new_error=Text::CSV_PP->SetDiag(0);defined $\ &&!exists$attr{eol}and $self->{eol}=$\;bless$self,$class;defined$self->{types}and $self->types ($self->{types});$self}my%_cache_id=(quote_char=>0,escape_char=>1,sep_char=>2,sep=>39,binary=>3,keep_meta_info=>4,always_quote=>5,allow_loose_quotes=>6,allow_loose_escapes=>7,allow_unquoted_escape=>8,allow_whitespace=>9,blank_is_undef=>10,eol=>11,quote=>15,verbatim=>22,empty_is_undef=>23,auto_diag=>24,diag_verbose=>33,quote_space=>25,quote_empty=>37,quote_binary=>32,escape_null=>31,decode_utf8=>35,_has_ahead=>30,_has_hooks=>36,_is_bound=>26,formula=>38,strict=>42,undef_str=>46,);my%_hidden_cache_id=qw(sep_len 38 eol_len 12 eol_is_cr 13 quo_len 16 has_error_input 34);my%_reverse_cache_id=(map({$_cache_id{$_}=>$_}keys%_cache_id),map({$_hidden_cache_id{$_}=>$_}keys%_hidden_cache_id),);sub _set_attr_C {my ($self,$name,$val,$ec)=@_;defined$val or $val=0;utf8::decode ($val);$self->{$name}=$val;$ec=_check_sanity ($self)and croak ($self->SetDiag ($ec));$self->_cache_set ($_cache_id{$name},$val)}sub _set_attr_X {my ($self,$name,$val)=@_;defined$val or $val=0;$self->{$name}=$val;$self->_cache_set ($_cache_id{$name},0 + $val)}sub _set_attr_N {my ($self,$name,$val)=@_;$self->{$name}=$val;$self->_cache_set ($_cache_id{$name},0 + $val)}sub quote_char {my$self=shift;if (@_){$self->_set_attr_C ("quote_char",shift);$self->_cache_set ($_cache_id{quote},"")}$self->{quote_char}}sub quote {my$self=shift;if (@_){my$quote=shift;defined$quote or $quote="";utf8::decode ($quote);my@b=unpack "U0C*",$quote;if (@b > 1){@b > 16 and croak ($self->SetDiag (1007));$self->quote_char ("\0")}else {$self->quote_char ($quote);$quote=""}$self->{quote}=$quote;my$ec=_check_sanity ($self);$ec and croak ($self->SetDiag ($ec));$self->_cache_set ($_cache_id{quote},$quote)}my$quote=$self->{quote};defined$quote && length ($quote)? $quote : $self->{quote_char}}sub escape_char {my$self=shift;if (@_){my$ec=shift;$self->_set_attr_C ("escape_char",$ec);$ec or $self->_set_attr_X ("escape_null",0)}$self->{escape_char}}sub sep_char {my$self=shift;if (@_){$self->_set_attr_C ("sep_char",shift);$self->_cache_set ($_cache_id{sep},"")}$self->{sep_char}}sub sep {my$self=shift;if (@_){my$sep=shift;defined$sep or $sep="";utf8::decode ($sep);my@b=unpack "U0C*",$sep;if (@b > 1){@b > 16 and croak ($self->SetDiag (1006));$self->sep_char ("\0")}else {$self->sep_char ($sep);$sep=""}$self->{sep}=$sep;my$ec=_check_sanity ($self);$ec and croak ($self->SetDiag ($ec));$self->_cache_set ($_cache_id{sep},$sep)}my$sep=$self->{sep};defined$sep && length ($sep)? $sep : $self->{sep_char}}sub eol {my$self=shift;if (@_){my$eol=shift;defined$eol or $eol="";length ($eol)> 16 and croak ($self->SetDiag (1005));$self->{eol}=$eol;$self->_cache_set ($_cache_id{eol},$eol)}$self->{eol}}sub always_quote {my$self=shift;@_ and $self->_set_attr_X ("always_quote",shift);$self->{always_quote}}sub quote_space {my$self=shift;@_ and $self->_set_attr_X ("quote_space",shift);$self->{quote_space}}sub quote_empty {my$self=shift;@_ and $self->_set_attr_X ("quote_empty",shift);$self->{quote_empty}}sub escape_null {my$self=shift;@_ and $self->_set_attr_X ("escape_null",shift);$self->{escape_null}}sub quote_null {goto&escape_null}sub quote_binary {my$self=shift;@_ and $self->_set_attr_X ("quote_binary",shift);$self->{quote_binary}}sub binary {my$self=shift;@_ and $self->_set_attr_X ("binary",shift);$self->{binary}}sub strict {my$self=shift;@_ and $self->_set_attr_X ("strict",shift);$self->{strict}}sub _SetDiagInfo {my ($self,$err,$msg)=@_;$self->SetDiag ($err);my$em=$self->error_diag;$em =~ s/^\d+$// and $msg =~ s/^/# /;my$sep=$em =~ m/[;\n]$/ ? "\n\t" : ": ";join$sep=>grep m/\S\S\S/=>$em,$msg}sub _supported_formula {my ($self,$f)=@_;defined$f or return 5;$f =~ m/^(?: 0 | none )$/xi ? 0 : $f =~ m/^(?: 1 | die )$/xi ? 1 : $f =~ m/^(?: 2 | croak )$/xi ? 2 : $f =~ m/^(?: 3 | diag )$/xi ? 3 : $f =~ m/^(?: 4 | empty | )$/xi ? 4 : $f =~ m/^(?: 5 | undef )$/xi ? 5 : do {$self ||= "Text::CSV_PP";croak ($self->_SetDiagInfo (1500,"formula-handling '$f' is not supported"))}}sub formula {my$self=shift;@_ and $self->_set_attr_N ("formula",_supported_formula ($self,shift));[qw(none die croak diag empty undef)]->[_supported_formula ($self,$self->{formula})]}sub formula_handling {my$self=shift;$self->formula (@_)}sub decode_utf8 {my$self=shift;@_ and $self->_set_attr_X ("decode_utf8",shift);$self->{decode_utf8}}sub keep_meta_info {my$self=shift;if (@_){my$v=shift;!defined$v || $v eq "" and $v=0;$v =~ m/^[0-9]/ or $v=lc$v eq "false" ? 0 : 1;$self->_set_attr_X ("keep_meta_info",$v)}$self->{keep_meta_info}}sub allow_loose_quotes {my$self=shift;@_ and $self->_set_attr_X ("allow_loose_quotes",shift);$self->{allow_loose_quotes}}sub allow_loose_escapes {my$self=shift;@_ and $self->_set_attr_X ("allow_loose_escapes",shift);$self->{allow_loose_escapes}}sub allow_whitespace {my$self=shift;if (@_){my$aw=shift;_unhealthy_whitespace ($self,$aw)and croak ($self->SetDiag (1002));$self->_set_attr_X ("allow_whitespace",$aw)}$self->{allow_whitespace}}sub allow_unquoted_escape {my$self=shift;@_ and $self->_set_attr_X ("allow_unquoted_escape",shift);$self->{allow_unquoted_escape}}sub blank_is_undef {my$self=shift;@_ and $self->_set_attr_X ("blank_is_undef",shift);$self->{blank_is_undef}}sub empty_is_undef {my$self=shift;@_ and $self->_set_attr_X ("empty_is_undef",shift);$self->{empty_is_undef}}sub verbatim {my$self=shift;@_ and $self->_set_attr_X ("verbatim",shift);$self->{verbatim}}sub undef_str {my$self=shift;if (@_){my$v=shift;$self->{undef_str}=defined$v ? "$v" : undef;$self->_cache_set ($_cache_id{undef_str},$self->{undef_str})}$self->{undef_str}}sub auto_diag {my$self=shift;if (@_){my$v=shift;!defined$v || $v eq "" and $v=0;$v =~ m/^[0-9]/ or $v=lc$v eq "false" ? 0 : 1;$self->_set_attr_X ("auto_diag",$v)}$self->{auto_diag}}sub diag_verbose {my$self=shift;if (@_){my$v=shift;!defined$v || $v eq "" and $v=0;$v =~ m/^[0-9]/ or $v=lc$v eq "false" ? 0 : 1;$self->_set_attr_X ("diag_verbose",$v)}$self->{diag_verbose}}sub status {$_[0]->{_STATUS}}sub eof {$_[0]->{_EOF}}sub types {my$self=shift;if (@_){if (my$types=shift){$self->{'_types'}=join("",map{chr($_)}@$types);$self->{'types'}=$types}else {delete$self->{'types'};delete$self->{'_types'};undef}}else {$self->{'types'}}}sub callbacks {my$self=shift;if (@_){my$cb;my$hf=0x00;if (defined $_[0]){grep {!defined}@_ and croak ($self->SetDiag (1004));$cb=@_==1 && ref $_[0]eq "HASH" ? shift : @_ % 2==0 ? {@_ }: croak ($self->SetDiag (1004));for my$cbk (keys %$cb){$cbk =~ m/^[\w.]+$/ && ref$cb->{$cbk}eq "CODE" or croak ($self->SetDiag (1004))}exists$cb->{error}and $hf |= 0x01;exists$cb->{after_parse}and $hf |= 0x02;exists$cb->{before_print}and $hf |= 0x04}elsif (@_ > 1){croak ($self->SetDiag (1004))}$self->_set_attr_X ("_has_hooks",$hf);$self->{callbacks}=$cb}$self->{callbacks}}sub error_diag {my$self=shift;my@diag=(0 + $last_new_error,$last_new_error,0,0,0);if ($self && ref$self && UNIVERSAL::isa ($self,__PACKAGE__)&& exists$self->{_ERROR_DIAG}){$diag[0]=0 + $self->{_ERROR_DIAG};$diag[1]=$self->{_ERROR_DIAG};$diag[2]=1 + $self->{_ERROR_POS}if exists$self->{_ERROR_POS};$diag[3]=$self->{_RECNO};$diag[4]=$self->{_ERROR_FLD}if exists$self->{_ERROR_FLD};$diag[0]&& $self->{callbacks}&& $self->{callbacks}{error}and return$self->{callbacks}{error}->(@diag)}my$context=wantarray;unless (defined$context){if ($diag[0]&& $diag[0]!=2012){my$msg="# CSV_PP ERROR: $diag[0] - $diag[1] \@ rec $diag[3] pos $diag[2]\n";$diag[4]and $msg =~ s/$/ field $diag[4]/;unless ($self && ref$self){warn$msg;return}if ($self->{diag_verbose}and $self->{_ERROR_INPUT}){$msg .= "$self->{_ERROR_INPUT}'\n";$msg .= " " x ($diag[2]- 1);$msg .= "^\n"}my$lvl=$self->{auto_diag};if ($lvl < 2){my@c=caller (2);if (@c >= 11 && $c[10]&& ref$c[10]eq "HASH"){my$hints=$c[10];(exists$hints->{autodie}&& $hints->{autodie}or exists$hints->{"guard Fatal"}&& !exists$hints->{"no Fatal"})and $lvl++}}$lvl > 1 ? die$msg : warn$msg}return}return$context ? @diag : $diag[1]}sub record_number {return shift->{_RECNO}}*string=\&_string;sub _string {defined $_[0]->{_STRING}? ${$_[0]->{_STRING}}: undef}*fields=\&_fields;sub _fields {ref($_[0]->{_FIELDS})? @{$_[0]->{_FIELDS}}: undef}sub meta_info {$_[0]->{_FFLAGS}? @{$_[0]->{_FFLAGS}}: undef}sub is_quoted {return unless (defined $_[0]->{_FFLAGS});return if($_[1]=~ /\D/ or $_[1]< 0 or $_[1]> $#{$_[0]->{_FFLAGS}});$_[0]->{_FFLAGS}->[$_[1]]& IS_QUOTED ? 1 : 0}sub is_binary {return unless (defined $_[0]->{_FFLAGS});return if($_[1]=~ /\D/ or $_[1]< 0 or $_[1]> $#{$_[0]->{_FFLAGS}});$_[0]->{_FFLAGS}->[$_[1]]& IS_BINARY ? 1 : 0}sub is_missing {my ($self,$idx,$val)=@_;return unless$self->{keep_meta_info};$idx < 0 ||!ref$self->{_FFLAGS}and return;$idx >= @{$self->{_FFLAGS}}and return 1;$self->{_FFLAGS}[$idx]& IS_MISSING ? 1 : 0}*combine=\&_combine;sub _combine {my ($self,@fields)=@_;my$str="";$self->{_FIELDS}=\@fields;$self->{_STATUS}=(@fields > 0)&& $self->__combine(\$str,\@fields,0);$self->{_STRING}=\$str;$self->{_STATUS}}*parse=\&_parse;sub _parse {my ($self,$str)=@_;ref$str and croak ($self->SetDiag (1500));my$fields=[];my$fflags=[];$self->{_STRING}=\$str;if (defined$str && $self->__parse ($fields,$fflags,$str,0)){$self->{_FIELDS}=$fields;$self->{_FFLAGS}=$fflags;$self->{_STATUS}=1}else {$self->{_FIELDS}=undef;$self->{_FFLAGS}=undef;$self->{_STATUS}=0}$self->{_STATUS}}sub column_names {my ($self,@columns)=@_;@columns or return defined$self->{_COLUMN_NAMES}? @{$self->{_COLUMN_NAMES}}: ();@columns==1 &&!defined$columns[0]and return$self->{_COLUMN_NAMES}=undef;if (@columns==1 && ref$columns[0]eq "ARRAY"){@columns=@{$columns[0]}}elsif (join "",map {defined $_ ? ref $_ : ""}@columns){croak$self->SetDiag(3001)}if ($self->{_BOUND_COLUMNS}&& @columns!=@{$self->{_BOUND_COLUMNS}}){croak$self->SetDiag(3003)}$self->{_COLUMN_NAMES}=[map {defined $_ ? $_ : "\cAUNDEF\cA"}@columns ];@{$self->{_COLUMN_NAMES}}}sub header {my ($self,$fh,@args)=@_;$fh or croak ($self->SetDiag (1014));my (@seps,%args);for (@args){if (ref $_ eq "ARRAY"){push@seps,@$_;next}if (ref $_ eq "HASH"){%args=%$_;next}croak (q{usage: $csv->header ($fh, [ seps ], { options })})}defined$args{munge}&&!defined$args{munge_column_names}and $args{munge_column_names}=$args{munge};defined$args{detect_bom}or $args{detect_bom}=1;defined$args{set_column_names}or $args{set_column_names}=1;defined$args{munge_column_names}or $args{munge_column_names}="lc";$self->{_RECNO}=0;$self->{_AHEAD}=undef;$self->{_COLUMN_NAMES}=undef if$args{set_column_names};$self->{_BOUND_COLUMNS}=undef if$args{set_column_names};$self->_cache_set($_cache_id{'_has_ahead'},0);if (defined$args{sep_set}){ref$args{sep_set}eq "ARRAY" or croak ($self->_SetDiagInfo (1500,"sep_set should be an array ref"));@seps=@{$args{sep_set}}}$^O eq "MSWin32" and binmode$fh;my$hdr=<$fh>;defined$hdr && $hdr ne "" or croak ($self->SetDiag (1010));my%sep;@seps or @seps=(",",";");for my$sep (@seps){index ($hdr,$sep)>= 0 and $sep{$sep}++}keys%sep >= 2 and croak ($self->SetDiag (1011));$self->sep (keys%sep);my$enc="";if ($args{detect_bom}){if ($hdr =~ s/^\x00\x00\xfe\xff//){$enc="utf-32be"}elsif ($hdr =~ s/^\xff\xfe\x00\x00//){$enc="utf-32le"}elsif ($hdr =~ s/^\xfe\xff//){$enc="utf-16be"}elsif ($hdr =~ s/^\xff\xfe//){$enc="utf-16le"}elsif ($hdr =~ s/^\xef\xbb\xbf//){$enc="utf-8"}elsif ($hdr =~ s/^\xf7\x64\x4c//){$enc="utf-1"}elsif ($hdr =~ s/^\xdd\x73\x66\x73//){$enc="utf-ebcdic"}elsif ($hdr =~ s/^\x0e\xfe\xff//){$enc="scsu"}elsif ($hdr =~ s/^\xfb\xee\x28//){$enc="bocu-1"}elsif ($hdr =~ s/^\x84\x31\x95\x33//){$enc="gb-18030"}elsif ($hdr =~ s/^\x{feff}//){$enc=""}$self->{ENCODING}=uc$enc;$hdr eq "" and croak ($self->SetDiag (1010));if ($enc){if ($enc =~ m/([13]).le$/){my$l=0 + $1;my$x;$hdr .= "\0" x $l;read$fh,$x,$l}if ($enc ne "utf-8"){require Encode;$hdr=Encode::decode ($enc,$hdr)}binmode$fh,":encoding($enc)"}}my ($ahead,$eol);if ($hdr =~ s/^([^\r\n]+)([\r\n]+)([^\r\n].+)\z/$1/s){$eol=$2;$ahead=$3}$args{munge_column_names}eq "lc" and $hdr=lc$hdr;$args{munge_column_names}eq "uc" and $hdr=uc$hdr;my$hr=\$hdr;open my$h,"<",$hr or croak ($self->SetDiag (1010));my$row=$self->getline ($h)or croak;close$h;if ($ahead){$self->_cache_set ($_cache_id{_has_ahead},1);$self->{_AHEAD}=$ahead;$eol =~ m/^\r([^\n]|\z)/ and $self->eol ($eol)}my@hdr=@$row;ref$args{munge_column_names}eq "CODE" and @hdr=map {$args{munge_column_names}->($_)}@hdr;ref$args{munge_column_names}eq "HASH" and @hdr=map {$args{munge_column_names}->{$_}|| $_}@hdr;my%hdr;$hdr{$_}++ for@hdr;exists$hdr{""}and croak ($self->SetDiag (1012));unless (keys%hdr==@hdr){croak ($self->_SetDiagInfo (1013,join ", "=>map {"$_ ($hdr{$_})"}grep {$hdr{$_}> 1}keys%hdr))}$args{set_column_names}and $self->column_names (@hdr);wantarray ? @hdr : $self}sub bind_columns {my ($self,@refs)=@_;@refs or return defined$self->{_BOUND_COLUMNS}? @{$self->{_BOUND_COLUMNS}}: undef;@refs==1 &&!defined$refs[0]and return$self->{_BOUND_COLUMNS}=undef;if ($self->{_COLUMN_NAMES}&& @refs!=@{$self->{_COLUMN_NAMES}}){croak$self->SetDiag(3003)}if (grep {ref $_ ne "SCALAR"}@refs){croak$self->SetDiag(3004)}$self->_set_attr_N("_is_bound",scalar@refs);$self->{_BOUND_COLUMNS}=[@refs ];@refs}sub getline_hr {my ($self,@args,%hr)=@_;$self->{_COLUMN_NAMES}or croak ($self->SetDiag (3002));my$fr=$self->getline (@args)or return;if (ref$self->{_FFLAGS}){$self->{_FFLAGS}[$_]=IS_MISSING for (@$fr ? $#{$fr}+ 1 : 0).. $#{$self->{_COLUMN_NAMES}};@$fr==1 && (!defined$fr->[0]|| $fr->[0]eq "")and $self->{_FFLAGS}[0]||= IS_MISSING}@hr{@{$self->{_COLUMN_NAMES}}}=@$fr;\%hr}sub getline_hr_all {my ($self,$io,@args)=@_;unless ($self->{_COLUMN_NAMES}){croak$self->SetDiag(3002)}my@cn=@{$self->{_COLUMN_NAMES}};return [map {my%h;@h{@cn }=@$_;\%h}@{$self->getline_all($io,@args)}]}sub say {my ($self,$io,@f)=@_;my$eol=$self->eol;$eol eq "" and $self->eol ($\ || $/);my$state=$self->print ($io,@f==1 &&!defined$f[0]? undef : @f);$self->eol ($eol);return$state}sub print_hr {my ($self,$io,$hr)=@_;$self->{_COLUMN_NAMES}or croak($self->SetDiag(3009));ref$hr eq "HASH" or croak($self->SetDiag(3010));$self->print ($io,[map {$hr->{$_}}$self->column_names ])}sub fragment {my ($self,$io,$spec)=@_;my$qd=qr{\s* [0-9]+ \s* }x;my$qs=qr{\s* (?: [0-9]+ | \* ) \s*}x;my$qr=qr{$qd (?: - $qs )?}x;my$qc=qr{$qr (?: ; $qr )*}x;defined$spec && $spec =~ m{^ \s*
320 \x23 ? \s* # optional leading #
321 ( row | col | cell ) \s* =
322 ( $qc # for row and col
323 | $qd , $qd (?: - $qs , $qs)? # for cell (ranges)
324 (?: ; $qd , $qd (?: - $qs , $qs)? )* # and cell (range) lists
325 ) \s* $}xi or croak ($self->SetDiag (2013));my ($type,$range)=(lc $1,$2);my@h=$self->column_names ();my@c;if ($type eq "cell"){my@spec;my$min_row;my$max_row=0;for (split m/\s*;\s*/=>$range){my ($tlr,$tlc,$brr,$brc)=(m{
326 ^ \s* ([0-9]+ ) \s* , \s* ([0-9]+ ) \s*
327 (?: - \s* ([0-9]+ | \*) \s* , \s* ([0-9]+ | \*) \s* )?
328 $}x)or croak ($self->SetDiag (2013));defined$brr or ($brr,$brc)=($tlr,$tlc);$tlr==0 || $tlc==0 || ($brr ne "*" && ($brr==0 || $brr < $tlr))|| ($brc ne "*" && ($brc==0 || $brc < $tlc))and croak ($self->SetDiag (2013));$tlc--;$brc-- unless$brc eq "*";defined$min_row or $min_row=$tlr;$tlr < $min_row and $min_row=$tlr;$brr eq "*" || $brr > $max_row and $max_row=$brr;push@spec,[$tlr,$tlc,$brr,$brc ]}my$r=0;while (my$row=$self->getline ($io)){++$r < $min_row and next;my%row;my$lc;for my$s (@spec){my ($tlr,$tlc,$brr,$brc)=@$s;$r < $tlr || ($brr ne "*" && $r > $brr)and next;!defined$lc || $tlc < $lc and $lc=$tlc;my$rr=$brc eq "*" ? $#$row : $brc;$row{$_}=$row->[$_]for$tlc .. $rr}push@c,[@row{sort {$a <=> $b}keys%row }];if (@h){my%h;@h{@h}=@{$c[-1]};$c[-1]=\%h}$max_row ne "*" && $r==$max_row and last}return \@c}my@r;my$eod=0;for (split m/\s*;\s*/=>$range){my ($from,$to)=m/^\s* ([0-9]+) (?: \s* - \s* ([0-9]+ | \* ))? \s* $/x or croak ($self->SetDiag (2013));$to ||= $from;$to eq "*" and ($to,$eod)=($from,1);$from <= 0 || $to < $from and croak ($self->SetDiag (2013));$r[$_]=1 for$from .. $to}my$r=0;$type eq "col" and shift@r;$_ ||= 0 for@r;while (my$row=$self->getline ($io)){$r++;if ($type eq "row"){if (($r > $#r && $eod)|| $r[$r]){push@c,$row;if (@h){my%h;@h{@h}=@{$c[-1]};$c[-1]=\%h}}next}push@c,[map {($_ > $#r && $eod)|| $r[$_]? $row->[$_]: ()}0..$#$row ];if (@h){my%h;@h{@h}=@{$c[-1]};$c[-1]=\%h}}return \@c}my$csv_usage=q{usage: my $aoa = csv (in => $file);};sub _csv_attr {my%attr=(@_==1 && ref $_[0]eq "HASH" ? %{$_[0]}: @_)or croak;$attr{binary}=1;my$enc=delete$attr{enc}|| delete$attr{encoding}|| "";$enc eq "auto" and ($attr{detect_bom},$enc)=(1,"");$enc =~ m/^[-\w.]+$/ and $enc=":encoding($enc)";my$fh;my$sink=0;my$cls=0;my$in=delete$attr{in}|| delete$attr{file}or croak$csv_usage;my$out=exists$attr{out}&&!$attr{out}? \"skip" : delete$attr{out}|| delete$attr{file};ref$in eq "CODE" || ref$in eq "ARRAY" and $out ||= \*STDOUT;$in && $out &&!ref$in &&!ref$out and croak join "\n"=>qq{Cannot use a string for both in and out. Instead use:},qq{ csv (in => csv (in => "$in"), out => "$out");\n};if ($out){if ((ref$out and "SCALAR" ne ref$out)or "GLOB" eq ref \$out){$fh=$out}elsif (ref$out and "SCALAR" eq ref$out and defined $$out and $$out eq "skip"){delete$attr{out};$sink=1}else {open$fh,">",$out or croak "$out: $!";$cls=1}if ($fh){$enc and binmode$fh,$enc;unless (defined$attr{eol}){my@layers=eval {PerlIO::get_layers ($fh)};$attr{eol}=(grep m/crlf/=>@layers)? "\n" : "\r\n"}}}if (ref$in eq "CODE" or ref$in eq "ARRAY"){}elsif (ref$in eq "SCALAR"){open$fh,"<",$in or croak "Cannot open from SCALAR using PerlIO";$cls=1}elsif (ref$in or "GLOB" eq ref \$in){if (!ref$in && $] < 5.008005){$fh=\*$in}else {$fh=$in}}else {open$fh,"<$enc",$in or croak "$in: $!";$cls=1}$fh || $sink or croak qq{No valid source passed. "in" is required};my$hdrs=delete$attr{headers};my$frag=delete$attr{fragment};my$key=delete$attr{key};my$val=delete$attr{value};my$kh=delete$attr{keep_headers}|| delete$attr{keep_column_names}|| delete$attr{kh};my$cbai=delete$attr{callbacks}{after_in}|| delete$attr{after_in}|| delete$attr{callbacks}{after_parse}|| delete$attr{after_parse};my$cbbo=delete$attr{callbacks}{before_out}|| delete$attr{before_out};my$cboi=delete$attr{callbacks}{on_in}|| delete$attr{on_in};my$hd_s=delete$attr{sep_set}|| delete$attr{seps};my$hd_b=delete$attr{detect_bom}|| delete$attr{bom};my$hd_m=delete$attr{munge}|| delete$attr{munge_column_names};my$hd_c=delete$attr{set_column_names};for ([quo=>"quote" ],[esc=>"escape" ],[escape=>"escape_char" ],){my ($f,$t)=@$_;exists$attr{$f}and!exists$attr{$t}and $attr{$t}=delete$attr{$f}}my$fltr=delete$attr{filter};my%fltr=(not_blank=>sub {@{$_[1]}> 1 or defined $_[1][0]&& $_[1][0]ne ""},not_empty=>sub {grep {defined && $_ ne ""}@{$_[1]}},filled=>sub {grep {defined && m/\S/}@{$_[1]}},);defined$fltr &&!ref$fltr && exists$fltr{$fltr}and $fltr={0=>$fltr{$fltr}};ref$fltr eq "CODE" and $fltr={0=>$fltr };ref$fltr eq "HASH" or $fltr=undef;exists$attr{formula}and $attr{formula}=_supported_formula (undef,$attr{formula});defined$attr{auto_diag}or $attr{auto_diag}=1;defined$attr{escape_null}or $attr{escape_null}=0;my$csv=delete$attr{csv}|| Text::CSV_PP->new (\%attr)or croak$last_new_error;return {csv=>$csv,attr=>{%attr },fh=>$fh,cls=>$cls,in=>$in,sink=>$sink,out=>$out,enc=>$enc,hdrs=>$hdrs,key=>$key,val=>$val,kh=>$kh,frag=>$frag,fltr=>$fltr,cbai=>$cbai,cbbo=>$cbbo,cboi=>$cboi,hd_s=>$hd_s,hd_b=>$hd_b,hd_m=>$hd_m,hd_c=>$hd_c,}}sub csv {@_ && (ref $_[0]eq __PACKAGE__ or ref $_[0]eq 'Text::CSV')and splice @_,0,0,"csv";@_ or croak$csv_usage;my$c=_csv_attr (@_);my ($csv,$in,$fh,$hdrs)=@{$c}{"csv","in","fh","hdrs"};my%hdr;if (ref$hdrs eq "HASH"){%hdr=%$hdrs;$hdrs="auto"}if ($c->{out}&&!$c->{sink}){if (ref$in eq "CODE"){my$hdr=1;while (my$row=$in->($csv)){if (ref$row eq "ARRAY"){$csv->print ($fh,$row);next}if (ref$row eq "HASH"){if ($hdr){$hdrs ||= [map {$hdr{$_}|| $_}keys %$row ];$csv->print ($fh,$hdrs);$hdr=0}$csv->print ($fh,[@{$row}{@$hdrs}])}}}elsif (ref$in->[0]eq "ARRAY"){ref$hdrs and $csv->print ($fh,$hdrs);for (@{$in}){$c->{cboi}and $c->{cboi}->($csv,$_);$c->{cbbo}and $c->{cbbo}->($csv,$_);$csv->print ($fh,$_)}}else {my@hdrs=ref$hdrs ? @{$hdrs}: keys %{$in->[0]};defined$hdrs or $hdrs="auto";ref$hdrs || $hdrs eq "auto" and $csv->print ($fh,[map {$hdr{$_}|| $_}@hdrs ]);for (@{$in}){local%_;*_=$_;$c->{cboi}and $c->{cboi}->($csv,$_);$c->{cbbo}and $c->{cbbo}->($csv,$_);$csv->print ($fh,[@{$_}{@hdrs}])}}$c->{cls}and close$fh;return 1}my@row1;if (defined$c->{hd_s}|| defined$c->{hd_b}|| defined$c->{hd_m}|| defined$c->{hd_c}){my%harg;defined$c->{hd_s}and $harg{set_set}=$c->{hd_s};defined$c->{hd_d}and $harg{detect_bom}=$c->{hd_b};defined$c->{hd_m}and $harg{munge_column_names}=$hdrs ? "none" : $c->{hd_m};defined$c->{hd_c}and $harg{set_column_names}=$hdrs ? 0 : $c->{hd_c};@row1=$csv->header ($fh,\%harg);my@hdr=$csv->column_names;@hdr and $hdrs ||= \@hdr}if ($c->{kh}){ref$c->{kh}eq "ARRAY" or croak ($csv->SetDiag (1501));$hdrs ||= "auto"}my$key=$c->{key};if ($key){!ref$key or ref$key eq "ARRAY" && @$key > 1 or croak ($csv->SetDiag (1501));$hdrs ||= "auto"}my$val=$c->{val};if ($val){$key or croak ($csv->SetDiag (1502));!ref$val or ref$val eq "ARRAY" && @$val > 0 or croak ($csv->SetDiag (1503))}$c->{fltr}&& grep m/\D/=>keys %{$c->{fltr}}and $hdrs ||= "auto";if (defined$hdrs){if (!ref$hdrs){if ($hdrs eq "skip"){$csv->getline ($fh)}elsif ($hdrs eq "auto"){my$h=$csv->getline ($fh)or return;$hdrs=[map {$hdr{$_}|| $_}@$h ]}elsif ($hdrs eq "lc"){my$h=$csv->getline ($fh)or return;$hdrs=[map {lc ($hdr{$_}|| $_)}@$h ]}elsif ($hdrs eq "uc"){my$h=$csv->getline ($fh)or return;$hdrs=[map {uc ($hdr{$_}|| $_)}@$h ]}}elsif (ref$hdrs eq "CODE"){my$h=$csv->getline ($fh)or return;my$cr=$hdrs;$hdrs=[map {$cr->($hdr{$_}|| $_)}@$h ]}$c->{kh}and $hdrs and @{$c->{kh}}=@$hdrs}if ($c->{fltr}){my%f=%{$c->{fltr}};my@hdr;if (ref$hdrs){@hdr=@{$hdrs};for (0 .. $#hdr){exists$f{$hdr[$_]}and $f{$_ + 1}=delete$f{$hdr[$_]}}}$csv->callbacks (after_parse=>sub {my ($CSV,$ROW)=@_;for my$FLD (sort keys%f){local $_=$ROW->[$FLD - 1];local%_;@hdr and @_{@hdr}=@$ROW;$f{$FLD}->($CSV,$ROW)or return \"skip";$ROW->[$FLD - 1]=$_}})}my$frag=$c->{frag};my$ref=ref$hdrs ? do {my@h=$csv->column_names ($hdrs);my%h;$h{$_}++ for@h;exists$h{""}and croak ($csv->SetDiag (1012));unless (keys%h==@h){croak ($csv->_SetDiagInfo (1013,join ", "=>map {"$_ ($h{$_})"}grep {$h{$_}> 1}keys%h))}$frag ? $csv->fragment ($fh,$frag): $key ? do {my ($k,$j,@f)=ref$key ? (undef,@$key): ($key);if (my@mk=grep {!exists$h{$_}}grep {defined}$k,@f){croak ($csv->_SetDiagInfo (4001,join ", "=>@mk))}+{map {my$r=$_;my$K=defined$k ? $r->{$k}: join$j=>@{$r}{@f};($K=>($val ? ref$val ? {map {$_=>$r->{$_}}@$val }: $r->{$val}: $r))}@{$csv->getline_hr_all ($fh)}}}: $csv->getline_hr_all ($fh)}: $frag ? $csv->fragment ($fh,$frag): $csv->getline_all ($fh);if ($ref){@row1 &&!$c->{hd_c}&&!ref$hdrs and unshift @$ref,\@row1}else {Text::CSV_PP->auto_diag}$c->{cls}and close$fh;if ($ref and $c->{cbai}|| $c->{cboi}){for my$r (ref$ref eq "ARRAY" ? @{$ref}: values %{$ref}){local%_;ref$r eq "HASH" and *_=$r;$c->{cbai}and $c->{cbai}->($csv,$r);$c->{cboi}and $c->{cboi}->($csv,$r)}}$c->{sink}and return;defined wantarray or return csv (%{$c->{attr}},in=>$ref,headers=>$hdrs,%{$c->{attr}});return$ref}sub _setup_ctx {my$self=shift;$last_error=undef;my$ctx;if ($self->{_CACHE}){%$ctx=%{$self->{_CACHE}}}else {$ctx->{sep}=',';if (defined$self->{sep_char}){$ctx->{sep}=$self->{sep_char}}if (defined$self->{sep}and $self->{sep}ne ''){use bytes;$ctx->{sep}=$self->{sep};my$sep_len=length($ctx->{sep});$ctx->{sep_len}=$sep_len if$sep_len > 1}$ctx->{quo}='"';if (exists$self->{quote_char}){my$quote_char=$self->{quote_char};if (defined$quote_char and length$quote_char){$ctx->{quo}=$quote_char}else {$ctx->{quo}="\0"}}if (defined$self->{quote}and $self->{quote}ne ''){use bytes;$ctx->{quo}=$self->{quote};my$quote_len=length($ctx->{quo});$ctx->{quo_len}=$quote_len if$quote_len > 1}$ctx->{escape_char}='"';if (exists$self->{escape_char}){my$escape_char=$self->{escape_char};if (defined$escape_char and length$escape_char){$ctx->{escape_char}=$escape_char}else {$ctx->{escape_char}="\0"}}if (defined$self->{eol}){my$eol=$self->{eol};my$eol_len=length($eol);$ctx->{eol}=$eol;$ctx->{eol_len}=$eol_len;if ($eol_len==1 and $eol eq "\015"){$ctx->{eol_is_cr}=1}}$ctx->{undef_flg}=0;if (defined$self->{undef_str}){$ctx->{undef_str}=$self->{undef_str};$ctx->{undef_flg}=3 if utf8::is_utf8($self->{undef_str})}else {$ctx->{undef_str}=undef}if (defined$self->{_types}){$ctx->{types}=$self->{_types};$ctx->{types_len}=length($ctx->{types})}if (defined$self->{_is_bound}){$ctx->{is_bound}=$self->{_is_bound}}if (defined$self->{callbacks}){my$cb=$self->{callbacks};$ctx->{has_hooks}=0;if (defined$cb->{after_parse}and ref$cb->{after_parse}eq 'CODE'){$ctx->{has_hooks}|= HOOK_AFTER_PARSE}if (defined$cb->{before_print}and ref$cb->{before_print}eq 'CODE'){$ctx->{has_hooks}|= HOOK_BEFORE_PRINT}}for (qw/binary decode_utf8 always_quote strict quote_empty allow_loose_quotes allow_loose_escapes allow_unquoted_escape allow_whitespace blank_is_undef empty_is_undef verbatim auto_diag diag_verbose keep_meta_info formula/){$ctx->{$_}=defined$self->{$_}? $self->{$_}: 0}for (qw/quote_space escape_null quote_binary/){$ctx->{$_}=defined$self->{$_}? $self->{$_}: 1}if ($ctx->{escape_char}eq "\0"){$ctx->{escape_null}=0}%{$self->{_CACHE}}=%$ctx}$ctx->{utf8}=0;$ctx->{size}=0;$ctx->{used}=0;if ($ctx->{is_bound}){my$bound=$self->{_BOUND_COLUMNS};if ($bound and ref$bound eq 'ARRAY'){$ctx->{bound}=$bound}else {$ctx->{is_bound}=0}}$ctx->{eol_pos}=-1;$ctx->{eolx}=$ctx->{eol_len}? $ctx->{verbatim}|| $ctx->{eol_len}>= 2 ? 1 : $ctx->{eol}=~ /\A[\015\012]/ ? 0 : 1 : 0;if ($ctx->{sep_len}and $ctx->{sep_len}> 1 and _is_valid_utf8($ctx->{sep})){$ctx->{utf8}=1}if ($ctx->{quo_len}and $ctx->{quo_len}> 1 and _is_valid_utf8($ctx->{quo})){$ctx->{utf8}=1}$ctx}sub _cache_set {my ($self,$idx,$value)=@_;return unless exists$self->{_CACHE};my$cache=$self->{_CACHE};my$key=$_reverse_cache_id{$idx};if (!defined$key){warn (sprintf "Unknown cache index %d ignored\n",$idx)}elsif ($key eq 'sep_char'){$cache->{sep}=$value;$cache->{sep_len}=0}elsif ($key eq 'quote_char'){$cache->{quo}=$value;$cache->{quo_len}=0}elsif ($key eq '_has_ahead'){$cache->{has_ahead}=$value}elsif ($key eq '_has_hooks'){$cache->{has_hooks}=$value}elsif ($key eq '_is_bound'){$cache->{is_bound}=$value}elsif ($key eq 'sep'){use bytes;my$len=bytes::length($value);$cache->{sep}=$value if$len;$cache->{sep_len}=$len==1 ? 0 : $len}elsif ($key eq 'quote'){use bytes;my$len=bytes::length($value);$cache->{quo}=$value if$len;$cache->{quo_len}=$len==1 ? 0 : $len}elsif ($key eq 'eol'){if (defined($value)){$cache->{eol}=$value;$cache->{eol_len}=length($value)}$cache->{eol_is_cr}=$value eq "\015" ? 1 : 0}elsif ($key eq 'undef_str'){if (defined$value){$cache->{undef_str}=$value;$cache->{undef_flg}=3 if utf8::is_utf8($value)}else {$cache->{undef_str}=undef;$cache->{undef_flg}=0}}else {$cache->{$key}=$value}return 1}sub _cache_diag {my$self=shift;unless (exists$self->{_CACHE}){warn ("CACHE: invalid\n");return}my$cache=$self->{_CACHE};warn ("CACHE:\n");$self->__cache_show_char(quote_char=>$cache->{quo});$self->__cache_show_char(escape_char=>$cache->{escape_char});$self->__cache_show_char(sep_char=>$cache->{sep});for (qw/binary decode_utf8 allow_loose_escapes allow_loose_quotes allow_unquoted_escape allow_whitespace always_quote quote_empty quote_space escape_null quote_binary auto_diag diag_verbose formula strict has_error_input blank_is_undef empty_is_undef has_ahead keep_meta_info verbatim has_hooks eol_is_cr eol_len/){$self->__cache_show_byte($_=>$cache->{$_})}$self->__cache_show_str(eol=>$cache->{eol_len},$cache->{eol});$self->__cache_show_byte(sep_len=>$cache->{sep_len});if ($cache->{sep_len}and $cache->{sep_len}> 1){$self->__cache_show_str(sep=>$cache->{sep_len},$cache->{sep})}$self->__cache_show_byte(quo_len=>$cache->{quo_len});if ($cache->{quo_len}and $cache->{quo_len}> 1){$self->__cache_show_str(quote=>$cache->{quo_len},$cache->{quo})}}sub __cache_show_byte {my ($self,$key,$value)=@_;warn (sprintf " %-21s %02x:%3d\n",$key,defined$value ? ord($value): 0,defined$value ? $value : 0)}sub __cache_show_char {my ($self,$key,$value)=@_;my$v=$value;if (defined$value){my@b=unpack "U0C*",$value;$v=pack "U*",$b[0]}warn (sprintf " %-21s %02x:%s\n",$key,defined$v ? ord($v): 0,$self->__pretty_str($v,1))}sub __cache_show_str {my ($self,$key,$len,$value)=@_;warn (sprintf " %-21s %02d:%s\n",$key,$len,$self->__pretty_str($value,$len))}sub __pretty_str {my ($self,$str,$len)=@_;return '' unless defined$str;$str=substr($str,0,$len);$str =~ s/"/\\"/g;$str =~ s/([^\x09\x20-\x7e])/sprintf '\\x{%x}', ord($1)/eg;qq{"$str"}}sub _hook {my ($self,$name,$fields)=@_;return 0 unless$self->{callbacks};my$cb=$self->{callbacks}{$name};return 0 unless$cb && ref$cb eq 'CODE';my (@res)=$cb->($self,$fields);if (@res){return 0 if ref$res[0]eq 'SCALAR' and ${$res[0]}eq "skip"}scalar@res}sub __combine {my ($self,$dst,$fields,$useIO)=@_;my$ctx=$self->_setup_ctx;my ($binary,$quot,$sep,$esc,$quote_space)=@{$ctx}{qw/binary quo sep escape_char quote_space/};if(!defined$quot or $quot eq "\0"){$quot=''}my$re_esc;if ($esc ne '' and $esc ne "\0"){if ($quot ne ''){$re_esc=$self->{_re_comb_escape}->{$quot}->{$esc}||= qr/(\Q$quot\E|\Q$esc\E)/}else {$re_esc=$self->{_re_comb_escape}->{$quot}->{$esc}||= qr/(\Q$esc\E)/}}my$bound=0;my$n=@$fields - 1;if ($n < 0 and $ctx->{is_bound}){$n=$ctx->{is_bound}- 1;$bound=1}my$check_meta=($ctx->{keep_meta_info}>= 10 and @{$self->{_FFLAGS}|| []}>= $n)? 1 : 0;my$must_be_quoted;my@results;for(my$i=0;$i <= $n;$i++){my$v_ref;if ($bound){$v_ref=$self->__bound_field($ctx,$i,1)}else {if (@$fields > $i){$v_ref=\($fields->[$i])}}next unless$v_ref;my$value=$$v_ref;if (!defined$value){if ($ctx->{undef_str}){if ($ctx->{undef_flg}){$ctx->{utf8}=1;$ctx->{binary}=1}push@results,$ctx->{undef_str}}else {push@results,''}next}if (substr($value,0,1)eq '=' && $ctx->{formula}){$value=$self->_formula($ctx,$value,$i);if (!defined$value){push@results,'';next}}$must_be_quoted=$ctx->{always_quote}? 1 : 0;if ($value eq ''){$must_be_quoted++ if$ctx->{quote_empty}or ($check_meta && $self->is_quoted($i))}else {if (utf8::is_utf8$value){$ctx->{utf8}=1;$ctx->{binary}=1}$must_be_quoted++ if$check_meta && $self->is_quoted($i);if (!$must_be_quoted and $quot ne ''){use bytes;$must_be_quoted++ if ($value =~ /\Q$quot\E/)|| ($sep ne '' and $sep ne "\0" and $value =~ /\Q$sep\E/)|| ($esc ne '' and $esc ne "\0" and $value =~ /\Q$esc\E/)|| ($ctx->{quote_binary}&& $value =~ /[\x00-\x1f\x7f-\xa0]/)|| ($ctx->{quote_space}&& $value =~ /[\x09\x20]/)}if (!$ctx->{binary}and $value =~ /[^\x09\x20-\x7E]/){$self->{_ERROR_INPUT}=$value;$self->SetDiag(2110);return 0}if ($re_esc){$value =~ s/($re_esc)/$esc$1/g}if ($ctx->{escape_null}){$value =~ s/\0/${esc}0/g}}if ($must_be_quoted){$value=$quot .$value .$quot}push@results,$value}$$dst=join($sep,@results).(defined$ctx->{eol}? $ctx->{eol}: '');return 1}sub _formula {my ($self,$ctx,$value,$i)=@_;my$fa=$ctx->{formula}or return;if ($fa==1){die "Formulas are forbidden\n"}if ($fa==2){die "Formulas are forbidden\n"}if ($fa==3){my$rec='';if ($ctx->{recno}){$rec=sprintf " in record %lu",$ctx->{recno}+ 1}my$field='';my$column_names=$self->{_COLUMN_NAMES};if (ref$column_names eq 'ARRAY' and @$column_names >= $i - 1){my$column_name=$column_names->[$i - 1];$field=sprintf " (column: '%.100s')",$column_name if defined$column_name}warn sprintf("Field %d%s%s contains formula '%s'\n",$i,$field,$rec,$value);return$value}if ($fa==4){return ''}if ($fa==5){return undef}return}sub print {my ($self,$io,$fields)=@_;require IO::Handle;if (!defined$fields){$fields=[]}elsif(ref($fields)ne 'ARRAY'){Carp::croak("Expected fields to be an array ref")}$self->_hook(before_print=>$fields);my$str="";$self->__combine(\$str,$fields,1)or return '';local $\='';$io->print($str)or $self->_set_error_diag(2200)}sub __parse {my ($self,$fields,$fflags,$src,$useIO)=@_;my$ctx=$self->_setup_ctx;my$state=$self->___parse($ctx,$fields,$fflags,$src,$useIO);if ($state and ($ctx->{has_hooks}|| 0)& HOOK_AFTER_PARSE){$self->_hook(after_parse=>$fields)}return$state ||!$last_error}sub ___parse {my ($self,$ctx,$fields,$fflags,$src,$useIO)=@_;local $/=$ctx->{eol}if$ctx->{eolx}or $ctx->{eol_is_cr};if ($ctx->{useIO}=$useIO){require IO::Handle;$ctx->{tmp}=undef;if ($ctx->{has_ahead}and defined$self->{_AHEAD}){$ctx->{tmp}=$self->{_AHEAD};$ctx->{size}=length$ctx->{tmp};$ctx->{used}=0}}else {$ctx->{tmp}=$src;$ctx->{size}=length$src;$ctx->{used}=0;$ctx->{utf8}=utf8::is_utf8($src)}if ($ctx->{has_error_input}){$self->{_ERROR_INPUT}=undef;$ctx->{has_error_input}=0}my$result=$self->____parse($ctx,$src,$fields,$fflags);$self->{_RECNO}=++($ctx->{recno});$self->{_EOF}='';if ($ctx->{strict}){$ctx->{strict_n}||= $ctx->{fld_idx};if ($ctx->{strict_n}!=$ctx->{fld_idx}){unless ($ctx->{useIO}& useIO_EOF){$self->__parse_error($ctx,2014,$ctx->{used})}$result=undef}}if ($ctx->{useIO}){if (defined$ctx->{tmp}and $ctx->{used}< $ctx->{size}and $ctx->{has_ahead}){$self->{_AHEAD}=substr($ctx->{tmp},$ctx->{used},$ctx->{size}- $ctx->{used})}else {$ctx->{has_ahead}=0;if ($ctx->{useIO}& useIO_EOF){$self->{_EOF}=1}}%{$self->{_CACHE}}=%$ctx;if ($fflags){if ($ctx->{keep_meta_info}){$self->{_FFLAGS}=$fflags}else {undef$fflags}}}else {%{$self->{_CACHE}}=%$ctx}if ($result and $ctx->{types}){my$len=@$fields;for(my$i=0;$i <= $len && $i <= $ctx->{types_len};$i++){my$value=$fields->[$i];next unless defined$value;my$type=ord(substr($ctx->{types},$i,1));if ($type==IV){$fields->[$i]=int($value)}elsif ($type==NV){$fields->[$i]=$value + 0.0}}}$result}sub ____parse {my ($self,$ctx,$src,$fields,$fflags)=@_;my ($quot,$sep,$esc,$eol)=@{$ctx}{qw/quo sep escape_char eol/};utf8::encode($sep)if!$ctx->{utf8}and $ctx->{sep_len};utf8::encode($quot)if!$ctx->{utf8}and $ctx->{quo_len};utf8::encode($eol)if!$ctx->{utf8}and $ctx->{eol_len};my$seenSomething=0;my$waitingForField=1;my ($value,$v_ref);$ctx->{fld_idx}=my$fnum=0;$ctx->{flag}=0;my$re_str=join '|',map({$_ eq "\0" ? '[\\0]' : quotemeta($_)}sort {length$b <=> length$a}grep {defined $_ and $_ ne ''}$sep,$quot,$esc,$eol),"\015","\012","\x09"," ";$ctx->{_re}=qr/$re_str/;my$re=qr/$re_str|[^\x09\x20-\x7E]|$/;LOOP: while($self->__get_from_src($ctx,$src)){while($ctx->{tmp}=~ /\G(.*?)($re)/gs){my ($hit,$c)=($1,$2);$ctx->{used}=pos($ctx->{tmp});if (!$waitingForField and $c eq '' and $hit ne '' and $ctx->{useIO}and!($ctx->{useIO}& useIO_EOF)){$self->{_AHEAD}=$hit;$ctx->{has_ahead}=1;$ctx->{has_leftover}=1;last}last if$seenSomething and $hit eq '' and $c eq '';if (!$v_ref){if ($ctx->{is_bound}){$v_ref=$self->__bound_field($ctx,$fnum,0)}else {$value='';$v_ref=\$value}$fnum++;return unless$v_ref;$ctx->{flag}=0;$ctx->{fld_idx}++}$seenSomething=1;if (defined$hit and $hit ne ''){if ($waitingForField){$waitingForField=0}if ($hit =~ /[^\x09\x20-\x7E]/){$ctx->{flag}|= IS_BINARY}$$v_ref .= $hit}RESTART: if (defined$c and defined$sep and $c eq $sep){if ($waitingForField){if ($ctx->{blank_is_undef}or $ctx->{empty_is_undef}){$$v_ref=undef}else {$$v_ref=""}unless ($ctx->{is_bound}){push @$fields,$$v_ref}$v_ref=undef;if ($ctx->{keep_meta_info}and $fflags){push @$fflags,$ctx->{flag}}}elsif ($ctx->{flag}& IS_QUOTED){$$v_ref .= $c}else {$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);$v_ref=undef;$waitingForField=1}}elsif (defined$c and defined$quot and $quot ne "\0" and $c eq $quot){if ($waitingForField){$ctx->{flag}|= IS_QUOTED;$waitingForField=0;next}if ($ctx->{flag}& IS_QUOTED){my$quoesc=0;my$c2=$self->__get($ctx);if ($ctx->{allow_whitespace}){while($self->__is_whitespace($ctx,$c2)){if ($ctx->{allow_loose_quotes}and!(defined$esc and $c2 eq $esc)){$$v_ref .= $c;$c=$c2}$c2=$self->__get($ctx)}}if (!defined$c2){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}if (defined$c2 and defined$sep and $c2 eq $sep){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);$v_ref=undef;$waitingForField=1;next}if (defined$c2 and ($c2 eq "\012" or (defined$eol and $c2 eq $eol))){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}if (defined$esc and $c eq $esc){$quoesc=1;if (defined$c2 and $c2 eq '0'){$$v_ref .= "\0";next}if (defined$c2 and defined$quot and $c2 eq $quot){if ($ctx->{utf8}){$ctx->{flag}|= IS_BINARY}$$v_ref .= $c2;next}if ($ctx->{allow_loose_escapes}and defined$c2 and $c2 ne "\015"){$$v_ref .= $c;$c=$c2;goto RESTART}}if (defined$c2 and $c2 eq "\015"){if ($ctx->{eol_is_cr}){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}my$c3=$self->__get($ctx);if (defined$c3 and $c3 eq "\012"){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}if ($ctx->{useIO}and!$ctx->{eol_len}and $c3 !~ /[^\x09\x20-\x7E]/){$self->__set_eol_is_cr($ctx);$ctx->{used}--;$ctx->{has_ahead}=1;$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}$self->__parse_error($ctx,$quoesc ? 2023 : 2010,$ctx->{used}- 2);return}if ($ctx->{allow_loose_quotes}and!$quoesc){$$v_ref .= $c;$c=$c2;goto RESTART}if ($quoesc){$ctx->{used}--;$self->__error_inside_quotes($ctx,2023);return}$self->__error_inside_quotes($ctx,2011);return}if ($ctx->{allow_loose_quotes}){$ctx->{flag}|= IS_ERROR;$$v_ref .= $c}else {$self->__error_inside_field($ctx,2034);return}}elsif (defined$c and defined$esc and $esc ne "\0" and $c eq $esc){if ($waitingForField){$waitingForField=0;if ($ctx->{allow_unquoted_escape}){my$c2=$self->__get($ctx);$$v_ref="";if (!defined$c2){$ctx->{used}--;$self->__error_inside_field($ctx,2035);return}if ($c2 eq '0'){$$v_ref .= "\0"}elsif ((defined$quot and $c2 eq $quot)or (defined$sep and $c2 eq $sep)or (defined$esc and $c2 eq $esc)or $ctx->{allow_loose_escapes}){if ($ctx->{utf8}){$ctx->{flag}|= IS_BINARY}$$v_ref .= $c2}else {$self->__parse_inside_quotes($ctx,2025);return}}}elsif ($ctx->{flag}& IS_QUOTED){my$c2=$self->__get($ctx);if (!defined$c2){$ctx->{used}--;$self->__error_inside_quotes($ctx,2024);return}if ($c2 eq '0'){$$v_ref .= "\0"}elsif ((defined$quot and $c2 eq $quot)or (defined$sep and $c2 eq $sep)or (defined$esc and $c2 eq $esc)or $ctx->{allow_loose_escapes}){if ($ctx->{utf8}){$ctx->{flag}|= IS_BINARY}$$v_ref .= $c2}else {$ctx->{used}--;$self->__error_inside_quotes($ctx,2025);return}}elsif ($v_ref){my$c2=$self->__get($ctx);if (!defined$c2){$ctx->{used}--;$self->__error_inside_field($ctx,2035);return}$$v_ref .= $c2}else {$self->__error_inside_field($ctx,2036);return}}elsif (defined$c and ($c eq "\012" or $c eq '' or (defined$eol and $c eq $eol and $eol ne "\015"))){EOLX: if ($waitingForField){if ($ctx->{blank_is_undef}or $ctx->{empty_is_undef}){$$v_ref=undef}else {$$v_ref=""}unless ($ctx->{is_bound}){push @$fields,$$v_ref}if ($ctx->{keep_meta_info}and $fflags){push @$fflags,$ctx->{flag}}return 1}if ($ctx->{flag}& IS_QUOTED){$ctx->{flag}|= IS_BINARY;unless ($ctx->{binary}){$self->__error_inside_quotes($ctx,2021);return}$$v_ref .= $c}elsif ($ctx->{verbatim}){$ctx->{flag}|= IS_BINARY;unless ($ctx->{binary}){$self->__error_inside_field($ctx,2030);return}$$v_ref .= $c unless$ctx->{eol}eq $c and $ctx->{useIO}}else {if (!$ctx->{recno}and $ctx->{fld_idx}==1 and $ctx->{useIO}and $hit =~ /^sep=(.{1,16})$/i){$ctx->{sep}=$1;use bytes;my$len=length$ctx->{sep};if ($len <= 16){$ctx->{sep_len}=$len==1 ? 0 : $len;return$self->____parse($ctx,$src,$fields,$fflags)}}$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}}elsif (defined$c and $c eq "\015" and!$ctx->{verbatim}){if ($waitingForField){$waitingForField=0;if ($ctx->{eol_is_cr}){$c="\012";goto RESTART}my$c2=$self->__get($ctx);if (!defined$c2){$c=undef;goto RESTART}if ($c2 eq "\012"){$c=$c2;goto RESTART}if ($ctx->{useIO}and!$ctx->{eol_len}and $c2 !~ /[^\x09\x20-\x7E]/){$self->__set_eol_is_cr($ctx);$ctx->{used}--;$ctx->{has_ahead}=1;$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}$ctx->{used}--;$self->__error_inside_field($ctx,2031);return}if ($ctx->{flag}& IS_QUOTED){$ctx->{flag}|= IS_BINARY;unless ($ctx->{binary}){$self->__error_inside_quotes($ctx,2022);return}$$v_ref .= $c}else {if ($ctx->{eol_is_cr}){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}my$c2=$self->__get($ctx);if (defined$c2 and $c2 eq "\012"){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}if ($ctx->{useIO}and!$ctx->{eol_len}and $c2 !~ /[^\x09\x20-\x7E]/){$self->__set_eol_is_cr($ctx);$ctx->{used}--;$ctx->{has_ahead}=1;$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum);return 1}$self->__error_inside_field($ctx,2032);return}}else {if ($ctx->{eolx}and $c eq $eol){$c='';goto EOLX}if ($waitingForField){if ($ctx->{allow_whitespace}and $self->__is_whitespace($ctx,$c)){do {$c=$self->__get($ctx);last if!defined$c}while$self->__is_whitespace($ctx,$c);goto RESTART}$waitingForField=0;goto RESTART}if ($ctx->{flag}& IS_QUOTED){if (!defined$c or $c =~ /[^\x09\x20-\x7E]/){$ctx->{flag}|= IS_BINARY;unless ($ctx->{binary}or $ctx->{utf8}){$self->__error_inside_quotes($ctx,2026);return}}$$v_ref .= $c}else {if (!defined$c or $c =~ /[^\x09\x20-\x7E]/){$ctx->{flag}|= IS_BINARY;unless ($ctx->{binary}or $ctx->{utf8}){$self->__error_inside_field($ctx,2037);return}}$$v_ref .= $c}}last LOOP if$ctx->{useIO}and $ctx->{verbatim}and $ctx->{used}==$ctx->{size}}}if ($waitingForField){if ($seenSomething or!$ctx->{useIO}){if (!$v_ref){if ($ctx->{is_bound}){$v_ref=$self->__bound_field($ctx,$fnum,0)}else {$value='';$v_ref=\$value}$fnum++;return unless$v_ref;$ctx->{flag}=0;$ctx->{fld_idx}++}if ($ctx->{blank_is_undef}or $ctx->{empty_is_undef}){$$v_ref=undef}else {$$v_ref=""}unless ($ctx->{is_bound}){push @$fields,$$v_ref}if ($ctx->{keep_meta_info}and $fflags){push @$fflags,$ctx->{flag}}return 1}$self->SetDiag(2012);return}if ($ctx->{flag}& IS_QUOTED){$self->__error_inside_quotes($ctx,2027);return}if ($v_ref){$self->__push_value($ctx,$v_ref,$fields,$fflags,$ctx->{flag},$fnum)}return 1}sub __get_from_src {my ($self,$ctx,$src)=@_;return 1 if defined$ctx->{tmp}and $ctx->{used}<= 0;return 1 if$ctx->{used}< $ctx->{size};return unless$ctx->{useIO};my$res=$src->getline;if (defined$res){if ($ctx->{has_ahead}){$ctx->{tmp}=$self->{_AHEAD};$ctx->{tmp}.= $ctx->{eol}if$ctx->{eol_len};$ctx->{tmp}.= $res;$ctx->{has_ahead}=0}else {$ctx->{tmp}=$res}if ($ctx->{size}=length$ctx->{tmp}){$ctx->{used}=-1;$ctx->{utf8}=1 if utf8::is_utf8($ctx->{tmp});pos($ctx->{tmp})=0;return 1}}elsif (delete$ctx->{has_leftover}){$ctx->{tmp}=$self->{_AHEAD};$ctx->{has_ahead}=0;$ctx->{useIO}|= useIO_EOF;if ($ctx->{size}=length$ctx->{tmp}){$ctx->{used}=-1;$ctx->{utf8}=1 if utf8::is_utf8($ctx->{tmp});pos($ctx->{tmp})=0;return 1}}$ctx->{tmp}='' unless defined$ctx->{tmp};$ctx->{useIO}|= useIO_EOF;return}sub __set_eol_is_cr {my ($self,$ctx)=@_;$ctx->{eol}="\015";$ctx->{eol_is_cr}=1;$ctx->{eol_len}=1;%{$self->{_CACHE}}=%$ctx;$self->{eol}=$ctx->{eol}}sub __bound_field {my ($self,$ctx,$i,$keep)=@_;if ($i >= $ctx->{is_bound}){$self->SetDiag(3006);return}if (ref$ctx->{bound}eq 'ARRAY'){my$ref=$ctx->{bound}[$i];if (ref$ref){if ($keep){return$ref}unless (Scalar::Util::readonly($$ref)){$$ref="";return$ref}}}$self->SetDiag(3008);return}sub __get {my ($self,$ctx)=@_;return unless defined$ctx->{used};return if$ctx->{used}>= $ctx->{size};my$pos=pos($ctx->{tmp});if ($ctx->{tmp}=~ /\G($ctx->{_re}|.)/gs){my$c=$1;if ($c =~ /[^\x09\x20-\x7e]/){$ctx->{flag}|= IS_BINARY}$ctx->{used}=pos($ctx->{tmp});return$c}else {pos($ctx->{tmp})=$pos;return}}sub __error_inside_quotes {my ($self,$ctx,$error)=@_;$self->__parse_error($ctx,$error,$ctx->{used}- 1)}sub __error_inside_field {my ($self,$ctx,$error)=@_;$self->__parse_error($ctx,$error,$ctx->{used}- 1)}sub __parse_error {my ($self,$ctx,$error,$pos)=@_;$self->{_ERROR_POS}=$pos;$self->{_ERROR_FLD}=$ctx->{fld_idx};$self->{_ERROR_INPUT}=$ctx->{tmp}if$ctx->{tmp};$self->SetDiag($error);return}sub __is_whitespace {my ($self,$ctx,$c)=@_;return unless defined$c;return ((!defined$ctx->{sep}or $c ne $ctx->{sep})&& (!defined$ctx->{quo}or $c ne $ctx->{quo})&& (!defined$ctx->{escape_char}or $c ne $ctx->{escape_char})&& ($c eq " " or $c eq "\t"))}sub __push_value {my ($self,$ctx,$v_ref,$fields,$fflags,$flag,$fnum)=@_;utf8::encode($$v_ref)if$ctx->{utf8};if ($ctx->{formula}&& $$v_ref && substr($$v_ref,0,1)eq '='){my$value=$self->_formula($ctx,$$v_ref,$fnum);push @$fields,defined$value ? $value : undef;return}if ((!defined $$v_ref or $$v_ref eq '')and ($ctx->{empty_is_undef}or (!($flag & IS_QUOTED)and $ctx->{blank_is_undef}))){$$v_ref=undef}else {if ($ctx->{allow_whitespace}&&!($flag & IS_QUOTED)){$$v_ref =~ s/[ \t]+$//}if ($flag & IS_BINARY and $ctx->{decode_utf8}and ($ctx->{utf8}|| _is_valid_utf8($$v_ref))){utf8::decode($$v_ref)}}unless ($ctx->{is_bound}){push @$fields,$$v_ref}if ($ctx->{keep_meta_info}and $fflags){push @$fflags,$flag}}sub getline {my ($self,$io)=@_;my (@fields,@fflags);my$res=$self->__parse(\@fields,\@fflags,$io,1);$res ? \@fields : undef}sub getline_all {my ($self,$io,$offset,$len)=@_;my$ctx=$self->_setup_ctx;my$tail=0;my$n=0;$offset ||= 0;if ($offset < 0){$tail=-$offset;$offset=-1}my (@row,@list);while ($self->___parse($ctx,\@row,undef,$io,1)){$ctx=$self->_setup_ctx;if ($offset > 0){$offset--;@row=();next}if ($n++ >= $tail and $tail){shift@list;$n--}if (($ctx->{has_hooks}|| 0)& HOOK_AFTER_PARSE){unless ($self->_hook(after_parse=>\@row)){@row=();next}}push@list,[@row];@row=();last if defined$len && $n >= $len and $offset >= 0}if (defined$len && $n > $len){@list=splice(@list,0,$len)}return \@list}sub _is_valid_utf8 {return ($_[0]=~ /^(?:
329 [\x00-\x7F]
330 |[\xC2-\xDF][\x80-\xBF]
331 |[\xE0][\xA0-\xBF][\x80-\xBF]
332 |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
333 |[\xED][\x80-\x9F][\x80-\xBF]
334 |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
335 |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
336 |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
337 |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
338 )+$/x)? 1 : 0}sub _set_error_diag {my ($self,$error,$pos)=@_;$self->SetDiag($error);if (defined$pos){$_[0]->{_ERROR_POS}=$pos}return}sub error_input {my$self=shift;if ($self and ((Scalar::Util::reftype($self)|| '')eq 'HASH' or (ref$self)=~ /^Text::CSV/)){return$self->{_ERROR_INPUT}}return}sub _sv_diag {my ($self,$error)=@_;bless [$error,$ERRORS->{$error}],'Text::CSV::ErrorDiag'}sub _set_diag {my ($self,$ctx,$error)=@_;$last_error=$self->_sv_diag($error);$self->{_ERROR_DIAG}=$last_error;if ($error==0){$self->{_ERROR_POS}=0;$self->{_ERROR_FLD}=0;$self->{_ERROR_INPUT}=undef;$ctx->{has_error_input}=0}if ($error==2012){$self->{_EOF}=1}if ($ctx->{auto_diag}){$self->error_diag}return$last_error}sub SetDiag {my ($self,$error,$errstr)=@_;my$res;if (ref$self){my$ctx=$self->_setup_ctx;$res=$self->_set_diag($ctx,$error)}else {$res=$self->_sv_diag($error)}if (defined$errstr){$res->[1]=$errstr}$res}package Text::CSV::ErrorDiag;use strict;use overload ('""'=>\&stringify,'+'=>\&numeric,'-'=>\&numeric,'*'=>\&numeric,'/'=>\&numeric,fallback=>1,);sub numeric {my ($left,$right)=@_;return ref$left ? $left->[0]: $right->[0]}sub stringify {$_[0]->[1]}1;
339 TEXT_CSV_PP
340
341 $fatpacked{"Text/Glob.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_GLOB';
342 package Text::Glob;use strict;use Exporter;use vars qw/$VERSION @ISA @EXPORT_OK $strict_leading_dot $strict_wildcard_slash/;$VERSION='0.11';@ISA='Exporter';@EXPORT_OK=qw(glob_to_regex glob_to_regex_string match_glob);$strict_leading_dot=1;$strict_wildcard_slash=1;use constant debug=>0;sub glob_to_regex {my$glob=shift;my$regex=glob_to_regex_string($glob);return qr/^$regex$/}sub glob_to_regex_string {my$glob=shift;my$seperator=$Text::Glob::seperator;$seperator="/" unless defined$seperator;$seperator=quotemeta($seperator);my ($regex,$in_curlies,$escaping);local $_;my$first_byte=1;for ($glob =~ m/(.)/gs){if ($first_byte){if ($strict_leading_dot){$regex .= '(?=[^\.])' unless $_ eq '.'}$first_byte=0}if ($_ eq '/'){$first_byte=1}if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%'){$regex .= "\\$_"}elsif ($_ eq '*'){$regex .= $escaping ? "\\*" : $strict_wildcard_slash ? "(?:(?!$seperator).)*" : ".*"}elsif ($_ eq '?'){$regex .= $escaping ? "\\?" : $strict_wildcard_slash ? "(?!$seperator)." : "."}elsif ($_ eq '{'){$regex .= $escaping ? "\\{" : "(";++$in_curlies unless$escaping}elsif ($_ eq '}' && $in_curlies){$regex .= $escaping ? "}" : ")";--$in_curlies unless$escaping}elsif ($_ eq ',' && $in_curlies){$regex .= $escaping ? "," : "|"}elsif ($_ eq "\\"){if ($escaping){$regex .= "\\\\";$escaping=0}else {$escaping=1}next}else {$regex .= $_;$escaping=0}$escaping=0}print "# $glob $regex\n" if debug;return$regex}sub match_glob {print "# ",join(', ',map {"'$_'"}@_),"\n" if debug;my$glob=shift;my$regex=glob_to_regex$glob;local $_;grep {$_ =~ $regex}@_}1;
343 TEXT_GLOB
344
345 $fatpacked{"Text/Table/Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_TABLE_ANY';
346 package Text::Table::Any;our$DATE='2019-11-29';our$VERSION='0.096';our@BACKENDS=qw(Text::Table::Tiny Text::Table::TinyColor Text::Table::TinyColorWide Text::Table::TinyWide Text::Table::Org Text::Table::CSV Text::Table::TSV Text::Table::LTSV Text::Table::ASV Text::Table::HTML Text::Table::HTML::DataTables Text::Table::Paragraph Text::ANSITable Text::ASCIITable Text::FormatTable Text::MarkdownTable Text::Table Text::TabularDisplay Text::Table::XLSX Term::TablePrint);sub _encode {my$val=shift;$val =~ s/([\\"])/\\$1/g;"\"$val\""}sub backends {@BACKENDS}sub table {my%params=@_;my$rows=$params{rows}or die "Must provide rows!";my$backend=$params{backend}|| 'Text::Table::Tiny';my$header_row=$params{header_row}// 1;if ($backend eq 'Text::Table::Tiny'){require Text::Table::Tiny;return Text::Table::Tiny::table(rows=>$rows,header_row=>$header_row)."\n"}elsif ($backend eq 'Text::Table::TinyColor'){require Text::Table::TinyColor;return Text::Table::TinyColor::table(rows=>$rows,header_row=>$header_row)."\n"}elsif ($backend eq 'Text::Table::TinyColorWide'){require Text::Table::TinyColorWide;return Text::Table::TinyColorWide::table(rows=>$rows,header_row=>$header_row)."\n"}elsif ($backend eq 'Text::Table::TinyWide'){require Text::Table::TinyWide;return Text::Table::TinyWide::table(rows=>$rows,header_row=>$header_row)."\n"}elsif ($backend eq 'Text::Table::Org'){require Text::Table::Org;return Text::Table::Org::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::Table::CSV'){require Text::Table::CSV;return Text::Table::CSV::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::Table::TSV'){require Text::Table::TSV;return Text::Table::TSV::table(rows=>$rows)}elsif ($backend eq 'Text::Table::LTSV'){require Text::Table::LTSV;return Text::Table::LTSV::table(rows=>$rows)}elsif ($backend eq 'Text::Table::ASV'){require Text::Table::ASV;return Text::Table::ASV::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::Table::HTML'){require Text::Table::HTML;return Text::Table::HTML::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::Table::HTML::DataTables'){require Text::Table::HTML::DataTables;return Text::Table::HTML::DataTables::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::Table::Paragraph'){require Text::Table::Paragraph;return Text::Table::Paragraph::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Text::ANSITable'){require Text::ANSITable;my$t=Text::ANSITable->new(use_utf8=>0,use_box_chars=>0,use_color=>0,border_style=>'Default::single_ascii',);if ($header_row){$t->columns($rows->[0]);$t->add_row($rows->[$_])for 1..@$rows-1}else {$t->columns([map {"col$_"}0..$#{$rows->[0]}]);$t->add_row($_)for @$rows}return$t->draw}elsif ($backend eq 'Text::ASCIITable'){require Text::ASCIITable;my$t=Text::ASCIITable->new();if ($header_row){$t->setCols(@{$rows->[0]});$t->addRow(@{$rows->[$_]})for 1..@$rows-1}else {$t->setCols(map {"col$_"}0..$#{$rows->[0]});$t->addRow(@$_)for @$rows}return "$t"}elsif ($backend eq 'Text::FormatTable'){require Text::FormatTable;my$t=Text::FormatTable->new(join('|',('l')x @{$rows->[0]}));$t->head(@{$rows->[0]});$t->row(@{$rows->[$_]})for 1..@$rows-1;return$t->render}elsif ($backend eq 'Text::MarkdownTable'){require Text::MarkdownTable;my$out="";my$fields=$header_row ? $rows->[0]: [map {"col$_"}0..$#{$rows->[0]}];my$t=Text::MarkdownTable->new(file=>\$out,columns=>$fields);for (($header_row ? 1:0).. $#{$rows}){my$row=$rows->[$_];$t->add({map {$fields->[$_]=>$row->[$_]}0..@$fields-1 })}$t->done;return$out}elsif ($backend eq 'Text::Table'){require Text::Table;my$t=Text::Table->new(@{$rows->[0]});$t->load(@{$rows}[1..@$rows-1]);return$t}elsif ($backend eq 'Text::TabularDisplay'){require Text::TabularDisplay;my$t=Text::TabularDisplay->new(@{$rows->[0]});$t->add(@{$rows->[$_]})for 1..@$rows-1;return$t->render ."\n"}elsif ($backend eq 'Text::Table::XLSX'){require Text::Table::XLSX;return Text::Table::XLSX::table(rows=>$rows,header_row=>$header_row)}elsif ($backend eq 'Term::TablePrint'){require Term::TablePrint;my$rows2;if ($header_row){$rows2=$rows}else {$rows2=[@$rows];shift @$rows2}return Term::TablePrint::print_table($rows)}else {die "Unknown backend '$backend'"}}1;
347 TEXT_TABLE_ANY
348
349 $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
350 package Try::Tiny;use 5.006;our$VERSION='0.30';use strict;use warnings;use Exporter 5.57 'import';our@EXPORT=our@EXPORT_OK=qw(try catch finally);use Carp;$Carp::Internal{+__PACKAGE__}++;BEGIN {my$su=$INC{'Sub/Util.pm'}&& defined&Sub::Util::set_subname;my$sn=$INC{'Sub/Name.pm'}&& eval {Sub::Name->VERSION(0.08)};unless ($su || $sn){$su=eval {require Sub::Util}&& defined&Sub::Util::set_subname;unless ($su){$sn=eval {require Sub::Name;Sub::Name->VERSION(0.08)}}}*_subname=$su ? \&Sub::Util::set_subname : $sn ? \&Sub::Name::subname : sub {$_[1]};*_HAS_SUBNAME=($su || $sn)? sub(){1}: sub(){0}}my%_finally_guards;sub try (&;@) {my ($try,@code_refs)=@_;my$wantarray=wantarray;my ($catch,@finally)=();for my$code_ref (@code_refs){if (ref($code_ref)eq 'Try::Tiny::Catch'){croak 'A try() may not be followed by multiple catch() blocks' if$catch;$catch=${$code_ref}}elsif (ref($code_ref)eq 'Try::Tiny::Finally'){push@finally,${$code_ref}}else {croak('try() encountered an unexpected argument (' .(defined$code_ref ? $code_ref : 'undef').') - perhaps a missing semi-colon before or')}}_subname(caller().'::try {...} '=>$try)if _HAS_SUBNAME;local$_finally_guards{guards}=[map {Try::Tiny::ScopeGuard->_new($_)}@finally ];my$prev_error=$@;my (@ret,$error);my$failed=not eval {$@=$prev_error;if ($wantarray){@ret=$try->()}elsif (defined$wantarray){$ret[0]=$try->()}else {$try->()};return 1};$error=$@;$@=$prev_error;if ($failed){push @$_,$error for @{$_finally_guards{guards}};if ($catch){for ($error){return$catch->($error)}}return}else {return$wantarray ? @ret : $ret[0]}}sub catch (&;@) {my ($block,@rest)=@_;croak 'Useless bare catch()' unless wantarray;_subname(caller().'::catch {...} '=>$block)if _HAS_SUBNAME;return (bless(\$block,'Try::Tiny::Catch'),@rest,)}sub finally (&;@) {my ($block,@rest)=@_;croak 'Useless bare finally()' unless wantarray;_subname(caller().'::finally {...} '=>$block)if _HAS_SUBNAME;return (bless(\$block,'Try::Tiny::Finally'),@rest,)}{package Try::Tiny::ScopeGuard;use constant UNSTABLE_DOLLARAT=>("$]" < '5.013002')? 1 : 0;sub _new {shift;bless [@_ ]}sub DESTROY {my ($code,@args)=@{$_[0]};local $@ if UNSTABLE_DOLLARAT;eval {$code->(@args);1}or do {warn "Execution of finally() block $code resulted in an exception, which " .'*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. ' .'Your program will continue as if this event never took place. ' ."Original exception text follows:\n\n" .(defined $@ ? $@ : '$@ left undefined...')."\n" }}}__PACKAGE__
351 TRY_TINY
352
353 s/^ //mg for values %fatpacked;
354
355 my $class = 'FatPacked::'.(0+\%fatpacked);
356 no strict 'refs';
357 *{"${class}::files"} = sub { keys %{$_[0]} };
358
359 if ($] < 5.008) {
360 *{"${class}::INC"} = sub {
361 if (my $fat = $_[0]{$_[1]}) {
362 my $pos = 0;
363 my $last = length $fat;
364 return (sub {
365 return 0 if $pos == $last;
366 my $next = (1 + index $fat, "\n", $pos) || $last;
367 $_ .= substr $fat, $pos, $next - $pos;
368 $pos = $next;
369 return 1;
370 });
371 }
372 };
373 }
374
375 else {
376 *{"${class}::INC"} = sub {
377 if (my $fat = $_[0]{$_[1]}) {
378 open my $fh, '<', \$fat
379 or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
380 return $fh;
381 }
382 return;
383 };
384 }
385
386 unshift @INC, bless \%fatpacked, $class;
387 } # END OF FATPACK CODE
388
389
390
391 use warnings;
392 use strict;
393
394 use GraphQL::Client::CLI;
395
396 our $VERSION = '0.604'; # VERSION
397
398 GraphQL::Client::CLI->main(@ARGV);
399
400 __END__
401
402 =pod
403
404 =encoding UTF-8
405
406 =head1 NAME
407
408 graphql - Command-line GraphQL client
409
410 =head1 VERSION
411
412 version 0.604
413
414 =head1 SYNOPSIS
415
416 graphql <URL> <QUERY> [ [--variables JSON] | [--variable KEY=VALUE]... ]
417 [--operation-name NAME] [--transport KEY=VALUE]...
418 [--[no-]unpack] [--filter JSONPATH]
419 [--format json|json:pretty|yaml|perl|csv|tsv|table] [--output FILE]
420
421 graphql --version|--help|--manual
422
423 =head1 DESCRIPTION
424
425 C<graphql> is a command-line program for executing queries and mutations on
426 a L<GraphQL|https://graphql.org/> server.
427
428 =head1 INSTALL
429
430 There are several ways to install F<graphql> to your system.
431
432 =head2 from CPAN
433
434 You can install F<graphql> using L<cpanm>:
435
436 cpanm GraphQL::Client
437
438 =head2 from GitHub
439
440 You can also choose to download F<graphql> as a self-contained executable:
441
442 curl -OL https://raw.githubusercontent.com/chazmcgarvey/graphql-client/solo/graphql
443 chmod +x graphql
444
445 To hack on the code, clone the repo instead:
446
447 git clone https://github.com/chazmcgarvey/graphql-client.git
448 cd graphql-client
449 make bootstrap # installs dependencies; requires cpanm
450
451 =head1 OPTIONS
452
453 =head2 C<--url URL>
454
455 The URL of the GraphQL server endpoint.
456
457 If no C<--url> option is given, the first argument is assumed to be the URL.
458
459 This option is required.
460
461 Alias: C<-u>
462
463 =head2 C<--query STR>
464
465 The query or mutation to execute.
466
467 If no C<--query> option is given, the next argument (after URL) is assumed to be the query.
468
469 If the value is "-" (which is the default), the query will be read from C<STDIN>.
470
471 See: L<https://graphql.org/learn/queries/>
472
473 Alias: C<--mutation>
474
475 =head2 C<--variables JSON>
476
477 Provide the variables as a JSON object.
478
479 Aliases: C<--vars>, C<-V>
480
481 =head2 C<--variable KEY=VALUE>
482
483 An alternative way to provide variables one at a time. This option can be repeated to provide
484 multiple variables.
485
486 If used in combination with L</"--variables JSON">, this option is silently ignored.
487
488 See: L<https://graphql.org/learn/queries/#variables>
489
490 Aliases: C<--var>, C<-d>
491
492 =head2 C<--operation-name NAME>
493
494 Inform the server which query/mutation to execute.
495
496 Alias: C<-n>
497
498 =head2 C<--output FILE>
499
500 Write the response to a file instead of STDOUT.
501
502 Alias: C<-o>
503
504 =head2 C<--transport KEY=VALUE>
505
506 Key-value pairs for configuring the transport (usually HTTP).
507
508 Alias: C<-t>
509
510 =head2 C<--format STR>
511
512 Specify the output format to use. See L</FORMAT>.
513
514 Alias: C<-f>
515
516 =head2 C<--unpack>
517
518 Enables unpack mode.
519
520 By default, the response structure is printed as-is from the server, and the program exits 0.
521
522 When unpack mode is enabled, if the response completes with no errors, only the data section of
523 the response is printed and the program exits 0. If the response has errors, the whole response
524 structure is printed as-is and the program exits 1. See L</EXAMPLES> to see what this looks like in
525 practice.
526
527 Use C<--no-unpack> to disable if unpack mode was enabled via C<GRAPHQL_CLIENT_OPTIONS>.
528
529 =head2 C<--filter JSONPATH>
530
531 Filter the response based on a L<JSONPath|JSON::Path/SYNOPSIS> expression.
532
533 Requires L<JSON::Path>.
534
535 Alias: C<-p>
536
537 =head1 FORMAT
538
539 The argument for L</"--format STR"> can be one of:
540
541 =over 4
542
543 =item *
544
545 C<csv> - Comma-separated values (requires L<Text::CSV>)
546
547 =item *
548
549 C<json:pretty> - Human-readable JSON (default)
550
551 =item *
552
553 C<json> - JSON
554
555 =item *
556
557 C<perl> - Perl code (requires L<Data::Dumper>)
558
559 =item *
560
561 C<table> - Table (requires L<Text::Table::Any>)
562
563 =item *
564
565 C<tsv> - Tab-separated values (requires L<Text::CSV>)
566
567 =item *
568
569 C<yaml> - YAML (requires L<YAML>)
570
571 =back
572
573 The C<csv>, C<tsv>, and C<table> formats will only work if the response has a particular shape:
574
575 {
576 "data" : {
577 "onefield" : [
578 {
579 "key" : "value",
580 ...
581 },
582 ...
583 ]
584 }
585 }
586
587 or
588
589 {
590 "data" : {
591 "onefield" : [
592 "value",
593 ...
594 ]
595 }
596 }
597
598 If the response cannot be formatted, the default format will be used instead, an error message will
599 be printed to STDERR, and the program will exit 3.
600
601 Table formatting can be done by one of several different modules, each with its own features and
602 bugs. The default module is L<Text::Table::Tiny>, but this can be overridden using the
603 C<PERL_TEXT_TABLE> environment variable if desired, like this:
604
605 PERL_TEXT_TABLE=Text::Table::HTML graphql ... -f table
606
607 The list of supported modules is at L<Text::Table::Any/@BACKENDS>.
608
609 =head1 EXAMPLES
610
611 Different ways to provide the query/mutation to execute:
612
613 graphql http://myserver/graphql {hello}
614
615 echo {hello} | graphql http://myserver/graphql
616
617 graphql http://myserver/graphql <<END
618 > {hello}
619 > END
620
621 graphql http://myserver/graphql
622 Interactive mode engaged! Waiting for a query on <STDIN>...
623 {hello}
624 ^D
625
626 Execute a query with variables:
627
628 graphql http://myserver/graphql <<END --var episode=JEDI
629 > query HeroNameAndFriends($episode: Episode) {
630 > hero(episode: $episode) {
631 > name
632 > friends {
633 > name
634 > }
635 > }
636 > }
637 > END
638
639 graphql http://myserver/graphql --vars '{"episode":"JEDI"}'
640
641 Configure the transport:
642
643 graphql http://myserver/graphql {hello} -t headers.authorization='Basic s3cr3t'
644
645 This example shows the effect of L</--unpack>:
646
647 graphql http://myserver/graphql {hello}
648
649 # Output:
650 {
651 "data" : {
652 "hello" : "Hello world!"
653 }
654 }
655
656 graphql http://myserver/graphql {hello} --unpack
657
658 # Output:
659 {
660 "hello" : "Hello world!"
661 }
662
663 =head1 ENVIRONMENT
664
665 Some environment variables affect the way C<graphql> behaves:
666
667 =over 4
668
669 =item *
670
671 C<GRAPHQL_CLIENT_DEBUG> - Set to 1 to print diagnostic messages to STDERR.
672
673 =item *
674
675 C<GRAPHQL_CLIENT_HTTP_USER_AGENT> - Set the HTTP user agent string.
676
677 =item *
678
679 C<GRAPHQL_CLIENT_OPTIONS> - Set the default set of options.
680
681 =item *
682
683 C<PERL_TEXT_TABLE> - Set table format backend; see L</FORMAT>.
684
685 =back
686
687 =head1 EXIT STATUS
688
689 Here is a consolidated summary of what exit statuses mean:
690
691 =over 4
692
693 =item *
694
695 C<0> - Success
696
697 =item *
698
699 C<1> - Client or server errors
700
701 =item *
702
703 C<2> - Option usage is wrong
704
705 =item *
706
707 C<3> - Could not format the response as requested
708
709 =back
710
711 =head1 SEE ALSO
712
713 =over 4
714
715 =item *
716
717 L<GraphQL::Client> - Programmatic interface
718
719 =back
720
721 =head1 BUGS
722
723 Please report any bugs or feature requests on the bugtracker website
724 L<https://github.com/chazmcgarvey/graphql-client/issues>
725
726 When submitting a bug or request, please include a test-file or a
727 patch to an existing test-file that illustrates the bug or desired
728 feature.
729
730 =head1 AUTHOR
731
732 Charles McGarvey <chazmcgarvey@brokenzipper.com>
733
734 =head1 COPYRIGHT AND LICENSE
735
736 This software is copyright (c) 2020 by Charles McGarvey.
737
738 This is free software; you can redistribute it and/or modify it under
739 the same terms as the Perl 5 programming language system itself.
740
741 =cut
This page took 0.593288 seconds and 4 git commands to generate.