In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/36b1c95c174efe412ba8229cef144b7351e5af27?hp=8c74b41425572faeb638f1269025b59d0785794f>
- Log ----------------------------------------------------------------- commit 36b1c95c174efe412ba8229cef144b7351e5af27 Author: Matthew Horsfall <[email protected]> Date: Sun Nov 17 16:25:57 2013 -0500 Rearrange dump.c to organize docs. Add some perlapi docs for debug methods. M dump.c commit 6f8f9722376cd83238aa5cb1c032a7ae3f9f01f8 Author: Father Chrysostomos <[email protected]> Date: Mon Dec 23 06:02:23 2013 -0800 perldelta: Silence podchecker M pod/perldelta.pod commit ac582d8a6eef12090970aa31d26386d42a944101 Author: Father Chrysostomos <[email protected]> Date: Mon Dec 23 05:57:49 2013 -0800 pp.c: Remove redundant diag_listed_as M pp.c commit a85ce6f00e06e5b8cbd3c9bd115058b4e9b08f8d Author: Daniel Dragan <[email protected]> Date: Sun Dec 22 00:54:14 2013 -0500 test various types of SVs with call_sv call_sv takes RVs, PVs, CVs, GVs, and an immortal. This isn't well documented. CVs and immortals can't, or can't easily be tested from pure perl, so do it from XS. SVt_PVLV with isGV_with_GP is one thing call_sv takes but is not tested by this commit. Part of [perl #120826] . M ext/XS-APItest/APItest.pm M ext/XS-APItest/APItest.xs M ext/XS-APItest/t/call.t commit e0b7b5e2d45f1c3adc7e7f4afb29a4cfa6ca788c Author: Daniel Dragan <[email protected]> Date: Sun Dec 22 01:39:09 2013 -0500 refactor pp_socket, pp_socketpair, pp_bind pp_socket: remove unreachable made by commit 9c9f25b8ce pp_socketpair: increase locality, now gv2/io2 is tested before gv1 is processed, *v1 vars become non-const to avoid large WS changes in opening new scope pp_bind: move op_type's init so it isn't saved by CC across a func call M pp_sys.c commit e8f91c91cc7c3a4a35c08d16f350eabe4852cdf4 Author: Daniel Dragan <[email protected]> Date: Mon Dec 23 02:11:29 2013 -0500 [perl #115736] fix undocumented param from newATTRSUB_flags flags param was poorly designed and didn't have a formal api. Replace it with the bool it really is. See #115736 for details. M embed.fnc M embed.h M gv.c M mathoms.c M op.c M op.h M pod/perldelta.pod M proto.h ----------------------------------------------------------------------- Summary of changes: dump.c | 290 ++++++++++++++++++++++++++-------------------- embed.fnc | 6 +- embed.h | 3 +- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 75 ++++++++++++ ext/XS-APItest/t/call.t | 9 +- gv.c | 4 +- mathoms.c | 2 +- op.c | 12 +- op.h | 3 +- pod/perldelta.pod | 8 +- pp.c | 1 - pp_sys.c | 18 +-- proto.h | 4 +- 14 files changed, 278 insertions(+), 159 deletions(-) diff --git a/dump.c b/dump.c index 409b975..ac46ad8 100644 --- a/dump.c +++ b/dump.c @@ -84,133 +84,6 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, #define append_flags(sv, f, flags) \ S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags)) - - -void -Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) -{ - va_list args; - PERL_ARGS_ASSERT_DUMP_INDENT; - va_start(args, pat); - dump_vindent(level, file, pat, &args); - va_end(args); -} - -void -Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) -{ - dVAR; - PERL_ARGS_ASSERT_DUMP_VINDENT; - PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); - PerlIO_vprintf(file, pat, *args); -} - -void -Perl_dump_all(pTHX) -{ - dump_all_perl(FALSE); -} - -void -Perl_dump_all_perl(pTHX_ bool justperl) -{ - - dVAR; - PerlIO_setlinebuf(Perl_debug_log); - if (PL_main_root) - op_dump(PL_main_root); - dump_packsubs_perl(PL_defstash, justperl); -} - -void -Perl_dump_packsubs(pTHX_ const HV *stash) -{ - PERL_ARGS_ASSERT_DUMP_PACKSUBS; - dump_packsubs_perl(stash, FALSE); -} - -void -Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) -{ - dVAR; - I32 i; - - PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; - - if (!HvARRAY(stash)) - return; - for (i = 0; i <= (I32) HvMAX(stash); i++) { - const HE *entry; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - const GV * const gv = (const GV *)HeVAL(entry); - if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) - continue; - if (GvCVu(gv)) - dump_sub_perl(gv, justperl); - if (GvFORM(gv)) - dump_form(gv); - if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { - const HV * const hv = GvHV(gv); - if (hv && (hv != PL_defstash)) - dump_packsubs_perl(hv, justperl); /* nested package */ - } - } - } -} - -void -Perl_dump_sub(pTHX_ const GV *gv) -{ - PERL_ARGS_ASSERT_DUMP_SUB; - dump_sub_perl(gv, FALSE); -} - -void -Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) -{ - SV * sv; - - PERL_ARGS_ASSERT_DUMP_SUB_PERL; - - if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) - return; - - sv = sv_newmortal(); - gv_fullname3(sv, gv, NULL); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); - if (CvISXSUB(GvCV(gv))) - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", - PTR2UV(CvXSUB(GvCV(gv))), - (int)CvXSUBANY(GvCV(gv)).any_i32); - else if (CvROOT(GvCV(gv))) - op_dump(CvROOT(GvCV(gv))); - else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); -} - -void -Perl_dump_form(pTHX_ const GV *gv) -{ - SV * const sv = sv_newmortal(); - - PERL_ARGS_ASSERT_DUMP_FORM; - - gv_fullname3(sv, gv, NULL); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); - if (CvROOT(GvFORM(gv))) - op_dump(CvROOT(GvFORM(gv))); - else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); -} - -void -Perl_dump_eval(pTHX) -{ - dVAR; - op_dump(PL_eval_root); -} - - /* =for apidoc pv_escape @@ -585,6 +458,151 @@ Perl_sv_peek(pTHX_ SV *sv) return SvPV_nolen(t); } +/* +=head1 Debugging Utilities +*/ + +void +Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) +{ + va_list args; + PERL_ARGS_ASSERT_DUMP_INDENT; + va_start(args, pat); + dump_vindent(level, file, pat, &args); + va_end(args); +} + +void +Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) +{ + dVAR; + PERL_ARGS_ASSERT_DUMP_VINDENT; + PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); + PerlIO_vprintf(file, pat, *args); +} + +/* +=for apidoc dump_all + +Dumps the entire optree of the current program starting at C<PL_main_root> to +C<STDERR>. Also dumps the optrees for all visible subroutines in C<PL_defstash>. + +=cut +*/ + +void +Perl_dump_all(pTHX) +{ + dump_all_perl(FALSE); +} + +void +Perl_dump_all_perl(pTHX_ bool justperl) +{ + + dVAR; + PerlIO_setlinebuf(Perl_debug_log); + if (PL_main_root) + op_dump(PL_main_root); + dump_packsubs_perl(PL_defstash, justperl); +} + +/* +=for apidoc dump_packsubs + +Dumps the optrees for all visible subroutines in C<stash>. + +=cut +*/ + +void +Perl_dump_packsubs(pTHX_ const HV *stash) +{ + PERL_ARGS_ASSERT_DUMP_PACKSUBS; + dump_packsubs_perl(stash, FALSE); +} + +void +Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) +{ + dVAR; + I32 i; + + PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; + + if (!HvARRAY(stash)) + return; + for (i = 0; i <= (I32) HvMAX(stash); i++) { + const HE *entry; + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + const GV * const gv = (const GV *)HeVAL(entry); + if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) + continue; + if (GvCVu(gv)) + dump_sub_perl(gv, justperl); + if (GvFORM(gv)) + dump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { + const HV * const hv = GvHV(gv); + if (hv && (hv != PL_defstash)) + dump_packsubs_perl(hv, justperl); /* nested package */ + } + } + } +} + +void +Perl_dump_sub(pTHX_ const GV *gv) +{ + PERL_ARGS_ASSERT_DUMP_SUB; + dump_sub_perl(gv, FALSE); +} + +void +Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) +{ + SV * sv; + + PERL_ARGS_ASSERT_DUMP_SUB_PERL; + + if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) + return; + + sv = sv_newmortal(); + gv_fullname3(sv, gv, NULL); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); + if (CvISXSUB(GvCV(gv))) + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", + PTR2UV(CvXSUB(GvCV(gv))), + (int)CvXSUBANY(GvCV(gv)).any_i32); + else if (CvROOT(GvCV(gv))) + op_dump(CvROOT(GvCV(gv))); + else + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); +} + +void +Perl_dump_form(pTHX_ const GV *gv) +{ + SV * const sv = sv_newmortal(); + + PERL_ARGS_ASSERT_DUMP_FORM; + + gv_fullname3(sv, gv, NULL); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); + if (CvROOT(GvFORM(gv))) + op_dump(CvROOT(GvFORM(gv))); + else + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); +} + +void +Perl_dump_eval(pTHX) +{ + dVAR; + op_dump(PL_eval_root); +} + void Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) { @@ -1168,6 +1186,14 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) Perl_dump_indent(aTHX_ level-1, file, "}\n"); } +/* +=for apidoc op_dump + +Dumps the optree starting at OP C<o> to C<STDERR>. + +=cut +*/ + void Perl_op_dump(pTHX_ const OP *o) { @@ -2219,6 +2245,16 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo SvREFCNT_dec_NN(d); } +/* +=for apidoc sv_dump + +Dumps the contents of an SV to the C<STDERR> filehandle. + +For an example of its output, see L<Devel::Peek>. + +=cut +*/ + void Perl_sv_dump(pTHX_ SV *sv) { diff --git a/embed.fnc b/embed.fnc index 422f6d1..2b82824 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1705,10 +1705,10 @@ Apd |SV* |sv_rvweaken |NN SV *const sv : This is indirectly referenced by globals.c. This is somewhat annoying. p |int |magic_killbackrefs|NN SV *sv|NN MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block -Ap |CV* |newATTRSUB |I32 floor|NULLOK OP *o|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block -p |CV* |newATTRSUB_flags|I32 floor|NULLOK OP *o|NULLOK OP *proto \ +Am |CV* |newATTRSUB |I32 floor|NULLOK OP *o|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block +pX |CV* |newATTRSUB_x |I32 floor|NULLOK OP *o|NULLOK OP *proto \ |NULLOK OP *attrs|NULLOK OP *block \ - |U32 flags + |bool o_is_gv Ap |CV * |newMYSUB |I32 floor|NN OP *o|NULLOK OP *proto \ |NULLOK OP *attrs|NULLOK OP *block p |CV* |newSTUB |NN GV *gv|bool fake diff --git a/embed.h b/embed.h index d25bb11..9e3af8b 100644 --- a/embed.h +++ b/embed.h @@ -343,7 +343,6 @@ #define newANONLIST(a) Perl_newANONLIST(aTHX_ a) #define newANONSUB(a,b,c) Perl_newANONSUB(aTHX_ a,b,c) #define newASSIGNOP(a,b,c,d) Perl_newASSIGNOP(aTHX_ a,b,c,d) -#define newATTRSUB(a,b,c,d,e) Perl_newATTRSUB(aTHX_ a,b,c,d,e) #define newAVREF(a) Perl_newAVREF(aTHX_ a) #define newBINOP(a,b,c,d) Perl_newBINOP(aTHX_ a,b,c,d) #define newCONDOP(a,b,c,d) Perl_newCONDOP(aTHX_ a,b,c,d) @@ -1193,7 +1192,7 @@ #define my_lstat_flags(a) Perl_my_lstat_flags(aTHX_ a) #define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a) #define my_unexec() Perl_my_unexec(aTHX) -#define newATTRSUB_flags(a,b,c,d,e,f) Perl_newATTRSUB_flags(aTHX_ a,b,c,d,e,f) +#define newATTRSUB_x(a,b,c,d,e,f) Perl_newATTRSUB_x(aTHX_ a,b,c,d,e,f) #define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b) #define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 0a07d0e..e454b01 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.58'; +our $VERSION = '0.59'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index f877047..e352195 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1942,6 +1942,81 @@ mxpushu() mXPUSHu(3); XSRETURN(3); +void +call_sv_C() +PREINIT: + CV * i_sub; + GV * i_gv; + I32 retcnt; + SV * errsv; + char * errstr; + SV * miscsv = sv_newmortal(); + HV * hv = (HV*)sv_2mortal((SV*)newHV()); +CODE: + i_sub = get_cv("i", 0); + PUSHMARK(SP); + /* PUTBACK not needed since this sub was called with 0 args, and is calling + 0 args, so global SP doesn't need to be moved before a call_* */ + retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */ + SPAGAIN; + SP -= retcnt; /* dont care about return count, wipe everything off */ + sv_setpvs(miscsv, "i"); + PUSHMARK(SP); + retcnt = call_sv(miscsv, 0); /* try a PV */ + SPAGAIN; + SP -= retcnt; + /* no add and SVt_NULL are intentional, sub i should be defined already */ + i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL); + PUSHMARK(SP); + retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */ + SPAGAIN; + SP -= retcnt; + /* the tests below are not declaring this being public API behavior, + only current internal behavior, these tests can be changed in the + future if necessery */ + PUSHMARK(SP); + retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */ + SPAGAIN; + SP -= retcnt; + PUSHMARK(SP); + retcnt = call_sv(&PL_sv_no, G_EVAL); + SPAGAIN; + SP -= retcnt; + errsv = ERRSV; + errstr = SvPV_nolen(errsv); + if(strnEQ(errstr, "Undefined subroutine &main:: called at", + sizeof("Undefined subroutine &main:: called at") - 1)) { + PUSHMARK(SP); + retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ + SPAGAIN; + SP -= retcnt; + } + PUSHMARK(SP); + retcnt = call_sv(&PL_sv_undef, G_EVAL); + SPAGAIN; + SP -= retcnt; + errsv = ERRSV; + errstr = SvPV_nolen(errsv); + if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at", + sizeof("Can't use an undefined value as a subroutine reference at") - 1)) { + PUSHMARK(SP); + retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ + SPAGAIN; + SP -= retcnt; + } + PUSHMARK(SP); + retcnt = call_sv((SV*)hv, G_EVAL); + SPAGAIN; + SP -= retcnt; + errsv = ERRSV; + errstr = SvPV_nolen(errsv); + if(strnEQ(errstr, "Not a CODE reference at", + sizeof("Not a CODE reference at") - 1)) { + PUSHMARK(SP); + retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ + SPAGAIN; + SP -= retcnt; + } void call_sv(sv, flags, ...) diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index 7ff9933..54f45ec 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -11,7 +11,7 @@ use strict; BEGIN { require '../../t/test.pl'; - plan(436); + plan(437); use_ok('XS::APItest') }; @@ -28,6 +28,13 @@ sub f { @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; } +our $call_sv_count = 0; +sub i { + $call_sv_count++; +} +call_sv_C(); +is($call_sv_count, 6, "call_sv_C passes"); + sub d { die "its_dead_jim\n"; } diff --git a/gv.c b/gv.c index 686f206..bda30b1 100644 --- a/gv.c +++ b/gv.c @@ -540,7 +540,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, CvLVALUE_on(cv); /* newATTRSUB will free the CV and return NULL if we're still compiling after a syntax error */ - if ((cv = newATTRSUB_flags( + if ((cv = newATTRSUB_x( oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( @@ -549,7 +549,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, : newSVpvn(name,len), code, opnum ), - 1 + TRUE )) != NULL) { assert(GvCV(gv) == orig_cv); if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS diff --git a/mathoms.c b/mathoms.c index 0543e88..2f91e57 100644 --- a/mathoms.c +++ b/mathoms.c @@ -1170,7 +1170,7 @@ Perl_custom_op_desc(pTHX_ const OP* o) CV * Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) { - return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block); + return newATTRSUB(floor, o, proto, NULL, block); } UV diff --git a/op.c b/op.c index f25112a..f411009 100644 --- a/op.c +++ b/op.c @@ -7645,15 +7645,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) return cv; } +/* _x = extended */ CV * -Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) -{ - return newATTRSUB_flags(floor, o, proto, attrs, block, 0); -} - -CV * -Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, - OP *block, U32 flags) +Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, bool o_is_gv) { dVAR; GV *gv; @@ -7674,7 +7669,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; - const bool o_is_gv = flags & 1; const char * const name = o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; diff --git a/op.h b/op.h index 0b84594..a1869ae 100644 --- a/op.h +++ b/op.h @@ -1022,7 +1022,8 @@ type. #define OP_TYPE_IS(o, type) ((o) && (o)->op_type == (type)) -#define newSUB(f, o, p, b) Perl_newATTRSUB(aTHX_ (f), (o), (p), NULL, (b)) +#define newATTRSUB(f, o, p, a, b) Perl_newATTRSUB_x(aTHX_ f, o, p, a, b, FALSE) +#define newSUB(f, o, p, b) newATTRSUB((f), (o), (p), NULL, (b)) #ifdef PERL_MAD # define MAD_NULL 1 diff --git a/pod/perldelta.pod b/pod/perldelta.pod index a30c98a..a167726 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -324,7 +324,13 @@ well. =over 4 -=item * +=item newATTRSUB is now a macro + +The public API newATTRSUB was previously a macro to the private +function Perl_newATTRSUB. Function Perl_newATTRSUB has been removed. newATTRSUB +is now macro to a different internal function. + +=item XXX XXX diff --git a/pp.c b/pp.c index a6ab24d..4175808 100644 --- a/pp.c +++ b/pp.c @@ -6016,7 +6016,6 @@ PP(pp_coreargs) ) ) DIE(aTHX_ - /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ "Type of arg %d to &CORE::%s must be %s", whicharg, PL_op_name[opnum], wantscalar diff --git a/pp_sys.c b/pp_sys.c index 74b65f7..aba3b14 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2379,8 +2379,6 @@ PP(pp_socket) if (!io) { report_evil_fh(gv); - if (io && IoIFP(io)) - do_close(gv, FALSE); SETERRNO(EBADF,LIB_INVARG); RETPUSHUNDEF; } @@ -2413,19 +2411,22 @@ PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dVAR; dSP; + int fd[2]; const int protocol = POPi; const int type = POPi; const int domain = POPi; + GV * gv1; + IO * io1; + GV * const gv2 = MUTABLE_GV(POPs); - GV * const gv1 = MUTABLE_GV(POPs); - IO * const io1 = gv1 ? GvIOn(gv1) : NULL; IO * const io2 = gv2 ? GvIOn(gv2) : NULL; - int fd[2]; + if (!io2) + report_evil_fh(gv2); + gv1 = MUTABLE_GV(POPs); + io1 = gv1 ? GvIOn(gv1) : NULL; if (!io1) report_evil_fh(gv1); - if (!io2) - report_evil_fh(gv2); if (io1 && IoIFP(io1)) do_close(gv1, FALSE); @@ -2475,12 +2476,13 @@ PP(pp_bind) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); STRLEN len; - const int op_type = PL_op->op_type; + int op_type; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); + op_type = PL_op->op_type; TAINT_PROPER(PL_op_desc[op_type]); if ((op_type == OP_BIND ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) diff --git a/proto.h b/proto.h index 221d14a..6943041 100644 --- a/proto.h +++ b/proto.h @@ -2707,8 +2707,8 @@ PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* ri __attribute__malloc__ __attribute__warn_unused_result__; -PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); -PERL_CALLCONV CV* Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, U32 flags); +/* PERL_CALLCONV CV* newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); */ +PERL_CALLCONV CV* Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, bool o_is_gv); /* PERL_CALLCONV AV* Perl_newAV(pTHX) __attribute__warn_unused_result__; */ -- Perl5 Master Repository
