my %fatpacked;
$fatpacked{"B/Hooks/EndOfScope.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'B_HOOKS_ENDOFSCOPE';
- package B::Hooks::EndOfScope;use strict;use warnings;our$VERSION='0.24';use 5.006001;BEGIN {use Module::Implementation 0.05;Module::Implementation::build_loader_sub(implementations=>['XS','PP' ],symbols=>['on_scope_end' ],)->()}use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end' ],groups=>{default=>['on_scope_end']},};1;
+ package B::Hooks::EndOfScope;use strict;use warnings;our$VERSION='0.26';use 5.006001;BEGIN {use Module::Implementation 0.05;Module::Implementation::build_loader_sub(implementations=>['XS','PP' ],symbols=>['on_scope_end' ],)->()}use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end' ],groups=>{default=>['on_scope_end']},};1;
B_HOOKS_ENDOFSCOPE
$fatpacked{"B/Hooks/EndOfScope/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'B_HOOKS_ENDOFSCOPE_PP';
- package B::Hooks::EndOfScope::PP;use warnings;use strict;our$VERSION='0.24';use constant _PERL_VERSION=>"$]";BEGIN {if (_PERL_VERSION =~ /^5\.009/){die "By design B::Hooks::EndOfScope does not operate in pure-perl mode on perl 5.9.X\n"}elsif (_PERL_VERSION < '5.010'){require B::Hooks::EndOfScope::PP::HintHash;*on_scope_end=\&B::Hooks::EndOfScope::PP::HintHash::on_scope_end}else {require B::Hooks::EndOfScope::PP::FieldHash;*on_scope_end=\&B::Hooks::EndOfScope::PP::FieldHash::on_scope_end}}use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end'],groups=>{default=>['on_scope_end']},};sub __invoke_callback {local $@;eval {$_[0]->();1}or do {my$err=$@;require Carp;Carp::cluck((join ' ','A scope-end callback raised an exception, which can not be propagated when','B::Hooks::EndOfScope operates in pure-perl mode. Your program will CONTINUE','EXECUTION AS IF NOTHING HAPPENED AFTER THIS WARNING. Below is the complete','exception text, followed by a stack-trace of the callback execution:',)."\n\n$err\n\r");sleep 1 if -t *STDERR}}1;
+ package B::Hooks::EndOfScope::PP;use warnings;use strict;our$VERSION='0.26';use constant _PERL_VERSION=>"$]";BEGIN {if (_PERL_VERSION =~ /^5\.009/){die "By design B::Hooks::EndOfScope does not operate in pure-perl mode on perl 5.9.X\n"}elsif (_PERL_VERSION < '5.010'){require B::Hooks::EndOfScope::PP::HintHash;*on_scope_end=\&B::Hooks::EndOfScope::PP::HintHash::on_scope_end}else {require B::Hooks::EndOfScope::PP::FieldHash;*on_scope_end=\&B::Hooks::EndOfScope::PP::FieldHash::on_scope_end}}use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end'],groups=>{default=>['on_scope_end']},};sub __invoke_callback {local $@;eval {$_[0]->();1}or do {my$err=$@;require Carp;Carp::cluck((join ' ','A scope-end callback raised an exception, which can not be propagated when','B::Hooks::EndOfScope operates in pure-perl mode. Your program will CONTINUE','EXECUTION AS IF NOTHING HAPPENED AFTER THIS WARNING. Below is the complete','exception text, followed by a stack-trace of the callback execution:',)."\n\n$err\n\r");sleep 1 if -t *STDERR}}1;
B_HOOKS_ENDOFSCOPE_PP
$fatpacked{"B/Hooks/EndOfScope/PP/FieldHash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'B_HOOKS_ENDOFSCOPE_PP_FIELDHASH';
- package B::Hooks::EndOfScope::PP::FieldHash;use strict;use warnings;our$VERSION='0.24';use Tie::Hash ();use Hash::Util::FieldHash 'fieldhash';fieldhash my%hh;{package B::Hooks::EndOfScope::PP::_TieHintHashFieldHash;our@ISA=('Tie::StdHash');sub DELETE {my$ret=shift->SUPER::DELETE(@_);B::Hooks::EndOfScope::PP::__invoke_callback($_)for @$ret;$ret}}sub on_scope_end (&) {$^H |= 0x020000;tie(%hh,'B::Hooks::EndOfScope::PP::_TieHintHashFieldHash')unless tied%hh;push @{$hh{\%^H}||= []},$_[0]}1;
+ package B::Hooks::EndOfScope::PP::FieldHash;use strict;use warnings;our$VERSION='0.26';use Tie::Hash ();use Hash::Util::FieldHash 'fieldhash';fieldhash my%hh;{package B::Hooks::EndOfScope::PP::_TieHintHashFieldHash;our@ISA=('Tie::StdHash');sub DELETE {my$ret=shift->SUPER::DELETE(@_);B::Hooks::EndOfScope::PP::__invoke_callback($_)for @$ret;$ret}}sub on_scope_end (&) {$^H |= 0x020000;tie(%hh,'B::Hooks::EndOfScope::PP::_TieHintHashFieldHash')unless tied%hh;push @{$hh{\%^H}||= []},$_[0]}1;
B_HOOKS_ENDOFSCOPE_PP_FIELDHASH
$fatpacked{"B/Hooks/EndOfScope/PP/HintHash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'B_HOOKS_ENDOFSCOPE_PP_HINTHASH';
- package B::Hooks::EndOfScope::PP::HintHash;use strict;use warnings;our$VERSION='0.24';use Scalar::Util ();use constant _NEEDS_MEMORY_CORRUPTION_FIXUP=>("$]" >= 5.008 and "$]" < 5.008004)? 1 : 0;use constant _PERL_VERSION=>"$]";sub on_scope_end (&) {$^H |= 0x020000 if _PERL_VERSION >= 5.008;local %^H=%^H if _PERL_VERSION < 5.008;bless \%^H,'B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport' if (_NEEDS_MEMORY_CORRUPTION_FIXUP and ref \%^H eq 'HASH');push @{$^H{sprintf '__B_H_EOS__guardstack_0X%x',Scalar::Util::refaddr(\%^H)}||= bless ([],'B::Hooks::EndOfScope::PP::_SG_STACK')},$_[0]}sub B::Hooks::EndOfScope::PP::_SG_STACK::DESTROY {B::Hooks::EndOfScope::PP::__invoke_callback($_)for @{$_[0]}}{my@Hint_Hash_Graveyard;push@Hint_Hash_Graveyard,\@Hint_Hash_Graveyard if _NEEDS_MEMORY_CORRUPTION_FIXUP;sub B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport::DESTROY {push@Hint_Hash_Graveyard,$_[0];bless $_[0],'B::Hooks::EndOfScope::PP::HintHash::__DeactivateGraveyardTransport';%{$_[0]}=()}}1;
+ package B::Hooks::EndOfScope::PP::HintHash;use strict;use warnings;our$VERSION='0.26';use Scalar::Util ();use constant _NEEDS_MEMORY_CORRUPTION_FIXUP=>("$]" >= 5.008 and "$]" < 5.008004)? 1 : 0;use constant _PERL_VERSION=>"$]";sub on_scope_end (&) {$^H |= 0x020000 if _PERL_VERSION >= 5.008;local %^H=%^H if _PERL_VERSION < 5.008;bless \%^H,'B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport' if (_NEEDS_MEMORY_CORRUPTION_FIXUP and ref \%^H eq 'HASH');push @{$^H{sprintf '__B_H_EOS__guardstack_0X%x',Scalar::Util::refaddr(\%^H)}||= bless ([],'B::Hooks::EndOfScope::PP::_SG_STACK')},$_[0]}sub B::Hooks::EndOfScope::PP::_SG_STACK::DESTROY {B::Hooks::EndOfScope::PP::__invoke_callback($_)for @{$_[0]}}{my@Hint_Hash_Graveyard;push@Hint_Hash_Graveyard,\@Hint_Hash_Graveyard if _NEEDS_MEMORY_CORRUPTION_FIXUP;sub B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport::DESTROY {push@Hint_Hash_Graveyard,$_[0];bless $_[0],'B::Hooks::EndOfScope::PP::HintHash::__DeactivateGraveyardTransport';%{$_[0]}=()}}1;
B_HOOKS_ENDOFSCOPE_PP_HINTHASH
$fatpacked{"B/Hooks/EndOfScope/XS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'B_HOOKS_ENDOFSCOPE_XS';
- package B::Hooks::EndOfScope::XS;use strict;use warnings;our$VERSION='0.24';use 5.008004;use Variable::Magic 0.48 ();use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end'],groups=>{default=>['on_scope_end']},};my$wiz=Variable::Magic::wizard data=>sub {[$_[1]]},free=>sub {$_->()for @{$_[1]};()},local=>\undef ;sub on_scope_end (&) {$^H |= 0x020000;if (my$stack=Variable::Magic::getdata %^H,$wiz){push @{$stack},$_[0]}else {Variable::Magic::cast %^H,$wiz,$_[0]}}1;
+ package B::Hooks::EndOfScope::XS;use strict;use warnings;our$VERSION='0.26';use 5.008004;use Variable::Magic 0.48 ();use Sub::Exporter::Progressive 0.001006 -setup=>{exports=>['on_scope_end'],groups=>{default=>['on_scope_end']},};my$wiz=Variable::Magic::wizard data=>sub {[$_[1]]},free=>sub {$_->()for @{$_[1]};()},local=>\undef ;sub on_scope_end (&) {$^H |= 0x020000;if (my$stack=Variable::Magic::getdata %^H,$wiz){push @{$stack},$_[0]}else {Variable::Magic::cast %^H,$wiz,$_[0]}}1;
B_HOOKS_ENDOFSCOPE_XS
$fatpacked{"Dist/CheckConflicts.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIST_CHECKCONFLICTS';
DIST_CHECKCONFLICTS
$fatpacked{"Future.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUTURE';
- package Future;use strict;use warnings;no warnings 'recursion';our$VERSION='0.43';use Carp qw();use Scalar::Util qw(weaken blessed reftype);use B qw(svref_2object);use Time::HiRes qw(gettimeofday tv_interval);require overload;require Future::Exception;our@CARP_NOT=qw(Future::Utils);use constant DEBUG=>!!$ENV{PERL_FUTURE_DEBUG};our$TIMES=DEBUG || $ENV{PERL_FUTURE_TIMES};use constant {CB_DONE=>1<<0,CB_FAIL=>1<<1,CB_CANCEL=>1<<2,CB_SELF=>1<<3,CB_RESULT=>1<<4,CB_SEQ_ONDONE=>1<<5,CB_SEQ_ONFAIL=>1<<6,CB_SEQ_IMDONE=>1<<7,CB_SEQ_IMFAIL=>1<<8,};use constant CB_ALWAYS=>CB_DONE|CB_FAIL|CB_CANCEL;sub CvNAME_FILE_LINE {my ($code)=@_;my$cv=svref_2object($code);my$name=join "::",$cv->STASH->NAME,$cv->GV->NAME;return$name unless$cv->GV->NAME eq "__ANON__";my$cop=$cv->START;$cop=$cop->next while$cop and ref$cop ne "B::COP" and ref$cop ne "B::NULL";return$cv->GV->NAME if ref$cop eq "B::NULL";sprintf "%s(%s line %d)",$cv->GV->NAME,$cop->file,$cop->line}sub _callable {my ($cb)=@_;defined$cb and (reftype($cb)eq 'CODE' || overload::Method($cb,'&{}'))}sub new {my$proto=shift;return bless {ready=>0,callbacks=>[],(DEBUG ? (do {my$at=Carp::shortmess("constructed");chomp$at;$at =~ s/\.$//;constructed_at=>$at}): ()),($TIMES ? (btime=>[gettimeofday ]): ()),},(ref$proto || $proto)}*AWAIT_CLONE=sub {shift->new};my$GLOBAL_END;END {$GLOBAL_END=1}sub DESTROY_debug {my$self=shift;return if$GLOBAL_END;return if$self->{ready}and ($self->{reported}or!$self->{failure});my$lost_at=join " line ",(caller)[1,2];if($self->{ready}and $self->{failure}){warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " .$self->{failure}[0]."\n"}elsif(!$self->{ready}){warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n"}}*DESTROY=\&DESTROY_debug if DEBUG;sub wrap {my$class=shift;my@values=@_;if(@values==1 and blessed$values[0]and $values[0]->isa(__PACKAGE__)){return$values[0]}else {return$class->done(@values)}}sub call {my$class=shift;my ($code,@args)=@_;my$f;eval {$f=$code->(@args);1}or $f=$class->fail($@);blessed$f and $f->isa("Future")or $f=$class->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future");return$f}sub _shortmess {my$at=Carp::shortmess($_[0]);chomp$at;$at =~ s/\.$//;return$at}sub _mark_ready {my$self=shift;$self->{ready}=1;$self->{ready_at}=_shortmess $_[0]if DEBUG;if($TIMES){$self->{rtime}=[gettimeofday ]}delete$self->{on_cancel};$_->[0]and $_->[0]->_revoke_on_cancel($_->[1])for @{$self->{revoke_when_ready}};delete$self->{revoke_when_ready};my$callbacks=delete$self->{callbacks}or return;my$cancelled=$self->{cancelled};my$fail=defined$self->{failure};my$done=!$fail &&!$cancelled;my@result=$done ? $self->get : $fail ? $self->failure : ();for my$cb (@$callbacks){my ($flags,$code)=@$cb;my$is_future=blessed($code)&& $code->isa("Future");next if$done and not($flags & CB_DONE);next if$fail and not($flags & CB_FAIL);next if$cancelled and not($flags & CB_CANCEL);$self->{reported}=1 if$fail;if($is_future){$done ? $code->done(@result): $fail ? $code->fail(@result): $code->cancel}elsif($flags & (CB_SEQ_ONDONE|CB_SEQ_ONFAIL)){my (undef,undef,$fseq)=@$cb;if(!$fseq){Carp::carp +(DEBUG ? "${\$self->__selfstr} ($self->{constructed_at})" : "${\$self->__selfstr} $self")." lost a sequence Future";next}my$f2;if($done and $flags & CB_SEQ_ONDONE or $fail and $flags & CB_SEQ_ONFAIL){if($flags & CB_SEQ_IMDONE){$fseq->done(@$code);next}elsif($flags & CB_SEQ_IMFAIL){$fseq->fail(@$code);next}my@args=(($flags & CB_SELF ? $self : ()),($flags & CB_RESULT ? @result : ()),);unless(eval {$f2=$code->(@args);1}){$fseq->fail($@);next}unless(blessed$f2 and $f2->isa("Future")){$fseq->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future");next}$fseq->on_cancel($f2)}else {$f2=$self}if($f2->is_ready){$f2->on_ready($fseq)if!$f2->{cancelled}}else {push @{$f2->{callbacks}},[CB_DONE|CB_FAIL,$fseq ];weaken($f2->{callbacks}[-1][1])}}else {$code->(($flags & CB_SELF ? $self : ()),($flags & CB_RESULT ? @result : ()),)}}}sub is_ready {my$self=shift;return$self->{ready}}*AWAIT_IS_READY=\&is_ready;sub is_done {my$self=shift;return$self->{ready}&&!$self->{failure}&&!$self->{cancelled}}sub is_failed {my$self=shift;return$self->{ready}&&!!$self->{failure}}sub is_cancelled {my$self=shift;return$self->{cancelled}}*AWAIT_IS_CANCELLED=\&is_cancelled;sub state {my$self=shift;return!$self->{ready}? "pending" : DEBUG ? $self->{ready_at}: $self->{failure}? "failed" : $self->{cancelled}? "cancelled" : "done"}sub done {my$self=shift;if(ref$self){$self->{cancelled}and return$self;$self->{ready}and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->done";$self->{subs}and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->done";$self->{result}=[@_ ];$self->_mark_ready("done")}else {$self=$self->new;$self->{ready}=1;$self->{ready_at}=_shortmess "done" if DEBUG;$self->{result}=[@_ ]}return$self}*AWAIT_NEW_DONE=*AWAIT_DONE=\&done;sub fail {my$self=shift;my ($exception,@more)=@_;if(ref$exception eq "Future::Exception"){@more=($exception->category,$exception->details);$exception=$exception->message}$exception or Carp::croak "$self ->fail requires an exception that is true";if(ref$self){$self->{cancelled}and return$self;$self->{ready}and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->fail'ed";$self->{subs}and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->fail'ed";$self->{failure}=[$exception,@more ];$self->_mark_ready("failed")}else {$self=$self->new;$self->{ready}=1;$self->{ready_at}=_shortmess "failed" if DEBUG;$self->{failure}=[$exception,@more ]}return$self}*AWAIT_NEW_FAIL=*AWAIT_FAIL=\&fail;sub die :method {my$self=shift;my ($exception,@more)=@_;if(!ref$exception and $exception !~ m/\n$/){$exception .= sprintf " at %s line %d\n",(caller)[1,2]}$self->fail($exception,@more)}sub on_cancel {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_cancel";$self->{ready}and return$self;push @{$self->{on_cancel}},$code;if($is_future){push @{$code->{revoke_when_ready}},my$r=[$self,\$self->{on_cancel}[-1]];weaken($r->[0]);weaken($r->[1])}return$self}sub AWAIT_ON_CANCEL {my$self=shift;my ($f2)=@_;push @{$self->{on_cancel}},$f2;push @{$f2->{revoke_when_ready}},my$r=[$self,\$self->{on_cancel}[-1]];weaken($r->[0]);weaken($r->[1])}sub _revoke_on_cancel {my$self=shift;my ($ref)=@_;undef $$ref;$self->{empty_on_cancel_slots}++;my$on_cancel=$self->{on_cancel}or return;if(@$on_cancel >= 8 and $self->{empty_on_cancel_slots}>= 0.5 * @$on_cancel){my$idx=0;while($idx < @$on_cancel){defined$on_cancel->[$idx]and $idx++,next;splice @$on_cancel,$idx,1,()}$self->{empty_on_cancel_slots}=0}}sub on_ready {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_ready";if($self->{ready}){my$fail=defined$self->{failure};my$done=!$fail &&!$self->{cancelled};$self->{reported}=1 if$fail;$is_future ? ($done ? $code->done($self->get): $fail ? $code->fail($self->failure): $code->cancel): $code->($self)}else {push @{$self->{callbacks}},[CB_ALWAYS|CB_SELF,$self->wrap_cb(on_ready=>$code)]}return$self}sub AWAIT_ON_READY {my$self=shift;my ($code)=@_;push @{$self->{callbacks}},[CB_ALWAYS|CB_SELF,$self->wrap_cb(on_ready=>$code)]}sub get {my$self=shift;$self->block_until_ready unless$self->{ready};if(my$failure=$self->{failure}){$self->{reported}=1;my$exception=$failure->[0];$exception=Future::Exception->new(@$failure)if @$failure > 1;!ref$exception && $exception =~ m/\n$/ ? CORE::die$exception : Carp::croak$exception}$self->{cancelled}and Carp::croak "${\$self->__selfstr} was cancelled";return$self->{result}->[0]unless wantarray;return @{$self->{result}}}*AWAIT_GET=\&get;sub await {my$self=shift;Carp::croak "$self is not yet complete and does not provide ->await"}sub block_until_ready {my$self=shift;until($self->{ready}){$self->await}return$self}sub unwrap {shift;my@values=@_;if(@values==1 and blessed$values[0]and $values[0]->isa(__PACKAGE__)){return$values[0]->get}else {return$values[0]if!wantarray;return@values}}sub on_done {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_done";if($self->{ready}){return$self if$self->{failure}or $self->{cancelled};$is_future ? $code->done($self->get): $code->($self->get)}else {push @{$self->{callbacks}},[CB_DONE|CB_RESULT,$self->wrap_cb(on_done=>$code)]}return$self}sub failure {my$self=shift;$self->block_until_ready unless$self->{ready};return unless$self->{failure};$self->{reported}=1;return$self->{failure}->[0]if!wantarray;return @{$self->{failure}}}sub on_fail {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_fail";if($self->{ready}){return$self if not $self->{failure};$self->{reported}=1;$is_future ? $code->fail($self->failure): $code->($self->failure)}else {push @{$self->{callbacks}},[CB_FAIL|CB_RESULT,$self->wrap_cb(on_fail=>$code)]}return$self}sub cancel {my$self=shift;return$self if$self->{ready};$self->{cancelled}++;my$on_cancel=delete$self->{on_cancel};for my$code ($on_cancel ? reverse @$on_cancel : ()){defined$code or next;my$is_future=blessed($code)&& $code->isa("Future");$is_future ? $code->cancel : $code->($self)}$self->_mark_ready("cancel");return$self}sub _sequence {my$f1=shift;my ($code,$flags)=@_;my$func=(caller 1)[3];$func =~ s/^.*:://;$flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL)or _callable($code)or Carp::croak "Expected \$code to be callable in ->$func";if(!defined wantarray){Carp::carp "Calling ->$func in void context"}if($f1->is_ready){return$f1 if$f1->is_done and not($flags & CB_SEQ_ONDONE)or $f1->failure and not($flags & CB_SEQ_ONFAIL);if($flags & CB_SEQ_IMDONE){return Future->done(@$code)}elsif($flags & CB_SEQ_IMFAIL){return Future->fail(@$code)}my@args=(($flags & CB_SELF ? $f1 : ()),($flags & CB_RESULT ? $f1->is_done ? $f1->get : $f1->failure ? $f1->failure : (): ()),);my$fseq;unless(eval {$fseq=$code->(@args);1}){return Future->fail($@)}unless(blessed$fseq and $fseq->isa("Future")){return Future->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future")}return$fseq}my$fseq=$f1->new;$fseq->on_cancel($f1);$code=$f1->wrap_cb(sequence=>$code)unless$flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL);push @{$f1->{callbacks}},[CB_DONE|CB_FAIL|$flags,$code,$fseq ];weaken($f1->{callbacks}[-1][2]);return$fseq}my$make_donecatchfail_sub=sub {my ($with_f,$done_code,$fail_code,@catch_list)=@_;my$func=(caller 1)[3];$func =~ s/^.*:://;!$done_code or _callable($done_code)or Carp::croak "Expected \$done_code to be callable in ->$func";!$fail_code or _callable($fail_code)or Carp::croak "Expected \$fail_code to be callable in ->$func";my%catch_handlers=@catch_list;_callable($catch_handlers{$_})or Carp::croak "Expected catch handler for '$_' to be callable in ->$func" for keys%catch_handlers;sub {my$self=shift;my@maybe_self=$with_f ? ($self): ();if(!$self->{failure}){return$self unless$done_code;return$done_code->(@maybe_self,$self->get)}else {my$name=$self->{failure}[1];if(defined$name and $catch_handlers{$name}){return$catch_handlers{$name}->(@maybe_self,$self->failure)}return$self unless$fail_code;return$fail_code->(@maybe_self,$self->failure)}}};sub then {my$self=shift;my$done_code=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;if($done_code and!@catch_list and!$fail_code){return$self->_sequence($done_code,CB_SEQ_ONDONE|CB_RESULT)}return$self->_sequence($make_donecatchfail_sub->(0,$done_code,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub else {my$self=shift;my ($fail_code)=@_;return$self->_sequence($fail_code,CB_SEQ_ONFAIL|CB_RESULT)}sub catch {my$self=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;return$self->_sequence($make_donecatchfail_sub->(0,undef,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub transform {my$self=shift;my%args=@_;my$xfrm_done=$args{done};my$xfrm_fail=$args{fail};return$self->_sequence(sub {my$self=shift;if(!$self->{failure}){return$self unless$xfrm_done;my@result=$xfrm_done->($self->get);return$self->new->done(@result)}else {return$self unless$xfrm_fail;my@failure=$xfrm_fail->($self->failure);return$self->new->fail(@failure)}},CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub then_with_f {my$self=shift;my$done_code=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;if($done_code and!@catch_list and!$fail_code){return$self->_sequence($done_code,CB_SEQ_ONDONE|CB_SELF|CB_RESULT)}return$self->_sequence($make_donecatchfail_sub->(1,$done_code,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub then_done {my$self=shift;my (@result)=@_;return$self->_sequence(\@result,CB_SEQ_ONDONE|CB_SEQ_IMDONE)}sub then_fail {my$self=shift;my (@failure)=@_;return$self->_sequence(\@failure,CB_SEQ_ONDONE|CB_SEQ_IMFAIL)}sub else_with_f {my$self=shift;my ($fail_code)=@_;return$self->_sequence($fail_code,CB_SEQ_ONFAIL|CB_SELF|CB_RESULT)}sub else_done {my$self=shift;my (@result)=@_;return$self->_sequence(\@result,CB_SEQ_ONFAIL|CB_SEQ_IMDONE)}sub else_fail {my$self=shift;my (@failure)=@_;return$self->_sequence(\@failure,CB_SEQ_ONFAIL|CB_SEQ_IMFAIL)}sub catch_with_f {my$self=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;return$self->_sequence($make_donecatchfail_sub->(1,undef,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub followed_by {my$self=shift;my ($code)=@_;return$self->_sequence($code,CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub without_cancel {my$self=shift;my$new=$self->new;$self->on_ready(sub {my$self=shift;if($self->failure){$new->fail($self->failure)}else {$new->done($self->get)}});$new->{orig}=$self;$new->on_ready(sub {undef $_[0]->{orig}});return$new}sub retain {my$self=shift;return$self->on_ready(sub {undef$self})}sub _new_convergent {shift;my ($subs)=@_;for my$sub (@$subs){blessed$sub and $sub->isa("Future")or Carp::croak "Expected a Future, got $sub"}my$self;ref($_)eq "Future" or $self=$_->new,last for @$subs;$self ||= Future->new;$self->{subs}=$subs;$self->on_cancel(sub {for my$sub (@$subs){$sub->cancel if$sub and!$sub->{ready}}});return$self}sub wait_all {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->done;$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$pending=0;$_->{ready}or $pending++ for@subs;if(!$pending){$self->{result}=[@subs ];$self->_mark_ready("wait_all");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;$pending--;$pending and return;$self->{result}=[@subs ];$self->_mark_ready("wait_all")};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub wait_any {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->fail("Cannot ->wait_any with no subfutures");$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_ready;for my$sub (@subs){$sub->{ready}and $immediate_ready=$sub,last}if($immediate_ready){for my$sub (@subs){$sub->{ready}or $sub->cancel}if($immediate_ready->{failure}){$self->{failure}=[$immediate_ready->failure ]}else {$self->{result}=[$immediate_ready->get ]}$self->_mark_ready("wait_any");return$self}my$pending=0;weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};return if --$pending and $_[0]->{cancelled};if($_[0]->{cancelled}){$self->{failure}=["All component futures were cancelled" ]}elsif($_[0]->{failure}){$self->{failure}=[$_[0]->failure ]}else {$self->{result}=[$_[0]->get ]}for my$sub (@subs){$sub->{ready}or $sub->cancel}$self->_mark_ready("wait_any")};for my$sub (@subs){$sub->on_ready($sub_on_ready);$pending++}return$self}sub needs_all {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->done;$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_fail;for my$sub (@subs){$sub->{ready}and $sub->{failure}and $immediate_fail=$sub,last}if($immediate_fail){for my$sub (@subs){$sub->{ready}or $sub->cancel}$self->{failure}=[$immediate_fail->failure ];$self->_mark_ready("needs_all");return$self}my$pending=0;$_->{ready}or $pending++ for@subs;if(!$pending){$self->{result}=[map {$_->get}@subs ];$self->_mark_ready("needs_all");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};if($_[0]->{cancelled}){$self->{failure}=["A component future was cancelled" ];for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_all")}elsif(my@failure=$_[0]->failure){$self->{failure}=\@failure;for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_all")}else {$pending--;$pending and return;$self->{result}=[map {$_->get}@subs ];$self->_mark_ready("needs_all")}};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub needs_any {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->fail("Cannot ->needs_any with no subfutures");$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_done;my$pending=0;for my$sub (@subs){$sub->{ready}and!$sub->{failure}and $immediate_done=$sub,last;$sub->{ready}or $pending++}if($immediate_done){for my$sub (@subs){$sub->{ready}? $sub->{reported}=1 : $sub->cancel}$self->{result}=[$immediate_done->get ];$self->_mark_ready("needs_any");return$self}my$immediate_fail=1;for my$sub (@subs){$sub->{ready}or $immediate_fail=0,last}if($immediate_fail){$_->{reported}=1 for@subs;$self->{failure}=[$subs[-1]->{failure}];$self->_mark_ready("needs_any");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};return if --$pending and $_[0]->{cancelled};if($_[0]->{cancelled}){$self->{failure}=["All component futures were cancelled" ];$self->_mark_ready("needs_any")}elsif(my@failure=$_[0]->failure){$pending and return;$self->{failure}=\@failure;$self->_mark_ready("needs_any")}else {$self->{result}=[$_[0]->get ];for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_any")}};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub pending_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->pending_futures on a non-convergent Future";return grep {not $_->{ready}}@{$self->{subs}}}sub ready_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->ready_futures on a non-convergent Future";return grep {$_->{ready}}@{$self->{subs}}}sub done_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->done_futures on a non-convergent Future";return grep {$_->{ready}and not $_->{failure}and not $_->{cancelled}}@{$self->{subs}}}sub failed_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->failed_futures on a non-convergent Future";return grep {$_->{ready}and $_->{failure}}@{$self->{subs}}}sub cancelled_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->cancelled_futures on a non-convergent Future";return grep {$_->{ready}and $_->{cancelled}}@{$self->{subs}}}sub set_label {my$self=shift;($self->{label})=@_;return$self}sub label {my$self=shift;return$self->{label}}sub __selfstr {my$self=shift;return "$self" unless defined$self->{label};return "$self (\"$self->{label}\")"}sub btime {my$self=shift;return$self->{btime}}sub rtime {my$self=shift;return$self->{rtime}}sub elapsed {my$self=shift;return undef unless defined$self->{btime}and defined$self->{rtime};return$self->{elapsed}||= tv_interval($self->{btime},$self->{rtime})}sub wrap_cb {my$self=shift;my ($op,$cb)=@_;return$cb}0x55AA;
+ package Future;use v5.10;use strict;use warnings;no warnings 'recursion';our$VERSION='0.48';use Carp qw();use Scalar::Util qw(weaken blessed reftype);use B qw(svref_2object);use Time::HiRes qw(gettimeofday tv_interval);require overload;require Future::Exception;our@CARP_NOT=qw(Future::Utils);use constant DEBUG=>!!$ENV{PERL_FUTURE_DEBUG};use constant STRICT=>!!$ENV{PERL_FUTURE_STRICT};our$TIMES=DEBUG || $ENV{PERL_FUTURE_TIMES};use constant {CB_DONE=>1<<0,CB_FAIL=>1<<1,CB_CANCEL=>1<<2,CB_SELF=>1<<3,CB_RESULT=>1<<4,CB_SEQ_ONDONE=>1<<5,CB_SEQ_ONFAIL=>1<<6,CB_SEQ_IMDONE=>1<<7,CB_SEQ_IMFAIL=>1<<8,CB_SEQ_STRICT=>1<<9,};use constant CB_ALWAYS=>CB_DONE|CB_FAIL|CB_CANCEL;sub CvNAME_FILE_LINE {my ($code)=@_;my$cv=svref_2object($code);my$name=join "::",$cv->STASH->NAME,$cv->GV->NAME;return$name unless$cv->GV->NAME eq "__ANON__";my$cop=$cv->START;$cop=$cop->next while$cop and ref$cop ne "B::COP" and ref$cop ne "B::NULL";return$cv->GV->NAME if ref$cop eq "B::NULL";sprintf "%s(%s line %d)",$cv->GV->NAME,$cop->file,$cop->line}sub _callable {my ($cb)=@_;defined$cb and (reftype($cb)eq 'CODE' || overload::Method($cb,'&{}'))}sub new {my$proto=shift;return bless {ready=>0,callbacks=>[],(DEBUG ? (do {my$at=Carp::shortmess("constructed");chomp$at;$at =~ s/\.$//;constructed_at=>$at}): ()),($TIMES ? (btime=>[gettimeofday ]): ()),},(ref$proto || $proto)}*AWAIT_CLONE=sub {shift->new};my$GLOBAL_END;END {$GLOBAL_END=1}sub DESTROY_debug {my$self=shift;return if$GLOBAL_END;return if$self->{ready}and ($self->{reported}or!$self->{failure});my$lost_at=join " line ",(caller)[1,2];if($self->{ready}and $self->{failure}){warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " .$self->{failure}[0]."\n"}elsif(!$self->{ready}){warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n"}}*DESTROY=\&DESTROY_debug if DEBUG;sub wrap {my$class=shift;my@values=@_;if(@values==1 and blessed$values[0]and $values[0]->isa(__PACKAGE__)){return$values[0]}else {return$class->done(@values)}}sub call {my$class=shift;my ($code,@args)=@_;my$f;eval {$f=$code->(@args);1}or $f=$class->fail($@);blessed$f and $f->isa("Future")or $f=$class->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future");return$f}sub _shortmess {my$at=Carp::shortmess($_[0]);chomp$at;$at =~ s/\.$//;return$at}sub _mark_ready {my$self=shift;$self->{ready}=1;$self->{ready_at}=_shortmess $_[0]if DEBUG;if($TIMES){$self->{rtime}=[gettimeofday ]}delete$self->{on_cancel};$_->[0]and $_->[0]->_revoke_on_cancel($_->[1])for @{$self->{revoke_when_ready}};delete$self->{revoke_when_ready};my$callbacks=delete$self->{callbacks}or return;my$cancelled=$self->{cancelled};my$fail=defined$self->{failure};my$done=!$fail &&!$cancelled;my@result=$done ? @{$self->{result}}: $fail ? @{$self->{failure}}: ();for my$cb (@$callbacks){my ($flags,$code)=@$cb;my$is_future=blessed($code)&& $code->isa("Future");next if$done and not($flags & CB_DONE);next if$fail and not($flags & CB_FAIL);next if$cancelled and not($flags & CB_CANCEL);$self->{reported}=1 if$fail;if($is_future){$done ? $code->done(@result): $fail ? $code->fail(@result): $code->cancel}elsif($flags & (CB_SEQ_ONDONE|CB_SEQ_ONFAIL)){my (undef,undef,$fseq)=@$cb;if(!$fseq){Carp::carp +(DEBUG ? "${\$self->__selfstr} ($self->{constructed_at})" : "${\$self->__selfstr} $self")." lost a sequence Future";next}my$f2;if($done and $flags & CB_SEQ_ONDONE or $fail and $flags & CB_SEQ_ONFAIL){if($flags & CB_SEQ_IMDONE){$fseq->done(@$code);next}elsif($flags & CB_SEQ_IMFAIL){$fseq->fail(@$code);next}my@args=(($flags & CB_SELF ? $self : ()),($flags & CB_RESULT ? @result : ()),);unless(eval {$f2=$code->(@args);1}){$fseq->fail($@);next}unless(blessed$f2 and $f2->isa("Future")){if($flags & CB_SEQ_STRICT){$fseq->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future");next}$f2=Future->done($f2)}$fseq->on_cancel($f2)}else {$f2=$self}if($f2->is_ready){$f2->on_ready($fseq)if!$f2->{cancelled}}else {push @{$f2->{callbacks}},[CB_DONE|CB_FAIL,$fseq ];weaken($f2->{callbacks}[-1][1])}}else {$code->(($flags & CB_SELF ? $self : ()),($flags & CB_RESULT ? @result : ()),)}}}sub is_ready {my$self=shift;return$self->{ready}}*AWAIT_IS_READY=sub {shift->is_ready};sub is_done {my$self=shift;return$self->{ready}&&!$self->{failure}&&!$self->{cancelled}}sub is_failed {my$self=shift;return$self->{ready}&&!!$self->{failure}}sub is_cancelled {my$self=shift;return$self->{cancelled}}*AWAIT_IS_CANCELLED=sub {shift->is_cancelled};sub state {my$self=shift;return!$self->{ready}? "pending" : DEBUG ? $self->{ready_at}: $self->{failure}? "failed" : $self->{cancelled}? "cancelled" : "done"}sub done {my$self=shift;if(ref$self){$self->{cancelled}and return$self;$self->{ready}and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->done";$self->{subs}and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->done";$self->{result}=[@_ ];$self->_mark_ready("done")}else {$self=$self->new;$self->{ready}=1;$self->{ready_at}=_shortmess "done" if DEBUG;$self->{result}=[@_ ];if($TIMES){$self->{rtime}=[gettimeofday ]}}return$self}*resolve=sub {shift->done(@_)};*AWAIT_NEW_DONE=*AWAIT_DONE=sub {shift->done(@_)};sub fail {my$self=shift;my ($exception,@more)=@_;if(ref$exception eq "Future::Exception"){@more=($exception->category,$exception->details);$exception=$exception->message}$exception or Carp::croak "$self ->fail requires an exception that is true";if(ref$self){$self->{cancelled}and return$self;$self->{ready}and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->fail'ed";$self->{subs}and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->fail'ed";$self->{failure}=[$exception,@more ];$self->_mark_ready("failed")}else {$self=$self->new;$self->{ready}=1;$self->{ready_at}=_shortmess "failed" if DEBUG;$self->{failure}=[$exception,@more ];if($TIMES){$self->{rtime}=[gettimeofday ]}}return$self}*reject=sub {shift->fail(@_)};*AWAIT_NEW_FAIL=*AWAIT_FAIL=sub {shift->fail(@_)};sub die :method {my$self=shift;my ($exception,@more)=@_;if(!ref$exception and $exception !~ m/\n$/){$exception .= sprintf " at %s line %d\n",(caller)[1,2]}$self->fail($exception,@more)}sub on_cancel {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_cancel";$self->{ready}and return$self;push @{$self->{on_cancel}},$code;if($is_future){push @{$code->{revoke_when_ready}},my$r=[$self,\$self->{on_cancel}[-1]];weaken($r->[0]);weaken($r->[1])}return$self}sub AWAIT_ON_CANCEL {my$self=shift;my ($code)=@_;push @{$self->{on_cancel}},$code}sub AWAIT_CHAIN_CANCEL {my$self=shift;my ($f2)=@_;push @{$self->{on_cancel}},$f2;push @{$f2->{revoke_when_ready}},my$r=[$self,\$self->{on_cancel}[-1]];weaken($r->[0]);weaken($r->[1])}sub _revoke_on_cancel {my$self=shift;my ($ref)=@_;undef $$ref;$self->{empty_on_cancel_slots}++;my$on_cancel=$self->{on_cancel}or return;if(@$on_cancel >= 8 and $self->{empty_on_cancel_slots}>= 0.5 * @$on_cancel){my$idx=0;while($idx < @$on_cancel){defined$on_cancel->[$idx]and $idx++,next;splice @$on_cancel,$idx,1,()}$self->{empty_on_cancel_slots}=0}}sub on_ready {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_ready";if($self->{ready}){my$fail=defined$self->{failure};my$done=!$fail &&!$self->{cancelled};$self->{reported}=1 if$fail;$is_future ? ($done ? $code->done(@{$self->{result}}): $fail ? $code->fail(@{$self->{failure}}): $code->cancel): $code->($self)}else {push @{$self->{callbacks}},[CB_ALWAYS|CB_SELF,$self->wrap_cb(on_ready=>$code)]}return$self}sub AWAIT_ON_READY {my$self=shift;my ($code)=@_;push @{$self->{callbacks}},[CB_ALWAYS|CB_SELF,$self->wrap_cb(on_ready=>$code)]}sub result {my$self=shift;$self->{ready}or Carp::croak("${\$self->__selfstr} is not yet ready");if(my$failure=$self->{failure}){$self->{reported}=1;my$exception=$failure->[0];$exception=Future::Exception->new(@$failure)if @$failure > 1;!ref$exception && $exception =~ m/\n$/ ? CORE::die$exception : Carp::croak$exception}$self->{cancelled}and Carp::croak "${\$self->__selfstr} was cancelled";return$self->{result}->[0]unless wantarray;return @{$self->{result}}}*AWAIT_RESULT=*AWAIT_GET=sub {shift->result};sub get {my$self=shift;$self->await unless$self->{ready};return$self->result}sub await {my$self=shift;return$self if$self->{ready};Carp::croak "$self is not yet complete and does not provide ->await"}sub block_until_ready {my$self=shift;return$self->await}sub unwrap {shift;my@values=@_;if(@values==1 and blessed$values[0]and $values[0]->isa(__PACKAGE__)){return$values[0]->get}else {return$values[0]if!wantarray;return@values}}sub on_done {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_done";if($self->{ready}){return$self if$self->{failure}or $self->{cancelled};$is_future ? $code->done(@{$self->{result}}): $code->(@{$self->{result}})}else {push @{$self->{callbacks}},[CB_DONE|CB_RESULT,$self->wrap_cb(on_done=>$code)]}return$self}sub failure {my$self=shift;$self->await unless$self->{ready};return unless$self->{failure};$self->{reported}=1;return$self->{failure}->[0]if!wantarray;return @{$self->{failure}}}sub on_fail {my$self=shift;my ($code)=@_;my$is_future=blessed($code)&& $code->isa("Future");$is_future or _callable($code)or Carp::croak "Expected \$code to be callable or a Future in ->on_fail";if($self->{ready}){return$self if not $self->{failure};$self->{reported}=1;$is_future ? $code->fail(@{$self->{failure}}): $code->(@{$self->{failure}})}else {push @{$self->{callbacks}},[CB_FAIL|CB_RESULT,$self->wrap_cb(on_fail=>$code)]}return$self}sub cancel {my$self=shift;return$self if$self->{ready};$self->{cancelled}++;my$on_cancel=delete$self->{on_cancel};for my$code ($on_cancel ? reverse @$on_cancel : ()){defined$code or next;my$is_future=blessed($code)&& $code->isa("Future");$is_future ? $code->cancel : $code->($self)}$self->_mark_ready("cancel");return$self}sub _sequence {my$f1=shift;my ($code,$flags)=@_;$flags |= CB_SEQ_STRICT if STRICT;my$func=(caller 1)[3];$func =~ s/^.*:://;$flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL)or _callable($code)or Carp::croak "Expected \$code to be callable in ->$func";if(!defined wantarray){Carp::carp "Calling ->$func in void context"}if($f1->is_ready){return$f1 if$f1->is_done and not($flags & CB_SEQ_ONDONE)or $f1->{failure}and not($flags & CB_SEQ_ONFAIL);if($flags & CB_SEQ_IMDONE){return Future->done(@$code)}elsif($flags & CB_SEQ_IMFAIL){return Future->fail(@$code)}my@args=(($flags & CB_SELF ? $f1 : ()),($flags & CB_RESULT ? $f1->is_done ? @{$f1->{result}}: $f1->{failure}? @{$f1->{failure}}: (): ()),);my$fseq;unless(eval {$fseq=$code->(@args);1}){return Future->fail($@)}unless(blessed$fseq and $fseq->isa("Future")){$flags & CB_SEQ_STRICT and return Future->fail("Expected " .CvNAME_FILE_LINE($code)." to return a Future");$fseq=$f1->new->done($fseq)}return$fseq}my$fseq=$f1->new;$fseq->on_cancel($f1);$code=$f1->wrap_cb(sequence=>$code)unless$flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL);push @{$f1->{callbacks}},[CB_DONE|CB_FAIL|$flags,$code,$fseq ];weaken($f1->{callbacks}[-1][2]);return$fseq}my$make_donecatchfail_sub=sub {my ($with_f,$done_code,$fail_code,@catch_list)=@_;my$func=(caller 1)[3];$func =~ s/^.*:://;!$done_code or _callable($done_code)or Carp::croak "Expected \$done_code to be callable in ->$func";!$fail_code or _callable($fail_code)or Carp::croak "Expected \$fail_code to be callable in ->$func";my%catch_handlers=@catch_list;_callable($catch_handlers{$_})or Carp::croak "Expected catch handler for '$_' to be callable in ->$func" for keys%catch_handlers;sub {my$self=shift;my@maybe_self=$with_f ? ($self): ();if(!$self->{failure}){return$self unless$done_code;return$done_code->(@maybe_self,@{$self->{result}})}else {my$name=$self->{failure}[1];if(defined$name and $catch_handlers{$name}){return$catch_handlers{$name}->(@maybe_self,@{$self->{failure}})}return$self unless$fail_code;return$fail_code->(@maybe_self,@{$self->{failure}})}}};sub then {my$self=shift;my$done_code=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;if($done_code and!@catch_list and!$fail_code){return$self->_sequence($done_code,CB_SEQ_ONDONE|CB_RESULT)}return$self->_sequence($make_donecatchfail_sub->(0,$done_code,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub else {my$self=shift;my ($fail_code)=@_;return$self->_sequence($fail_code,CB_SEQ_ONFAIL|CB_RESULT)}sub catch {my$self=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;return$self->_sequence($make_donecatchfail_sub->(0,undef,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub transform {my$self=shift;my%args=@_;my$xfrm_done=$args{done};my$xfrm_fail=$args{fail};return$self->_sequence(sub {my$self=shift;if(!$self->{failure}){return$self unless$xfrm_done;my@result=$xfrm_done->(@{$self->{result}});return$self->new->done(@result)}else {return$self unless$xfrm_fail;my@failure=$xfrm_fail->(@{$self->{failure}});return$self->new->fail(@failure)}},CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub then_with_f {my$self=shift;my$done_code=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;if($done_code and!@catch_list and!$fail_code){return$self->_sequence($done_code,CB_SEQ_ONDONE|CB_SELF|CB_RESULT)}return$self->_sequence($make_donecatchfail_sub->(1,$done_code,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub then_done {my$self=shift;my (@result)=@_;return$self->_sequence(\@result,CB_SEQ_ONDONE|CB_SEQ_IMDONE)}sub then_fail {my$self=shift;my (@failure)=@_;return$self->_sequence(\@failure,CB_SEQ_ONDONE|CB_SEQ_IMFAIL)}sub else_with_f {my$self=shift;my ($fail_code)=@_;return$self->_sequence($fail_code,CB_SEQ_ONFAIL|CB_SELF|CB_RESULT)}sub else_done {my$self=shift;my (@result)=@_;return$self->_sequence(\@result,CB_SEQ_ONFAIL|CB_SEQ_IMDONE)}sub else_fail {my$self=shift;my (@failure)=@_;return$self->_sequence(\@failure,CB_SEQ_ONFAIL|CB_SEQ_IMFAIL)}sub catch_with_f {my$self=shift;my$fail_code=(@_ % 2)? pop : undef;my@catch_list=@_;return$self->_sequence($make_donecatchfail_sub->(1,undef,$fail_code,@catch_list,),CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub followed_by {my$self=shift;my ($code)=@_;return$self->_sequence($code,CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF)}sub without_cancel {my$self=shift;my$new=$self->new;$self->on_ready(sub {my$self=shift;if($self->{cancelled}){$new->cancel}elsif($self->{failure}){$new->fail(@{$self->{failure}})}else {$new->done(@{$self->{result}})}});$new->{orig}=$self;$new->on_ready(sub {undef $_[0]->{orig}});return$new}sub retain {my$self=shift;return$self->on_ready(sub {undef$self})}sub _new_convergent {shift;my ($subs)=@_;for my$sub (@$subs){blessed$sub and $sub->isa("Future")or Carp::croak "Expected a Future, got $sub"}my$self;ref($_)eq "Future" or $self=$_->new,last for @$subs;$self ||= Future->new;$self->{subs}=$subs;$self->on_cancel(sub {for my$sub (@$subs){$sub->cancel if$sub and!$sub->{ready}}});return$self}sub wait_all {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->done;$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$pending=0;$_->{ready}or $pending++ for@subs;if(!$pending){$self->{result}=[@subs ];$self->_mark_ready("wait_all");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;$pending--;$pending and return;$self->{result}=[@subs ];$self->_mark_ready("wait_all")};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub wait_any {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->fail("Cannot ->wait_any with no subfutures");$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_ready;for my$sub (@subs){$sub->{ready}and $immediate_ready=$sub,last}if($immediate_ready){for my$sub (@subs){$sub->{ready}or $sub->cancel}if($immediate_ready->{failure}){$self->{failure}=[@{$immediate_ready->{failure}}]}else {$self->{result}=[@{$immediate_ready->{result}}]}$self->_mark_ready("wait_any");return$self}my$pending=0;weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};return if --$pending and $_[0]->{cancelled};if($_[0]->{cancelled}){$self->{failure}=["All component futures were cancelled" ]}elsif($_[0]->{failure}){$self->{failure}=[@{$_[0]->{failure}}]}else {$self->{result}=[@{$_[0]->{result}}]}for my$sub (@subs){$sub->{ready}or $sub->cancel}$self->_mark_ready("wait_any")};for my$sub (@subs){$sub->on_ready($sub_on_ready);$pending++}return$self}sub needs_all {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->done;$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_fail;for my$sub (@subs){$sub->{ready}and $sub->{failure}and $immediate_fail=$sub,last}if($immediate_fail){for my$sub (@subs){$sub->{ready}or $sub->cancel}$self->{failure}=[@{$immediate_fail->{failure}}];$self->_mark_ready("needs_all");return$self}my$pending=0;$_->{ready}or $pending++ for@subs;if(!$pending){$self->{result}=[map {@{$_->{result}}}@subs ];$self->_mark_ready("needs_all");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};if($_[0]->{cancelled}){$self->{failure}=["A component future was cancelled" ];for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_all")}elsif($_[0]->{failure}){$self->{failure}=[@{$_[0]->{failure}}];for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_all")}else {$pending--;$pending and return;$self->{result}=[map {@{$_->{result}}}@subs ];$self->_mark_ready("needs_all")}};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub needs_any {my$class=shift;my@subs=@_;unless(@subs){my$self=$class->fail("Cannot ->needs_any with no subfutures");$self->{subs}=[];return$self}my$self=Future->_new_convergent(\@subs);my$immediate_done;my$pending=0;for my$sub (@subs){$sub->{ready}and!$sub->{failure}and $immediate_done=$sub,last;$sub->{ready}or $pending++}if($immediate_done){for my$sub (@subs){$sub->{ready}? $sub->{reported}=1 : $sub->cancel}$self->{result}=[@{$immediate_done->{result}}];$self->_mark_ready("needs_any");return$self}my$immediate_fail=1;for my$sub (@subs){$sub->{ready}or $immediate_fail=0,last}if($immediate_fail){$_->{reported}=1 for@subs;$self->{failure}=[$subs[-1]->{failure}];$self->_mark_ready("needs_any");return$self}weaken(my$weakself=$self);my$sub_on_ready=sub {return unless my$self=$weakself;return if$self->{result}or $self->{failure};return if --$pending and $_[0]->{cancelled};if($_[0]->{cancelled}){$self->{failure}=["All component futures were cancelled" ];$self->_mark_ready("needs_any")}elsif($_[0]->{failure}){$pending and return;$self->{failure}=[@{$_[0]->{failure}}];$self->_mark_ready("needs_any")}else {$self->{result}=[@{$_[0]->{result}}];for my$sub (@subs){$sub->cancel if!$sub->{ready}}$self->_mark_ready("needs_any")}};for my$sub (@subs){$sub->{ready}or $sub->on_ready($sub_on_ready)}return$self}sub pending_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->pending_futures on a non-convergent Future";return grep {not $_->{ready}}@{$self->{subs}}}sub ready_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->ready_futures on a non-convergent Future";return grep {$_->{ready}}@{$self->{subs}}}sub done_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->done_futures on a non-convergent Future";return grep {$_->{ready}and not $_->{failure}and not $_->{cancelled}}@{$self->{subs}}}sub failed_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->failed_futures on a non-convergent Future";return grep {$_->{ready}and $_->{failure}}@{$self->{subs}}}sub cancelled_futures {my$self=shift;$self->{subs}or Carp::croak "Cannot call ->cancelled_futures on a non-convergent Future";return grep {$_->{ready}and $_->{cancelled}}@{$self->{subs}}}sub set_label {my$self=shift;($self->{label})=@_;return$self}sub label {my$self=shift;return$self->{label}}sub __selfstr {my$self=shift;return "$self" unless defined$self->{label};return "$self (\"$self->{label}\")"}sub btime {my$self=shift;return$self->{btime}}sub rtime {my$self=shift;return$self->{rtime}}sub elapsed {my$self=shift;return undef unless defined$self->{btime}and defined$self->{rtime};return$self->{elapsed}||= tv_interval($self->{btime},$self->{rtime})}sub wrap_cb {my$self=shift;my ($op,$cb)=@_;return$cb}0x55AA;
FUTURE
$fatpacked{"Future/Exception.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUTURE_EXCEPTION';
- package Future::Exception;use strict;use warnings;our$VERSION='0.43';use overload '""'=>"message",fallback=>1;sub from_future {my$class=shift;my ($f)=@_;return$class->new($f->failure)}sub new {my$class=shift;bless [@_ ],$class}sub message {shift->[0]}sub category {shift->[1]}sub details {my$self=shift;@{$self}[2..$#$self]}sub throw {my$class=shift;my ($message,$category,@details)=@_;$message =~ m/\n$/ or $message .= sprintf " at %s line %d.\n",(caller)[1,2];die$class->new($message,$category,@details)}sub as_future {my$self=shift;return Future->fail($self->message,$self->category,$self->details)}0x55AA;
+ package Future::Exception;use v5.10;use strict;use warnings;our$VERSION='0.48';use overload '""'=>"message",fallback=>1;sub from_future {my$class=shift;my ($f)=@_;return$class->new($f->failure)}sub new {my$class=shift;bless [@_ ],$class}sub message {shift->[0]}sub category {shift->[1]}sub details {my$self=shift;@{$self}[2..$#$self]}sub throw {my$class=shift;my ($message,$category,@details)=@_;$message =~ m/\n$/ or $message .= sprintf " at %s line %d.\n",(caller)[1,2];die$class->new($message,$category,@details)}sub as_future {my$self=shift;return Future->fail($self->message,$self->category,$self->details)}0x55AA;
FUTURE_EXCEPTION
$fatpacked{"Future/Mutex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUTURE_MUTEX';
- package Future::Mutex;use strict;use warnings;use 5.010;our$VERSION='0.43';use Future;sub new {my$class=shift;my%params=@_;return bless {avail=>$params{count}// 1,queue=>[],},$class}sub enter {my$self=shift;my ($code)=@_;my$down_f;if($self->{avail}){$self->{avail}--;$down_f=Future->done}else {push @{$self->{queue}},$down_f=Future->new}my$up=sub {if(my$next_f=shift @{$self->{queue}}){$next_f->done}else {$self->{avail}++}};$down_f->then($code)->on_ready($up)}sub available {my$self=shift;return$self->{avail}}0x55AA;
+ package Future::Mutex;use v5.10;use strict;use warnings;our$VERSION='0.48';use Future;sub new {my$class=shift;my%params=@_;return bless {avail=>$params{count}// 1,waitf=>undef,queue=>[],},$class}sub enter {my$self=shift;my ($code)=@_;my$down_f;if($self->{avail}){$self->{avail}--;$down_f=Future->done}else {die "ARGH Need to clone an existing future\n" unless defined$self->{waitf};push @{$self->{queue}},$down_f=$self->{waitf}->new}my$up=sub {if(my$next_f=shift @{$self->{queue}}){$next_f->done}else {$self->{avail}++;undef$self->{waitf}}};my$retf=$down_f->then($code)->on_ready($up);$self->{waitf}or $self->{waitf}=$retf;return$retf}sub available {my$self=shift;return$self->{avail}}0x55AA;
FUTURE_MUTEX
$fatpacked{"Future/Queue.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUTURE_QUEUE';
- package Future::Queue;use strict;use warnings;our$VERSION='0.43';sub new {my$class=shift;return bless {items=>[],waiters=>[],},$class}sub push :method {my$self=shift;my ($item)=@_;push @{$self->{items}},$item;(shift @{$self->{waiters}})->done if @{$self->{waiters}}}sub shift :method {my$self=shift;if(@{$self->{items}}){return Future->done(shift @{$self->{items}})}push @{$self->{waiters}},my$f=Future->new;return$f->then(sub {return Future->done(shift @{$self->{items}})})}0x55AA;
+ package Future::Queue;use v5.10;use strict;use warnings;our$VERSION='0.48';sub new {my$class=shift;return bless {items=>[],waiters=>[],},$class}sub push :method {my$self=shift;my ($item)=@_;push @{$self->{items}},$item;(shift @{$self->{waiters}})->done if @{$self->{waiters}}}sub shift :method {my$self=shift;if(@{$self->{items}}){return Future->done(shift @{$self->{items}})}push @{$self->{waiters}},my$f=Future->new;return$f->then(sub {return Future->done(shift @{$self->{items}})})}0x55AA;
FUTURE_QUEUE
$fatpacked{"Future/Utils.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FUTURE_UTILS';
- package Future::Utils;use strict;use warnings;our$VERSION='0.43';use Exporter 'import';sub export_to_level {my$pkg=shift;local$Exporter::ExportLevel=1 + shift;$pkg->import(@_)}our@EXPORT_OK=qw(call call_with_escape repeat try_repeat try_repeat_until_success repeat_until_success fmap fmap_concat fmap1 fmap_scalar fmap0 fmap_void);use Carp;our@CARP_NOT=qw(Future);use Future;sub call(&) {my ($code)=@_;return Future->call($code)}sub call_with_escape(&) {my ($code)=@_;my$escape_f=Future->new;return Future->wait_any(Future->call($code,$escape_f),$escape_f,)}sub _repeat {my ($code,$return,$trialp,$cond,$sense,$is_try)=@_;my$prev=$$trialp;while(1){my$trial=$$trialp ||= Future->call($code,$prev);$prev=$trial;if(!$trial->is_ready){$return ||= $trial->new;$trial->on_ready(sub {return if $$trialp->is_cancelled;_repeat($code,$return,$trialp,$cond,$sense,$is_try)});return$return}my$stop;if(not eval {$stop=!$cond->($trial)^ $sense;1}){$return ||= $trial->new;$return->fail($@);return$return}if($stop){$return ||= $trial->new;$trial->on_done($return);$trial->on_fail($return);return$return}if(!$is_try and $trial->failure){carp "Using Future::Utils::repeat to retry a failure is deprecated; use try_repeat instead"}undef $$trialp}}sub repeat(&@) {my$code=shift;my%args=@_;defined($args{while})+ defined($args{until})==1 or defined($args{foreach})or defined($args{generate})or croak "Expected one of 'while', 'until', 'foreach' or 'generate'";if($args{foreach}){$args{generate}and croak "Cannot use both 'foreach' and 'generate'";my$array=delete$args{foreach};$args{generate}=sub {@$array ? shift @$array : ()}}if($args{generate}){my$generator=delete$args{generate};my$otherwise=delete$args{otherwise};my$done;my$orig_code=$code;$code=sub {my ($last_trial_f)=@_;my$again=my ($value)=$generator->($last_trial_f);if($again){unshift @_,$value;goto &$orig_code}$done++;if($otherwise){goto &$otherwise}else {return$last_trial_f || Future->done}};if(my$orig_while=delete$args{while}){$args{while}=sub {$orig_while->($_[0])and!$done}}elsif(my$orig_until=delete$args{until}){$args{while}=sub {!$orig_until->($_[0])and!$done}}else {$args{while}=sub {!$done}}}my$future=$args{return};my$trial;$args{while}and $future=_repeat($code,$future,\$trial,$args{while},0,$args{try});$args{until}and $future=_repeat($code,$future,\$trial,$args{until},1,$args{try});$future->on_cancel(sub {$trial->cancel});return$future}sub try_repeat(&@) {&repeat(@_,try=>1)}sub try_repeat_until_success(&@) {my$code=shift;my%args=@_;defined($args{while})or defined($args{until})and croak "Cannot pass 'while' or 'until' to try_repeat_until_success";&try_repeat($code,while=>sub {shift->failure},%args)}*repeat_until_success=\&try_repeat_until_success;sub _fmap_slot {my ($slots,undef,$code,$generator,$collect,$results,$return)=@_;SLOT: while(1){my (undef,$idx)=my@args=@_;unless($slots->[$idx]){my$item;unless(($item)=$generator->()){undef$slots->[$idx];defined and return$return for @$slots;$return ||= Future->new;$return->done(@$results);return$return}my$f=$slots->[$idx]=Future->call($code,local $_=$item);if($collect eq "array"){push @$results,my$r=[];$f->on_done(sub {@$r=@_})}elsif($collect eq "scalar"){push @$results,undef;my$r=\$results->[-1];$f->on_done(sub {$$r=$_[0]})}}my$f=$slots->[$idx];if(!$f->is_ready){$args[-1]=($return ||= $f->new);$f->on_done(sub {_fmap_slot(@args)});$f->on_fail($return);my$i=$idx + 1;while($i!=$idx){$i++;$i %= @$slots;next if defined$slots->[$i];$_[1]=$i;redo SLOT}return$return}if($f->failure){$return ||= $f->new;$return->fail($f->failure);return$return}undef$slots->[$idx]}}sub _fmap {my$code=shift;my%args=@_;my$concurrent=$args{concurrent}|| 1;my@slots;my$results=[];my$future=$args{return};my$generator;if($generator=$args{generate}){}elsif(my$array=$args{foreach}){$generator=sub {return unless @$array;shift @$array}}else {croak "Expected either 'generate' or 'foreach'"}for my$idx (0 .. $concurrent-1){$future=_fmap_slot(\@slots,$idx,$code,$generator,$args{collect},$results,$future);last if$future->is_ready}$future->on_fail(sub {!defined $_ or $_->is_ready or $_->cancel for@slots});$future->on_cancel(sub {!defined $_ or $_->is_ready or $_->cancel for@slots});return$future}sub fmap_concat(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"array")->then(sub {return Future->done(map {@$_}@_)})}*fmap=\&fmap_concat;sub fmap_scalar(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"scalar")}*fmap1=\&fmap_scalar;sub fmap_void(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"void")}*fmap0=\&fmap_void;0x55AA;
+ package Future::Utils;use v5.10;use strict;use warnings;our$VERSION='0.48';use Exporter 'import';sub export_to_level {my$pkg=shift;local$Exporter::ExportLevel=1 + shift;$pkg->import(@_)}our@EXPORT_OK=qw(call call_with_escape repeat try_repeat try_repeat_until_success repeat_until_success fmap fmap_concat fmap1 fmap_scalar fmap0 fmap_void);use Carp;our@CARP_NOT=qw(Future);use Future;sub call(&) {my ($code)=@_;return Future->call($code)}sub call_with_escape(&) {my ($code)=@_;my$escape_f=Future->new;return Future->wait_any(Future->call($code,$escape_f),$escape_f,)}sub _repeat {my ($code,$return,$trialp,$cond,$sense,$is_try)=@_;my$prev=$$trialp;while(1){my$trial=$$trialp ||= Future->call($code,$prev);$prev=$trial;if(!$trial->is_ready){$return ||= $trial->new;$trial->on_ready(sub {return if $$trialp->is_cancelled;_repeat($code,$return,$trialp,$cond,$sense,$is_try)});return$return}my$stop;if(not eval {$stop=!$cond->($trial)^ $sense;1}){$return ||= $trial->new;$return->fail($@);return$return}if($stop){$return ||= $trial->new;$trial->on_done($return);$trial->on_fail($return);return$return}if(!$is_try and $trial->failure){carp "Using Future::Utils::repeat to retry a failure is deprecated; use try_repeat instead"}undef $$trialp}}sub repeat(&@) {my$code=shift;my%args=@_;defined($args{while})+ defined($args{until})==1 or defined($args{foreach})or defined($args{generate})or croak "Expected one of 'while', 'until', 'foreach' or 'generate'";if($args{foreach}){$args{generate}and croak "Cannot use both 'foreach' and 'generate'";my$array=delete$args{foreach};$args{generate}=sub {@$array ? shift @$array : ()}}if($args{generate}){my$generator=delete$args{generate};my$otherwise=delete$args{otherwise};my$done;my$orig_code=$code;$code=sub {my ($last_trial_f)=@_;my$again=my ($value)=$generator->($last_trial_f);if($again){unshift @_,$value;goto &$orig_code}$done++;if($otherwise){goto &$otherwise}else {return$last_trial_f || Future->done}};if(my$orig_while=delete$args{while}){$args{while}=sub {$orig_while->($_[0])and!$done}}elsif(my$orig_until=delete$args{until}){$args{while}=sub {!$orig_until->($_[0])and!$done}}else {$args{while}=sub {!$done}}}my$future=$args{return};my$trial;$args{while}and $future=_repeat($code,$future,\$trial,$args{while},0,$args{try});$args{until}and $future=_repeat($code,$future,\$trial,$args{until},1,$args{try});$future->on_cancel(sub {$trial->cancel});return$future}sub try_repeat(&@) {&repeat(@_,try=>1)}sub try_repeat_until_success(&@) {my$code=shift;my%args=@_;defined($args{while})or defined($args{until})and croak "Cannot pass 'while' or 'until' to try_repeat_until_success";&try_repeat($code,while=>sub {shift->failure},%args)}*repeat_until_success=\&try_repeat_until_success;sub _fmap_slot {my ($slots,undef,$code,$generator,$collect,$results,$return)=@_;SLOT: while(1){my (undef,$idx)=my@args=@_;unless($slots->[$idx]){my$item;unless(($item)=$generator->()){undef$slots->[$idx];defined and return$return for @$slots;$return ||= Future->new;$return->done(@$results);return$return}my$f=$slots->[$idx]=Future->call($code,local $_=$item);if($collect eq "array"){push @$results,my$r=[];$f->on_done(sub {@$r=@_})}elsif($collect eq "scalar"){push @$results,undef;my$r=\$results->[-1];$f->on_done(sub {$$r=$_[0]})}}my$f=$slots->[$idx];if(!$f->is_ready){$args[-1]=($return ||= $f->new);$f->on_done(sub {_fmap_slot(@args)});$f->on_fail($return);my$i=$idx + 1;while($i!=$idx){$i++;$i %= @$slots;next if defined$slots->[$i];$_[1]=$i;redo SLOT}return$return}if($f->failure){$return ||= $f->new;$return->fail($f->failure);return$return}undef$slots->[$idx]}}sub _fmap {my$code=shift;my%args=@_;my$concurrent=$args{concurrent}|| 1;my@slots;my$results=[];my$future=$args{return};my$generator;if($generator=$args{generate}){}elsif(my$array=$args{foreach}){$generator=sub {return unless @$array;shift @$array}}else {croak "Expected either 'generate' or 'foreach'"}for my$idx (0 .. $concurrent-1){$future=_fmap_slot(\@slots,$idx,$code,$generator,$args{collect},$results,$future);last if$future->is_ready}$future->on_fail(sub {!defined $_ or $_->is_ready or $_->cancel for@slots});$future->on_cancel(sub {!defined $_ or $_->is_ready or $_->cancel for@slots});return$future}sub fmap_concat(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"array")->then(sub {return Future->done(map {@$_}@_)})}*fmap=\&fmap_concat;sub fmap_scalar(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"scalar")}*fmap1=\&fmap_scalar;sub fmap_void(&@) {my$code=shift;my%args=@_;_fmap($code,%args,collect=>"void")}*fmap0=\&fmap_void;0x55AA;
FUTURE_UTILS
$fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG';
- 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;^
+ use 5.004;use strict;use warnings;package Getopt::Long;use vars qw($VERSION);$VERSION=2.52;use vars qw($VERSION_STRING);$VERSION_STRING="2.52";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){my$given=$opt;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,given=>$given,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;^
(
# Option name
(?: \w+[-\w]* )
# ... or an optional-with-default spec
: (?: -?\d+ | \+ ) [@%]?
)?
- $;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;
+ $;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 || $ctl->[CTL_DEST]==CTL_DEST_HASH){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}}sub given {my$self=shift;$self->{given}}use overload '""'=>\&name,fallback=>1;1;
GETOPT_LONG
$fatpacked{"GraphQL/Client.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT';
- 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;
+ package GraphQL::Client;use warnings;use strict;use Module::Load qw(load);use Scalar::Util qw(reftype);use namespace::clean;our$VERSION='0.605';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;
GRAPHQL_CLIENT
$fatpacked{"GraphQL/Client/CLI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_CLI';
- 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;
+ 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.605';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 $@;$options{transport}=$transport if ref$transport eq 'HASH' && %$transport;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;
Online documentation is available at:
https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
GRAPHQL_CLIENT_CLI
$fatpacked{"GraphQL/Client/http.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_HTTP';
- 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;
+ 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.605';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;
GRAPHQL_CLIENT_HTTP
$fatpacked{"GraphQL/Client/https.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GRAPHQL_CLIENT_HTTPS';
- 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;
+ package GraphQL::Client::https;use warnings;use strict;use parent 'GraphQL::Client::http';our$VERSION='0.605';sub new {my$class=shift;GraphQL::Client::http->new(@_)}1;
GRAPHQL_CLIENT_HTTPS
$fatpacked{"HTTP/AnyUA.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_ANYUA';
HTTP_ANYUA_UTIL
$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
- 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;
+ package HTTP::Tiny;use strict;use warnings;our$VERSION='0.080';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}=($ENV{CGI_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 patch 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|SSL read error)}}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);_croak("form data keys must not be undef")if!defined($key);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}){return$self->{handle}->connected}return}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;my$version=$class->VERSION;$default_agent .= "/$version" if defined$version;return$default_agent}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);if ($scheme ne 'http' && $scheme ne 'https'){die(qq/Unsupported URL scheme '$scheme'\n/)}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}&& $handle->connected && $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 ($request->{method}eq 'PUT' || $request->{method}eq 'POST'){if (!defined($args->{content})||!length($args->{content})){$request->{headers}{'content-length'}=0}}if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){if (exists$request->{'content-length'}&& $request->{'content-length'}==0){$request->{cb}=sub {""}}else {$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless exists$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)=@_;return "" if!defined$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.32)}? '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}$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 connected {my ($self)=@_;if ($self->{fh}&& $self->{fh}->connected){return wantarray ? ($self->{fh}->peerhost,$self->{fh}->peerport): join(':',$self->{fh}->peerhost,$self->{fh}->peerport)}return}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}local$SIG{PIPE}='IGNORE';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 (exists$request->{headers}{'content-length'}){return unless$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);$reason="" unless defined$reason;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;
sub $sub_name {
my (\$self, \$url, \$args) = \@_;
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
HTTP_TINY
$fatpacked{"JSON/MaybeXS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_MAYBEXS';
- package JSON::MaybeXS;use strict;use warnings FATAL=>'all';use base qw(Exporter);our$VERSION='1.004000';$VERSION=eval$VERSION;sub _choose_json_module {return 'Cpanel::JSON::XS' if$INC{'Cpanel/JSON/XS.pm'};return 'JSON::XS' if$INC{'JSON/XS.pm'};my@err;return 'Cpanel::JSON::XS' if eval {require Cpanel::JSON::XS;1};push@err,"Error loading Cpanel::JSON::XS: $@";return 'JSON::XS' if eval {require JSON::XS;1};push@err,"Error loading JSON::XS: $@";return 'JSON::PP' if eval {require JSON::PP;1};push@err,"Error loading JSON::PP: $@";die join("\n","Couldn't load a JSON module:",@err)}BEGIN {our$JSON_Class=_choose_json_module();$JSON_Class->import(qw(encode_json decode_json));no strict 'refs';*$_=$JSON_Class->can($_)for qw(true false)}our@EXPORT=qw(encode_json decode_json JSON);my@EXPORT_ALL=qw(is_bool);our@EXPORT_OK=qw(is_bool to_json from_json);our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_ALL ],legacy=>[@EXPORT,@EXPORT_OK ],);sub JSON () {our$JSON_Class}sub new {shift;my%args=@_==1 ? %{$_[0]}: @_;my$new=(our$JSON_Class)->new;$new->$_($args{$_})for keys%args;return$new}use Scalar::Util ();sub is_bool {die 'is_bool is not a method' if $_[1];Scalar::Util::blessed($_[0])and ($_[0]->isa('JSON::XS::Boolean')or $_[0]->isa('Cpanel::JSON::XS::Boolean')or $_[0]->isa('JSON::PP::Boolean'))}use Carp ();sub from_json ($@) {if (ref($_[0])=~ /^JSON/ or $_[0]=~ /^JSON/){Carp::croak "from_json should not be called as a method."}my$json=JSON()->new;if (@_==2 and ref $_[1]eq 'HASH'){my$opt=$_[1];for my$method (keys %$opt){$json->$method($opt->{$method})}}return$json->decode($_[0])}sub to_json ($@) {if (ref($_[0])=~ /^JSON/ or (@_ > 2 and $_[0]=~ /^JSON/)){Carp::croak "to_json should not be called as a method."}my$json=JSON()->new;if (@_==2 and ref $_[1]eq 'HASH'){my$opt=$_[1];for my$method (keys %$opt){$json->$method($opt->{$method})}}$json->encode($_[0])}1;
+ package JSON::MaybeXS;use strict;use warnings FATAL=>'all';use base qw(Exporter);our$VERSION='1.004003';$VERSION =~ tr/_//d;sub _choose_json_module {return 'Cpanel::JSON::XS' if$INC{'Cpanel/JSON/XS.pm'};return 'JSON::XS' if$INC{'JSON/XS.pm'}&& eval {JSON::XS->VERSION(3.0);1};my@err;return 'Cpanel::JSON::XS' if eval {require Cpanel::JSON::XS;1};push@err,"Error loading Cpanel::JSON::XS: $@";return 'JSON::XS' if eval {require JSON::XS;JSON::XS->VERSION(3.0);1};push@err,"Error loading JSON::XS: $@";return 'JSON::PP' if eval {require JSON::PP;1};push@err,"Error loading JSON::PP: $@";die join("\n","Couldn't load a JSON module:",@err)}BEGIN {our$JSON_Class=_choose_json_module();$JSON_Class->import(qw(encode_json decode_json));no strict 'refs';*$_=$JSON_Class->can($_)for qw(true false)}our@EXPORT=qw(encode_json decode_json JSON);my@EXPORT_ALL=qw(is_bool);our@EXPORT_OK=qw(is_bool to_json from_json);our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_ALL ],legacy=>[@EXPORT,@EXPORT_OK ],);sub JSON () {our$JSON_Class}sub new {shift;my%args=@_==1 ? %{$_[0]}: @_;my$new=(our$JSON_Class)->new;$new->$_($args{$_})for keys%args;return$new}use Scalar::Util ();sub is_bool {die 'is_bool is not a method' if $_[1];Scalar::Util::blessed($_[0])and ($_[0]->isa('JSON::XS::Boolean')or $_[0]->isa('Cpanel::JSON::XS::Boolean')or $_[0]->isa('JSON::PP::Boolean'))}use Carp ();sub from_json ($@) {if (ref($_[0])=~ /^JSON/ or $_[0]=~ /^JSON/){Carp::croak "from_json should not be called as a method."}my$json=JSON()->new;if (@_==2 and ref $_[1]eq 'HASH'){my$opt=$_[1];for my$method (keys %$opt){$json->$method($opt->{$method})}}return$json->decode($_[0])}sub to_json ($@) {if (ref($_[0])=~ /^JSON/ or (@_ > 2 and $_[0]=~ /^JSON/)){Carp::croak "to_json should not be called as a method."}my$json=JSON()->new;if (@_==2 and ref $_[1]eq 'HASH'){my$opt=$_[1];for my$method (keys %$opt){$json->$method($opt->{$method})}}$json->encode($_[0])}1;
JSON_MAYBEXS
$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
- 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/
+ 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.07';@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/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
sub get_$name {
\$_[0]->{PROPS}->[$property_id] ? 1 : '';
}
- /}}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 =~ /^(?:
+ /}}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}else {delete$self->{false};delete$self->{true}}return$self}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 =~ /^(?:
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
}
$_[0]->{_incr_parser}->{incr_text};
}
- } 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;
+ } 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}}unless ($coder->get_utf8){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}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;
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
- 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;
+ 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.07';1;
JSON_PP_BOOLEAN
$fatpacked{"Module/Implementation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_IMPLEMENTATION';
MODULE_IMPLEMENTATION
$fatpacked{"Module/Loader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_LOADER';
- package Module::Loader;$Module::Loader::VERSION='0.03';use 5.006;use strict;use warnings;use Path::Iterator::Rule;use File::Spec::Functions qw/catfile splitdir/;use Carp qw/croak/;sub new {my ($class,%attributes)=@_;bless {%attributes},$class}sub max_depth {my$self=shift;croak 'max_depth is immutable' if @_ > 0;return$self->{max_depth}if exists($self->{max_depth});return}sub find_modules {my$self=shift;my$base=shift;my$argref=@_ > 0 ? shift : {};my$max_depth=$argref->{max_depth}|| $self->{max_depth}|| 0;my@baseparts=split(/::/,$base);my%modules;for my$directory (@INC){my$path=catfile($directory,@baseparts);next unless -d $path;my$rule=Path::Iterator::Rule->new->perl_module;$rule->max_depth($max_depth)if$max_depth;for my$file ($rule->all($path)){(my$modpath=$file)=~ s!^\Q$directory\E.|\.pm$!!g;my$module=join('::',splitdir($modpath));$modules{$module }++}}return keys(%modules)}sub search {my ($self,$base)=@_;return$self->find_modules($base,{max_depth=>1 })}sub load {my ($self,@modules)=@_;require Module::Runtime;for my$module (@modules){Module::Runtime::require_module($module)}}1;
+ package Module::Loader;$Module::Loader::VERSION='0.04';use 5.006;use strict;use warnings;use Path::Iterator::Rule;use File::Spec::Functions qw/catfile splitdir/;use Carp qw/croak/;sub new {my ($class,%attributes)=@_;bless {%attributes},$class}sub max_depth {my$self=shift;croak 'max_depth is immutable' if @_ > 0;return$self->{max_depth}if exists($self->{max_depth});return}sub find_modules {my$self=shift;my$base=shift;my$argref=@_ > 0 ? shift : {};my$max_depth=$argref->{max_depth}|| $self->{max_depth}|| 0;my@baseparts=split(/::/,$base);my%modules;for my$directory (@INC){my$path=catfile($directory,@baseparts);next unless -d $path;my$rule=Path::Iterator::Rule->new->perl_module;$rule->max_depth($max_depth)if$max_depth;for my$file ($rule->all($path)){(my$modpath=$file)=~ s!^\Q$directory\E.|\.pm$!!g;my$module=join('::',splitdir($modpath));$modules{$module }++}}return keys(%modules)}sub search {my ($self,$base)=@_;return$self->find_modules($base,{max_depth=>1 })}sub load {my ($self,@modules)=@_;require Module::Runtime;for my$module (@modules){Module::Runtime::require_module($module)}}1;
MODULE_LOADER
$fatpacked{"Module/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_RUNTIME';
NUMBER_COMPARE
$fatpacked{"PIR.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PIR';
- use 5.008001;use strict;use warnings;package PIR;our$VERSION='1.014';use Path::Iterator::Rule;our@ISA=qw/Path::Iterator::Rule/;1;
+ use 5.008001;use strict;use warnings;package PIR;our$VERSION='1.015';use Path::Iterator::Rule;our@ISA=qw/Path::Iterator::Rule/;1;
PIR
$fatpacked{"Package/Stash.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PACKAGE_STASH';
- package Package::Stash;use strict;use warnings;use 5.008001;our$VERSION='0.38';our$IMPLEMENTATION;use Module::Implementation 0.06;BEGIN {local$ENV{PACKAGE_STASH_IMPLEMENTATION}=$IMPLEMENTATION if ($IMPLEMENTATION and not $ENV{PACKAGE_STASH_IMPLEMENTATION});Module::Implementation::build_loader_sub(implementations=>['XS','PP' ],symbols=>[qw(new name namespace add_symbol remove_glob has_symbol get_symbol get_or_add_symbol remove_symbol list_all_symbols get_all_symbols)],)->();$IMPLEMENTATION=Module::Implementation::implementation_for(__PACKAGE__)}1;
+ package Package::Stash;use strict;use warnings;use 5.008001;our$VERSION='0.40';our$IMPLEMENTATION;use Module::Implementation 0.06;BEGIN {local$ENV{PACKAGE_STASH_IMPLEMENTATION}=$IMPLEMENTATION if ($IMPLEMENTATION and not $ENV{PACKAGE_STASH_IMPLEMENTATION});Module::Implementation::build_loader_sub(implementations=>['XS','PP' ],symbols=>[qw(new name namespace add_symbol remove_glob has_symbol get_symbol get_or_add_symbol remove_symbol list_all_symbols get_all_symbols)],)->();$IMPLEMENTATION=Module::Implementation::implementation_for(__PACKAGE__)}
PACKAGE_STASH
$fatpacked{"Package/Stash/Conflicts.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PACKAGE_STASH_CONFLICTS';
PACKAGE_STASH_CONFLICTS
$fatpacked{"Package/Stash/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PACKAGE_STASH_PP';
- package Package::Stash::PP;use strict;use warnings;our$VERSION='0.38';use B;use Carp qw(confess);use Scalar::Util qw(blessed reftype weaken);use Symbol;use constant BROKEN_ISA_ASSIGNMENT=>($] < 5.012);use constant BROKEN_WEAK_STASH=>($] < 5.010);use constant BROKEN_SCALAR_INITIALIZATION=>($] < 5.010);use constant BROKEN_GLOB_ASSIGNMENT=>($] < 5.013004);use constant HAS_ISA_CACHE=>($] < 5.010);sub new {my$class=shift;my ($package)=@_;if (!defined($package)|| (ref($package)&& reftype($package)ne 'HASH')){confess "Package::Stash->new must be passed the name of the " ."package to access"}elsif (ref($package)&& reftype($package)eq 'HASH'){confess "The PP implementation of Package::Stash does not support " ."anonymous stashes before perl 5.14" if BROKEN_GLOB_ASSIGNMENT;return bless {'namespace'=>$package,},$class}elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/){return bless {'package'=>$package,},$class}else {confess "$package is not a module name"}}sub name {confess "Can't call name as a class method" unless blessed($_[0]);confess "Can't get the name of an anonymous package" unless defined($_[0]->{package});return $_[0]->{package}}sub namespace {confess "Can't call namespace as a class method" unless blessed($_[0]);if (BROKEN_WEAK_STASH){no strict 'refs';return \%{$_[0]->name .'::'}}else {return $_[0]->{namespace}if defined $_[0]->{namespace};{no strict 'refs';$_[0]->{namespace}=\%{$_[0]->name .'::'}}weaken($_[0]->{namespace});return $_[0]->{namespace}}}{my%SIGIL_MAP=('$'=>'SCALAR','@'=>'ARRAY','%'=>'HASH','&'=>'CODE',''=>'IO',);sub _deconstruct_variable_name {my ($variable)=@_;my@ret;if (ref($variable)eq 'HASH'){@ret=@{$variable}{qw[name sigil type]}}else {(defined$variable && length$variable)|| confess "You must pass a variable name";my$sigil=substr($variable,0,1,'');if (exists$SIGIL_MAP{$sigil}){@ret=($variable,$sigil,$SIGIL_MAP{$sigil})}else {@ret=("${sigil}${variable}",'',$SIGIL_MAP{''})}}($ret[0]!~ /::/)|| confess "Variable names may not contain ::";return@ret}}sub _valid_for_type {my ($value,$type)=@_;if ($type eq 'HASH' || $type eq 'ARRAY' || $type eq 'IO' || $type eq 'CODE'){return reftype($value)eq $type}else {my$ref=reftype($value);return!defined($ref)|| $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING'}}sub add_symbol {my ($self,$variable,$initial_value,%opts)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);if (@_ > 2){_valid_for_type($initial_value,$type)|| confess "$initial_value is not of type $type";if ($^P and $^P & 0x10 && $sigil eq '&'){my$filename=$opts{filename};my$first_line_num=$opts{first_line_num};(undef,$filename,$first_line_num)=caller if not defined$filename;my$last_line_num=$opts{last_line_num}|| ($first_line_num ||= 0);$DB::sub{$self->name .'::' .$name}="$filename:$first_line_num-$last_line_num"}}if (BROKEN_GLOB_ASSIGNMENT){if (@_ > 2){no strict 'refs';no warnings 'redefine';*{$self->name .'::' .$name}=ref$initial_value ? $initial_value : \$initial_value}else {no strict 'refs';if (BROKEN_ISA_ASSIGNMENT && $name eq 'ISA'){*{$self->name .'::' .$name}}else {my$undef=_undef_ref_for_type($type);*{$self->name .'::' .$name}=$undef}}}else {my$namespace=$self->namespace;{local*__ANON__::=$namespace;no strict 'refs';no warnings 'void';no warnings 'once';*{"__ANON__::$name"}}if (@_ > 2){no warnings 'redefine';*{$namespace->{$name}}=ref$initial_value ? $initial_value : \$initial_value}else {return if BROKEN_ISA_ASSIGNMENT && $name eq 'ISA';*{$namespace->{$name}}=_undef_ref_for_type($type)}}}sub _undef_ref_for_type {my ($type)=@_;if ($type eq 'ARRAY'){return []}elsif ($type eq 'HASH'){return {}}elsif ($type eq 'SCALAR'){return \undef}elsif ($type eq 'IO'){return Symbol::geniosym}elsif ($type eq 'CODE'){confess "Don't know how to vivify CODE variables"}else {confess "Unknown type $type in vivication"}}sub remove_glob {my ($self,$name)=@_;delete$self->namespace->{$name}}sub has_symbol {my ($self,$variable)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my$namespace=$self->namespace;return unless exists$namespace->{$name};my$entry_ref=\$namespace->{$name};if (reftype($entry_ref)eq 'GLOB'){if ($type eq 'SCALAR'){if (BROKEN_SCALAR_INITIALIZATION){return defined ${*{$entry_ref}{$type}}}else {my$sv=B::svref_2object($entry_ref)->SV;return$sv->isa('B::SV')|| ($sv->isa('B::SPECIAL')&& $B::specialsv_name[$$sv]ne 'Nullsv')}}else {return defined *{$entry_ref}{$type}}}else {return$type eq 'CODE'}}sub get_symbol {my ($self,$variable,%opts)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my$namespace=$self->namespace;if (!exists$namespace->{$name}){if ($opts{vivify}){$self->add_symbol($variable)}else {return undef}}my$entry_ref=\$namespace->{$name};if (ref($entry_ref)eq 'GLOB'){return *{$entry_ref}{$type}}else {if ($type eq 'CODE'){if (BROKEN_GLOB_ASSIGNMENT || defined($self->{package})){no strict 'refs';return \&{$self->name .'::' .$name}}if (blessed($namespace)&& $namespace->isa('Package::Anon')){$namespace->bless(\(my$foo))->can($name)}else {confess "Don't know how to inflate a " .ref($entry_ref)." into a full coderef (perhaps you could use" ." Package::Anon instead of a bare stash?)"}return *{$namespace->{$name}}{CODE}}else {return undef}}}sub get_or_add_symbol {my$self=shift;$self->get_symbol(@_,vivify=>1)}sub remove_symbol {my ($self,$variable)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my%desc=(SCALAR=>{sigil=>'$',type=>'SCALAR',name=>$name },ARRAY=>{sigil=>'@',type=>'ARRAY',name=>$name },HASH=>{sigil=>'%',type=>'HASH',name=>$name },CODE=>{sigil=>'&',type=>'CODE',name=>$name },IO=>{sigil=>'',type=>'IO',name=>$name },);confess "This should never ever ever happen" if!$desc{$type};my@types_to_store=grep {$type ne $_ && $self->has_symbol($desc{$_})}keys%desc;my%values=map {$_,$self->get_symbol($desc{$_})}@types_to_store;$values{SCALAR}=$self->get_symbol($desc{SCALAR})if!defined$values{SCALAR}&& $type ne 'SCALAR' && BROKEN_SCALAR_INITIALIZATION;$self->remove_glob($name);$self->add_symbol($desc{$_}=>$values{$_})for grep {defined$values{$_}}keys%values}sub list_all_symbols {my ($self,$type_filter)=@_;my$namespace=$self->namespace;if (HAS_ISA_CACHE){return grep {$_ ne '::ISA::CACHE::'}keys %{$namespace}unless defined$type_filter}else {return keys %{$namespace}unless defined$type_filter}if ($type_filter eq 'CODE'){return grep {ref(\$namespace->{$_})ne 'GLOB' || defined(*{$namespace->{$_}}{CODE})}keys %{$namespace}}elsif ($type_filter eq 'SCALAR'){return grep {!(HAS_ISA_CACHE && $_ eq '::ISA::CACHE::')&& (BROKEN_SCALAR_INITIALIZATION ? (ref(\$namespace->{$_})eq 'GLOB' && defined(${*{$namespace->{$_}}{'SCALAR'}})): (do {my$entry=\$namespace->{$_};ref($entry)eq 'GLOB' && B::svref_2object($entry)->SV->isa('B::SV')}))}keys %{$namespace}}else {return grep {ref(\$namespace->{$_})eq 'GLOB' && defined(*{$namespace->{$_}}{$type_filter})}keys %{$namespace}}}sub get_all_symbols {my ($self,$type_filter)=@_;my$namespace=$self->namespace;return {%{$namespace}}unless defined$type_filter;return {map {$_=>$self->get_symbol({name=>$_,type=>$type_filter})}$self->list_all_symbols($type_filter)}}1;
+ package Package::Stash::PP;use strict;use warnings;our$VERSION='0.40';use B;use Carp qw(confess);use Scalar::Util qw(blessed reftype weaken);use Symbol;use constant BROKEN_ISA_ASSIGNMENT=>($] < 5.012);use constant BROKEN_WEAK_STASH=>($] < 5.010);use constant BROKEN_SCALAR_INITIALIZATION=>($] < 5.010);use constant BROKEN_GLOB_ASSIGNMENT=>($] < 5.013004);use constant HAS_ISA_CACHE=>($] < 5.010);sub new {my$class=shift;my ($package)=@_;if (!defined($package)|| (ref($package)&& reftype($package)ne 'HASH')){confess "Package::Stash->new must be passed the name of the " ."package to access"}elsif (ref($package)&& reftype($package)eq 'HASH'){confess "The PP implementation of Package::Stash does not support " ."anonymous stashes before perl 5.14" if BROKEN_GLOB_ASSIGNMENT;return bless {'namespace'=>$package,},$class}elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/){return bless {'package'=>$package,},$class}else {confess "$package is not a module name"}}sub name {confess "Can't call name as a class method" unless blessed($_[0]);confess "Can't get the name of an anonymous package" unless defined($_[0]->{package});return $_[0]->{package}}sub namespace {confess "Can't call namespace as a class method" unless blessed($_[0]);if (BROKEN_WEAK_STASH){no strict 'refs';return \%{$_[0]->name .'::'}}else {return $_[0]->{namespace}if defined $_[0]->{namespace};{no strict 'refs';$_[0]->{namespace}=\%{$_[0]->name .'::'}}weaken($_[0]->{namespace});return $_[0]->{namespace}}}{my%SIGIL_MAP=('$'=>'SCALAR','@'=>'ARRAY','%'=>'HASH','&'=>'CODE',''=>'IO',);sub _deconstruct_variable_name {my ($variable)=@_;my@ret;if (ref($variable)eq 'HASH'){@ret=@{$variable}{qw[name sigil type]}}else {(defined$variable && length$variable)|| confess "You must pass a variable name";my$sigil=substr($variable,0,1,'');if (exists$SIGIL_MAP{$sigil}){@ret=($variable,$sigil,$SIGIL_MAP{$sigil})}else {@ret=("${sigil}${variable}",'',$SIGIL_MAP{''})}}($ret[0]!~ /::/)|| confess "Variable names may not contain ::";return@ret}}sub _valid_for_type {my ($value,$type)=@_;if ($type eq 'HASH' || $type eq 'ARRAY' || $type eq 'IO' || $type eq 'CODE'){return reftype($value)eq $type}else {my$ref=reftype($value);return!defined($ref)|| $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING'}}sub add_symbol {my ($self,$variable,$initial_value,%opts)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);if (@_ > 2){_valid_for_type($initial_value,$type)|| confess "$initial_value is not of type $type";if ($^P and $^P & 0x10 && $sigil eq '&'){my$filename=$opts{filename};my$first_line_num=$opts{first_line_num};(undef,$filename,$first_line_num)=caller if not defined$filename;my$last_line_num=$opts{last_line_num}|| ($first_line_num ||= 0);$DB::sub{$self->name .'::' .$name}="$filename:$first_line_num-$last_line_num"}}if (BROKEN_GLOB_ASSIGNMENT){if (@_ > 2){no strict 'refs';no warnings 'redefine';*{$self->name .'::' .$name}=ref$initial_value ? $initial_value : \$initial_value}else {no strict 'refs';if (BROKEN_ISA_ASSIGNMENT && $name eq 'ISA'){*{$self->name .'::' .$name}}else {my$undef=_undef_ref_for_type($type);*{$self->name .'::' .$name}=$undef}}}else {my$namespace=$self->namespace;{local*__ANON__::=$namespace;no strict 'refs';no warnings 'void';no warnings 'once';*{"__ANON__::$name"}}if (@_ > 2){no warnings 'redefine';*{$namespace->{$name}}=ref$initial_value ? $initial_value : \$initial_value}else {return if BROKEN_ISA_ASSIGNMENT && $name eq 'ISA';*{$namespace->{$name}}=_undef_ref_for_type($type)}}}sub _undef_ref_for_type {my ($type)=@_;if ($type eq 'ARRAY'){return []}elsif ($type eq 'HASH'){return {}}elsif ($type eq 'SCALAR'){return \undef}elsif ($type eq 'IO'){return Symbol::geniosym}elsif ($type eq 'CODE'){confess "Don't know how to vivify CODE variables"}else {confess "Unknown type $type in vivication"}}sub remove_glob {my ($self,$name)=@_;delete$self->namespace->{$name}}sub has_symbol {my ($self,$variable)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my$namespace=$self->namespace;return unless exists$namespace->{$name};my$entry_ref=\$namespace->{$name};if (reftype($entry_ref)eq 'GLOB'){if ($type eq 'SCALAR'){if (BROKEN_SCALAR_INITIALIZATION){return defined ${*{$entry_ref}{$type}}}else {my$sv=B::svref_2object($entry_ref)->SV;return$sv->isa('B::SV')|| ($sv->isa('B::SPECIAL')&& $B::specialsv_name[$$sv]ne 'Nullsv')}}else {return defined *{$entry_ref}{$type}}}else {return$type eq 'CODE'}}sub get_symbol {my ($self,$variable,%opts)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my$namespace=$self->namespace;if (!exists$namespace->{$name}){if ($opts{vivify}){$self->add_symbol($variable)}else {return undef}}my$entry_ref=\$namespace->{$name};if (ref($entry_ref)eq 'GLOB'){return *{$entry_ref}{$type}}else {if ($type eq 'CODE'){if (BROKEN_GLOB_ASSIGNMENT || defined($self->{package})){no strict 'refs';return \&{$self->name .'::' .$name}}if (blessed($namespace)&& $namespace->isa('Package::Anon')){$namespace->bless(\(my$foo))->can($name)}else {confess "Don't know how to inflate a " .ref($entry_ref)." into a full coderef (perhaps you could use" ." Package::Anon instead of a bare stash?)"}return *{$namespace->{$name}}{CODE}}else {return undef}}}sub get_or_add_symbol {my$self=shift;$self->get_symbol(@_,vivify=>1)}sub remove_symbol {my ($self,$variable)=@_;my ($name,$sigil,$type)=_deconstruct_variable_name($variable);my%desc=(SCALAR=>{sigil=>'$',type=>'SCALAR',name=>$name },ARRAY=>{sigil=>'@',type=>'ARRAY',name=>$name },HASH=>{sigil=>'%',type=>'HASH',name=>$name },CODE=>{sigil=>'&',type=>'CODE',name=>$name },IO=>{sigil=>'',type=>'IO',name=>$name },);confess "This should never ever ever happen" if!$desc{$type};my@types_to_store=grep {$type ne $_ && $self->has_symbol($desc{$_})}keys%desc;my%values=map {$_,$self->get_symbol($desc{$_})}@types_to_store;$values{SCALAR}=$self->get_symbol($desc{SCALAR})if!defined$values{SCALAR}&& $type ne 'SCALAR' && BROKEN_SCALAR_INITIALIZATION;$self->remove_glob($name);$self->add_symbol($desc{$_}=>$values{$_})for grep {defined$values{$_}}keys%values}sub list_all_symbols {my ($self,$type_filter)=@_;my$namespace=$self->namespace;if (HAS_ISA_CACHE){return grep {$_ ne '::ISA::CACHE::'}keys %{$namespace}unless defined$type_filter}else {return keys %{$namespace}unless defined$type_filter}if ($type_filter eq 'CODE'){return grep {ref(\$namespace->{$_})ne 'GLOB' || defined(*{$namespace->{$_}}{CODE})}keys %{$namespace}}elsif ($type_filter eq 'SCALAR'){return grep {!(HAS_ISA_CACHE && $_ eq '::ISA::CACHE::')&& (BROKEN_SCALAR_INITIALIZATION ? (ref(\$namespace->{$_})eq 'GLOB' && defined(${*{$namespace->{$_}}{'SCALAR'}})): (do {my$entry=\$namespace->{$_};ref($entry)eq 'GLOB' && B::svref_2object($entry)->SV->isa('B::SV')}))}keys %{$namespace}}else {return grep {ref(\$namespace->{$_})eq 'GLOB' && defined(*{$namespace->{$_}}{$type_filter})}keys %{$namespace}}}sub get_all_symbols {my ($self,$type_filter)=@_;my$namespace=$self->namespace;return {%{$namespace}}unless defined$type_filter;return {map {$_=>$self->get_symbol({name=>$_,type=>$type_filter})}$self->list_all_symbols($type_filter)}}
PACKAGE_STASH_PP
$fatpacked{"Path/Iterator/Rule.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_ITERATOR_RULE';
- use 5.008001;use strict;use warnings;package Path::Iterator::Rule;our$VERSION='1.014';use warnings::register;use if $] ge '5.010000','re','regexp_pattern';use Carp ();use File::Basename ();use File::Spec ();use List::Util ();use Number::Compare 0.02;use Scalar::Util ();use Text::Glob ();use Try::Tiny;sub new {my$class=shift;$class=ref$class if ref$class;return bless {rules=>[]},$class}sub clone {my$self=shift;return bless _my_clone({%$self}),ref$self}sub _my_clone {my$d=shift;if (ref$d eq 'HASH'){return {map {;my$v=$d->{$_};$_=>(ref($v)? _my_clone($v): $v)}keys %$d }}elsif (ref$d eq 'ARRAY'){return [map {ref($_)? _my_clone($_): $_}@$d ]}else {return$d}}sub add_helper {my ($class,$name,$coderef,$skip_negation)=@_;$class=ref$class if ref$class;if (!$class->can($name)){no strict 'refs';*$name=sub {my$self=shift;my$rule=$coderef->(@_);$self->and($rule)};if (!$skip_negation){*{"not_$name"}=sub {my$self=shift;my$rule=$coderef->(@_);$self->not($rule)}}}else {Carp::croak("Can't add rule '$name' because it conflicts with an existing method")}}sub _objectify {my ($self,$path)=@_;return "$path"}sub _defaults {return (_stringify=>1,follow_symlinks=>1,depthfirst=>0,sorted=>1,loop_safe=>($^O eq 'MSWin32' ? 0 : 1),error_handler=>sub {die sprintf("%s: %s",@_)},visitor=>undef,)}sub _fast_defaults {return (_stringify=>1,follow_symlinks=>1,depthfirst=>-1,sorted=>0,loop_safe=>0,error_handler=>undef,visitor=>undef,)}sub iter {my$self=shift;$self->_iter({$self->_defaults },@_)}sub iter_fast {my$self=shift;$self->_iter({$self->_fast_defaults },@_)}sub _iter {my$self=shift;my$defaults=shift;my$args=ref($_[0])&&!Scalar::Util::blessed($_[0])? shift : ref($_[-1])&&!Scalar::Util::blessed($_[-1])? pop : {};my%opts=(%$defaults,%$args);my$opt_stringify=$opts{_stringify};my$opt_depthfirst=$opts{depthfirst};my$opt_follow_symlinks=$opts{follow_symlinks};my$opt_sorted=$opts{sorted};my$opt_loop_safe=$opts{loop_safe};my$opt_error_handler=$opts{error_handler};my$opt_relative=$opts{relative};my$opt_visitor=$opts{visitor};my$has_rules=@{$self->{rules}};my$stash={};my$opt_report_symlinks=defined($opts{report_symlinks})? $opts{report_symlinks}: $opts{follow_symlinks};my$can_children=$self->can("_children");my@queue=map {my$i=$self->_objectify($_);($i,File::Basename::basename("$_"),0,$i)}@_ ? @_ : '.';return sub {LOOP: {my ($item,$base,$depth,$origin)=splice(@queue,0,4);return unless$item;if (ref$item eq 'CODE'){unshift@queue,$item->();redo LOOP}return$item->[0]if ref$item eq 'ARRAY';my$string_item=$opt_stringify ? "$item" : $item;my ($interest,$prune)=(1,0);if (-l $string_item){$prune=1 if!$opt_follow_symlinks;redo LOOP if!$opt_report_symlinks}if ($has_rules){local $_=$item;$stash->{_depth}=$depth;if ($opt_error_handler){$interest=try {$self->test($item,$base,$stash)}catch {$opt_error_handler->($item,$_)}}else {$interest=$self->test($item,$base,$stash)}if (ref$interest eq 'SCALAR'){$prune=1;$interest=$$interest}}if ($opt_visitor && $interest){local $_=$item;$stash->{_depth}=$depth;$opt_visitor->($item,$base,$stash)}if ((-d $string_item)&& (!$prune)&& (!$opt_loop_safe || $self->_is_unique($string_item,$stash))){if (!-r $string_item){warnings::warnif("Directory '$string_item' is not readable. Skipping it")}else {my$depth_p1=$depth + 1;my$next;if ($can_children){$next=sub {my@paths=$can_children->($self,$item);if ($opt_sorted){@paths=sort {"$a->[0]" cmp "$b->[0]"}@paths}map {($_->[1],$_->[0],$depth_p1,$origin)}@paths}}else {$next=sub {opendir(my$dh,$string_item);if ($opt_sorted){map {("$string_item/$_",$_,$depth_p1,$origin)}sort {$a cmp $b}grep {$_ ne "." && $_ ne ".."}readdir$dh}else {map {("$string_item/$_",$_,$depth_p1,$origin)}grep {$_ ne "." && $_ ne ".."}readdir$dh}}}if ($opt_depthfirst){unshift@queue,[($opt_relative ? $self->_objectify(File::Spec->abs2rel($string_item,$origin)): $item)],undef,undef,undef if$interest && $opt_depthfirst > 0;unshift@queue,$next,undef,undef,undef;redo LOOP if$opt_depthfirst > 0}else {push@queue,$next,undef,undef,undef}}}return ($opt_relative ? $self->_objectify(File::Spec->abs2rel($string_item,$origin)): $item)if$interest;redo LOOP}}}sub all {my$self=shift;return$self->_all($self->iter(@_))}sub all_fast {my$self=shift;return$self->_all($self->iter_fast(@_))}sub _all {my$self=shift;my$iter=shift;if (wantarray){my@results;while (defined(my$item=$iter->())){push@results,$item}return@results}elsif (defined wantarray){my$count=0;$count++ while defined$iter->();return$count}else {1 while defined$iter->()}}sub and {my$self=shift;push @{$self->{rules}},$self->_rulify(@_);return$self}sub or {my$self=shift;my@rules=$self->_rulify(@_);my$coderef=sub {my ($result,$prune);for my$rule (@rules){$result=$rule->(@_);$prune ||= ref($result)eq 'SCALAR';$result=$$result if ref($result)eq 'SCALAR';return ($prune ? \1 : 1)if$result}return ($prune ? \$result : $result)};return$self->and($coderef)}sub not {my$self=shift;my$obj=$self->new->and(@_);my$coderef=sub {my$result=$obj->test(@_);return ref($result)? \!$$result :!$result};return$self->and($coderef)}sub skip {my$self=shift;my@rules=@_;my$obj=$self->new->or(@rules);my$coderef=sub {my$result=$obj->test(@_);my ($prune,$interest);if (ref($result)eq 'SCALAR'){$prune=1;$interest=0}else {$prune=$result;$interest=!$result}return$prune ? \$interest : $interest};return$self->and($coderef)}sub test {my ($self,$item,$base,$stash)=@_;my ($result,$prune);for my$rule (@{$self->{rules}}){$result=$rule->($item,$base,$stash)|| 0;if (!ref($result)&& $result eq '0 but true'){Carp::croak("0 but true no longer supported by custom rules")}$prune ||= ref($result)eq 'SCALAR';$result=$$result if ref($result)eq 'SCALAR';return ($prune ? \0 : 0)if!$result}return ($prune ? \1 : 1)}sub _rulify {my ($self,@args)=@_;my@rules;for my$arg (@args){my$rule;if (Scalar::Util::blessed($arg)&& $arg->isa("Path::Iterator::Rule")){$rule=sub {$arg->test(@_)}}elsif (ref($arg)eq 'CODE'){$rule=$arg}else {Carp::croak("Rules must be coderef or Path::Iterator::Rule")}push@rules,$rule}return@rules}sub _is_unique {my ($self,$string_item,$stash)=@_;my$unique_id;my@st=eval {stat$string_item};@st=eval {lstat$string_item}unless@st;if (@st){$unique_id=join(",",$st[0],$st[1])}else {my$type=-d $string_item ? 'directory' : 'file';warnings::warnif("Could not stat $type '$string_item'");$unique_id=$string_item}return!$stash->{_seen}{$unique_id}++}sub _regexify {my ($re,$add)=@_;$add ||= '';my$new=ref($re)eq 'Regexp' ? $re : Text::Glob::glob_to_regex($re);return$new unless$add;my ($pattern,$flags)=_split_re($new);my$new_flags=$add ? _reflag($flags,$add): "";return qr/$new_flags$pattern/}sub _split_re {my$value=shift;if ($] ge 5.010){return re::regexp_pattern($value)}else {$value =~ s/^\(\?\^?//;$value =~ s/\)$//;my ($opt,$re)=split(/:/,$value,2);$opt =~ s/\-\w+$//;return ($re,$opt)}}sub _reflag {my ($orig,$add)=@_;$orig ||= "";if ($] >= 5.014){return "(?^$orig$add)"}else {my ($pos,$neg)=split /-/,$orig;$pos ||= "";$neg ||= "";$neg =~ s/i//;$neg="-$neg" if length$neg;return "(?$add$pos$neg)"}}my%simple_helpers=(directory=>sub {-d $_},dangling=>sub {-l $_ &&!stat $_},);while (my ($k,$v)=each%simple_helpers){__PACKAGE__->add_helper($k,sub {return$v})}sub _generate_name_matcher {my (@patterns)=@_;if (@patterns > 1){return sub {my$name="$_[1]";return (List::Util::first {$name =~ $_}@patterns)? 1 : 0}}else {my$pattern=$patterns[0];return sub {my$name="$_[1]";return$name =~ $pattern ? 1 : 0}}}my%complex_helpers=(name=>sub {Carp::croak("No patterns provided to 'name'")unless @_;_generate_name_matcher(map {_regexify($_)}@_)},iname=>sub {Carp::croak("No patterns provided to 'iname'")unless @_;_generate_name_matcher(map {_regexify($_,"i")}@_)},min_depth=>sub {Carp::croak("No depth argument given to 'min_depth'")unless @_;my$min_depth=0+ shift;return sub {my ($f,$b,$stash)=@_;return$stash->{_depth}>= $min_depth}},max_depth=>sub {Carp::croak("No depth argument given to 'max_depth'")unless @_;my$max_depth=0+ shift;return sub {my ($f,$b,$stash)=@_;return 1 if$stash->{_depth}< $max_depth;return \1 if$stash->{_depth}==$max_depth;return \0}},shebang=>sub {Carp::croak("No patterns provided to 'shebang'")unless @_;my@patterns=map {_regexify($_)}@_;return sub {my$f=shift;return unless!-d $f;open my$fh,"<",$f;my$shebang=<$fh>;return unless defined$shebang;return (List::Util::first {$shebang =~ $_}@patterns)? 1 : 0}},contents_match=>sub {my@regexp=@_;my$filter=':encoding(UTF-8)';$filter=shift@regexp unless ref$regexp[0];return sub {my$f=shift;return unless!-d $f;my$contents=do {local $/=undef;open my$fh,"<$filter",$f;<$fh>};for my$re (@regexp){return 1 if$contents =~ $re}return 0}},line_match=>sub {my@regexp=@_;my$filter=':encoding(UTF-8)';$filter=shift@regexp unless ref$regexp[0];return sub {my$f=shift;return unless!-d $f;open my$fh,"<$filter",$f;while (my$line=<$fh>){for my$re (@regexp){return 1 if$line =~ $re}}return 0}},);while (my ($k,$v)=each%complex_helpers){__PACKAGE__->add_helper($k,$v)}__PACKAGE__->add_helper(skip_dirs=>sub {Carp::croak("No patterns provided to 'skip_dirs'")unless @_;my$name_check=Path::Iterator::Rule->new->name(@_);return sub {return \0 if -d $_[0]&& $name_check->test(@_);return 1}}=>1);__PACKAGE__->add_helper(skip_subdirs=>sub {Carp::croak("No patterns provided to 'skip_subdirs'")unless @_;my$name_check=Path::Iterator::Rule->new->name(@_);return sub {my ($f,$b,$stash)=@_;return \0 if -d $f && $stash->{_depth}&& $name_check->test(@_);return 1}}=>1);my%X_tests=(-r=>readable=>-R=>r_readable=>-w=>writeable=>-W=>r_writeable=>-w=>writable=>-W=>r_writable=>-x=>executable=>-X=>r_executable=>-o=>owned=>-O=>r_owned=>-e=>exists=>-f=>file=>-z=>empty=>-d=>dir=>-s=>nonempty=>-l=>symlink=>=>-p=>fifo=>-u=>setuid=>-S=>socket=>-g=>setgid=>-b=>block=>-k=>sticky=>-c=>character=>=>-t=>tty=>-T=>ascii=>-B=>binary=>);while (my ($op,$name)=each%X_tests){my$coderef=eval "sub { $op \$_ }";__PACKAGE__->add_helper($name,sub {return$coderef})}my%time_tests=(-A=>accessed=>-M=>modified=>-C=>changed=>);while (my ($op,$name)=each%time_tests){my$filetest=eval "sub { $op \$_ }";my$coderef=sub {Carp::croak("The '$name' test requires a single argument")unless @_==1;my$comparator=Number::Compare->new(shift);return sub {return$comparator->($filetest->())}};__PACKAGE__->add_helper($name,$coderef)}my@stat_tests=qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks);for my$i (0 .. $#stat_tests){my$name=$stat_tests[$i];my$coderef=sub {Carp::croak("The '$name' test requires a single argument")unless @_==1;my$comparator=Number::Compare->new(shift);return sub {return$comparator->((stat($_))[$i])}};__PACKAGE__->add_helper($name,$coderef)}my%vcs_rules=(skip_cvs=>sub {return Path::Iterator::Rule->new->skip_dirs('CVS')->not_name(qr/\.\#$/)},skip_rcs=>sub {return Path::Iterator::Rule->new->skip_dirs('RCS')->not_name(qr/,v$/)},skip_git=>sub {return Path::Iterator::Rule->new->skip_dirs('.git')},skip_svn=>sub {return Path::Iterator::Rule->new->skip_dirs(($^O eq 'MSWin32')? ('.svn','_svn'): ('.svn'))},skip_bzr=>sub {return Path::Iterator::Rule->new->skip_dirs('.bzr')},skip_hg=>sub {return Path::Iterator::Rule->new->skip_dirs('.hg')},skip_darcs=>sub {return Path::Iterator::Rule->new->skip_dirs('_darcs')},skip_vcs=>sub {return Path::Iterator::Rule->new->skip_dirs(qw/.git .bzr .hg _darcs CVS RCS/)->skip_svn->not_name(qr/\.\#$/,qr/,v$/)},);while (my ($name,$coderef)=each%vcs_rules){__PACKAGE__->add_helper($name,$coderef,1)}my%perl_rules=(perl_module=>sub {return Path::Iterator::Rule->new->file->name('*.pm')},perl_pod=>sub {return Path::Iterator::Rule->new->file->name('*.pod')},perl_test=>sub {return Path::Iterator::Rule->new->file->name('*.t')},perl_installer=>sub {return Path::Iterator::Rule->new->file->name('Makefile.PL','Build.PL')},perl_script=>sub {return Path::Iterator::Rule->new->file->or(Path::Iterator::Rule->new->name('*.pl'),Path::Iterator::Rule->new->shebang(qr/#!.*\bperl\b/),)},perl_file=>sub {return Path::Iterator::Rule->new->or(Path::Iterator::Rule->new->perl_module,Path::Iterator::Rule->new->perl_pod,Path::Iterator::Rule->new->perl_test,Path::Iterator::Rule->new->perl_installer,Path::Iterator::Rule->new->perl_script,)},);while (my ($name,$coderef)=each%perl_rules){__PACKAGE__->add_helper($name,$coderef)}1;
+ use 5.008001;use strict;use warnings;package Path::Iterator::Rule;our$VERSION='1.015';use warnings::register;use if $] ge '5.010000','re','regexp_pattern';use Carp ();use File::Basename ();use File::Spec ();use List::Util ();use Number::Compare 0.02;use Scalar::Util ();use Text::Glob ();use Try::Tiny;sub new {my$class=shift;$class=ref$class if ref$class;return bless {rules=>[]},$class}sub clone {my$self=shift;return bless _my_clone({%$self}),ref$self}sub _my_clone {my$d=shift;if (ref$d eq 'HASH'){return {map {;my$v=$d->{$_};$_=>(ref($v)? _my_clone($v): $v)}keys %$d }}elsif (ref$d eq 'ARRAY'){return [map {ref($_)? _my_clone($_): $_}@$d ]}else {return$d}}sub add_helper {my ($class,$name,$coderef,$skip_negation)=@_;$class=ref$class if ref$class;if (!$class->can($name)){no strict 'refs';*$name=sub {my$self=shift;my$rule=$coderef->(@_);$self->and($rule)};if (!$skip_negation){*{"not_$name"}=sub {my$self=shift;my$rule=$coderef->(@_);$self->not($rule)}}}else {Carp::croak("Can't add rule '$name' because it conflicts with an existing method")}}sub _objectify {my ($self,$path)=@_;return "$path"}sub _defaults {return (_stringify=>1,follow_symlinks=>1,depthfirst=>0,sorted=>1,loop_safe=>($^O eq 'MSWin32' ? 0 : 1),error_handler=>sub {die sprintf("%s: %s",@_)},visitor=>undef,)}sub _fast_defaults {return (_stringify=>1,follow_symlinks=>1,depthfirst=>-1,sorted=>0,loop_safe=>0,error_handler=>undef,visitor=>undef,)}sub iter {my$self=shift;$self->_iter({$self->_defaults },@_)}sub iter_fast {my$self=shift;$self->_iter({$self->_fast_defaults },@_)}sub _iter {my$self=shift;my$defaults=shift;my$args=ref($_[0])&&!Scalar::Util::blessed($_[0])? shift : ref($_[-1])&&!Scalar::Util::blessed($_[-1])? pop : {};my%opts=(%$defaults,%$args);my$opt_stringify=$opts{_stringify};my$opt_depthfirst=$opts{depthfirst};my$opt_follow_symlinks=$opts{follow_symlinks};my$opt_sorted=$opts{sorted};my$opt_loop_safe=$opts{loop_safe};my$opt_error_handler=$opts{error_handler};my$opt_relative=$opts{relative};my$opt_visitor=$opts{visitor};my$has_rules=@{$self->{rules}};my$stash={};my$opt_report_symlinks=defined($opts{report_symlinks})? $opts{report_symlinks}: $opts{follow_symlinks};my$can_children=$self->can("_children");my@queue=map {my$i=$self->_objectify($_);($i,File::Basename::basename("$_"),0,$i)}@_ ? @_ : '.';return sub {LOOP: {my ($item,$base,$depth,$origin)=splice(@queue,0,4);return unless$item;if (ref$item eq 'CODE'){unshift@queue,$item->();redo LOOP}return$item->[0]if ref$item eq 'ARRAY';my$string_item=$opt_stringify ? "$item" : $item;my ($interest,$prune)=(1,0);if (-l $string_item){$prune=1 if!$opt_follow_symlinks;redo LOOP if!$opt_report_symlinks}if ($has_rules){local $_=$item;$stash->{_depth}=$depth;if ($opt_error_handler){$interest=try {$self->test($item,$base,$stash)}catch {$opt_error_handler->($item,$_)}}else {$interest=$self->test($item,$base,$stash)}if (ref$interest eq 'SCALAR'){$prune=1;$interest=$$interest}}if ($opt_visitor && $interest){local $_=$item;$stash->{_depth}=$depth;$opt_visitor->($item,$base,$stash)}if ((-d $string_item)&& (!$prune)&& (!$opt_loop_safe || $self->_is_unique($string_item,$stash))){if (!-r $string_item){warnings::warnif("Directory '$string_item' is not readable. Skipping it")}else {my$depth_p1=$depth + 1;my$next;if ($can_children){$next=sub {my@paths=$can_children->($self,$item);if ($opt_sorted){@paths=sort {"$a->[0]" cmp "$b->[0]"}@paths}map {($_->[1],$_->[0],$depth_p1,$origin)}@paths}}else {$next=sub {my$dh;if (!opendir($dh,$string_item)){warnings::warnif("Directory '$string_item' is not readable. Skipping it");return}if ($opt_sorted){map {("$string_item/$_",$_,$depth_p1,$origin)}sort {$a cmp $b}grep {$_ ne "." && $_ ne ".."}readdir$dh}else {map {("$string_item/$_",$_,$depth_p1,$origin)}grep {$_ ne "." && $_ ne ".."}readdir$dh}}}if ($opt_depthfirst){unshift@queue,[($opt_relative ? $self->_objectify(File::Spec->abs2rel($string_item,$origin)): $item)],undef,undef,undef if$interest && $opt_depthfirst > 0;unshift@queue,$next,undef,undef,undef;redo LOOP if$opt_depthfirst > 0}else {push@queue,$next,undef,undef,undef}}}return ($opt_relative ? $self->_objectify(File::Spec->abs2rel($string_item,$origin)): $item)if$interest;redo LOOP}}}sub all {my$self=shift;return$self->_all($self->iter(@_))}sub all_fast {my$self=shift;return$self->_all($self->iter_fast(@_))}sub _all {my$self=shift;my$iter=shift;if (wantarray){my@results;while (defined(my$item=$iter->())){push@results,$item}return@results}elsif (defined wantarray){my$count=0;$count++ while defined$iter->();return$count}else {1 while defined$iter->()}}sub and {my$self=shift;push @{$self->{rules}},$self->_rulify(@_);return$self}sub or {my$self=shift;my@rules=$self->_rulify(@_);my$coderef=sub {my ($result,$prune);for my$rule (@rules){$result=$rule->(@_);$prune ||= ref($result)eq 'SCALAR';$result=$$result if ref($result)eq 'SCALAR';return ($prune ? \1 : 1)if$result}return ($prune ? \$result : $result)};return$self->and($coderef)}sub not {my$self=shift;my$obj=$self->new->and(@_);my$coderef=sub {my$result=$obj->test(@_);return ref($result)? \!$$result :!$result};return$self->and($coderef)}sub skip {my$self=shift;my@rules=@_;my$obj=$self->new->or(@rules);my$coderef=sub {my$result=$obj->test(@_);my ($prune,$interest);if (ref($result)eq 'SCALAR'){$prune=1;$interest=0}else {$prune=$result;$interest=!$result}return$prune ? \$interest : $interest};return$self->and($coderef)}sub test {my ($self,$item,$base,$stash)=@_;my ($result,$prune);for my$rule (@{$self->{rules}}){$result=$rule->($item,$base,$stash)|| 0;if (!ref($result)&& $result eq '0 but true'){Carp::croak("0 but true no longer supported by custom rules")}$prune ||= ref($result)eq 'SCALAR';$result=$$result if ref($result)eq 'SCALAR';return ($prune ? \0 : 0)if!$result}return ($prune ? \1 : 1)}sub _rulify {my ($self,@args)=@_;my@rules;for my$arg (@args){my$rule;if (Scalar::Util::blessed($arg)&& $arg->isa("Path::Iterator::Rule")){$rule=sub {$arg->test(@_)}}elsif (ref($arg)eq 'CODE'){$rule=$arg}else {Carp::croak("Rules must be coderef or Path::Iterator::Rule")}push@rules,$rule}return@rules}sub _is_unique {my ($self,$string_item,$stash)=@_;my$unique_id;my@st=eval {stat$string_item};@st=eval {lstat$string_item}unless@st;if (@st){$unique_id=join(",",$st[0],$st[1])}else {my$type=-d $string_item ? 'directory' : 'file';warnings::warnif("Could not stat $type '$string_item'");$unique_id=$string_item}return!$stash->{_seen}{$unique_id}++}sub _regexify {my ($re,$add)=@_;$add ||= '';my$new=ref($re)eq 'Regexp' ? $re : Text::Glob::glob_to_regex($re);return$new unless$add;my ($pattern,$flags)=_split_re($new);my$new_flags=$add ? _reflag($flags,$add): "";return qr/$new_flags$pattern/}sub _split_re {my$value=shift;if ($] ge 5.010){return re::regexp_pattern($value)}else {$value =~ s/^\(\?\^?//;$value =~ s/\)$//;my ($opt,$re)=split(/:/,$value,2);$opt =~ s/\-\w+$//;return ($re,$opt)}}sub _reflag {my ($orig,$add)=@_;$orig ||= "";if ($] >= 5.014){return "(?^$orig$add)"}else {my ($pos,$neg)=split /-/,$orig;$pos ||= "";$neg ||= "";$neg =~ s/i//;$neg="-$neg" if length$neg;return "(?$add$pos$neg)"}}my%simple_helpers=(directory=>sub {-d $_},dangling=>sub {-l $_ &&!stat $_},);while (my ($k,$v)=each%simple_helpers){__PACKAGE__->add_helper($k,sub {return$v})}sub _generate_name_matcher {my (@patterns)=@_;if (@patterns > 1){return sub {my$name="$_[1]";return (List::Util::first {$name =~ $_}@patterns)? 1 : 0}}else {my$pattern=$patterns[0];return sub {my$name="$_[1]";return$name =~ $pattern ? 1 : 0}}}my%complex_helpers=(name=>sub {Carp::croak("No patterns provided to 'name'")unless @_;_generate_name_matcher(map {_regexify($_)}@_)},iname=>sub {Carp::croak("No patterns provided to 'iname'")unless @_;_generate_name_matcher(map {_regexify($_,"i")}@_)},min_depth=>sub {Carp::croak("No depth argument given to 'min_depth'")unless @_;my$min_depth=0+ shift;return sub {my ($f,$b,$stash)=@_;return$stash->{_depth}>= $min_depth}},max_depth=>sub {Carp::croak("No depth argument given to 'max_depth'")unless @_;my$max_depth=0+ shift;return sub {my ($f,$b,$stash)=@_;return 1 if$stash->{_depth}< $max_depth;return \1 if$stash->{_depth}==$max_depth;return \0}},shebang=>sub {Carp::croak("No patterns provided to 'shebang'")unless @_;my@patterns=map {_regexify($_)}@_;return sub {my$f=shift;return unless!-d $f;open my$fh,"<",$f;my$shebang=<$fh>;return unless defined$shebang;return (List::Util::first {$shebang =~ $_}@patterns)? 1 : 0}},contents_match=>sub {my@regexp=@_;my$filter=':encoding(UTF-8)';$filter=shift@regexp unless ref$regexp[0];return sub {my$f=shift;return unless!-d $f;my$contents=do {local $/=undef;open my$fh,"<$filter",$f;<$fh>};for my$re (@regexp){return 1 if$contents =~ $re}return 0}},line_match=>sub {my@regexp=@_;my$filter=':encoding(UTF-8)';$filter=shift@regexp unless ref$regexp[0];return sub {my$f=shift;return unless!-d $f;open my$fh,"<$filter",$f;while (my$line=<$fh>){for my$re (@regexp){return 1 if$line =~ $re}}return 0}},);while (my ($k,$v)=each%complex_helpers){__PACKAGE__->add_helper($k,$v)}__PACKAGE__->add_helper(skip_dirs=>sub {Carp::croak("No patterns provided to 'skip_dirs'")unless @_;my$name_check=Path::Iterator::Rule->new->name(@_);return sub {return \0 if -d $_[0]&& $name_check->test(@_);return 1}}=>1);__PACKAGE__->add_helper(skip_subdirs=>sub {Carp::croak("No patterns provided to 'skip_subdirs'")unless @_;my$name_check=Path::Iterator::Rule->new->name(@_);return sub {my ($f,$b,$stash)=@_;return \0 if -d $f && $stash->{_depth}&& $name_check->test(@_);return 1}}=>1);my%X_tests=(-r=>readable=>-R=>r_readable=>-w=>writeable=>-W=>r_writeable=>-w=>writable=>-W=>r_writable=>-x=>executable=>-X=>r_executable=>-o=>owned=>-O=>r_owned=>-e=>exists=>-f=>file=>-z=>empty=>-d=>dir=>-s=>nonempty=>-l=>symlink=>=>-p=>fifo=>-u=>setuid=>-S=>socket=>-g=>setgid=>-b=>block=>-k=>sticky=>-c=>character=>=>-t=>tty=>-T=>ascii=>-B=>binary=>);while (my ($op,$name)=each%X_tests){my$coderef=eval "sub { $op \$_ }";__PACKAGE__->add_helper($name,sub {return$coderef})}my%time_tests=(-A=>accessed=>-M=>modified=>-C=>changed=>);while (my ($op,$name)=each%time_tests){my$filetest=eval "sub { $op \$_ }";my$coderef=sub {Carp::croak("The '$name' test requires a single argument")unless @_==1;my$comparator=Number::Compare->new(shift);return sub {return$comparator->($filetest->())}};__PACKAGE__->add_helper($name,$coderef)}my@stat_tests=qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks);for my$i (0 .. $#stat_tests){my$name=$stat_tests[$i];my$coderef=sub {Carp::croak("The '$name' test requires a single argument")unless @_==1;my$comparator=Number::Compare->new(shift);return sub {return$comparator->((stat($_))[$i])}};__PACKAGE__->add_helper($name,$coderef)}my%vcs_rules=(skip_cvs=>sub {return Path::Iterator::Rule->new->skip_dirs('CVS')->not_name(qr/\.\#$/)},skip_rcs=>sub {return Path::Iterator::Rule->new->skip_dirs('RCS')->not_name(qr/,v$/)},skip_git=>sub {return Path::Iterator::Rule->new->skip_dirs('.git')},skip_svn=>sub {return Path::Iterator::Rule->new->skip_dirs(($^O eq 'MSWin32')? ('.svn','_svn'): ('.svn'))},skip_bzr=>sub {return Path::Iterator::Rule->new->skip_dirs('.bzr')},skip_hg=>sub {return Path::Iterator::Rule->new->skip_dirs('.hg')},skip_darcs=>sub {return Path::Iterator::Rule->new->skip_dirs('_darcs')},skip_vcs=>sub {return Path::Iterator::Rule->new->skip_dirs(qw/.git .bzr .hg _darcs CVS RCS/)->skip_svn->not_name(qr/\.\#$/,qr/,v$/)},);while (my ($name,$coderef)=each%vcs_rules){__PACKAGE__->add_helper($name,$coderef,1)}my%perl_rules=(perl_module=>sub {return Path::Iterator::Rule->new->file->name('*.pm')},perl_pod=>sub {return Path::Iterator::Rule->new->file->name('*.pod')},perl_test=>sub {return Path::Iterator::Rule->new->file->name('*.t')},perl_installer=>sub {return Path::Iterator::Rule->new->file->name('Makefile.PL','Build.PL')},perl_script=>sub {return Path::Iterator::Rule->new->file->or(Path::Iterator::Rule->new->name('*.pl'),Path::Iterator::Rule->new->shebang(qr/#!.*\bperl\b/),)},perl_file=>sub {return Path::Iterator::Rule->new->or(Path::Iterator::Rule->new->perl_module,Path::Iterator::Rule->new->perl_pod,Path::Iterator::Rule->new->perl_test,Path::Iterator::Rule->new->perl_installer,Path::Iterator::Rule->new->perl_script,)},);while (my ($name,$coderef)=each%perl_rules){__PACKAGE__->add_helper($name,$coderef)}1;
PATH_ITERATOR_RULE
$fatpacked{"Proc/Find/Parents.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PROC_FIND_PARENTS';
SUB_EXPORTER_PROGRESSIVE
$fatpacked{"Text/CSV.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_CSV';
- 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;
+ 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.01';$DEBUG=0}my$Module_XS='Text::CSV_XS';my$Module_PP='Text::CSV_PP';my$XS_Version='1.46';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;
TEXT_CSV
$fatpacked{"Text/CSV_PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_CSV_PP';
- 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*
+ package Text::CSV_PP;require 5.006001;use strict;use Exporter ();use vars qw($VERSION @ISA @EXPORT_OK);use Carp;$VERSION='2.01';@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",5001=>"PRM - The result does not match the output to append to",5002=>"PRM - Unsupported output",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,skip_empty_rows=>0,undef_str=>undef,comment_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,_FORMULA_CB=>undef,ENCODING=>undef,);my%attr_alias=(quote_always=>"always_quote",verbose_diag=>"diag_verbose",quote_null=>"escape_null",escape=>"escape_char",comment=>"comment_str",);my$last_new_error=Text::CSV_PP->SetDiag(0);my$ebcdic=ord("A")==0xC1;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};my$attr_formula=delete$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});defined$attr_formula and $self->{formula}=_supported_formula($self,$attr_formula);$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,skip_empty_rows=>43,undef_str=>46,comment_str=>54,types=>62,);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 and 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 skip_empty_rows {my$self=shift;@_ and $self->_set_attr_X ("skip_empty_rows",shift);$self->{skip_empty_rows}}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;if ($self && $f && ref$f && ref$f eq "CODE"){$self->{_FORMULA_CB}=$f;return 6}$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 : $f =~ m/^(?: 6 | cb )$/xi ? 6 : 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));$self->{formula}==6 or $self->{_FORMULA_CB}=undef;[qw(none die croak diag empty undef cb)]->[_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 comment_str {my$self=shift;if (@_){my$v=shift;$self->{comment_str}=defined$v ? "$v" : undef;$self->_cache_set ($_cache_id{comment_str},$self->{comment_str})}$self->{comment_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;$self->_cache_set ($_cache_id{'types'},$self->{'_types'})}else {delete$self->{'types'};delete$self->{'_types'};$self->_cache_set ($_cache_id{'types'},undef);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}$self->{diag_verbose}and $self->{_ERROR_INPUT}and $msg .= "$self->{_ERROR_INPUT}'\n".(" " x ($diag[2]- 1))."^\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}=$enc ? uc$enc : undef;$hdr eq "" and croak ($self->SetDiag (1010));if ($enc){$ebcdic && $enc eq "utf-ebcdic" and $enc="";if ($enc =~ m/([13]).le$/){my$l=0 + $1;my$x;$hdr .= "\0" x $l;read$fh,$x,$l}if ($enc){if ($enc ne "utf-8"){require Encode;$hdr=Encode::decode ($enc,$hdr)}binmode$fh,":encoding($enc)"}}}my ($ahead,$eol);if ($hdr and $hdr =~ s/\Asep=(\S)([\r\n]+)//i){$self->sep ($1);length$hdr or $hdr=<$fh>}if ($hdr =~ s/^([^\r\n]+)([\r\n]+)([^\r\n].+)\z/$1/s){$eol=$2;$ahead=$3}my$hr=\$hdr;open my$h,"<",$hr or croak ($self->SetDiag (1010));my$row=$self->getline ($h)or croak;close$h;if ($args{'munge_column_names'}eq "lc"){$_=lc for @{$row}}elsif ($args{'munge_column_names'}eq "uc"){$_=uc for @{$row}}elsif ($args{'munge_column_names'}eq "db"){for (@{$row}){s/\W+/_/g;s/^_+//;$_=lc}}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*
\x23 ? \s* # optional leading #
( row | col | cell ) \s* =
( $qc # for row and col
) \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{
^ \s* ([0-9]+ ) \s* , \s* ([0-9]+ ) \s*
(?: - \s* ([0-9]+ | \*) \s* , \s* ([0-9]+ | \*) \s* )?
- $}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]=~ /^(?:
+ $}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,"");my$stack=$enc =~ s/(:\w.*)// ? $1 : "";$enc =~ m/^[-\w.]+$/ and $enc=":encoding($enc)";$enc .= $stack;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 ("ARRAY" eq ref$out or "HASH" eq ref$out)){delete$attr{out};$sink=1}elsif ((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){if ($enc){binmode$fh,$enc;my$fn=fileno$fh}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;my$form=delete$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;defined$form and $csv->formula ($form);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}{qw(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)}}if ($c->{sink}){my$ro=ref$c->{out}or return;$ro eq "SCALAR" && ${$c->{out}}eq "skip" and return;$ro eq ref$ref or croak ($csv->_SetDiagInfo (5001,"Output type mismatch"));if ($ro eq "ARRAY"){if (@{$c->{out}}and @$ref and ref$c->{out}[0]eq ref$ref->[0]){push @{$c->{out}}=>@$ref;return$c->{out}}croak ($csv->_SetDiagInfo (5001,"Output type mismatch"))}if ($ro eq "HASH"){@{$c->{out}}{keys %{$ref}}=values %{$ref};return$c->{out}}croak ($csv->_SetDiagInfo (5002,"Unsupported output type"))}defined wantarray or return csv (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->{comment_str}){$ctx->{comment_str}=$self->{comment_str}}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 skip_empty_rows/){$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 skip_empty_rows 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})}if ($cache->{types_len}){$self->__cache_show_str(types=>$cache->{types_len},$cache->{types})}else {$self->__cache_show_str(types=>0,"")}if ($cache->{bptr}){$self->__cache_show_str(bptr=>length($cache->{bptr}),$cache->{bptr})}if ($cache->{tmp}){$self->__cache_show_str(tmp=>length($cache->{tmp}),$cache->{tmp})}}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}if ($fa==6){if (ref$self->{_FORMULA_CB}eq 'CODE'){local $_=$value;return$self->{_FORMULA_CB}->()}}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$spl=-1;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;$spl++;if (defined$hit and $hit ne ''){if ($waitingForField){if (!$spl && $ctx->{comment_str}&& $ctx->{tmp}=~ /\A\Q$ctx->{comment_str}/){$ctx->{used}=$ctx->{size};next LOOP}$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,$src);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,$src)}}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,$src);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}){if ($c3 eq "\015"){$self->__set_eol_is_cr($ctx);goto EOLX}if ($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,$src);$$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,$src);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,$src);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 ($fnum==1 && $ctx->{flag}==0 && (!$v_ref || $$v_ref eq '')&& $ctx->{skip_empty_rows}){$ctx->{fld_idx}=0;$c=$self->__get($ctx,$src);if (!defined$c){$v_ref=undef;$waitingForField=0;last LOOP}goto RESTART}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){if ($ctx->{eol_is_cr}){$c="\012";goto EOLX}my$c2=$self->__get($ctx,$src);if (!defined$c2){$c=undef;last unless$seenSomething;goto RESTART}if ($c2 eq "\012"){$c=$c2;goto EOLX}if ($ctx->{useIO}and!$ctx->{eol_len}){if ($c2 eq "\012"){$self->__set_eol_is_cr($ctx);goto EOLX}$waitingForField=0;if ($c2 !~ /[^\x09\x20-\x7E]/){$self->__set_eol_is_cr($ctx);$ctx->{used}--;$ctx->{has_ahead}=1;if ($fnum==1 && $ctx->{flag}==0 && (!$v_ref or $$v_ref eq '')&& $ctx->{skip_empty_rows}){$ctx->{fld_idx}=0;$c=$self->__get($ctx,$src);if (!defined$c){$v_ref=undef;$waitingForField=0;last LOOP}$$v_ref=$c2;goto RESTART}$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}){goto EOLX}my$c2=$self->__get($ctx,$src);if (defined$c2 and $c2 eq "\012"){goto EOLX}if ($ctx->{useIO}and!$ctx->{eol_len}){if ($c2 !~ /[^\x09\x20-\x7E]/ or $c2 eq "\015"){$self->__set_eol_is_cr($ctx);$ctx->{used}--;$ctx->{has_ahead}=1;if ($fnum==1 && $ctx->{flag}==0 && (!$v_ref or $$v_ref eq '')&& $ctx->{skip_empty_rows}){$ctx->{fld_idx}=0;$c=$self->__get($ctx,$src);if (!defined$c){$v_ref=undef;$waitingForField=0;last LOOP}goto RESTART}$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 (!$spl && $ctx->{comment_str}&& $ctx->{tmp}=~ /\A$ctx->{comment_str}/){$ctx->{used}=$ctx->{size};next LOOP}if ($ctx->{allow_whitespace}and $self->__is_whitespace($ctx,$c)){do {$c=$self->__get($ctx,$src);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]/){last if$ctx->{useIO}&&!defined$c;$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,$src)=@_;return unless defined$ctx->{used};if ($ctx->{used}>= $ctx->{size}){if ($self->__get_from_src($ctx,$src)){return$self->__get($ctx,$src)}return}my$pos=pos($ctx->{tmp});if ($ctx->{tmp}=~ /\G($ctx->{_re}|.)/gs){my$c=$1;if ($c =~ /[^\x09\012\015\x20-\x7e]/){$ctx->{flag}|= IS_BINARY}$ctx->{used}=pos($ctx->{tmp});return$c}else {if ($self->__get_from_src($ctx,$src)){return$self->__get($ctx,$src)}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]=~ /^(?:
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
TEXT_GLOB
$fatpacked{"Text/Table/Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_TABLE_ANY';
- 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;
+ package Text::Table::Any;use 5.010001;use strict;use warnings;use Exporter qw(import);our@EXPORT_OK=qw(generate_table);our$AUTHORITY='cpan:PERLANCAR';our$DATE='2022-01-23';our$DIST='Text-Table-Any';our$VERSION='0.111';our%BACKEND_FEATURES=("Term::Table"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},"Term::TablePrint"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},"Text::ANSITable"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,},"Text::ASCIITable"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},"Text::FormatTable"=>{rows=>1,header_row=>0,separate_rows=>0,caption=>0,},"Text::MarkdownTable"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},"Text::Table"=>{rows=>1,header_row=>0,separate_rows=>0,caption=>0,},"Text::Table::ASV"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::CSV"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::HTML"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>1,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::HTML::DataTables"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>1,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::LTSV"=>{rows=>1,header_row=>0,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::Manifold"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},"Text::Table::More"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::Org"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::Paragraph"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::Sprintf"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TickitWidget"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::Tiny"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TinyBorderStyle"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TinyColor"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TinyColorWide"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TinyWide"=>{rows=>1,header_row=>1,separate_rows=>1,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::TSV"=>{rows=>1,header_row=>0,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::Table::XLSX"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,backend_opts=>1,backend_opts_note=>"Backend-specific options (backend_opts) will be passed to table() or generate_table() directly",},"Text::TabularDisplay"=>{rows=>1,header_row=>0,separate_rows=>0,caption=>0,},"Text::UnicodeBox::Table"=>{rows=>1,header_row=>1,separate_rows=>0,caption=>0,},);our@BACKENDS=sort keys%BACKEND_FEATURES;sub _encode {my$val=shift;$val =~ s/([\\"])/\\$1/g;"\"$val\""}sub backends {@BACKENDS}sub generate_table {my%params=@_;my$rows=$params{rows}or die "Must provide rows!";my$backend=$params{backend}|| 'Text::Table::Sprintf';my$header_row=$params{header_row}// 1;my$separate_rows=$params{separate_rows}// 0;if ($backend eq 'Term::Table'){require Term::Table;my ($header,$data_rows);if ($header_row){$header=$rows->[0];$data_rows=[@{$rows}[1 .. $#{$rows}]]}else {$header=[map {"col$_"}0..$#{$rows->[0]}];$data_rows=$rows}my$table=Term::Table->new(header=>$header,rows=>$data_rows,);return join("\n",$table->render)."\n"}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)}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=>'ASCII::SingleLine',);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}$t->show_row_separator(1)if$separate_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::Table::ASV'){require Text::Table::ASV;return Text::Table::ASV::table(rows=>$rows,header_row=>$header_row,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::CSV'){require Text::Table::CSV;return Text::Table::CSV::table(rows=>$rows,header_row=>$header_row,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::HTML'){require Text::Table::HTML;return Text::Table::HTML::table(rows=>$rows,header_row=>$header_row,(caption=>$params{caption})x!!defined($params{caption}),defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::HTML::DataTables'){require Text::Table::HTML::DataTables;return Text::Table::HTML::DataTables::table(rows=>$rows,header_row=>$header_row,(caption=>$params{caption})x!!defined($params{caption}),defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::LTSV'){require Text::Table::LTSV;return Text::Table::LTSV::table(rows=>$rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::Manifold'){require Text::Table::Manifold;my$t=Text::Table::Manifold->new;if ($header_row){$t->headers($rows->[0]);$t->data([@{$rows}[1 .. $#{$rows}]])}else {$t->headers([map {"col$_"}0..$#{$rows->[0]}]);$t->data($rows)}return join("\n",@{$t->render(padding=>1)})."\n"}elsif ($backend eq 'Text::Table::More'){require Text::Table::More;return Text::Table::More::generate_table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::Org'){require Text::Table::Org;return Text::Table::Org::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{caption})? (caption=>$params{caption}): (),defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::Paragraph'){require Text::Table::Paragraph;return Text::Table::Paragraph::table(rows=>$rows,header_row=>$header_row,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::Sprintf'){require Text::Table::Sprintf;return Text::Table::Sprintf::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::TickitWidget'){require Text::Table::TickitWidget;return Text::Table::TickitWidget::table(rows=>$rows,header_row=>$header_row,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::Tiny'){require Text::Table::Tiny;return Text::Table::Tiny::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::TinyBorderStyle'){require Text::Table::TinyBorderStyle;return Text::Table::TinyBorderStyle::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::TinyColor'){require Text::Table::TinyColor;return Text::Table::TinyColor::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::TinyColorWide'){require Text::Table::TinyColorWide;return Text::Table::TinyColorWide::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::TinyWide'){require Text::Table::TinyWide;return Text::Table::TinyWide::table(rows=>$rows,header_row=>$header_row,separate_rows=>$separate_rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)."\n"}elsif ($backend eq 'Text::Table::TSV'){require Text::Table::TSV;return Text::Table::TSV::table(rows=>$rows,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}elsif ($backend eq 'Text::Table::XLSX'){require Text::Table::XLSX;return Text::Table::XLSX::table(rows=>$rows,header_row=>$header_row,defined($params{backend_opts})? %{$params{backend_opts}}: (),)}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::UnicodeBox::Table'){require Text::UnicodeBox::Table;my$t=Text::UnicodeBox::Table->new;if ($header_row){$t->add_header(@{$rows->[0]});$t->add_row(@{$rows->[$_]})for 1 .. $#{$rows}}else {$t->add_header(map {"col$_"}0..$#{$rows->[0]});$t->add_row(@{$rows->[$_]})for 0 .. $#{$rows}}return$t->render}else {die "Unknown backend '$backend'"}}{no strict 'refs';no warnings 'once';*table=\&generate_table}1;
TEXT_TABLE_ANY
-$fatpacked{"Text/Table/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_TABLE_TINY';
- use 5.006;use strict;use warnings;package Text::Table::Tiny;$Text::Table::Tiny::VERSION='0.05';use parent 'Exporter';use List::Util qw();use Carp qw/croak/;our@EXPORT_OK=qw/generate_table/;our$COLUMN_SEPARATOR='|';our$ROW_SEPARATOR='-';our$CORNER_MARKER='+';our$HEADER_ROW_SEPARATOR='=';our$HEADER_CORNER_MARKER='O';sub generate_table {my%params=@_;my$rows=$params{rows}or croak "generate_table(): you must pass the 'rows' argument!";my$widths=_maxwidths($rows);my$max_index=_max_array_index($rows);my$format=_get_format($widths);my$row_sep=_get_row_separator($widths);my$head_row_sep=_get_header_row_separator($widths);my@table;push(@table,$row_sep)unless$params{top_and_tail};my$data_begins=0;if ($params{header_row}){my$header_row=$rows->[0];$data_begins++;push@table,sprintf($format,map {defined($header_row->[$_])? $header_row->[$_]: ''}(0..$max_index));push@table,$params{separate_rows}? $head_row_sep : $row_sep}my$row_number=0;my$last_line_number=int(@$rows);$last_line_number-- if$params{header_row};for my$row (@{$rows}[$data_begins..$#$rows]){$row_number++;push(@table,sprintf($format,map {defined($row->[$_])? $row->[$_]: ''}(0..$max_index)));push(@table,$row_sep)if$params{separate_rows}&& (!$params{top_and_tail}|| $row_number < $last_line_number)}push(@table,$row_sep)unless$params{separate_rows}|| $params{top_and_tail};return join("\n",grep {$_}@table)}sub _maxwidths {my$rows=shift;my$max_index=_max_array_index($rows);my$widths=[];for my$i (0..$max_index){my$max=List::Util::max(map {defined $$_[$i]? length($$_[$i]): 0}@$rows);push @$widths,$max}return$widths}sub _max_array_index {my$rows=shift;return List::Util::max(map {$#$_}@$rows)}sub _get_format {my$widths=shift;return "$COLUMN_SEPARATOR ".join(" $COLUMN_SEPARATOR ",map {"%-${_}s"}@$widths)." $COLUMN_SEPARATOR"}sub _get_row_separator {my$widths=shift;return "$CORNER_MARKER$ROW_SEPARATOR".join("$ROW_SEPARATOR$CORNER_MARKER$ROW_SEPARATOR",map {$ROW_SEPARATOR x $_}@$widths)."$ROW_SEPARATOR$CORNER_MARKER"}sub _get_header_row_separator {my$widths=shift;return "$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR".join("$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER$HEADER_ROW_SEPARATOR",map {$HEADER_ROW_SEPARATOR x $_}@$widths)."$HEADER_ROW_SEPARATOR$HEADER_CORNER_MARKER"}*table=\&generate_table;1;
-TEXT_TABLE_TINY
+$fatpacked{"Text/Table/Sprintf.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_TABLE_SPRINTF';
+ package Text::Table::Sprintf;our$AUTHORITY='cpan:PERLANCAR';our$DATE='2022-01-07';our$DIST='Text-Table-Sprintf';our$VERSION='0.006';our%FEATURES=(set_v=>{TextTable=>1,},features=>{TextTable=>{can_align_cell_containing_wide_character=>0,can_align_cell_containing_color_code=>0,can_align_cell_containing_newline=>0,can_use_box_character=>0,can_customize_border=>0,can_halign=>0,can_halign_individual_row=>0,can_halign_individual_column=>0,can_halign_individual_cell=>0,can_valign=>0,can_valign_individual_row=>0,can_valign_individual_column=>0,can_valign_individual_cell=>0,can_rowspan=>0,can_colspan=>0,can_color=>0,can_color_theme=>0,can_set_cell_height=>0,can_set_cell_height_of_individual_row=>0,can_set_cell_width=>0,can_set_cell_width_of_individual_column=>0,speed=>'fast',can_hpad=>0,can_hpad_individual_row=>0,can_hpad_individual_column=>0,can_hpad_individual_cell=>0,can_vpad=>0,can_vpad_individual_row=>0,can_vpad_individual_column=>0,can_vpad_individual_cell=>0,},},);sub table {my%params=@_;my$rows=$params{rows}or die "Must provide rows!";return "" unless @$rows;my@widths;for my$row (@$rows){for (0..$#{$row}){my$len=length$row->[$_];$widths[$_]=$len if!defined$widths[$_]|| $widths[$_]< $len}}my$rowfmt=join("",(map {($_ ? "" : "|")." %-$widths[$_]s |"}0..$#widths),"\n");my$line=join("",(map {($_ ? "" : "+").("-" x ($widths[$_]+2))."+"}0..$#widths),"\n");my$tblfmt;if ($params{header_row}){$tblfmt=join("",$line,$rowfmt,$line,(map {$rowfmt .($params{separate_rows}&& $_ < $#{$rows}? $line : '')}1..@$rows-1),$line,)}else {$tblfmt=join("",$line,(map {$rowfmt .($params{separate_rows}&& $_ < $#{$rows}? $line : '')}1..@$rows),$line,)}sprintf$tblfmt,map {@$_}@$rows}*generate_table=\&table;1;
+TEXT_TABLE_SPRINTF
$fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
- 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__
+ package Try::Tiny;use 5.006;our$VERSION='0.31';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__
TRY_TINY
$fatpacked{"YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML';
use GraphQL::Client::CLI;
-our $VERSION = '0.604'; # VERSION
+our $VERSION = '0.605'; # VERSION
GraphQL::Client::CLI->main(@ARGV);
=head1 VERSION
-version 0.604
+version 0.605
=head1 SYNOPSIS
=head1 AUTHOR
-Charles McGarvey <chazmcgarvey@brokenzipper.com>
+Charles McGarvey <ccm@cpan.org>
+
+=head1 CONTRIBUTOR
+
+=for stopwords jwright
+
+jwright <jwright@ecstuning.com>
=head1 COPYRIGHT AND LICENSE
projects / chaz / graphql-client / commitdiff
