diff options
Diffstat (limited to 'gnu/usr.bin/perl/ext')
106 files changed, 4966 insertions, 3713 deletions
diff --git a/gnu/usr.bin/perl/ext/B/B.pm b/gnu/usr.bin/perl/ext/B/B.pm index 5c1e5997b83..ce061e49101 100644 --- a/gnu/usr.bin/perl/ext/B/B.pm +++ b/gnu/usr.bin/perl/ext/B/B.pm @@ -6,16 +6,21 @@ # License or the Artistic License, as specified in the README file. # package B; -use strict; -require Exporter; @B::ISA = qw(Exporter); +# If B is loaded without imports, we do not want to unnecessarily pollute the stash with Exporter. +sub import { + return unless scalar @_ > 1; # Called as a method call. + require Exporter; + B->export_to_level(1, @_); +} + # walkoptree_slow comes from B.pm (you are there), # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.62'; + $B::VERSION = '1.74'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -43,12 +48,12 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs @B::IV::ISA = 'B::SV'; @B::NV::ISA = 'B::SV'; # RV is eliminated with 5.11.0, but effectively is a specialisation of IV now. -@B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV'; +@B::RV::ISA = 'B::IV'; @B::PVIV::ISA = qw(B::PV B::IV); @B::PVNV::ISA = qw(B::PVIV B::NV); @B::PVMG::ISA = 'B::PVNV'; -@B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011; -@B::INVLIST::ISA = 'B::PV' if $] >= 5.019; +@B::REGEXP::ISA = 'B::PVMG'; +@B::INVLIST::ISA = 'B::PV'; @B::PVLV::ISA = 'B::GV'; @B::BM::ISA = 'B::GV'; @B::AV::ISA = 'B::PVMG'; @@ -74,13 +79,14 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs @B::SPECIAL::ISA = 'B::OBJECT'; -@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP +our @optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP METHOP UNOP_AUX); # bytecode.pl contained the following comment: # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). -@B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no - (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD); +our @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no + (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD + &PL_sv_zero); { # Stop "-w" from complaining about the lack of a real B::OBJECT class @@ -114,15 +120,17 @@ sub B::IV::int_value { } sub B::NULL::as_string() {""} -*B::IV::as_string = \*B::IV::int_value; -*B::PV::as_string = \*B::PV::PV; +*B::IV::as_string = *B::IV::as_string = \*B::IV::int_value; +*B::PV::as_string = *B::PV::as_string = \*B::PV::PV; # The input typemap checking makes no distinction between different SV types, # so the XS body will generate the same C code, despite the different XS # "types". So there is no change in behaviour from doing "newXS" like this, # compared with the old approach of having a (near) duplicate XS body. # We should fix the typemap checking. -*B::IV::RV = \*B::PV::RV if $] > 5.012; + +# Since perl 5.12.0 +*B::IV::RV = *B::IV::RV = \*B::PV::RV; my $debug; my $op_count = 0; @@ -256,12 +264,12 @@ sub walkoptree_exec { sub walksymtable { my ($symref, $method, $recurse, $prefix) = @_; my $sym; - my $ref; my $fullname; no strict 'refs'; $prefix = '' unless defined $prefix; foreach my $sym ( sort keys %$symref ) { - $ref= $symref->{$sym}; + my $dummy = $symref->{$sym}; # Copying the glob and incrementing + # the GPs refcnt clears cached methods $fullname = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; @@ -541,52 +549,10 @@ give incomprehensible results, or worse. =head2 SV-RELATED CLASSES -B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM (5.9.5 and -earlier), B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes +B::IV, B::NV, B::PV, B::PVIV, B::PVNV, B::PVMG, +B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in the obvious way to the underlying C structures of similar names. -The inheritance hierarchy mimics the underlying C "inheritance". For the -5.10.x branch, (I<ie> 5.10.0, 5.10.1 I<etc>) this is: - - B::SV - | - +------------+------------+------------+ - | | | | - B::PV B::IV B::NV B::RV - \ / / - \ / / - B::PVIV / - \ / - \ / - \ / - B::PVNV - | - | - B::PVMG - | - +-----+-----+-----+-----+ - | | | | | - B::AV B::GV B::HV B::CV B::IO - | | - | | - B::PVLV B::FM - -For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, and BM is still -present as a distinct type, so the base of this diagram is - - - | - | - B::PVMG - | - +------+-----+-----+-----+-----+-----+ - | | | | | | | - B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO - | - | - B::FM - -For 5.11.0 and later, B::RV is abolished, and IVs can be used to store -references, and a new type B::REGEXP is introduced, giving this structure: +The inheritance hierarchy mimics the underlying C "inheritance": B::SV | @@ -950,17 +916,6 @@ IoIFP($io) == PerlIO_stderr(). Like C<ARRAY>, but takes an index as an argument to get only one element, rather than a list of all of them. -=item OFF - -This method is deprecated if running under Perl 5.8, and is no longer present -if running under Perl 5.9 - -=item AvFLAGS - -This method returns the AV specific -flags. In Perl 5.9 these are now stored -in with the main SV flags, so this method is no longer present. - =back =head2 B::CV Methods @@ -981,8 +936,7 @@ in with the main SV flags, so this method is no longer present. =item PADLIST -Returns a B::PADLIST object under Perl 5.18 or higher, or a B::AV in -earlier versions. +Returns a B::PADLIST object. =item OUTSIDE @@ -1020,11 +974,6 @@ Returns the name of a lexical sub, otherwise C<undef>. =item ARRAY -=item PMROOT - -This method is not present if running under Perl 5.9, as the PMROOT -information is no longer stored directly in the hash. - =back =head2 OP-RELATED CLASSES @@ -1167,16 +1116,8 @@ op is contained within. =item pmreplstart -=item pmnext - -Only up to Perl 5.9.4 - =item pmflags -=item extflags - -Since Perl 5.9.5 - =item precomp =item pmoffset @@ -1292,10 +1233,8 @@ Perl 5.22 introduced the B::PADNAMELIST and B::PADNAME classes. =item ARRAY -A list of pads. The first one contains the names. - -The first one is a B::PADNAMELIST under Perl 5.22, and a B::AV under -earlier versions. The rest are currently B::AV objects, but that could +A list of pads. The first one is a B::PADNAMELIST containing the names. +The rest are currently B::AV objects, but that could change in future versions. =item ARRAYelt diff --git a/gnu/usr.bin/perl/ext/B/B.xs b/gnu/usr.bin/perl/ext/B/B.xs index b4b6a40ac53..d9d77157c67 100644 --- a/gnu/usr.bin/perl/ext/B/B.xs +++ b/gnu/usr.bin/perl/ext/B/B.xs @@ -39,22 +39,6 @@ static const char* const svclassnames[] = { "B::IO", }; -typedef enum { - OPc_NULL, /* 0 */ - OPc_BASEOP, /* 1 */ - OPc_UNOP, /* 2 */ - OPc_BINOP, /* 3 */ - OPc_LOGOP, /* 4 */ - OPc_LISTOP, /* 5 */ - OPc_PMOP, /* 6 */ - OPc_SVOP, /* 7 */ - OPc_PADOP, /* 8 */ - OPc_PVOP, /* 9 */ - OPc_LOOP, /* 10 */ - OPc_COP, /* 11 */ - OPc_METHOP, /* 12 */ - OPc_UNOP_AUX /* 13 */ -} opclass; static const char* const opclassnames[] = { "B::NULL", @@ -93,7 +77,7 @@ static const size_t opsizes[] = { #define MY_CXT_KEY "B::_guts" XS_VERSION typedef struct { - SV * x_specialsv_list[7]; + SV * x_specialsv_list[8]; int x_walkoptree_debug; /* Flag for walkoptree debug hook */ } my_cxt_t; @@ -111,148 +95,15 @@ static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { cxt->x_specialsv_list[4] = (SV *) pWARN_ALL; cxt->x_specialsv_list[5] = (SV *) pWARN_NONE; cxt->x_specialsv_list[6] = (SV *) pWARN_STD; + cxt->x_specialsv_list[7] = &PL_sv_zero; } -static opclass -cc_opclass(pTHX_ const OP *o) -{ - bool custom = 0; - - if (!o) - return OPc_NULL; - - if (o->op_type == 0) { - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - return OPc_COP; - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - } - - if (o->op_type == OP_SASSIGN) - return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); - - if (o->op_type == OP_AELEMFAST) { -#ifdef USE_ITHREADS - return OPc_PADOP; -#else - return OPc_SVOP; -#endif - } - -#ifdef USE_ITHREADS - if (o->op_type == OP_GV || o->op_type == OP_GVSV || - o->op_type == OP_RCATLINE) - return OPc_PADOP; -#endif - - if (o->op_type == OP_CUSTOM) - custom = 1; - - switch (OP_CLASS(o)) { - case OA_BASEOP: - return OPc_BASEOP; - - case OA_UNOP: - return OPc_UNOP; - - case OA_BINOP: - return OPc_BINOP; - - case OA_LOGOP: - return OPc_LOGOP; - - case OA_LISTOP: - return OPc_LISTOP; - - case OA_PMOP: - return OPc_PMOP; - - case OA_SVOP: - return OPc_SVOP; - - case OA_PADOP: - return OPc_PADOP; - - case OA_PVOP_OR_SVOP: - /* - * Character translations (tr///) are usually a PVOP, keeping a - * pointer to a table of shorts used to look up translations. - * Under utf8, however, a simple table isn't practical; instead, - * the OP is an SVOP (or, under threads, a PADOP), - * and the SV is a reference to a swash - * (i.e., an RV pointing to an HV). - */ - return (!custom && - (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) - ) -#if defined(USE_ITHREADS) - ? OPc_PADOP : OPc_PVOP; -#else - ? OPc_SVOP : OPc_PVOP; -#endif - - case OA_LOOP: - return OPc_LOOP; - - case OA_COP: - return OPc_COP; - - case OA_BASEOP_OR_UNOP: - /* - * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on - * whether parens were seen. perly.y uses OPf_SPECIAL to - * signal whether a BASEOP had empty parens or none. - * Some other UNOPs are created later, though, so the best - * test is OPf_KIDS, which is set in newUNOP. - */ - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - - case OA_FILESTATOP: - /* - * The file stat OPs are created via UNI(OP_foo) in toke.c but use - * the OPf_REF flag to distinguish between OP types instead of the - * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we - * return OPc_UNOP so that walkoptree can find our children. If - * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set - * (no argument to the operator) it's an OP; with OPf_REF set it's - * an SVOP (and op_sv is the GV for the filehandle argument). - */ - return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : -#ifdef USE_ITHREADS - (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); -#else - (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); -#endif - case OA_LOOPEXOP: - /* - * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a - * label was omitted (in which case it's a BASEOP) or else a term was - * seen. In this last case, all except goto are definitely PVOP but - * goto is either a PVOP (with an ordinary constant label), an UNOP - * with OPf_STACKED (with a non-constant non-sub) or an UNOP for - * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to - * get set. - */ - if (o->op_flags & OPf_STACKED) - return OPc_UNOP; - else if (o->op_flags & OPf_SPECIAL) - return OPc_BASEOP; - else - return OPc_PVOP; - case OA_METHOP: - return OPc_METHOP; - case OA_UNOP_AUX: - return OPc_UNOP_AUX; - } - warn("can't determine class of operator %s, assuming BASEOP\n", - OP_NAME(o)); - return OPc_BASEOP; -} static SV * make_op_object(pTHX_ const OP *o) { SV *opsv = sv_newmortal(); - sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o)); + sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o)); return opsv; } @@ -509,7 +360,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) dSP; OP *kid; SV *object; - const char *const classname = opclassnames[cc_opclass(aTHX_ o)]; + const char *const classname = opclassnames[op_class(o)]; dMY_CXT; /* Check that no-one has changed our reference, or is holding a reference @@ -542,7 +393,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) ref = walkoptree(aTHX_ kid, method, ref); } } - if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE + if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT && (kid = PMOP_pmreplroot(cPMOPo))) { ref = walkoptree(aTHX_ kid, method, ref); @@ -617,9 +468,7 @@ typedef IO *B__IO; typedef MAGIC *B__MAGIC; typedef HE *B__HE; typedef struct refcounted_he *B__RHE; -#ifdef PadlistARRAY typedef PADLIST *B__PADLIST; -#endif typedef PADNAMELIST *B__PADNAMELIST; typedef PADNAME *B__PADNAME; @@ -777,10 +626,6 @@ BOOT: ASSIGN_COMMON_ALIAS(I, defstash); cv = newXS("B::curstash", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, curstash); -#ifdef PL_formfeed - cv = newXS("B::formfeed", intrpvar_sv_common, file); - ASSIGN_COMMON_ALIAS(I, formfeed); -#endif #ifdef USE_ITHREADS cv = newXS("B::regex_padav", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, regex_padav); @@ -797,15 +642,11 @@ BOOT: #endif } -#ifndef PL_formfeed - void formfeed() PPCODE: PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)))); -#endif - long amagic_generation() CODE: @@ -818,16 +659,12 @@ comppadlist() PREINIT: PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv); PPCODE: -#ifdef PadlistARRAY { SV * const rv = sv_newmortal(); sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"), PTR2IV(padlist)); PUSHs(rv); } -#else - PUSHs(make_sv_object(aTHX_ (SV *)padlist)); -#endif void sv_undef() @@ -894,11 +731,11 @@ CODE: int i; IV result = -1; ST(0) = sv_newmortal(); - if (strncmp(name,"pp_",3) == 0) + if (strBEGINs(name,"pp_")) name += 3; for (i = 0; i < PL_maxo; i++) { - if (strcmp(name, PL_op_name[i]) == 0) + if (strEQ(name, PL_op_name[i])) { result = i; break; @@ -923,7 +760,7 @@ hash(sv) U32 hash = 0; const char *s = SvPVbyte(sv, len); PERL_HASH(hash, s, len); - ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash)); + ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%" UVxf, (UV)hash)); #define cast_I32(foo) (I32)foo IV @@ -1083,7 +920,7 @@ next(o) : &PL_sv_undef); break; case 26: /* B::OP::size */ - ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); + ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)]))); break; case 27: /* B::OP::name */ case 28: /* B::OP::desc */ @@ -1128,16 +965,19 @@ next(o) } break; case 34: /* B::PMOP::pmreplroot */ - if (cPMOPo->op_type == OP_PUSHRE) { -#ifdef USE_ITHREADS + if (cPMOPo->op_type == OP_SPLIT) { ret = sv_newmortal(); - sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff); -#else - GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv; - ret = sv_newmortal(); - sv_setiv(newSVrv(ret, target ? - svclassnames[SvTYPE((SV*)target)] : "B::SV"), - PTR2IV(target)); +#ifndef USE_ITHREADS + if (o->op_private & OPpSPLIT_LEX) +#endif + sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff); +#ifndef USE_ITHREADS + else { + GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv; + sv_setiv(newSVrv(ret, target ? + svclassnames[SvTYPE((SV*)target)] : "B::SV"), + PTR2IV(target)); + } #endif } else { @@ -1182,20 +1022,18 @@ next(o) ret = make_sv_object(aTHX_ NULL); break; case 41: /* B::PVOP::pv */ - /* OP_TRANS uses op_pv to point to a table of 256 or >=258 - * shorts whereas other PVOPs point to a null terminated - * string. */ - if ( (cPVOPo->op_type == OP_TRANS - || cPVOPo->op_type == OP_TRANSR) && - (cPVOPo->op_private & OPpTRANS_COMPLEMENT) && - !(cPVOPo->op_private & OPpTRANS_DELETE)) - { - const short* const tbl = (short*)cPVOPo->op_pv; - const short entries = 257 + tbl[256]; - ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP); - } - else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) { - ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP); + /* OP_TRANS uses op_pv to point to a OPtrans_map struct, + * whereas other PVOPs point to a null terminated string. + * For trans, for now just return the whole struct as a + * string and let the caller unpack() it */ + if ( cPVOPo->op_type == OP_TRANS + || cPVOPo->op_type == OP_TRANSR) + { + const OPtrans_map *const tbl = (OPtrans_map*)cPVOPo->op_pv; + ret = newSVpvn_flags(cPVOPo->op_pv, + (char*)(&tbl->map[tbl->size + 1]) + - (char*)tbl, + SVs_TEMP); } else ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP); @@ -1325,14 +1163,34 @@ string(o, cv) B::CV cv PREINIT: SV *ret; + UNOP_AUX_item *aux; PPCODE: + aux = cUNOP_AUXo->op_aux; switch (o->op_type) { + case OP_MULTICONCAT: + ret = multiconcat_stringify(o); + break; + case OP_MULTIDEREF: ret = multideref_stringify(o, cv); break; + + case OP_ARGELEM: + ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%" IVdf, + PTR2IV(aux))); + break; + + case OP_ARGCHECK: + ret = Perl_newSVpvf(aTHX_ "%" IVdf ",%" IVdf, aux[0].iv, aux[1].iv); + if (aux[2].iv) + Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv); + ret = sv_2mortal(ret); + break; + default: ret = sv_2mortal(newSVpvn("", 0)); } + ST(0) = ret; XSRETURN(1); @@ -1346,12 +1204,83 @@ void aux_list(o, cv) B::OP o B::CV cv + PREINIT: + UNOP_AUX_item *aux; PPCODE: PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */ + aux = cUNOP_AUXo->op_aux; switch (o->op_type) { default: XSRETURN(0); /* by default, an empty list */ + case OP_ARGELEM: + XPUSHs(sv_2mortal(newSViv(PTR2IV(aux)))); + XSRETURN(1); + break; + + case OP_ARGCHECK: + EXTEND(SP, 3); + PUSHs(sv_2mortal(newSViv(aux[0].iv))); + PUSHs(sv_2mortal(newSViv(aux[1].iv))); + PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c", + (char)aux[2].iv) : &PL_sv_no)); + break; + + case OP_MULTICONCAT: + { + SSize_t nargs; + char *p; + STRLEN len; + U32 utf8 = 0; + SV *sv; + UNOP_AUX_item *lens; + + /* return (nargs, const string, segment len 0, 1, 2, ...) */ + + /* if this changes, this block of code probably needs fixing */ + assert(PERL_MULTICONCAT_HEADER_SIZE == 5); + nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; + EXTEND(SP, ((SSize_t)(2 + (nargs+1)))); + PUSHs(sv_2mortal(newSViv((IV)nargs))); + + p = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; + len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; + if (!p) { + p = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; + len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize; + utf8 = SVf_UTF8; + } + sv = newSVpvn(p, len); + SvFLAGS(sv) |= utf8; + PUSHs(sv_2mortal(sv)); + + lens = aux + PERL_MULTICONCAT_IX_LENGTHS; + nargs++; /* loop (nargs+1) times */ + if (utf8) { + U8 *p = (U8*)SvPVX(sv); + while (nargs--) { + SSize_t bytes = lens->ssize; + SSize_t chars; + if (bytes <= 0) + chars = bytes; + else { + /* return char lengths rather than byte lengths */ + chars = utf8_length(p, p + bytes); + p += bytes; + } + lens++; + PUSHs(sv_2mortal(newSViv(chars))); + } + } + else { + while (nargs--) { + PUSHs(sv_2mortal(newSViv(lens->ssize))); + lens++; + } + } + break; + } + case OP_MULTIDEREF: #ifdef USE_ITHREADS # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE); @@ -1722,19 +1651,12 @@ PV(sv) U32 utf8 = 0; CODE: if (ix == 3) { -#ifndef PERL_FBM_TABLE_OFFSET const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm); if (!mg) croak("argument to B::BM::TABLE is not a PVBM"); p = mg->mg_ptr; len = mg->mg_len; -#else - p = SvPV(sv, len); - /* Boyer-Moore table is just after string and its safety-margin \0 */ - p += len + PERL_FBM_TABLE_OFFSET; - len = 256; -#endif } else if (ix == 2) { /* This used to read 257. I think that that was buggy - should have been 258. (The "\0", the flags byte, and 256 for the table.) @@ -1752,38 +1674,22 @@ PV(sv) 5.15 and later store the BM table via MAGIC, so the compiler should handle this just fine without changes if PVBM now always returns the SvPVX() buffer. */ -#ifdef isREGEXP p = isREGEXP(sv) ? RX_WRAPPED_const((REGEXP*)sv) : SvPVX_const(sv); -#else - p = SvPVX_const(sv); -#endif -#ifdef PERL_FBM_TABLE_OFFSET - len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0); -#else len = SvCUR(sv); -#endif } else if (ix) { -#ifdef isREGEXP p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv); -#else - p = SvPVX(sv); -#endif len = strlen(p); } else if (SvPOK(sv)) { len = SvCUR(sv); p = SvPVX_const(sv); utf8 = SvUTF8(sv); - } -#ifdef isREGEXP - else if (isREGEXP(sv)) { + } else if (isREGEXP(sv)) { len = SvCUR(sv); p = RX_WRAPPED_const((REGEXP*)sv); utf8 = SvUTF8(sv); - } -#endif - else { + } else { /* XXX for backward compatibility, but should fail */ /* croak( "argument is not SvPOK" ); */ p = NULL; @@ -1906,7 +1812,7 @@ is_empty(gv) isGV_with_GP = 1 CODE: if (ix) { - RETVAL = isGV_with_GP(gv) ? TRUE : FALSE; + RETVAL = cBOOL(isGV_with_GP(gv)); } else { RETVAL = GvGP(gv) == Null(GP*); } @@ -2063,8 +1969,6 @@ I32 CvDEPTH(cv) B::CV cv -#ifdef PadlistARRAY - B::PADLIST CvPADLIST(cv) B::CV cv @@ -2073,17 +1977,6 @@ CvPADLIST(cv) OUTPUT: RETVAL -#else - -B::AV -CvPADLIST(cv) - B::CV cv - PPCODE: - PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv))); - - -#endif - SV * CvHSCXT(cv) B::CV cv @@ -2179,13 +2072,11 @@ SV* HASH(h) B::RHE h CODE: - RETVAL = newRV( (SV*)cophh_2hv(h, 0) ); + RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) ); OUTPUT: RETVAL -#ifdef PadlistARRAY - MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist SSize_t @@ -2245,8 +2136,6 @@ PadlistREFCNT(padlist) OUTPUT: RETVAL -#endif - MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist void diff --git a/gnu/usr.bin/perl/ext/B/B/Concise.pm b/gnu/usr.bin/perl/ext/B/B/Concise.pm index 311e0e738a9..9032e9b082b 100644 --- a/gnu/usr.bin/perl/ext/B/B/Concise.pm +++ b/gnu/usr.bin/perl/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "0.996"; +our $VERSION = "1.003"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -28,7 +28,10 @@ our %EXPORT_TAGS = # use #6 use B qw(class ppname main_start main_root main_cv cstring svref_2object SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL - CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK); + OPf_STACKED + OPpSPLIT_ASSIGN OPpSPLIT_LEX + CVf_ANON CVf_LEXICAL CVf_NAMED + PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK); my %style = ("terse" => @@ -143,13 +146,14 @@ sub concise_subref { sub concise_stashref { my($order, $h) = @_; - local *s; + my $name = svref_2object($h)->NAME; foreach my $k (sort keys %$h) { next unless defined $h->{$k}; - *s = $h->{$k}; - my $coderef = *s{CODE} or next; + my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k} + : ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next + : next; reset_sequence(); - print "FUNC: ", *s, "\n"; + print "FUNC: *", $name, "::", $k, "\n"; my $codeobj = svref_2object($coderef); next unless ref $codeobj eq 'B::CV'; eval { concise_cv_obj($order, $codeobj, $k) }; @@ -595,31 +599,43 @@ require B::Op_private; our %hints; # used to display each COP's op_hints values # strict refs, subs, vars -@hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*'); +@hints{0x2,0x200,0x400,0x20,0x40,0x80} = ('$', '&', '*', 'x$', 'x&', 'x*'); # integers, locale, bytes -@hints{1,4,8,16} = ('i', 'l', 'b'); +@hints{0x1,0x4,0x8,0x10} = ('i', 'l', 'b'); # block scope, localise %^H, $^OPEN (in), $^OPEN (out) -@hints{256,131072,262144,524288} = ('{','%','<','>'); +@hints{0x100,0x20000,0x40000,0x80000} = ('{','%','<','>'); # overload new integer, float, binary, string, re -@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R'); +@hints{0x1000,0x2000,0x4000,0x8000,0x10000} = ('I', 'F', 'B', 'S', 'R'); # taint and eval -@hints{1048576,2097152} = ('T', 'E'); -# filetest access, UTF-8 -@hints{4194304,8388608} = ('X', 'U'); +@hints{0x100000,0x200000} = ('T', 'E'); +# filetest access, use utf8, unicode_strings feature +@hints{0x400000,0x800000,0x800} = ('X', 'U', 'us'); -sub _flags { - my($hash, $x) = @_; +# pick up the feature hints constants. +# Note that we're relying on non-API parts of feature.pm, +# but its less naughty than just blindly copying those constants into +# this src file. +# +require feature; + +sub hints_flags { + my($x) = @_; my @s; - for my $flag (sort {$b <=> $a} keys %$hash) { - if ($hash->{$flag} and $x & $flag and $x >= $flag) { + for my $flag (sort {$b <=> $a} keys %hints) { + if ($hints{$flag} and $x & $flag and $x >= $flag) { $x -= $flag; - push @s, $hash->{$flag}; + push @s, $hints{$flag}; } } - push @s, $x if $x; + if ($x & $feature::hint_mask) { + push @s, "fea=" . (($x & $feature::hint_mask) >> $feature::hint_shift); + $x &= ~$feature::hint_mask; + } + push @s, sprintf "0x%x", $x if $x; return join(",", @s); } + # return a string like 'LVINTRO,1' for the op $name with op_private # value $x @@ -677,11 +693,6 @@ sub private_flags { return join ",", @flags; } -sub hints_flags { - my($x) = @_; - _flags(\%hints, $x); -} - sub concise_sv { my($sv, $hr, $preferpv) = @_; $hr->{svclass} = class($sv); @@ -706,30 +717,47 @@ sub concise_sv { $hr->{svval} = "*$stash" . $gv->SAFENAME; return "*$stash" . $gv->SAFENAME; } else { - if ($] >= 5.011) { - while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) { - $hr->{svval} .= "\\"; - $sv = $sv->RV; - } - } else { - while (class($sv) eq "RV") { - $hr->{svval} .= "\\"; - $sv = $sv->RV; - } + while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) { + $hr->{svval} .= "\\"; + $sv = $sv->RV; } if (class($sv) eq "SPECIAL") { - $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no", + '', '', '', "sv_zero"]->[$$sv]; } elsif ($preferpv - && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) { + && ($sv->FLAGS & SVf_POK)) { $hr->{svval} .= cstring($sv->PV); } elsif ($sv->FLAGS & SVf_NOK) { $hr->{svval} .= $sv->NV; } elsif ($sv->FLAGS & SVf_IOK) { $hr->{svval} .= $sv->int_value; - } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") { + } elsif ($sv->FLAGS & SVf_POK) { $hr->{svval} .= cstring($sv->PV); } elsif (class($sv) eq "HV") { $hr->{svval} .= 'HASH'; + } elsif (class($sv) eq "AV") { + $hr->{svval} .= 'ARRAY'; + } elsif (class($sv) eq "CV") { + if ($sv->CvFLAGS & CVf_ANON) { + $hr->{svval} .= 'CODE'; + } elsif ($sv->CvFLAGS & CVf_NAMED) { + $hr->{svval} .= "&"; + unless ($sv->CvFLAGS & CVf_LEXICAL) { + my $stash = $sv->STASH; + unless (class($stash) eq "SPECIAL") { + $hr->{svval} .= $stash->NAME . "::"; + } + } + $hr->{svval} .= $sv->NAME_HEK; + } else { + $hr->{svval} .= "&"; + $sv = $sv->GV; + my $stash = $sv->STASH; + unless (class($stash) eq "SPECIAL") { + $hr->{svval} .= $stash->NAME . "::"; + } + $hr->{svval} .= $sv->SAFENAME; + } } $hr->{svval} = 'undef' unless defined $hr->{svval}; @@ -755,6 +783,50 @@ sub fill_srclines { $srclines{$fullnm} = \@l; } +# Given a pad target, return the pad var's name and cop range / +# fakeness, or failing that, its target number. +# e.g. +# ('$i', '$i:5,7') +# or +# ('$i', '$i:fake:a') +# or +# ('t5', 't5') + +sub padname { + my ($targ) = @_; + + my ($targarg, $targarglife); + my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ]; + if (defined $padname and class($padname) ne "SPECIAL" and + $padname->LEN) + { + $targarg = $padname->PVX; + if ($padname->FLAGS & SVf_FAKE) { + # These changes relate to the jumbo closure fix. + # See changes 19939 and 20005 + my $fake = ''; + $fake .= 'a' + if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON; + $fake .= 'm' + if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI; + $fake .= ':' . $padname->PARENT_PAD_INDEX + if $curcv->CvFLAGS & CVf_ANON; + $targarglife = "$targarg:FAKE:$fake"; + } + else { + my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base; + my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base; + $finish = "end" if $finish == 999999999 - $cop_seq_base; + $targarglife = "$targarg:$intro,$finish"; + } + } else { + $targarglife = $targarg = "t" . $targ; + } + return $targarg, $targarglife; +} + + + sub concise_op { my ($op, $level, $format) = @_; my %h; @@ -787,39 +859,14 @@ sub concise_op { : 1; my (@targarg, @targarglife); for my $i (0..$count-1) { - my ($targarg, $targarglife); - my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i]; - if (defined $padname and class($padname) ne "SPECIAL" and - $padname->LEN) - { - $targarg = $padname->PVX; - if ($padname->FLAGS & SVf_FAKE) { - # These changes relate to the jumbo closure fix. - # See changes 19939 and 20005 - my $fake = ''; - $fake .= 'a' - if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON; - $fake .= 'm' - if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI; - $fake .= ':' . $padname->PARENT_PAD_INDEX - if $curcv->CvFLAGS & CVf_ANON; - $targarglife = "$targarg:FAKE:$fake"; - } - else { - my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base; - my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base; - $finish = "end" if $finish == 999999999 - $cop_seq_base; - $targarglife = "$targarg:$intro,$finish"; - } - } else { - $targarglife = $targarg = "t" . ($h{targ}+$i); - } + my ($targarg, $targarglife) = padname($h{targ} + $i); push @targarg, $targarg; push @targarglife, $targarglife; } $h{targarg} = join '; ', @targarg; $h{targarglife} = join '; ', @targarglife; } + $h{arg} = ""; $h{svclass} = $h{svaddr} = $h{svval} = ""; if ($h{class} eq "PMOP") { @@ -837,22 +884,35 @@ sub concise_op { $extra = " replstart->" . seq($op->pmreplstart); } } - elsif ($op->name eq 'pushre') { - # with C<@stash_array = split(/pat/, str);>, - # *stash_array is stored in /pat/'s pmreplroot. - my $gv = $op->pmreplroot; - if (!ref($gv)) { - # threaded: the value is actually a pad offset for where - # the GV is kept (op_pmtargetoff) - if ($gv) { - $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME; - } - } - else { - # unthreaded: its a GV (if it exists) - $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef; - } - $extra = " => \@$gv" if $gv; + elsif ($op->name eq 'split') { + if ( ($op->private & OPpSPLIT_ASSIGN) # @array = split + && (not $op->flags & OPf_STACKED)) # @{expr} = split + { + # with C<@array = split(/pat/, str);>, + # array is stored in /pat/'s pmreplroot; either + # as an integer index into the pad (for a lexical array) + # or as GV for a package array (which will be a pad index + # on threaded builds) + + if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) { + my $off = $op->pmreplroot; # union with op_pmtargetoff + my ($name, $full) = padname($off); + $extra = " => $full"; + } + else { + # union with op_pmtargetoff, op_pmtargetgv + my $gv = $op->pmreplroot; + if (!ref($gv)) { + # the value is actually a pad offset + $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME; + } + else { + # unthreaded: its a GV + $gv = $gv->NAME; + } + $extra = " => \@$gv"; + } + } } $h{arg} = "($precomp$extra)"; } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') { @@ -871,10 +931,7 @@ sub concise_op { $h{arg} = "($label$stash $cseq $loc)"; if ($show_src) { fill_srclines($pathnm) unless exists $srclines{$pathnm}; - # Would love to retain Jim's use of // but this code needs to be - # portable to 5.8.x - my $line = $srclines{$pathnm}[$ln]; - $line = "-src unavailable under -e" unless defined $line; + my $line = $srclines{$pathnm}[$ln] // "-src unavailable under -e"; $h{src} = "$ln: $line"; } } elsif ($h{class} eq "LOOP") { @@ -884,6 +941,11 @@ sub concise_op { undef $lastnext; $h{arg} = "(other->" . seq($op->other) . ")"; $h{otheraddr} = sprintf("%#x", $ {$op->other}); + if ($h{name} eq "argdefelem") { + # targ used for element index + $h{targarglife} = $h{targarg} = ""; + $h{arg} .= "[" . $op->targ . "]"; + } } elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { @@ -1039,10 +1101,6 @@ sub tree { # number for the user's program as being a small offset later, so all we # have to worry about are changes in the offset. -# [For 5.8.x and earlier perl is generating sequence numbers for all ops, -# and using them to reference labels] - - # When you say "perl -MO=Concise -e '$a'", the output should look like: # 4 <@> leave[t1] vKP/REFC ->(end) @@ -1057,7 +1115,7 @@ sub tree { # to update the corresponding magic number in the next line. # Remember, this needs to stay the last things in the module. -my $cop_seq_mnum = 16; +my $cop_seq_mnum = 12; $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum; 1; @@ -1591,6 +1649,9 @@ string if this is not a COP. Here are the symbols used: X filetest access U utf-8 + us use feature 'unicode_strings' + fea=NNN feature bundle number + =item B<#hintsval> The numeric value of the COP's hint flags, or an empty string if this is not @@ -1642,21 +1703,10 @@ The numeric value of the OP's private flags. The sequence number of the OP. Note that this is a sequence number generated by B::Concise. -=item B<#seqnum> - -5.8.x and earlier only. 5.9 and later do not provide this. - -The real sequence number of the OP, as a regular number and not adjusted -to be relative to the start of the real program. (This will generally be -a fairly large number because all of B<B::Concise> is compiled before -your program is). - =item B<#opt> Whether or not the op has been optimized by the peephole optimizer. -Only available in 5.9 and later. - =item B<#sibaddr> The address of the OP's next youngest sibling, in hexadecimal. diff --git a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm index a099a97ec9d..53236c91d4e 100644 --- a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm +++ b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm @@ -2,10 +2,10 @@ package OptreeCheck; use parent 'Exporter'; use strict; use warnings; -use vars qw($TODO $Level $using_open); +our ($TODO, $Level, $using_open); require "test.pl"; -our $VERSION = '0.13'; +our $VERSION = '0.16'; # now export checkOptree, and those test.pl functions used by tests our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike @@ -208,15 +208,10 @@ In either case, $coderef is then passed to B::Concise::compile(): =head2 expect and expect_nt expect and expect_nt args are the B<golden-sample> renderings, and are -sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds. +sampled from known-ok threaded and un-threaded bleadperl builds. They're both required, and the correct one is selected for the platform being tested, and saved into the synthesized property B<wanted>. -Individual sample lines may be suffixed with whitespace followed -by (<|<=|==|>=|>)5.nnnn (up to two times) to -select that line only for the listed perl -version; the whitespace and conditional are stripped. - =head2 bcopts => $bcopts || [ @bcopts ] When getRendering() runs, it passes bcopts into B::Concise::compile(). @@ -640,33 +635,6 @@ sub mkCheckRex { $str =~ s/^\# //mg; # ease cut-paste testcase authoring - # strip out conditional lines - - $str =~ s{^(.*?) \s+(<|<=|==|>=|>)\s*(5\.\d+) - (?:\s+(<|<=|==|>=|>)\s*(5\.\d+))? \ *\n} - { - my ($line, $cmp, $version, $cmp2, $v2) = ($1,$2,$3,$4,$5,$6); - my $repl = ""; - if ( $cmp eq '<' ? $] < $version - : $cmp eq '<=' ? $] <= $version - : $cmp eq '==' ? $] == $version - : $cmp eq '>=' ? $] >= $version - : $cmp eq '>' ? $] > $version - : die("bad comparison '$cmp' in string [$str]\n") - and !$cmp2 || ( - $cmp2 eq '<' ? $] < $v2 - : $cmp2 eq '<=' ? $] <= $v2 - : $cmp2 eq '==' ? $] == $v2 - : $cmp2 eq '>=' ? $] >= $v2 - : $cmp2 eq '>' ? $] > $v2 - : die("bad comparison '$cmp2' in string [$str]\n") - ) - ) { - $repl = "$line\n"; - } - $repl; - }gemx; - $tc->{wantstr} = $str; # make UNOP_AUX flag type literal @@ -703,12 +671,12 @@ sub mkCheckRex { .* # all sorts of things follow it v # The opening v ) - (?:(:>,<,%,\\{) # hints when open.pm is in force + (?:(:>,<,%,\\\{) # hints when open.pm is in force |(:>,<,%)) # (two variations) (\ ->(?:-|[0-9a-z]+))? $ ] - [$1 . ($2 && ':{') . $4]xegm; # change to the hints without open.pm + [$1 . ($2 && ':\{') . $4]xegm; # change to the hints without open.pm } @@ -781,8 +749,9 @@ sub reduceDiffs { my $exp = shift @want; my $line = shift @got; # remove matches, and report - unless ($got =~ s/($rex\n)//msg) { + unless ($got =~ s/^($rex\n)//ms) { _diag("got:\t\t'$line'\nwant:\t $rex\n"); + last; } } _diag("remainder:\n$got"); @@ -1001,7 +970,7 @@ sub OptreeCheck::processExamples { # turned into optreeCheck tests, foreach my $file (@files) { - open (my $fh, $file) or die "cant open $file: $!\n"; + open (my $fh, '<', $file) or die "cant open $file: $!\n"; $/ = ""; my @chunks = <$fh>; print preamble (scalar @chunks); diff --git a/gnu/usr.bin/perl/ext/B/t/b.t b/gnu/usr.bin/perl/ext/B/t/b.t index 4638c3e5770..09dba39b1dd 100644 --- a/gnu/usr.bin/perl/ext/B/t/b.t +++ b/gnu/usr.bin/perl/ext/B/t/b.t @@ -21,7 +21,7 @@ BEGIN { use_ok( 'B' ); } package Testing::Symtable; -use vars qw($This @That %wibble $moo %moo); +our ($This, @That, %wibble, $moo, %moo); my $not_a_sym = 'moo'; sub moo { 42 } @@ -35,7 +35,7 @@ package Testing::Symtable::Bar; sub hock { "yarrow" } package main; -use vars qw(%Subs); +our %Subs; local %Subs = (); B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ }, 'Testing::Symtable::'); @@ -46,8 +46,7 @@ sub B::GV::find_syms { $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++; } -my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car - BEGIN); +my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car); push @syms, "Testing::Symtable::Foo::yarrow"; # Make sure we hit all the expected symbols. @@ -56,6 +55,21 @@ ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' ); # Make sure we only hit them each once. ok( (!grep $_ != 1, values %Subs), '...and found once' ); + +# Make sure method caches are not present when walking the sym tab +@Testing::Method::Caches::Foo::ISA='Testing::Method::Caches::Bar'; +sub Testing::Method::Caches::Bar::foo{} +Testing::Method::Caches::Foo->foo; # caches the sub in the *foo glob + +my $have_cv; +sub B::GV::method_cache_test { ${shift->CV} and ++$have_cv } + +B::walksymtable(\%Testing::Method::Caches::, 'method_cache_test', + sub { 1 }, 'Testing::Method::Caches::'); +# $have_cv should only have been incremented for ::Bar::foo +is $have_cv, 1, 'walksymtable clears cached methods'; + + # Tests for MAGIC / MOREMAGIC ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); { @@ -107,8 +121,7 @@ ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); } my $r = qr/foo/; -my $obj = B::svref_2object($r); -my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj; +my $regexp = B::svref_2object($r); ok($regexp->precomp() eq 'foo', 'Get string from qr//'); like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value"); like($regexp->compflags, qr/^\d+\z/, "compflags returns numeric value"); @@ -179,25 +192,21 @@ my $null_ret = $nv_ref->object_2svref(); is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); is($$null_ret, $nv, "Test object_2svref()"); -my $RV_class = $] >= 5.011 ? 'B::IV' : 'B::RV'; my $cv = sub{ 1; }; my $cv_ref = B::svref_2object(\$cv); -is($cv_ref->REFCNT, 1, "Test $RV_class->REFCNT"); -is(ref $cv_ref, "$RV_class", - "Test $RV_class return from svref_2object - code"); +is($cv_ref->REFCNT, 1, "Test B::IV->REFCNT"); +is(ref $cv_ref, "B::IV", "Test B::IV return from svref_2object - code"); my $cv_ret = $cv_ref->object_2svref(); is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); is($$cv_ret, $cv, "Test object_2svref()"); my $av = []; my $av_ref = B::svref_2object(\$av); -is(ref $av_ref, "$RV_class", - "Test $RV_class return from svref_2object - array"); +is(ref $av_ref, "B::IV", "Test B::IV return from svref_2object - array"); my $hv = []; my $hv_ref = B::svref_2object(\$hv); -is(ref $hv_ref, "$RV_class", - "Test $RV_class return from svref_2object - hash"); +is(ref $hv_ref, "B::IV", "Test B::IV return from svref_2object - hash"); local *gv = *STDOUT; my $gv_ref = B::svref_2object(\*gv); @@ -298,8 +307,7 @@ is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); -is(B::opnumber("chop"), $] >= 5.015 ? 39 : 38, - "Testing opnumber with opname (chop)"); +is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)"); { no warnings 'once'; @@ -313,9 +321,8 @@ like( B::amagic_generation, qr/^\d+\z/, "amagic_generation" ); is(B::svref_2object(sub {})->ROOT->ppaddr, 'PL_ppaddr[OP_LEAVESUB]', 'OP->ppaddr'); -# This one crashes from perl 5.8.9 to B 1.24 (perl 5.13.6): B::svref_2object(sub{y/\x{100}//})->ROOT->first->first->sibling->sv; -ok 1, 'B knows that UTF trans is a padop in 5.8.9, not an svop'; +ok 1, 'B knows that UTF trans is a padop, not an svop'; { my $o = B::svref_2object(sub{0;0})->ROOT->first->first; @@ -346,13 +353,10 @@ my $bobby = B::svref_2object($sub2)->ROOT->first->first; is $cop->stash->object_2svref, \%main::, 'COP->stash'; is $cop->stashpv, 'main', 'COP->stashpv'; -SKIP: { - skip "no nulls in packages before 5.17", 1 if $] < 5.017; - is $bobby->stashpv, "Pe\0e\x{142}", 'COP->stashpv with utf8 and nulls'; -} +is $bobby->stashpv, "Pe\0e\x{142}", 'COP->stashpv with utf8 and nulls'; SKIP: { - skip "no stashoff", 2 if $] < 5.017 || !$Config::Config{useithreads}; + skip "no stashoff", 2 unless $Config::Config{useithreads}; like $cop->stashoff, qr/^[1-9]\d*\z/a, 'COP->stashoff'; isnt $cop->stashoff, $bobby->stashoff, 'different COP->stashoff for different stashes'; @@ -429,17 +433,9 @@ is $regexp->precomp, 'fit', 'pmregexp returns the right regexp'; ok($gv, "we get a GV from a GV on a normal sub"); isa_ok($gv, "B::GV"); is($gv->NAME, "foo", "check the GV name"); - SKIP: - { # do we need these version checks? - skip "no HEK before 5.18", 1 if $] < 5.018; - is($cv->NAME_HEK, undef, "no hek for a global sub"); - } + is($cv->NAME_HEK, undef, "no hek for a global sub"); } -SKIP: - { - skip "no HEK before 5.18", 4 if $] < 5.018; - eval <<'EOS' { use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; @@ -452,10 +448,6 @@ SKIP: my $gv = $cv->GV; isa_ok($gv, "B::GV", "GV on a lexical sub"); } - 1; -EOS - or die "lexical_subs test failed to compile: $@"; - } } { # [perl #120535] diff --git a/gnu/usr.bin/perl/ext/B/t/concise.t b/gnu/usr.bin/perl/ext/B/t/concise.t index bb1056fe5c2..3541ce3504b 100644 --- a/gnu/usr.bin/perl/ext/B/t/concise.t +++ b/gnu/usr.bin/perl/ext/B/t/concise.t @@ -10,7 +10,7 @@ BEGIN { require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More } -plan tests => 163; +plan tests => 167; require_ok("B::Concise"); @@ -502,4 +502,26 @@ $end =~ s/<NEXT>/$next/; like $out, qr/$end/, 'OP_AND->op_other points correctly'; +# test nextstate hints display + +{ + + $out = runperl( + switches => ["-MO=Concise"], + prog => q{my $x; use strict; use warnings; $x++; use feature q(:5.11); $x++}, + stderr => 1, + ); + + my @hints = $out =~ /nextstate\([^)]+\) (.*) ->/g; + + # handle test script run with PERL_UNICODE="" + s/>,<,// for @hints; + s/%,// for @hints; + + is(scalar(@hints), 3, "3 hints"); + is($hints[0], 'v:{', "hints[0]"); + is($hints[1], 'v:*,&,{,x*,x&,x$,$', "hints[1]"); + is($hints[2], 'v:us,*,&,{,x*,x&,x$,$,fea=7', "hints[2]"); +} + __END__ diff --git a/gnu/usr.bin/perl/ext/B/t/f_map.t b/gnu/usr.bin/perl/ext/B/t/f_map.t index a1cbc38c012..221f2926e2a 100755 --- a/gnu/usr.bin/perl/ext/B/t/f_map.t +++ b/gnu/usr.bin/perl/ext/B/t/f_map.t @@ -108,7 +108,7 @@ checkOptree(note => q{}, # goto 7 # g <0> pushmark s # h <#> gv[*hash] s -# i <1> rv2hv lKRM*/1 +# i <1> rv2hv[t2] lKRM* # j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -130,7 +130,7 @@ EOT_EOT # goto 7 # g <0> pushmark s # h <$> gv(*hash) s -# i <1> rv2hv lKRM*/1 +# i <1> rv2hv[t1] lKRM* # j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -157,7 +157,7 @@ checkOptree(note => q{}, # 4 <0> pushmark s # 5 <0> pushmark s # 6 <#> gv[*hash] s -# 7 <1> rv2hv lKRM*/1 +# 7 <1> rv2hv[t2] lKRM* # 8 <2> aassign[t3] vKS # 9 <;> nextstate(main 476 (eval 10):1) v:{ # a <0> pushmark sM @@ -171,7 +171,7 @@ checkOptree(note => q{}, # g <;> nextstate(main 475 (eval 10):1) v:{ # h <#> gvsv[*_] s # i <#> gv[*hash] s -# j <1> rv2hv sKR/1 +# j <1> rv2hv sKR # k <0> pushmark s # l <#> gvsv[*_] s # m <#> gv[*getkey] s/EARLYCV @@ -190,7 +190,7 @@ EOT_EOT # 4 <0> pushmark s # 5 <0> pushmark s # 6 <$> gv(*hash) s -# 7 <1> rv2hv lKRM*/1 +# 7 <1> rv2hv[t1] lKRM* # 8 <2> aassign[t2] vKS # 9 <;> nextstate(main 560 (eval 15):1) v:{ # a <0> pushmark sM @@ -204,7 +204,7 @@ EOT_EOT # g <;> nextstate(main 559 (eval 15):1) v:{ # h <$> gvsv(*_) s # i <$> gv(*hash) s -# j <1> rv2hv sKR/1 +# j <1> rv2hv sKR # k <0> pushmark s # l <$> gvsv(*_) s # m <$> gv(*getkey) s/EARLYCV @@ -243,7 +243,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t10] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -260,7 +260,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t6] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -289,7 +289,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t10] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -306,7 +306,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t6] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -335,7 +335,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t9] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -352,7 +352,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t5] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -381,7 +381,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t8] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -398,7 +398,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t5] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -426,7 +426,7 @@ checkOptree(note => q{}, # goto 7 # a <0> pushmark s # b <#> gv[*hash] s -# c <1> rv2hv lKRM*/1 +# c <1> rv2hv[t2] lKRM* # d <2> aassign[t6] KS/COM_AGG # e <#> gv[*array] s # f <1> rv2av[t8] K/1 @@ -445,7 +445,7 @@ EOT_EOT # goto 7 # a <0> pushmark s # b <$> gv(*hash) s -# c <1> rv2hv lKRM*/1 +# c <1> rv2hv[t1] lKRM* # d <2> aassign[t4] KS/COM_AGG # e <$> gv(*array) s # f <1> rv2av[t5] K/1 diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort.t b/gnu/usr.bin/perl/ext/B/t/f_sort.t index eda5a21cc58..24a9f2e38c6 100755 --- a/gnu/usr.bin/perl/ext/B/t/f_sort.t +++ b/gnu/usr.bin/perl/ext/B/t/f_sort.t @@ -13,7 +13,7 @@ BEGIN { } } use OptreeCheck; -plan tests => 40; +plan tests => 38; =head1 f_sort.t @@ -129,8 +129,7 @@ checkOptree(note => q{}, # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*files] s -# 5 <1> rv2av[t9] lK/1 < 5.019002 -# 5 <1> rv2av[t9] lKM/1 >=5.019002 +# 5 <1> rv2av[t9] lKM/1 # 6 <@> sort lKS* # 7 <0> pushmark s # 8 <#> gv[*articles] s @@ -142,8 +141,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*files) s -# 5 <1> rv2av[t5] lK/1 < 5.019002 -# 5 <1> rv2av[t5] lKM/1 >=5.019002 +# 5 <1> rv2av[t5] lKM/1 # 6 <@> sort lKS* # 7 <0> pushmark s # 8 <$> gv(*articles) s @@ -280,10 +278,8 @@ checkOptree(note => q{}, # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*age] s -# 5 <1> rv2hv[t9] lKRM/1 < 5.019006 -# 5 <1> rv2hv lKRM/1 >=5.019006 -# 6 <1> keys[t10] lK/1 < 5.019002 -# 6 <1> keys[t10] lKM/1 >=5.019002 +# 5 <1> rv2hv[t9] lKRM +# 6 <1> keys[t10] lKM/1 # 7 <@> sort lKS* # 8 <0> pushmark s # 9 <#> gv[*eldest] s @@ -295,10 +291,8 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*age) s -# 5 <1> rv2hv[t3] lKRM/1 < 5.019006 -# 5 <1> rv2hv lKRM/1 >=5.019006 -# 6 <1> keys[t4] lK/1 < 5.019002 -# 6 <1> keys[t4] lKM/1 >=5.019002 +# 5 <1> rv2hv[t3] lKRM +# 6 <1> keys[t4] lKM/1 # 7 <@> sort lKS* # 8 <0> pushmark s # 9 <$> gv(*eldest) s @@ -327,8 +321,7 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <$> const[PV "byage"] s/BARE # 5 <#> gv[*class] s -# 6 <1> rv2av[t4] lK/1 < 5.019002 -# 6 <1> rv2av[t4] lKM/1 >=5.019002 +# 6 <1> rv2av[t4] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <#> gv[*sortedclass] s @@ -341,8 +334,7 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> const(PV "byage") s/BARE # 5 <$> gv(*class) s -# 6 <1> rv2av[t2] lK/1 < 5.019002 -# 6 <1> rv2av[t2] lKM/1 >=5.019002 +# 6 <1> rv2av[t2] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <$> gv(*sortedclass) s @@ -408,8 +400,7 @@ checkOptree(name => q{sort USERSUB LIST }, # w <0> pushmark s # x <$> const[PV "backwards"] s/BARE # y <#> gv[*harry] s -# z <1> rv2av[t10] lK/1 < 5.019002 -# z <1> rv2av[t10] lKM/1 >=5.019002 +# z <1> rv2av[t10] lKM/1 # 10 <@> sort lKS # 11 <@> print vK # 12 <;> nextstate(main 602 (eval 32):5) v:{ @@ -458,8 +449,7 @@ EOT_EOT # w <0> pushmark s # x <$> const(PV "backwards") s/BARE # y <$> gv(*harry) s -# z <1> rv2av[t6] lK/1 < 5.019002 -# z <1> rv2av[t6] lKM/1 >=5.019002 +# z <1> rv2av[t6] lKM/1 # 10 <@> sort lKS # 11 <@> print vK # 12 <;> nextstate(main 602 (eval 32):5) v:{ @@ -516,7 +506,7 @@ checkOptree(name => q{Compound sort/map Expression }, # b <;> nextstate(main 608 (eval 34):2) v:{ # c <0> pushmark s # d <#> gvsv[*_] s -# e </> match(/"=(\\d+)"/) l/RTIME +# e </> match(/"=(\\d+)"/) l # f <#> gvsv[*_] s # g <1> uc[t17] sK/1 # h <@> anonlist sK*/1 @@ -546,7 +536,7 @@ EOT_EOT # b <;> nextstate(main 608 (eval 34):2) v:{ # c <0> pushmark s # d <$> gvsv(*_) s -# e </> match(/"=(\\d+)"/) l/RTIME +# e </> match(/"=(\\d+)"/) l # f <$> gvsv(*_) s # g <1> uc[t9] sK/1 # h <@> anonlist sK*/1 @@ -586,8 +576,7 @@ checkOptree(name => q{sort other::sub LIST }, # 3 <0> pushmark s # 4 <$> const[PV "other::backwards"] s/BARE # 5 <#> gv[*old] s -# 6 <1> rv2av[t4] lK/1 < 5.019002 -# 6 <1> rv2av[t4] lKM/1 >=5.019002 +# 6 <1> rv2av[t4] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <#> gv[*new] s @@ -600,8 +589,7 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> const(PV "other::backwards") s/BARE # 5 <$> gv(*old) s -# 6 <1> rv2av[t2] lK/1 < 5.019002 -# 6 <1> rv2av[t2] lKM/1 >=5.019002 +# 6 <1> rv2av[t2] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <$> gv(*new) s @@ -628,8 +616,7 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <$> const[PV "other::backwards"] s/BARE # 5 <#> gv[*old] s -# 6 <1> rv2av[t4] lK/1 < 5.019002 -# 6 <1> rv2av[t4] lKM/1 >=5.019002 +# 6 <1> rv2av[t4] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <#> gv[*new] s @@ -642,8 +629,7 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> const(PV "other::backwards") s/BARE # 5 <$> gv(*old) s -# 6 <1> rv2av[t2] lK/1 < 5.019002 -# 6 <1> rv2av[t2] lKM/1 >=5.019002 +# 6 <1> rv2av[t2] lKM/1 # 7 <@> sort lKS # 8 <0> pushmark s # 9 <$> gv(*new) s @@ -666,8 +652,7 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT'); # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*old] s -# 5 <1> rv2av[t9] lK/1 < 5.019002 -# 5 <1> rv2av[t9] lKM/1 >=5.019002 +# 5 <1> rv2av[t9] lKM/1 # 6 <@> sort lKS*/STABLE # 7 <0> pushmark s # 8 <#> gv[*new] s @@ -679,8 +664,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*old) s -# 5 <1> rv2av[t5] lK/1 < 5.019002 -# 5 <1> rv2av[t5] lKM/1 >=5.019002 +# 5 <1> rv2av[t5] lKM/1 # 6 <@> sort lKS*/STABLE # 7 <0> pushmark s # 8 <$> gv(*new) s @@ -697,46 +681,6 @@ checkOptree(note => q{}, =for gentest -# chunk: # force use of mergesort (not portable outside Perl 5.8) -use sort '_mergesort'; -@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; - -=cut - -checkOptree(note => q{}, - bcopts => q{-exec}, - code => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; }, - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 1 <;> nextstate(main 662 (eval 42):1) v:%,{ -# 2 <0> pushmark s -# 3 <0> pushmark s -# 4 <#> gv[*old] s -# 5 <1> rv2av[t9] lK/1 < 5.019002 -# 5 <1> rv2av[t9] lKM/1 >=5.019002 -# 6 <@> sort lKS* -# 7 <0> pushmark s -# 8 <#> gv[*new] s -# 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t14] KS/COM_AGG -# b <1> leavesub[1 ref] K/REFC,1 -EOT_EOT -# 1 <;> nextstate(main 578 (eval 15):1) v:%,{ -# 2 <0> pushmark s -# 3 <0> pushmark s -# 4 <$> gv(*old) s -# 5 <1> rv2av[t5] lK/1 < 5.019002 -# 5 <1> rv2av[t5] lKM/1 >=5.019002 -# 6 <@> sort lKS* -# 7 <0> pushmark s -# 8 <$> gv(*new) s -# 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t6] KS/COM_AGG -# b <1> leavesub[1 ref] K/REFC,1 -EONT_EONT - - -=for gentest - # chunk: # you should have a good reason to do this! @articles = sort {$FooPack::b <=> $FooPack::a} @files; @@ -750,8 +694,7 @@ checkOptree(note => q{}, # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*files] s -# 5 <1> rv2av[t7] lK/1 < 5.019002 -# 5 <1> rv2av[t7] lKM/1 >=5.019002 +# 5 <1> rv2av[t7] lKM/1 # 6 <@> sort lKS* # 7 <0> pushmark s # 8 <#> gv[*articles] s @@ -763,8 +706,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*files) s -# 5 <1> rv2av[t3] lK/1 < 5.019002 -# 5 <1> rv2av[t3] lKM/1 >=5.019002 +# 5 <1> rv2av[t3] lKM/1 # 6 <@> sort lKS* # 7 <0> pushmark s # 8 <$> gv(*articles) s @@ -791,13 +733,11 @@ checkOptree(note => q{}, # 4 <0> pushmark s # 5 <#> gv[*input] s # 6 <1> rv2av[t9] lKM/1 -# 7 <@> grepstart lK* < 5.017002 -# 7 <@> grepstart lK >=5.017002 +# 7 <@> grepstart lK # 8 <|> grepwhile(other->9)[t10] lK # 9 <#> gvsv[*_] s # a <#> gvsv[*_] s # b <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 8 # c <@> sort lK/NUM # d <0> pushmark s @@ -812,13 +752,11 @@ EOT_EOT # 4 <0> pushmark s # 5 <$> gv(*input) s # 6 <1> rv2av[t3] lKM/1 -# 7 <@> grepstart lK* < 5.017002 -# 7 <@> grepstart lK >=5.017002 +# 7 <@> grepstart lK # 8 <|> grepwhile(other->9)[t4] lK # 9 <$> gvsv(*_) s # a <$> gvsv(*_) s # b <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 8 # c <@> sort lK/NUM # d <0> pushmark s @@ -872,13 +810,11 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*input] s # 5 <1> rv2av[t7] lKM/1 -# 6 <@> grepstart lK* < 5.017002 -# 6 <@> grepstart lK >=5.017002 +# 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t8] lK # 8 <#> gvsv[*_] s # 9 <#> gvsv[*_] s # a <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 7 # b <@> sort K/NUM # c <1> leavesub[1 ref] K/REFC,1 @@ -888,13 +824,11 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> gv(*input) s # 5 <1> rv2av[t2] lKM/1 -# 6 <@> grepstart lK* < 5.017002 -# 6 <@> grepstart lK >=5.017002 +# 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t3] lK # 8 <$> gvsv(*_) s # 9 <$> gvsv(*_) s # a <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 7 # b <@> sort K/NUM # c <1> leavesub[1 ref] K/REFC,1 @@ -947,13 +881,11 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*input] s # 5 <1> rv2av[t8] lKM/1 -# 6 <@> grepstart lK* < 5.017002 -# 6 <@> grepstart lK >=5.017002 +# 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t9] lK # 8 <#> gvsv[*_] s # 9 <#> gvsv[*_] s # a <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 7 # b <@> sort sK/NUM # c <#> gvsv[*s] s @@ -965,13 +897,11 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> gv(*input) s # 5 <1> rv2av[t2] lKM/1 -# 6 <@> grepstart lK* < 5.017002 -# 6 <@> grepstart lK >=5.017002 +# 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t3] lK # 8 <$> gvsv(*_) s # 9 <$> gvsv(*_) s # a <2> eq sK/2 -# - <@> scope sK < 5.017002 # goto 7 # b <@> sort sK/NUM # c <$> gvsv(*s) s diff --git a/gnu/usr.bin/perl/ext/B/t/optree_concise.t b/gnu/usr.bin/perl/ext/B/t/optree_concise.t index 12781acdb82..1e2594703fe 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_concise.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_concise.t @@ -183,13 +183,13 @@ checkOptree ( name => "terse basic", UNOP (0x82b0918) leavesub [1] LISTOP (0x82b08d8) lineseq COP (0x82b0880) nextstate - UNOP (0x82b0860) null [15] + UNOP (0x82b0860) null [14] PADOP (0x82b0840) gvsv GV (0x82a818c) *a EOT_EOT # UNOP (0x8282310) leavesub [1] # LISTOP (0x82822f0) lineseq # COP (0x82822b8) nextstate -# UNOP (0x812fc20) null [15] +# UNOP (0x812fc20) null [14] # SVOP (0x812fc00) gvsv GV (0x814692c) *a EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_misc.t b/gnu/usr.bin/perl/ext/B/t/optree_misc.t index 2d6b80f820b..f8ff3ce9689 100644 --- a/gnu/usr.bin/perl/ext/B/t/optree_misc.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_misc.t @@ -37,11 +37,11 @@ checkOptree ( name => 'OP_AELEMFAST opclass', # 3 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->4 # 6 <2> add[t6] sK/2 ->7 # - <1> ex-aelem sK/2 ->5 -# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5 +# 4 <0> aelemfast_lex[@x:634,636] sR/key=127 ->5 # - <0> ex-const s ->- # - <1> ex-aelem sK/2 ->6 # - <1> ex-rv2av sKR/1 ->- -# 5 <#> aelemfast[*y] s/128 ->6 +# 5 <#> aelemfast[*y] s/key=128 ->6 # - <0> ex-const s/FOLD ->- EOT_EOT # 7 <1> leavesub[1 ref] K/REFC,1 ->(end) @@ -54,41 +54,18 @@ EOT_EOT # 3 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->4 # 6 <2> add[t4] sK/2 ->7 # - <1> ex-aelem sK/2 ->5 -# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5 +# 4 <0> aelemfast_lex[@x:634,636] sR/key=127 ->5 # - <0> ex-const s ->- # - <1> ex-aelem sK/2 ->6 # - <1> ex-rv2av sKR/1 ->- -# 5 <$> aelemfast(*y) s/128 ->6 +# 5 <$> aelemfast(*y) s/key=128 ->6 # - <0> ex-const s/FOLD ->- EONT_EONT checkOptree ( name => 'PMOP children', code => sub { $foo =~ s/(a)/$1/ }, strip_open_hints => 1, - ( $] < 5.017002 - ? (expect => <<'EOT_EOT16', expect_nt => <<'EONT_EONT16') -# 6 <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->6 -# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2 -# 3 </> subst(/"(a)"/ replstart->4) KS ->6 -# - <1> ex-rv2sv sKRM/1 ->3 -# 2 <#> gvsv[*foo] s ->3 -# 5 <|> substcont(other->3) sK/1 ->(end) -# - <1> ex-rv2sv sK/1 ->5 -# 4 <#> gvsv[*1] s ->5 -EOT_EOT16 -# 6 <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->6 -# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2 -# 3 </> subst(/"(a)"/ replstart->4) KS ->6 -# - <1> ex-rv2sv sKRM/1 ->3 -# 2 <$> gvsv(*foo) s ->3 -# 5 <|> substcont(other->3) sK/1 ->(end) -# - <1> ex-rv2sv sK/1 ->5 -# 4 <$> gvsv(*1) s ->5 -EONT_EONT16 - - : (expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'))); + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->5 # 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2 @@ -149,7 +126,6 @@ checkOptree ( name => 'formats', bcopts => 'STDOUT', progfile => $tmpfile, strip_open_hints => 1, - skip => ($] < 5.017003), expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # main::STDOUT (FORMAT): # c <1> leavewrite[1 ref] K/REFC,1 ->(end) @@ -195,19 +171,18 @@ EONT_EONT checkOptree ( name => 'padrange', code => sub { my ($x,$y); @a = ($x,$y); ($x,$y) = @a }, strip_open_hints => 1, - skip => ($] < 5.017006), expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # f <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->f # 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2 # - <@> list vKP ->3 -# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3 +# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,range=2 ->3 # - <0> padsv[$x:1,2] vM/LVINTRO ->- # - <0> padsv[$y:1,2] vM/LVINTRO ->- # 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4 # 8 <2> aassign[t4] vKS/COM_AGG ->9 # - <1> ex-list lKP ->5 -# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5 +# 4 <0> padrange[$x:1,2; $y:1,2] /range=2 ->5 # - <0> padsv[$x:1,2] s ->- # - <0> padsv[$y:1,2] s ->- # - <1> ex-list lK ->8 @@ -221,7 +196,7 @@ checkOptree ( name => 'padrange', # c <1> rv2av[t5] lK/1 ->d # b <#> gv[*a] s ->c # - <1> ex-list lKPRM* ->e -# d <0> padrange[$x:1,2; $y:1,2] RM/2 ->e +# d <0> padrange[$x:1,2; $y:1,2] RM/range=2 ->e # - <0> padsv[$x:1,2] sRM* ->- # - <0> padsv[$y:1,2] sRM* ->- EOT_EOT @@ -229,13 +204,13 @@ EOT_EOT # - <@> lineseq KP ->f # 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2 # - <@> list vKP ->3 -# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3 +# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,range=2 ->3 # - <0> padsv[$x:1,2] vM/LVINTRO ->- # - <0> padsv[$y:1,2] vM/LVINTRO ->- # 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4 # 8 <2> aassign[t4] vKS/COM_AGG ->9 # - <1> ex-list lKP ->5 -# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5 +# 4 <0> padrange[$x:1,2; $y:1,2] /range=2 ->5 # - <0> padsv[$x:1,2] s ->- # - <0> padsv[$y:1,2] s ->- # - <1> ex-list lK ->8 @@ -249,7 +224,7 @@ EOT_EOT # c <1> rv2av[t5] lK/1 ->d # b <$> gv(*a) s ->c # - <1> ex-list lKPRM* ->e -# d <0> padrange[$x:1,2; $y:1,2] RM/2 ->e +# d <0> padrange[$x:1,2; $y:1,2] RM/range=2 ->e # - <0> padsv[$x:1,2] sRM* ->- # - <0> padsv[$y:1,2] sRM* ->- EONT_EONT @@ -261,14 +236,13 @@ checkOptree ( name => 'padrange and @_', my ($e,$f) = @_; }, strip_open_hints => 1, - skip => ($] < 5.017006), expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # d <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->d # 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2 # 3 <2> aassign[t5] vKS ->4 # - <1> ex-list lK ->- -# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3 +# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,range=2 ->3 # - <1> rv2av[t4] lK/1 ->- # - <#> gv[*_] s ->- # - <1> ex-list lKPRM* ->3 @@ -282,13 +256,13 @@ checkOptree ( name => 'padrange and @_', # 7 <1> rv2av[t9] lK/1 ->8 # 6 <#> gv[*X::_] s ->7 # - <1> ex-list lKPRM* ->9 -# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,2 ->9 +# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,range=2 ->9 # - <0> padsv[$c:2,4] sRM*/LVINTRO ->- # - <0> padsv[$d:2,4] sRM*/LVINTRO ->- # a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b # c <2> aassign[t15] KS ->d # - <1> ex-list lK ->- -# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c +# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,range=2 ->c # - <1> rv2av[t14] lK/1 ->- # - <#> gv[*_] s ->- # - <1> ex-list lKPRM* ->c @@ -301,7 +275,7 @@ EOT_EOT # 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2 # 3 <2> aassign[t5] vKS ->4 # - <1> ex-list lK ->- -# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3 +# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,range=2 ->3 # - <1> rv2av[t4] lK/1 ->- # - <$> gv(*_) s ->- # - <1> ex-list lKPRM* ->3 @@ -315,13 +289,13 @@ EOT_EOT # 7 <1> rv2av[t9] lK/1 ->8 # 6 <$> gv(*X::_) s ->7 # - <1> ex-list lKPRM* ->9 -# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,2 ->9 +# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,range=2 ->9 # - <0> padsv[$c:2,4] sRM*/LVINTRO ->- # - <0> padsv[$d:2,4] sRM*/LVINTRO ->- # a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b # c <2> aassign[t15] KS ->d # - <1> ex-list lK ->- -# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c +# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,range=2 ->c # - <1> rv2av[t14] lK/1 ->- # - <$> gv(*_) s ->- # - <1> ex-list lKPRM* ->c @@ -333,13 +307,12 @@ EONT_EONT checkOptree ( name => 'consolidate padranges', code => sub { my ($a,$b); my ($c,$d); 1 }, strip_open_hints => 1, - skip => ($] < 5.017006), expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->5 # 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2 # - <@> list vKP ->- -# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3 +# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,range=4 ->3 # - <0> padsv[$a:900,902] vM/LVINTRO ->- # - <0> padsv[$b:900,902] vM/LVINTRO ->- # - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->- @@ -354,7 +327,7 @@ EOT_EOT # - <@> lineseq KP ->5 # 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2 # - <@> list vKP ->- -# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3 +# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,range=4 ->3 # - <0> padsv[$a:900,902] vM/LVINTRO ->- # - <0> padsv[$b:900,902] vM/LVINTRO ->- # - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->- @@ -371,13 +344,12 @@ checkOptree ( name => 'consolidate padranges and singletons', code => sub { my ($a,$b); my $c; my ($d,$e); my @f; my $g; my ($h,$i); my %j; 1 }, strip_open_hints => 1, - skip => ($] < 5.017006), expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->5 # 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2 # - <@> list vKP ->- -# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3 +# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,range=10 ->3 # - <0> padsv[$a:903,910] vM/LVINTRO ->- # - <0> padsv[$b:903,910] vM/LVINTRO ->- # - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->- @@ -405,7 +377,7 @@ EOT_EOT # - <@> lineseq KP ->5 # 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2 # - <@> list vKP ->- -# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3 +# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,range=10 ->3 # - <0> padsv[$a:903,910] vM/LVINTRO ->- # - <0> padsv[$b:903,910] vM/LVINTRO ->- # - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->- @@ -438,12 +410,12 @@ checkOptree ( name => 'm?x?', # 3 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->3 # 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2 -# 2 </> match(/"x"/) /RTIME ->3 +# 2 </> match(/"x"/) ->3 EOT_EOT # 3 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->3 # 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2 -# 2 </> match(/"x"/) /RTIME ->3 +# 2 </> match(/"x"/) ->3 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_samples.t b/gnu/usr.bin/perl/ext/B/t/optree_samples.t index c6288d940b7..15b5799ce08 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_samples.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_samples.t @@ -240,38 +240,36 @@ checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->d last->g redo->7) KS/DEF -# e <0> iter s -# f <|> and(other->7) K/1 -# 7 <;> nextstate(main 442 optree.t:158) v:>,<,% +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF +# d <0> iter s +# e <|> and(other->7) K/1 +# 7 <;> nextstate(main 1659 optree_samples.t:234) v:>,<,% # 8 <0> pushmark s -# 9 <$> const[PV "foo "] s -# a <#> gvsv[*_] s -# b <2> concat[t4] sK/2 -# c <@> print vK -# d <0> unstack s -# goto e -# g <2> leaveloop K/2 -# h <1> leavesub[1 ref] K/REFC,1 +# 9 <#> gvsv[*_] s +# a <+> multiconcat("foo ",4,-1)[t5] sK/STRINGIFY +# b <@> print vK +# c <0> unstack s +# goto d +# f <2> leaveloop K/2 +# g <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 444 optree_samples.t:182) v:>,<,% # 2 <0> pushmark s # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->d last->g redo->7) KS/DEF -# e <0> iter s -# f <|> and(other->7) K/1 +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF +# d <0> iter s +# e <|> and(other->7) K/1 # 7 <;> nextstate(main 443 optree_samples.t:182) v:>,<,% # 8 <0> pushmark s -# 9 <$> const(PV "foo ") s -# a <$> gvsv(*_) s -# b <2> concat[t3] sK/2 -# c <@> print vK -# d <0> unstack s -# goto e -# g <2> leaveloop K/2 -# h <1> leavesub[1 ref] K/REFC,1 +# 9 <$> gvsv(*_) s +# a <+> multiconcat("foo ",4,-1)[t4] sK/STRINGIFY +# b <@> print vK +# c <0> unstack s +# goto d +# f <2> leaveloop K/2 +# g <1> leavesub[1 ref] K/REFC,1 EONT_EONT checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', @@ -279,55 +277,53 @@ checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', bcopts => '-basic', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# g <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->g +# f <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->f # 1 <;> nextstate(main 445 optree.t:167) v:>,<,% ->2 -# f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) KS/DEF ->d +# e <2> leaveloop K/2 ->f +# 6 <{> enteriter(next->b last->e redo->7) KS/DEF ->c # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 # 3 <$> const[IV 1] s ->4 # 4 <$> const[IV 10] s ->5 # 5 <#> gv[*_] s ->6 -# - <1> null K/1 ->f -# e <|> and(other->7) K/1 ->f -# d <0> iter s ->e +# - <1> null K/1 ->e +# d <|> and(other->7) K/1 ->e +# c <0> iter s ->d # - <@> lineseq sK ->- -# b <@> print vK ->c +# a <@> print vK ->b # 7 <0> pushmark s ->8 -# - <1> ex-stringify sK/1 ->b -# - <0> ex-pushmark s ->8 -# a <2> concat[t2] sK/2 ->b -# 8 <$> const[PV "foo "] s ->9 -# - <1> ex-rv2sv sK/1 ->a -# 9 <#> gvsv[*_] s ->a -# c <0> unstack s ->d +# 9 <+> multiconcat("foo ",4,-1)[t3] sK/STRINGIFY ->a +# - <0> ex-pushmark s ->- +# - <0> ex-const s ->8 +# - <1> ex-rv2sv sK/1 ->9 +# 8 <#> gvsv[*_] s ->9 +# b <0> unstack s ->c EOT_EOT -# g <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->g +# f <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->f # 1 <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2 -# f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) KS/DEF ->d +# e <2> leaveloop K/2 ->f +# 6 <{> enteriter(next->b last->e redo->7) KS/DEF ->c # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 # 3 <$> const(IV 1) s ->4 # 4 <$> const(IV 10) s ->5 # 5 <$> gv(*_) s ->6 -# - <1> null K/1 ->f -# e <|> and(other->7) K/1 ->f -# d <0> iter s ->e +# - <1> null K/1 ->e +# d <|> and(other->7) K/1 ->e +# c <0> iter s ->d # - <@> lineseq sK ->- -# b <@> print vK ->c +# a <@> print vK ->b # 7 <0> pushmark s ->8 -# - <1> ex-stringify sK/1 ->b -# - <0> ex-pushmark s ->8 -# a <2> concat[t1] sK/2 ->b -# 8 <$> const(PV "foo ") s ->9 -# - <1> ex-rv2sv sK/1 ->a -# 9 <$> gvsv(*_) s ->a -# c <0> unstack s ->d +# 9 <+> multiconcat("foo ",4,-1)[t2] sK/STRINGIFY ->a +# - <0> ex-pushmark s ->- +# - <0> ex-const s ->8 +# - <1> ex-rv2sv sK/1 ->9 +# 8 <$> gvsv(*_) s ->9 +# b <0> unstack s ->c EONT_EONT checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', @@ -341,19 +337,18 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', # 4 <$> const[IV 1] s # 5 <$> const[IV 10] s # 6 <#> gv[*_] s -# 7 <{> enteriter(next->e last->h redo->8) vKS/DEF -# f <0> iter s -# g <|> and(other->8) vK/1 +# 7 <{> enteriter(next->d last->g redo->8) vKS/DEF +# e <0> iter s +# f <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% # 9 <0> pushmark s -# a <$> const[PV "foo "] s -# b <#> gvsv[*_] s -# c <2> concat[t4] sK/2 -# d <@> print vK -# e <0> unstack v -# goto f -# h <2> leaveloop vK/2 -# i <@> leave[1 ref] vKP/REFC +# a <#> gvsv[*_] s +# b <+> multiconcat("foo ",4,-1)[t5] sK/STRINGIFY +# c <@> print vK +# d <0> unstack v +# goto e +# g <2> leaveloop vK/2 +# h <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -361,19 +356,18 @@ EOT_EOT # 4 <$> const(IV 1) s # 5 <$> const(IV 10) s # 6 <$> gv(*_) s -# 7 <{> enteriter(next->e last->h redo->8) vKS/DEF -# f <0> iter s -# g <|> and(other->8) vK/1 +# 7 <{> enteriter(next->d last->g redo->8) vKS/DEF +# e <0> iter s +# f <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% # 9 <0> pushmark s -# a <$> const(PV "foo ") s -# b <$> gvsv(*_) s -# c <2> concat[t3] sK/2 -# d <@> print vK -# e <0> unstack v -# goto f -# h <2> leaveloop vK/2 -# i <@> leave[1 ref] vKP/REFC +# a <$> gvsv(*_) s +# b <+> multiconcat("foo ",4,-1)[t4] sK/STRINGIFY +# c <@> print vK +# d <0> unstack v +# goto e +# g <2> leaveloop vK/2 +# h <@> leave[1 ref] vKP/REFC EONT_EONT checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', @@ -386,36 +380,34 @@ checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->c last->f redo->7) KS/DEF -# d <0> iter s -# e <|> and(other->7) K/1 +# 6 <{> enteriter(next->b last->e redo->7) KS/DEF +# c <0> iter s +# d <|> and(other->7) K/1 # 7 <0> pushmark s -# 8 <$> const[PV "foo "] s -# 9 <#> gvsv[*_] s -# a <2> concat[t2] sK/2 -# b <@> print vK -# c <0> unstack s -# goto d -# f <2> leaveloop K/2 -# g <1> leavesub[1 ref] K/REFC,1 +# 8 <#> gvsv[*_] s +# 9 <+> multiconcat("foo ",4,-1)[t3] sK/STRINGIFY +# a <@> print vK +# b <0> unstack s +# goto c +# e <2> leaveloop K/2 +# f <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 447 optree_samples.t:252) v:>,<,% # 2 <0> pushmark s # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->c last->f redo->7) KS/DEF -# d <0> iter s -# e <|> and(other->7) K/1 +# 6 <{> enteriter(next->b last->e redo->7) KS/DEF +# c <0> iter s +# d <|> and(other->7) K/1 # 7 <0> pushmark s -# 8 <$> const(PV "foo ") s -# 9 <$> gvsv(*_) s -# a <2> concat[t1] sK/2 -# b <@> print vK -# c <0> unstack s -# goto d -# f <2> leaveloop K/2 -# g <1> leavesub[1 ref] K/REFC,1 +# 8 <$> gvsv(*_) s +# 9 <+> multiconcat("foo ",4,-1)[t2] sK/STRINGIFY +# a <@> print vK +# b <0> unstack s +# goto c +# e <2> leaveloop K/2 +# f <1> leavesub[1 ref] K/REFC,1 EONT_EONT pass("GREP: SAMPLES FROM PERLDOC -F GREP"); @@ -431,7 +423,7 @@ checkOptree ( name => '@foo = grep(!/^\#/, @bar)', # 5 <1> rv2av[t4] lKM/1 # 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t5] lK -# 8 </> match(/"^#"/) s/RTIME +# 8 </> match(/"^#"/) s # 9 <1> not sK/1 # goto 7 # a <0> pushmark s @@ -447,7 +439,7 @@ EOT_EOT # 5 <1> rv2av[t2] lKM/1 # 6 <@> grepstart lK # 7 <|> grepwhile(other->8)[t3] lK -# 8 </> match(/"^\\#"/) s/RTIME +# 8 </> match(/"^\\#"/) s # 9 <1> not sK/1 # goto 7 # a <0> pushmark s @@ -469,8 +461,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # 3 <0> pushmark s # 4 <#> gv[*a] s # 5 <1> rv2av[t8] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t9] lK # 8 <0> enter l # 9 <;> nextstate(main 500 (eval 22):1) v:{ @@ -483,8 +474,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # goto 7 # g <0> pushmark s # h <#> gv[*h] s -# i <1> rv2hv[t2] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 +# i <1> rv2hv[t2] lKRM* # j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -493,8 +483,7 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> gv(*a) s # 5 <1> rv2av[t3] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t4] lK # 8 <0> enter l # 9 <;> nextstate(main 500 (eval 22):1) v:{ @@ -507,8 +496,7 @@ EOT_EOT # goto 7 # g <0> pushmark s # h <$> gv(*h) s -# i <1> rv2hv[t1] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 +# i <1> rv2hv[t1] lKRM* # j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -521,8 +509,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*h] s -# 5 <1> rv2hv[t2] lKRM*/1 < 5.019006 -# 5 <1> rv2hv lKRM*/1 >=5.019006 +# 5 <1> rv2hv[t2] lKRM* # 6 <2> aassign[t3] vKS # 7 <;> nextstate(main 506 (eval 24):1) v:{ # 8 <0> pushmark sM @@ -536,7 +523,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # e <;> nextstate(main 505 (eval 24):1) v:{ # f <#> gvsv[*_] s # g <#> gv[*h] s -# h <1> rv2hv sKR/1 +# h <1> rv2hv sKR # i <0> pushmark s # j <#> gvsv[*_] s # k <#> gv[*getkey] s/EARLYCV @@ -552,8 +539,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*h) s -# 5 <1> rv2hv[t1] lKRM*/1 < 5.019006 -# 5 <1> rv2hv lKRM*/1 >=5.019006 +# 5 <1> rv2hv[t1] lKRM* # 6 <2> aassign[t2] vKS # 7 <;> nextstate(main 506 (eval 24):1) v:{ # 8 <0> pushmark sM @@ -567,7 +553,7 @@ EOT_EOT # e <;> nextstate(main 505 (eval 24):1) v:{ # f <$> gvsv(*_) s # g <$> gv(*h) s -# h <1> rv2hv sKR/1 +# h <1> rv2hv sKR # i <0> pushmark s # j <$> gvsv(*_) s # k <$> gv(*getkey) s/EARLYCV @@ -586,7 +572,7 @@ checkOptree ( name => 'map $_+42, 10..20', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 497 (eval 20):1) v # 2 <0> pushmark s -# 3 <$> const[AV ] s +# 3 <$> const[AV ARRAY] s # 4 <1> rv2av lKPM/1 # 5 <@> mapstart K # 6 <|> mapwhile(other->7)[t5] K @@ -598,7 +584,7 @@ checkOptree ( name => 'map $_+42, 10..20', EOT_EOT # 1 <;> nextstate(main 511 (eval 26):1) v # 2 <0> pushmark s -# 3 <$> const(AV ) s +# 3 <$> const(AV ARRAY) s # 4 <1> rv2av lKPM/1 # 5 <@> mapstart K # 6 <|> mapwhile(other->7)[t4] K @@ -619,16 +605,14 @@ checkOptree ( name => '-e use constant j => qq{junk}; print j', # 1 <0> enter # 2 <;> nextstate(main 71 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <$> const[PV "junk"] s* < 5.017002 -# 4 <$> const[PV "junk"] s*/FOLD >=5.017002 +# 4 <$> const[PV "junk"] s*/FOLD # 5 <@> print vK # 6 <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter # 2 <;> nextstate(main 71 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <$> const(PV "junk") s* < 5.017002 -# 4 <$> const(PV "junk") s*/FOLD >=5.017002 +# 4 <$> const(PV "junk") s*/FOLD # 5 <@> print vK # 6 <@> leave[1 ref] vKP/REFC EONT_EONT @@ -710,13 +694,13 @@ checkOptree ( name => 'my $a; my @b; my %c; return 1', bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 991 (eval 17):1) v -# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,3 +# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,range=3 # 3 <;> nextstate(main 994 (eval 17):1) v:{ # 4 <$> const[IV 1] s # 5 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 991 (eval 17):1) v -# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,3 +# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,range=3 # 3 <;> nextstate(main 994 (eval 17):1) v:{ # 4 <$> const(IV 1) s # 5 <1> leavesub[1 ref] K/REFC,1 diff --git a/gnu/usr.bin/perl/ext/B/t/optree_specials.t b/gnu/usr.bin/perl/ext/B/t/optree_specials.t index d7200db9894..96e430e3030 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_specials.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_specials.t @@ -6,6 +6,12 @@ # output is matched losely. If the match fails even though the "got" and # "expected" output look exactly the same, then watch for trailing, invisible # spaces. +# +# Note that if this test is mysteriously failing smokes and is hard to +# reproduce, try running with LC_ALL=en_US.UTF-8 PERL_UNICODE="". +# This causes nextstate ops to have a bunch of extra hint info, which +# needs adding to the expected output (for both thraded and non-threaded +# versions) BEGIN { unshift @INC, 't'; @@ -39,108 +45,183 @@ checkOptree ( name => 'BEGIN', prog => $src, strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# BEGIN 1: -# a <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->a -# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2 -# 3 <1> require sK/1 ->4 -# 2 <$> const[PV "strict.pm"] s/BARE ->3 -# - <;> ex-nextstate(B::Concise -837 Concise.pm:366) v:*,&,{,x*,x&,x$,$ ->4 -# - <@> lineseq K ->- -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ ->5 -# 9 <1> entersub[t1] KS*/TARG,STRICT ->a -# 5 <0> pushmark s ->6 -# 6 <$> const[PV "strict"] sM ->7 -# 7 <$> const[PV "refs"] sM ->8 -# 8 <.> method_named[PV "unimport"] ->9 +# - <@> lineseq KP ->7 +# 1 <;> nextstate(B::Concise -1151 Concise.pm:116) v:*,&,{,x*,x&,x$,$ ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <1> srefgen sK/1 ->5 +# - <1> ex-list lKRM ->4 +# 3 <1> rv2gv sKRM/STRICT,1 ->4 +# 2 <#> gv[*STDOUT] s ->3 +# - <1> ex-rv2sv sKRM*/STRICT,1 ->6 +# 5 <#> gvsv[*B::Concise::walkHandle] s ->6 # BEGIN 2: -# k <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq K ->k -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c -# d <1> require sK/1 ->e -# c <$> const[PV "strict.pm"] s/BARE ->d -# - <;> ex-nextstate(B::Concise -812 Concise.pm:386) v:*,&,x*,x&,x$,$ ->e +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->h +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ ->9 +# a <1> require sK/1 ->b +# 9 <$> const[PV "strict.pm"] s/BARE ->a +# - <;> ex-nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ ->b # - <@> lineseq K ->- -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ ->f -# j <1> entersub[t1] KS*/TARG,STRICT ->k -# f <0> pushmark s ->g -# g <$> const[PV "strict"] sM ->h -# h <$> const[PV "refs"] sM ->i -# i <.> method_named[PV "unimport"] ->j +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ ->c +# g <1> entersub[t1] KRS*/TARG,STRICT ->h +# c <0> pushmark s ->d +# d <$> const[PV "strict"] sM ->e +# e <$> const[PV "refs"] sM ->f +# f <.> method_named[PV "unimport"] ->g # BEGIN 3: -# u <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->u -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m -# n <1> require sK/1 ->o -# m <$> const[PV "warnings.pm"] s/BARE ->n -# - <;> ex-nextstate(B::Concise -798 Concise.pm:406) v:*,&,{,x*,x&,x$,$ ->o +# r <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->r +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ ->j +# k <1> require sK/1 ->l +# j <$> const[PV "strict.pm"] s/BARE ->k +# - <;> ex-nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ ->l # - <@> lineseq K ->- -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ ->p -# t <1> entersub[t1] KS*/TARG,STRICT ->u -# p <0> pushmark s ->q -# q <$> const[PV "warnings"] sM ->r -# r <$> const[PV "qw"] sM ->s -# s <.> method_named[PV "unimport"] ->t +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ ->m +# q <1> entersub[t1] KRS*/TARG,STRICT ->r +# m <0> pushmark s ->n +# n <$> const[PV "strict"] sM ->o +# o <$> const[PV "refs"] sM ->p +# p <.> method_named[PV "unimport"] ->q # BEGIN 4: -# y <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->y -# v <;> nextstate(main 2 -e:1) v:>,<,%,{ ->w -# x <1> postinc[t3] sK/1 ->y -# - <1> ex-rv2sv sKRM/1 ->x -# w <#> gvsv[*beg] s ->x +# 11 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->11 +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ ->t +# u <1> require sK/1 ->v +# t <$> const[PV "strict.pm"] s/BARE ->u +# - <;> ex-nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ ->v +# - <@> lineseq K ->- +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ ->w +# 10 <1> entersub[t1] KRS*/TARG,STRICT ->11 +# w <0> pushmark s ->x +# x <$> const[PV "strict"] sM ->y +# y <$> const[PV "refs"] sM ->z +# z <.> method_named[PV "unimport"] ->10 +# BEGIN 5: +# 1b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->1b +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ ->13 +# 14 <1> require sK/1 ->15 +# 13 <$> const[PV "strict.pm"] s/BARE ->14 +# - <;> ex-nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ ->15 +# - <@> lineseq K ->- +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ ->16 +# 1a <1> entersub[t1] KRS*/TARG,STRICT ->1b +# 16 <0> pushmark s ->17 +# 17 <$> const[PV "strict"] sM ->18 +# 18 <$> const[PV "refs"] sM ->19 +# 19 <.> method_named[PV "unimport"] ->1a +# BEGIN 6: +# 1l <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->1l +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ ->1d +# 1e <1> require sK/1 ->1f +# 1d <$> const[PV "warnings.pm"] s/BARE ->1e +# - <;> ex-nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ ->1f +# - <@> lineseq K ->- +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ ->1g +# 1k <1> entersub[t1] KRS*/TARG,STRICT ->1l +# 1g <0> pushmark s ->1h +# 1h <$> const[PV "warnings"] sM ->1i +# 1i <$> const[PV "qw"] sM ->1j +# 1j <.> method_named[PV "unimport"] ->1k +# BEGIN 7: +# 1p <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->1p +# 1m <;> nextstate(main 3 -e:1) v:>,<,%,{ ->1n +# 1o <1> postinc[t3] sK/1 ->1p +# - <1> ex-rv2sv sKRM/1 ->1o +# 1n <#> gvsv[*beg] s ->1o EOT_EOT # BEGIN 1: -# a <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->a -# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2 -# 3 <1> require sK/1 ->4 -# 2 <$> const(PV "strict.pm") s/BARE ->3 -# - <;> ex-nextstate(B::Concise -837 Concise.pm:366) v:*,&,{,x*,x&,x$,$ ->4 -# - <@> lineseq K ->- -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ ->5 -# 9 <1> entersub[t1] KS*/TARG,STRICT ->a -# 5 <0> pushmark s ->6 -# 6 <$> const(PV "strict") sM ->7 -# 7 <$> const(PV "refs") sM ->8 -# 8 <.> method_named(PV "unimport") ->9 +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(B::Concise -1151 Concise.pm:116) v:*,&,{,x*,x&,x$,$ ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <1> srefgen sK/1 ->5 +# - <1> ex-list lKRM ->4 +# 3 <1> rv2gv sKRM/STRICT,1 ->4 +# 2 <$> gv(*STDOUT) s ->3 +# - <1> ex-rv2sv sKRM*/STRICT,1 ->6 +# 5 <$> gvsv(*B::Concise::walkHandle) s ->6 # BEGIN 2: -# k <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq K ->k -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c -# d <1> require sK/1 ->e -# c <$> const(PV "strict.pm") s/BARE ->d -# - <;> ex-nextstate(B::Concise -812 Concise.pm:386) v:*,&,x*,x&,x$,$ ->e +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->h +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ ->9 +# a <1> require sK/1 ->b +# 9 <$> const(PV "strict.pm") s/BARE ->a +# - <;> ex-nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ ->b # - <@> lineseq K ->- -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ ->f -# j <1> entersub[t1] KS*/TARG,STRICT ->k -# f <0> pushmark s ->g -# g <$> const(PV "strict") sM ->h -# h <$> const(PV "refs") sM ->i -# i <.> method_named(PV "unimport") ->j +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ ->c +# g <1> entersub[t1] KRS*/TARG,STRICT ->h +# c <0> pushmark s ->d +# d <$> const(PV "strict") sM ->e +# e <$> const(PV "refs") sM ->f +# f <.> method_named(PV "unimport") ->g # BEGIN 3: -# u <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->u -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m -# n <1> require sK/1 ->o -# m <$> const(PV "warnings.pm") s/BARE ->n -# - <;> ex-nextstate(B::Concise -798 Concise.pm:406) v:*,&,{,x*,x&,x$,$ ->o +# r <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->r +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ ->j +# k <1> require sK/1 ->l +# j <$> const(PV "strict.pm") s/BARE ->k +# - <;> ex-nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ ->l # - <@> lineseq K ->- -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ ->p -# t <1> entersub[t1] KS*/TARG,STRICT ->u -# p <0> pushmark s ->q -# q <$> const(PV "warnings") sM ->r -# r <$> const(PV "qw") sM ->s -# s <.> method_named(PV "unimport") ->t +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ ->m +# q <1> entersub[t1] KRS*/TARG,STRICT ->r +# m <0> pushmark s ->n +# n <$> const(PV "strict") sM ->o +# o <$> const(PV "refs") sM ->p +# p <.> method_named(PV "unimport") ->q # BEGIN 4: -# y <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->y -# v <;> nextstate(main 2 -e:1) v:>,<,%,{ ->w -# x <1> postinc[t2] sK/1 ->y -# - <1> ex-rv2sv sKRM/1 ->x -# w <$> gvsv(*beg) s ->x +# 11 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->11 +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ ->t +# u <1> require sK/1 ->v +# t <$> const(PV "strict.pm") s/BARE ->u +# - <;> ex-nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ ->v +# - <@> lineseq K ->- +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ ->w +# 10 <1> entersub[t1] KRS*/TARG,STRICT ->11 +# w <0> pushmark s ->x +# x <$> const(PV "strict") sM ->y +# y <$> const(PV "refs") sM ->z +# z <.> method_named(PV "unimport") ->10 +# BEGIN 5: +# 1b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq K ->1b +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ ->13 +# 14 <1> require sK/1 ->15 +# 13 <$> const(PV "strict.pm") s/BARE ->14 +# - <;> ex-nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ ->15 +# - <@> lineseq K ->- +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ ->16 +# 1a <1> entersub[t1] KRS*/TARG,STRICT ->1b +# 16 <0> pushmark s ->17 +# 17 <$> const(PV "strict") sM ->18 +# 18 <$> const(PV "refs") sM ->19 +# 19 <.> method_named(PV "unimport") ->1a +# BEGIN 6: +# 1l <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->1l +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ ->1d +# 1e <1> require sK/1 ->1f +# 1d <$> const(PV "warnings.pm") s/BARE ->1e +# - <;> ex-nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ ->1f +# - <@> lineseq K ->- +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ ->1g +# 1k <1> entersub[t1] KRS*/TARG,STRICT ->1l +# 1g <0> pushmark s ->1h +# 1h <$> const(PV "warnings") sM ->1i +# 1i <$> const(PV "qw") sM ->1j +# 1j <.> method_named(PV "unimport") ->1k +# BEGIN 7: +# 1p <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->1p +# 1m <;> nextstate(main 3 -e:1) v:>,<,%,{ ->1n +# 1o <1> postinc[t2] sK/1 ->1p +# - <1> ex-rv2sv sKRM/1 ->1o +# 1n <$> gvsv(*beg) s ->1o EONT_EONT - checkOptree ( name => 'END', bcopts => 'END', prog => $src, @@ -163,7 +244,6 @@ EOT_EOT # 2 <$> gvsv(*end) s ->3 EONT_EONT - checkOptree ( name => 'CHECK', bcopts => 'CHECK', prog => $src, @@ -231,205 +311,321 @@ EOT_EOT # 2 <$> gvsv(*init) s ->3 EONT_EONT - checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', bcopts => [qw/ BEGIN END INIT CHECK UNITCHECK -exec /], prog => $src, strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # BEGIN 1: -# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ -# 2 <$> const[PV "strict.pm"] s/BARE -# 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ -# 5 <0> pushmark s -# 6 <$> const[PV "strict"] sM -# 7 <$> const[PV "refs"] sM -# 8 <.> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,STRICT -# a <1> leavesub[1 ref] K/REFC,1 +# 1 <;> nextstate(B::Concise -1151 Concise.pm:116) v:*,&,{,x*,x&,x$,$ +# 2 <#> gv[*STDOUT] s +# 3 <1> rv2gv sKRM/STRICT,1 +# 4 <1> srefgen sK/1 +# 5 <#> gvsv[*B::Concise::walkHandle] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ -# c <$> const[PV "strict.pm"] s/BARE -# d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ -# f <0> pushmark s -# g <$> const[PV "strict"] sM -# h <$> const[PV "refs"] sM -# i <.> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,STRICT -# k <1> leavesub[1 ref] K/REFC,1 +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ +# 9 <$> const[PV "strict.pm"] s/BARE +# a <1> require sK/1 +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ +# c <0> pushmark s +# d <$> const[PV "strict"] sM +# e <$> const[PV "refs"] sM +# f <.> method_named[PV "unimport"] +# g <1> entersub[t1] KRS*/TARG,STRICT +# h <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ -# m <$> const[PV "warnings.pm"] s/BARE -# n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ -# p <0> pushmark s -# q <$> const[PV "warnings"] sM -# r <$> const[PV "qw"] sM -# s <.> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,STRICT -# u <1> leavesub[1 ref] K/REFC,1 +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ +# j <$> const[PV "strict.pm"] s/BARE +# k <1> require sK/1 +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ +# m <0> pushmark s +# n <$> const[PV "strict"] sM +# o <$> const[PV "refs"] sM +# p <.> method_named[PV "unimport"] +# q <1> entersub[t1] KRS*/TARG,STRICT +# r <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: -# v <;> nextstate(main 2 -e:1) v:>,<,%,{ -# w <#> gvsv[*beg] s -# x <1> postinc[t3] sK/1 -# y <1> leavesub[1 ref] K/REFC,1 +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ +# t <$> const[PV "strict.pm"] s/BARE +# u <1> require sK/1 +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ +# w <0> pushmark s +# x <$> const[PV "strict"] sM +# y <$> const[PV "refs"] sM +# z <.> method_named[PV "unimport"] +# 10 <1> entersub[t1] KRS*/TARG,STRICT +# 11 <1> leavesub[1 ref] K/REFC,1 +# BEGIN 5: +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ +# 13 <$> const[PV "strict.pm"] s/BARE +# 14 <1> require sK/1 +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ +# 16 <0> pushmark s +# 17 <$> const[PV "strict"] sM +# 18 <$> const[PV "refs"] sM +# 19 <.> method_named[PV "unimport"] +# 1a <1> entersub[t1] KRS*/TARG,STRICT +# 1b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 6: +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ +# 1d <$> const[PV "warnings.pm"] s/BARE +# 1e <1> require sK/1 +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ +# 1g <0> pushmark s +# 1h <$> const[PV "warnings"] sM +# 1i <$> const[PV "qw"] sM +# 1j <.> method_named[PV "unimport"] +# 1k <1> entersub[t1] KRS*/TARG,STRICT +# 1l <1> leavesub[1 ref] K/REFC,1 +# BEGIN 7: +# 1m <;> nextstate(main 3 -e:1) v:>,<,%,{ +# 1n <#> gvsv[*beg] s +# 1o <1> postinc[t3] sK/1 +# 1p <1> leavesub[1 ref] K/REFC,1 # END 1: -# z <;> nextstate(main 5 -e:1) v:>,<,%,{ -# 10 <#> gvsv[*end] s -# 11 <1> postinc[t3] sK/1 -# 12 <1> leavesub[1 ref] K/REFC,1 +# 1q <;> nextstate(main 9 -e:1) v:>,<,%,{ +# 1r <#> gvsv[*end] s +# 1s <1> postinc[t3] sK/1 +# 1t <1> leavesub[1 ref] K/REFC,1 # INIT 1: -# 13 <;> nextstate(main 4 -e:1) v:>,<,%,{ -# 14 <#> gvsv[*init] s -# 15 <1> postinc[t3] sK/1 -# 16 <1> leavesub[1 ref] K/REFC,1 +# 1u <;> nextstate(main 7 -e:1) v:>,<,%,{ +# 1v <#> gvsv[*init] s +# 1w <1> postinc[t3] sK/1 +# 1x <1> leavesub[1 ref] K/REFC,1 # CHECK 1: -# 17 <;> nextstate(main 3 -e:1) v:>,<,%,{ -# 18 <#> gvsv[*chk] s -# 19 <1> postinc[t3] sK/1 -# 1a <1> leavesub[1 ref] K/REFC,1 +# 1y <;> nextstate(main 5 -e:1) v:>,<,%,{ +# 1z <#> gvsv[*chk] s +# 20 <1> postinc[t3] sK/1 +# 21 <1> leavesub[1 ref] K/REFC,1 # UNITCHECK 1: -# 1b <;> nextstate(main 6 -e:1) v:>,<,%,{ -# 1c <#> gvsv[*uc] s -# 1d <1> postinc[t3] sK/1 -# 1e <1> leavesub[1 ref] K/REFC,1 +# 22 <;> nextstate(main 11 -e:1) v:>,<,%,{ +# 23 <#> gvsv[*uc] s +# 24 <1> postinc[t3] sK/1 +# 25 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: -# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ -# 2 <$> const(PV "strict.pm") s/BARE -# 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ -# 5 <0> pushmark s -# 6 <$> const(PV "strict") sM -# 7 <$> const(PV "refs") sM -# 8 <.> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,STRICT -# a <1> leavesub[1 ref] K/REFC,1 +# 1 <;> nextstate(B::Concise -1151 Concise.pm:116) v:*,&,{,x*,x&,x$,$ +# 2 <$> gv(*STDOUT) s +# 3 <1> rv2gv sKRM/STRICT,1 +# 4 <1> srefgen sK/1 +# 5 <$> gvsv(*B::Concise::walkHandle) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ -# c <$> const(PV "strict.pm") s/BARE -# d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ -# f <0> pushmark s -# g <$> const(PV "strict") sM -# h <$> const(PV "refs") sM -# i <.> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,STRICT -# k <1> leavesub[1 ref] K/REFC,1 +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ +# 9 <$> const(PV "strict.pm") s/BARE +# a <1> require sK/1 +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ +# c <0> pushmark s +# d <$> const(PV "strict") sM +# e <$> const(PV "refs") sM +# f <.> method_named(PV "unimport") +# g <1> entersub[t1] KRS*/TARG,STRICT +# h <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ -# m <$> const(PV "warnings.pm") s/BARE -# n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ -# p <0> pushmark s -# q <$> const(PV "warnings") sM -# r <$> const(PV "qw") sM -# s <.> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,STRICT -# u <1> leavesub[1 ref] K/REFC,1 +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ +# j <$> const(PV "strict.pm") s/BARE +# k <1> require sK/1 +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ +# m <0> pushmark s +# n <$> const(PV "strict") sM +# o <$> const(PV "refs") sM +# p <.> method_named(PV "unimport") +# q <1> entersub[t1] KRS*/TARG,STRICT +# r <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: -# v <;> nextstate(main 2 -e:1) v:>,<,%,{ -# w <$> gvsv(*beg) s -# x <1> postinc[t2] sK/1 -# y <1> leavesub[1 ref] K/REFC,1 +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ +# t <$> const(PV "strict.pm") s/BARE +# u <1> require sK/1 +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ +# w <0> pushmark s +# x <$> const(PV "strict") sM +# y <$> const(PV "refs") sM +# z <.> method_named(PV "unimport") +# 10 <1> entersub[t1] KRS*/TARG,STRICT +# 11 <1> leavesub[1 ref] K/REFC,1 +# BEGIN 5: +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ +# 13 <$> const(PV "strict.pm") s/BARE +# 14 <1> require sK/1 +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ +# 16 <0> pushmark s +# 17 <$> const(PV "strict") sM +# 18 <$> const(PV "refs") sM +# 19 <.> method_named(PV "unimport") +# 1a <1> entersub[t1] KRS*/TARG,STRICT +# 1b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 6: +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ +# 1d <$> const(PV "warnings.pm") s/BARE +# 1e <1> require sK/1 +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ +# 1g <0> pushmark s +# 1h <$> const(PV "warnings") sM +# 1i <$> const(PV "qw") sM +# 1j <.> method_named(PV "unimport") +# 1k <1> entersub[t1] KRS*/TARG,STRICT +# 1l <1> leavesub[1 ref] K/REFC,1 +# BEGIN 7: +# 1m <;> nextstate(main 3 -e:1) v:>,<,%,{ +# 1n <$> gvsv(*beg) s +# 1o <1> postinc[t2] sK/1 +# 1p <1> leavesub[1 ref] K/REFC,1 # END 1: -# z <;> nextstate(main 5 -e:1) v:>,<,%,{ -# 10 <$> gvsv(*end) s -# 11 <1> postinc[t2] sK/1 -# 12 <1> leavesub[1 ref] K/REFC,1 +# 1q <;> nextstate(main 9 -e:1) v:>,<,%,{ +# 1r <$> gvsv(*end) s +# 1s <1> postinc[t2] sK/1 +# 1t <1> leavesub[1 ref] K/REFC,1 # INIT 1: -# 13 <;> nextstate(main 4 -e:1) v:>,<,%,{ -# 14 <$> gvsv(*init) s -# 15 <1> postinc[t2] sK/1 -# 16 <1> leavesub[1 ref] K/REFC,1 +# 1u <;> nextstate(main 7 -e:1) v:>,<,%,{ +# 1v <$> gvsv(*init) s +# 1w <1> postinc[t2] sK/1 +# 1x <1> leavesub[1 ref] K/REFC,1 # CHECK 1: -# 17 <;> nextstate(main 3 -e:1) v:>,<,%,{ -# 18 <$> gvsv(*chk) s -# 19 <1> postinc[t2] sK/1 -# 1a <1> leavesub[1 ref] K/REFC,1 +# 1y <;> nextstate(main 5 -e:1) v:>,<,%,{ +# 1z <$> gvsv(*chk) s +# 20 <1> postinc[t2] sK/1 +# 21 <1> leavesub[1 ref] K/REFC,1 # UNITCHECK 1: -# 1b <;> nextstate(main 6 -e:1) v:>,<,%,{ -# 1c <$> gvsv(*uc) s -# 1d <1> postinc[t2] sK/1 -# 1e <1> leavesub[1 ref] K/REFC,1 +# 22 <;> nextstate(main 11 -e:1) v:>,<,%,{ +# 23 <$> gvsv(*uc) s +# 24 <1> postinc[t2] sK/1 +# 25 <1> leavesub[1 ref] K/REFC,1 EONT_EONT - # perl "-I../lib" -MO=Concise,BEGIN,CHECK,INIT,END,-exec -e '$a=$b && print q/foo/' - - checkOptree ( name => 'regression test for patch 25352', bcopts => [qw/ BEGIN END INIT CHECK -exec /], prog => 'print q/foo/', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # BEGIN 1: # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ -# 2 <$> const[PV "strict.pm"] s/BARE -# 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ -# 5 <0> pushmark s -# 6 <$> const[PV "strict"] sM -# 7 <$> const[PV "refs"] sM -# 8 <.> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,STRICT -# a <1> leavesub[1 ref] K/REFC,1 +# 2 <#> gv[*STDOUT] s +# 3 <1> rv2gv sKRM/STRICT,1 +# 4 <1> srefgen sK/1 +# 5 <#> gvsv[*B::Concise::walkHandle] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ -# c <$> const[PV "strict.pm"] s/BARE -# d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ -# f <0> pushmark s -# g <$> const[PV "strict"] sM -# h <$> const[PV "refs"] sM -# i <.> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,STRICT -# k <1> leavesub[1 ref] K/REFC,1 +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ +# 9 <$> const[PV "strict.pm"] s/BARE +# a <1> require sK/1 +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ +# c <0> pushmark s +# d <$> const[PV "strict"] sM +# e <$> const[PV "refs"] sM +# f <.> method_named[PV "unimport"] +# g <1> entersub[t1] KRS*/TARG,STRICT +# h <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ -# m <$> const[PV "warnings.pm"] s/BARE -# n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ -# p <0> pushmark s -# q <$> const[PV "warnings"] sM -# r <$> const[PV "qw"] sM -# s <.> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,STRICT -# u <1> leavesub[1 ref] K/REFC,1 +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ +# j <$> const[PV "strict.pm"] s/BARE +# k <1> require sK/1 +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ +# m <0> pushmark s +# n <$> const[PV "strict"] sM +# o <$> const[PV "refs"] sM +# p <.> method_named[PV "unimport"] +# q <1> entersub[t1] KRS*/TARG,STRICT +# r <1> leavesub[1 ref] K/REFC,1 +# BEGIN 4: +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ +# t <$> const[PV "strict.pm"] s/BARE +# u <1> require sK/1 +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ +# w <0> pushmark s +# x <$> const[PV "strict"] sM +# y <$> const[PV "refs"] sM +# z <.> method_named[PV "unimport"] +# 10 <1> entersub[t1] KRS*/TARG,STRICT +# 11 <1> leavesub[1 ref] K/REFC,1 +# BEGIN 5: +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ +# 13 <$> const[PV "strict.pm"] s/BARE +# 14 <1> require sK/1 +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ +# 16 <0> pushmark s +# 17 <$> const[PV "strict"] sM +# 18 <$> const[PV "refs"] sM +# 19 <.> method_named[PV "unimport"] +# 1a <1> entersub[t1] KRS*/TARG,STRICT +# 1b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 6: +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ +# 1d <$> const[PV "warnings.pm"] s/BARE +# 1e <1> require sK/1 +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ +# 1g <0> pushmark s +# 1h <$> const[PV "warnings"] sM +# 1i <$> const[PV "qw"] sM +# 1j <.> method_named[PV "unimport"] +# 1k <1> entersub[t1] KRS*/TARG,STRICT +# 1l <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: -# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ -# 2 <$> const(PV "strict.pm") s/BARE -# 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ -# 5 <0> pushmark s -# 6 <$> const(PV "strict") sM -# 7 <$> const(PV "refs") sM -# 8 <.> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,STRICT -# a <1> leavesub[1 ref] K/REFC,1 +# 1 <;> nextstate(B::Concise -1151 Concise.pm:116) v:*,&,{,x*,x&,x$,$ +# 2 <$> gv(*STDOUT) s +# 3 <1> rv2gv sKRM/STRICT,1 +# 4 <1> srefgen sK/1 +# 5 <$> gvsv(*B::Concise::walkHandle) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: -# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ -# c <$> const(PV "strict.pm") s/BARE -# d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ -# f <0> pushmark s -# g <$> const(PV "strict") sM -# h <$> const(PV "refs") sM -# i <.> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,STRICT -# k <1> leavesub[1 ref] K/REFC,1 +# 8 <;> nextstate(B::Concise -1113 Concise.pm:181) v:*,&,x*,x&,x$,$ +# 9 <$> const(PV "strict.pm") s/BARE +# a <1> require sK/1 +# b <;> nextstate(B::Concise -1113 Concise.pm:181) :*,&,x*,x&,x$,$ +# c <0> pushmark s +# d <$> const(PV "strict") sM +# e <$> const(PV "refs") sM +# f <.> method_named(PV "unimport") +# g <1> entersub[t1] KRS*/TARG,STRICT +# h <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: -# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ -# m <$> const(PV "warnings.pm") s/BARE -# n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ -# p <0> pushmark s -# q <$> const(PV "warnings") sM -# r <$> const(PV "qw") sM -# s <.> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,STRICT -# u <1> leavesub[1 ref] K/REFC,1 +# i <;> nextstate(B::Concise -1010 Concise.pm:303) v:*,&,x*,x&,x$,$ +# j <$> const(PV "strict.pm") s/BARE +# k <1> require sK/1 +# l <;> nextstate(B::Concise -1010 Concise.pm:303) :*,&,x*,x&,x$,$ +# m <0> pushmark s +# n <$> const(PV "strict") sM +# o <$> const(PV "refs") sM +# p <.> method_named(PV "unimport") +# q <1> entersub[t1] KRS*/TARG,STRICT +# r <1> leavesub[1 ref] K/REFC,1 +# BEGIN 4: +# s <;> nextstate(B::Concise -963 Concise.pm:368) v:*,&,{,x*,x&,x$,$ +# t <$> const(PV "strict.pm") s/BARE +# u <1> require sK/1 +# v <;> nextstate(B::Concise -963 Concise.pm:368) :*,&,{,x*,x&,x$,$ +# w <0> pushmark s +# x <$> const(PV "strict") sM +# y <$> const(PV "refs") sM +# z <.> method_named(PV "unimport") +# 10 <1> entersub[t1] KRS*/TARG,STRICT +# 11 <1> leavesub[1 ref] K/REFC,1 +# BEGIN 5: +# 12 <;> nextstate(B::Concise -938 Concise.pm:388) v:*,&,x*,x&,x$,$ +# 13 <$> const(PV "strict.pm") s/BARE +# 14 <1> require sK/1 +# 15 <;> nextstate(B::Concise -938 Concise.pm:388) :*,&,x*,x&,x$,$ +# 16 <0> pushmark s +# 17 <$> const(PV "strict") sM +# 18 <$> const(PV "refs") sM +# 19 <.> method_named(PV "unimport") +# 1a <1> entersub[t1] KRS*/TARG,STRICT +# 1b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 6: +# 1c <;> nextstate(B::Concise -924 Concise.pm:408) v:*,&,{,x*,x&,x$,$ +# 1d <$> const(PV "warnings.pm") s/BARE +# 1e <1> require sK/1 +# 1f <;> nextstate(B::Concise -924 Concise.pm:408) :*,&,{,x*,x&,x$,$ +# 1g <0> pushmark s +# 1h <$> const(PV "warnings") sM +# 1i <$> const(PV "qw") sM +# 1j <.> method_named(PV "unimport") +# 1k <1> entersub[t1] KRS*/TARG,STRICT +# 1l <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t index 6d2038deb82..5938048f3ab 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t @@ -390,14 +390,14 @@ checkOptree ( name => 'my ($a,$b)=()', # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2 +# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2 # 5 <2> aassign[t3] vKS # 6 <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2 +# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2 # 5 <2> aassign[t3] vKS # 6 <@> leave[1 ref] vKP/REFC EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/showlex.t b/gnu/usr.bin/perl/ext/B/t/showlex.t index dd5cdb7f38a..f92ac9ea7ea 100644 --- a/gnu/usr.bin/perl/ext/B/t/showlex.t +++ b/gnu/usr.bin/perl/ext/B/t/showlex.t @@ -21,10 +21,8 @@ plan tests => 15; my $verbose = @ARGV; # set if ANY ARGS my $a; -my $Is_VMS = $^O eq 'VMS'; my $path = join " ", map { qq["-I$_"] } @INC; -$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; if ($is_thread) { diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm index c0483ca1449..3d790e763ad 100644 --- a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm +++ b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.23'; +$VERSION = '1.27'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -133,7 +133,9 @@ means no limit. If C<use Devel::Peek> directive has a C<:opd=FLAGS> argument, this switches on debugging of opcode dispatch. C<FLAGS> should be a -combination of C<s>, C<t>, and C<P> (see B<-D> flags in L<perlrun>). +combination of C<s>, C<t>, and C<P> (see +L<< B<-D> flags in perlrun|perlrun/B<-D>I<letters> >>). + C<:opd> is a shortcut for C<:opd=st>. =head2 Runtime debugging @@ -352,7 +354,6 @@ The output: ARRAY = 0xc7e820 FILL = 0 MAX = 0 - ARYLEN = 0x0 FLAGS = (REAL) Elt No. 0 SV = IV(0xc70f88) at 0xc70f98 @@ -384,7 +385,6 @@ The output: ARRAY = 0x1585820 FILL = 1 MAX = 1 - ARYLEN = 0x0 FLAGS = (REAL) Elt No. 0 SV = IV(0x1577f88) at 0x1577f98 @@ -548,7 +548,7 @@ inside a 5th eval in the program; =item * -it is not currently executed (see C<DEPTH>); +it is not currently executed (because C<DEPTH> is 0); =item * diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs index 132cad79e32..8a8c0b96d76 100644 --- a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs +++ b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs @@ -181,46 +181,46 @@ _mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) SV **svp; int type; - svp = hv_fetch(hv, "topbucket", 9, 1); + svp = hv_fetchs(hv, "topbucket", 1); sv_setiv(*svp, b->buffer.topbucket); - svp = hv_fetch(hv, "topbucket_ev", 12, 1); + svp = hv_fetchs(hv, "topbucket_ev", 1); sv_setiv(*svp, b->buffer.topbucket_ev); - svp = hv_fetch(hv, "topbucket_odd", 13, 1); + svp = hv_fetchs(hv, "topbucket_odd", 1); sv_setiv(*svp, b->buffer.topbucket_odd); - svp = hv_fetch(hv, "totfree", 7, 1); + svp = hv_fetchs(hv, "totfree", 1); sv_setiv(*svp, b->buffer.totfree); - svp = hv_fetch(hv, "total", 5, 1); + svp = hv_fetchs(hv, "total", 1); sv_setiv(*svp, b->buffer.total); - svp = hv_fetch(hv, "total_chain", 11, 1); + svp = hv_fetchs(hv, "total_chain", 1); sv_setiv(*svp, b->buffer.total_chain); - svp = hv_fetch(hv, "total_sbrk", 10, 1); + svp = hv_fetchs(hv, "total_sbrk", 1); sv_setiv(*svp, b->buffer.total_sbrk); - svp = hv_fetch(hv, "sbrks", 5, 1); + svp = hv_fetchs(hv, "sbrks", 1); sv_setiv(*svp, b->buffer.sbrks); - svp = hv_fetch(hv, "sbrk_good", 9, 1); + svp = hv_fetchs(hv, "sbrk_good", 1); sv_setiv(*svp, b->buffer.sbrk_good); - svp = hv_fetch(hv, "sbrk_slack", 10, 1); + svp = hv_fetchs(hv, "sbrk_slack", 1); sv_setiv(*svp, b->buffer.sbrk_slack); - svp = hv_fetch(hv, "start_slack", 11, 1); + svp = hv_fetchs(hv, "start_slack", 1); sv_setiv(*svp, b->buffer.start_slack); - svp = hv_fetch(hv, "sbrked_remains", 14, 1); + svp = hv_fetchs(hv, "sbrked_remains", 1); sv_setiv(*svp, b->buffer.sbrked_remains); - svp = hv_fetch(hv, "minbucket", 9, 1); + svp = hv_fetchs(hv, "minbucket", 1); sv_setiv(*svp, b->buffer.minbucket); - svp = hv_fetch(hv, "nbuckets", 8, 1); + svp = hv_fetchs(hv, "nbuckets", 1); sv_setiv(*svp, b->buffer.nbuckets); if (_NBUCKETS < b->buffer.nbuckets) @@ -444,7 +444,7 @@ BOOT: { CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0); assert(cv); - cv_set_call_checker(cv, S_ck_dump, (SV *)cv); + cv_set_call_checker_flags(cv, S_ck_dump, (SV *)cv, 0); Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop); } @@ -461,7 +461,7 @@ PPCODE: PL_dumpindent = 2; for (i=1; i<items; i++) { - PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); + PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%" UVxf "\n", i - 1, PTR2UV(ST(i))); do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, (bool)(dumpop && SvTRUE(dumpop)), pv_lim); } diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t b/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t index 56522af1e8d..2c0c849cf6b 100755 --- a/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t +++ b/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t @@ -37,7 +37,7 @@ sub do_test { my $repeat_todo = $_[4]; my $pattern = $_[2]; my $do_eval = $_[5]; - if (open(OUT,">peek$$")) { + if (open(OUT,'>', "peek$$")) { open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; if ($do_eval) { my $sub = eval "sub { Dump $_[1] }"; @@ -56,7 +56,7 @@ sub do_test { } open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; close(OUT); - if (open(IN, "peek$$")) { + if (open(IN, '<', "peek$$")) { local $/; $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g; @@ -77,7 +77,7 @@ sub do_test { # Could do this is in a s///mge but seems clearer like this: $pattern = join '', map { # If we identify the version condition, take *it* out whatever - s/\s*# (\$].*)$// + s/\s*# (\$\].*)$// ? (eval $1 ? $_ : '') : $_ # Didn't match, so this line is in } split /^/, $pattern; @@ -262,7 +262,6 @@ do_test('reference to array', ARRAY = $ADDR FILL = 1 MAX = 1 - ARYLEN = 0x0 FLAGS = \\(REAL\\) Elt No. 0 SV = IV\\($ADDR\\) at $ADDR @@ -360,11 +359,10 @@ do_test('reference to regexp', RV = $ADDR SV = REGEXP\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006 - FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006 + FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) PV = $ADDR "\\(\\?\\^:tic\\)" CUR = 8 - LEN = 0 # $] < 5.017006 + LEN = 0 STASH = $ADDR\\t"Regexp"' . ($] < 5.013 ? '' : ' @@ -388,9 +386,10 @@ do_test('reference to regexp', . ($] < 5.019003 ? '' : ' SV = REGEXP\($ADDR\) at $ADDR REFCNT = 2 - FLAGS = \(\) + FLAGS = \(POK,pPOK\) PV = $ADDR "\(\?\^:tic\)" CUR = 8 + LEN = \d+ COMPFLAGS = 0x0 \(\) EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) (?: ENGINE = $ADDR \(STANDARD\) @@ -783,7 +782,7 @@ do_test('ENAME on a stash', AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 - FILL = 0 \(cached = 0\) + FILL = 0 MAX = 7 RITER = -1 EITER = 0x0 @@ -806,7 +805,7 @@ do_test('ENAMEs on a stash', AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 - FILL = 0 \(cached = 0\) + FILL = 0 MAX = 7 RITER = -1 EITER = 0x0 @@ -832,7 +831,7 @@ do_test('ENAMEs on a stash with no NAME', AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 - FILL = 0 \(cached = 0\) + FILL = 0 MAX = 7 RITER = -1 EITER = 0x0 @@ -882,7 +881,7 @@ do_test('small hash after keys', ARRAY = $ADDR \\(0:[67],.*\\) hash quality = [0-9.]+% KEYS = 2 - FILL = [12] \\(cached = 0\\) + FILL = [12] MAX = 7 RITER = -1 EITER = 0x0 @@ -912,7 +911,7 @@ do_test('small hash after keys and scalar', ARRAY = $ADDR \\(0:[67],.*\\) hash quality = [0-9.]+% KEYS = 2 - FILL = ([12]) \\(cached = \1\\) + FILL = ([12]) MAX = 7 RITER = -1 EITER = 0x0 @@ -927,30 +926,6 @@ do_test('small hash after keys and scalar', COW_REFCNT = 1 ){2}'); -# This should immediately start with the FILL cached correctly. -my %large = (0..1999); -$b = %large; -do_test('large hash', - \%large, -'SV = $RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\($PADMY,OOK,SHAREKEYS\\) - AUX_FLAGS = 0 # $] > 5.019008 - ARRAY = $ADDR \\(0:\d+,.*\\) - hash quality = \d+\\.\d+% - KEYS = 1000 - FILL = (\d+) \\(cached = \1\\) - MAX = 1023 - RITER = -1 - EITER = 0x0 - RAND = $ADDR - Elt .* -'); - # Dump with arrays, hashes, and operator return values @array = 1..3; do_test('Dump @array', '@array', <<'ARRAY', '', '', 1); @@ -960,7 +935,6 @@ SV = PVAV\($ADDR\) at $ADDR ARRAY = $ADDR FILL = 2 MAX = 3 - ARYLEN = 0x0 FLAGS = \(REAL\) Elt No. 0 SV = IV\($ADDR\) at $ADDR @@ -986,7 +960,6 @@ SV = PVAV\($ADDR\) at $ADDR ARRAY = $ADDR FILL = 2 MAX = 3 - ARYLEN = 0x0 FLAGS = \(REAL\) Elt No. 0 SV = IV\($ADDR\) at $ADDR @@ -1072,14 +1045,10 @@ unless ($Config{useithreads}) { eval 'index "", perl'; - # FIXME - really this shouldn't say EVALED. It's a false posistive on - # 0x40000000 being used for several things, not a flag for "I'm in a string - # eval" - do_test('string constant now an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "rule"\\\0 CUR = 4 LEN = \d+ @@ -1099,7 +1068,7 @@ unless ($Config{useithreads}) { do_test('string constant still an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "rule"\\\0 CUR = 4 LEN = \d+ @@ -1139,7 +1108,7 @@ unless ($Config{useithreads}) { my $want = 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 6 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "foam"\\\0 CUR = 4 LEN = \d+ @@ -1177,7 +1146,7 @@ unless ($Config{useithreads}) { # (One block of study tests removed when study was made a no-op.) { - open(OUT,">peek$$") or die "Failed to open peek $$: $!"; + open(OUT, '>', "peek$$") or die "Failed to open peek $$: $!"; open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; DeadCode(); open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; @@ -1193,9 +1162,10 @@ do_test('UTF-8 in a regular expression', RV = $ADDR SV = REGEXP\($ADDR\) at $ADDR REFCNT = 1 - FLAGS = \(OBJECT,FAKE,UTF8\) + FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\) PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] CUR = 13 + LEN = 0 STASH = $ADDR "Regexp" COMPFLAGS = 0x0 \(\) EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) @@ -1217,9 +1187,10 @@ do_test('UTF-8 in a regular expression', . ($] < 5.019003 ? '' : ' SV = REGEXP\($ADDR\) at $ADDR REFCNT = 2 - FLAGS = \(UTF8\) + FLAGS = \(POK,pPOK,UTF8\) PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] CUR = 13 + LEN = \d+ COMPFLAGS = 0x0 \(\) EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) (?: ENGINE = $ADDR \(STANDARD\) @@ -1263,12 +1234,12 @@ do_test('UTF-8 in a regular expression', use utf8; sub _dump { - open(OUT,">peek$$") or die $!; + open(OUT, '>', "peek$$") or die $!; open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; Dump($_[0]); open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; close(OUT); - open(IN, "peek$$") or die $!; + open(IN, '<', "peek$$") or die $!; my $dump = do { local $/; <IN> }; close(IN); 1 while unlink "peek$$"; @@ -1486,58 +1457,51 @@ for my $test ( local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS'; my $e = <<'EODUMP'; dumpindent is 4 at -e line 1. -{ -1 TYPE = leave ===> NULL - TARG = 1 - FLAGS = (VOID,KIDS,PARENS,SLABBED) - PRIVATE = (REFC) - REFCNT = 1 - { -2 TYPE = enter ===> 3 - FLAGS = (UNKNOWN,SLABBED,MORESIB) - } - { -3 TYPE = nextstate ===> 4 - FLAGS = (VOID,SLABBED,MORESIB) - LINE = 1 - PACKAGE = "t" - } - { -5 TYPE = entersub ===> 1 - TARG = 1 - FLAGS = (VOID,KIDS,STACKED,SLABBED) - PRIVATE = (TARG) - { -6 TYPE = null ===> (5) - (was list) - FLAGS = (UNKNOWN,KIDS,SLABBED) - { -4 TYPE = pushmark ===> 7 - FLAGS = (SCALAR,SLABBED,MORESIB) - } - { -8 TYPE = null ===> (6) - (was rv2cv) - FLAGS = (SCALAR,KIDS,SLABBED) - PRIVATE = (0x1) - { -7 TYPE = gv ===> 5 - FLAGS = (SCALAR,SLABBED) - GV_OR_PADIX - } - } - } - } -} + +1 leave LISTOP(0xNNN) ===> [0x0] + PARENT ===> [0x0] + TARG = 1 + FLAGS = (VOID,KIDS,PARENS,SLABBED) + PRIVATE = (REFC) + REFCNT = 1 + | +2 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN] + | FLAGS = (UNKNOWN,SLABBED,MORESIB) + | +3 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN] + | FLAGS = (VOID,SLABBED,MORESIB) + | LINE = 1 + | PACKAGE = "t" + | | +5 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN] + TARG = 1 + FLAGS = (VOID,KIDS,STACKED,SLABBED) + PRIVATE = (TARG) + | +6 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN] + FLAGS = (UNKNOWN,KIDS,SLABBED) + | +4 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN] + | FLAGS = (SCALAR,SLABBED,MORESIB) + | +8 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN] + FLAGS = (SCALAR,KIDS,SLABBED) + PRIVATE = (0x1) + | +7 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN] + FLAGS = (SCALAR,SLABBED) + GV_OR_PADIX EODUMP - $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; - $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004; + $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e; + $e =~ s/SVOP/PADOP/g if $threads; my $out = t::runperl switches => ['-Ilib'], prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();', stderr=>1; $out =~ s/ *SEQ = .*\n//; + $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g; + $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g; is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning"; } done_testing(); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL index e828f357571..41e6f942191 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL @@ -65,7 +65,7 @@ sub expand_os_specific { } unlink "DynaLoader.pm" if -f "DynaLoader.pm"; -open OUT, ">DynaLoader.pm" or die $!; +open OUT, '>', "DynaLoader.pm" or die $!; print OUT <<'EOT'; # Generated from DynaLoader_pm.PL, this file is unique for every OS @@ -85,7 +85,7 @@ package DynaLoader; # Tim.Bunce@ig.co.uk, August 1994 BEGIN { - $VERSION = '1.38'; + $VERSION = '1.45'; } EOT @@ -373,7 +373,7 @@ sub bootstrap { $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library if (-s $bs) { # only read file if it's not empty print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; - eval { do $bs; }; + eval { local @INC = ('.'); do $bs; }; warn "$bs: $@\n" if $@; } @@ -454,7 +454,7 @@ sub dl_findfile { # Deal with directories first: # Using a -L prefix is the preferred option (faster and more robust) - if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + if ( s{^-L}{} ) { push(@dirs, $_); next; } # Otherwise we try to try to spot directories by a heuristic # (this is a more complicated issue than it first appears) @@ -468,10 +468,8 @@ sub dl_findfile { # Only files should get this far... my(@names, $name); # what filenames to look for - if (m:-l: ) { # convert -lname to appropriate library name - s/-l//; - push(@names,"lib$_.$dl_so"); - push(@names,"lib$_.a"); + if ( s{^-l}{} ) { # convert -lname to appropriate library name + push(@names, "lib$_.$dl_so", "lib$_.a"); } else { # Umm, a bare name. Try various alternatives: # these should be ordered with the most likely first push(@names,"$_.$dl_dlext") unless m/\.$dl_dlext$/o; @@ -566,7 +564,7 @@ DynaLoader - Dynamically load C libraries into Perl code package YourPackage; require DynaLoader; @ISA = qw(... DynaLoader ...); - bootstrap YourPackage; + __PACKAGE__->bootstrap; # optional method for 'global' loading sub dl_load_flags { 0x01 } diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL index 81bd54665a7..864af3ed8e2 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL @@ -65,8 +65,8 @@ sub MY::static { return " $object : \$(FIRST_MAKEFILE) \$(OBJECT) - #\$(RM_RF) $object - #\$(CP) \$(OBJECT) $object + \$(RM_RF) $object + \$(CP) \$(OBJECT) $object static :: $object "; diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs index 8e7d8ac0a55..54a8e3db133 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs @@ -226,7 +226,7 @@ void *dlopen(char *path, int mode) * Scan the list of modules if have the module already loaded. */ for (mp = dl_modList; mp; mp = mp->next) - if (strcmp(mp->name, path) == 0) { + if (strEQ(mp->name, path)) { mp->refCnt++; return mp; } @@ -364,7 +364,7 @@ void *dlsym(void *handle, const char *symbol) * the result to function pointers anyways. */ for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (strcmp(ep->name, symbol) == 0) + if (strEQ(ep->name, symbol)) return ep->addr; dl_errvalid++; strcpy(dl_errbuf, "dlsym: undefined symbol "); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs index 172da13ce7d..c9d164c7665 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs @@ -88,8 +88,7 @@ Dean Roerich's Perl 5 API document. Also, have a look in the typemap file (in the ext directory) for a fairly comprehensive list of types that are already supported. If you are completely stuck, I suggest you - post a message to perl5-porters, comp.lang.perl.misc or if you are really - desperate to me. + post a message to perl5-porters. Remember when you are making any changes that the return value from dl_load_file is used as a parameter in the dl_find_symbol @@ -256,7 +255,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref const char * filename CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%"UVxf")\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%" UVxf ")\n", perl_name, PTR2UV(symref))); ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name, DPTR2FPTR(XSUBADDR_t, symref), diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs index 3260402f3d6..b076f2141cb 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs @@ -82,7 +82,7 @@ dl_static_linked(char *filename) return 0; /* change all the '\\' to '/' */ - strcpy(szBuffer, filename); + my_strlcpy(szBuffer, filename, sizeof(szBuffer)); for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr) *ptr = '/'; @@ -102,7 +102,7 @@ dl_static_linked(char *filename) if (hptr = strstr(ptr, *p)) { /* found substring, need more detailed check if module name match */ if (hptr==ptr) { - return strcmp(ptr, *p)==0; + return strEQ(ptr, *p); } if (hptr[strlen(*p)] == 0) return hptr[-1]=='/'; diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c index 557c0ec1db6..8584f89e6bb 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c +++ b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c @@ -75,18 +75,16 @@ static void dl_unload_all_files(pTHX_ void *unused) { CV *sub; - AV *dl_librefs; - SV *dl_libref; - + PERL_UNUSED_ARG(unused); if ((sub = get_cvs("DynaLoader::dl_unload_file", 0)) != NULL) { - dl_librefs = get_av("DynaLoader::dl_librefs", 0); - EXTEND(SP,1); + AV *dl_librefs = get_av("DynaLoader::dl_librefs", 0); + SV *dl_libref; while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); - PUSHs(sv_2mortal(dl_libref)); + XPUSHs(sv_2mortal(dl_libref)); PUTBACK; call_sv((SV*)sub, G_DISCARD | G_NODEBUG); FREETMPS; diff --git a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t index 77fb65d4702..7fe30b34972 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t +++ b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t @@ -4,7 +4,7 @@ use strict; use Config; push @INC, '.'; if (-f 't/test.pl') { - require 't/test.pl'; + require './t/test.pl'; } else { require '../../t/test.pl'; } diff --git a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL index 6251a3cf33b..d565f31b2fe 100644 --- a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL +++ b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; use Config; use strict; -our $VERSION = "1.25"; +our $VERSION = "1.29"; my %err = (); @@ -13,7 +13,7 @@ my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian; unlink "Errno.pm" if -f "Errno.pm"; unlink "Errno.tmp" if -f "Errno.tmp"; -open OUT, ">Errno.tmp" or die "Cannot open Errno.tmp: $!"; +open OUT, '>', 'Errno.tmp' or die "Cannot open Errno.tmp: $!"; select OUT; my $file; my @files = get_files(); @@ -21,7 +21,7 @@ if ($Config{gccversion} ne '' && $^O eq 'MSWin32') { # MinGW complains "warning: #pragma system_header ignored outside include # file" if the header files are processed individually, so include them # all in .c file and process that instead. - open INCS, '>includes.c' or + open INCS, '>', 'includes.c' or die "Cannot open includes.c"; foreach $file (@files) { next if $file eq 'errno.c'; @@ -68,7 +68,7 @@ sub process_file { return; } } else { - unless(open(FH,"< $file")) { + unless(open(FH, '<', $file)) { # This file could be a temporary file created by cppstdin # so only warn under -w, and return warn "Cannot open '$file'" if $^W; @@ -149,7 +149,7 @@ sub get_files { $SDK =~ s!\\!/!g; $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1; } else { - open(CPPI,"> errno.c") or + open(CPPI, '>', 'errno.c') or die "Cannot open errno.c"; if ($^O eq 'NetWare') { @@ -200,7 +200,7 @@ sub write_errno_pm { # create the CPP input - open(CPPI,"> errno.c") or + open(CPPI, '>', 'errno.c') or die "Cannot open errno.c"; if ($^O eq 'NetWare') { @@ -257,7 +257,7 @@ sub write_errno_pm { my($name,$expr); next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; next if $name eq $expr; - $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)\(?([^\)]+)\)?\)?/$1/i; # ((type)0xcafebabe) at alia + $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)\(?([^\)]+)\)?\)?/$1/i; # ((type)0xcafebabe) et alia $expr =~ s/\b((?:0x)?[0-9a-f]+)[LU]+\b/$1/gi; # 2147483647L et alia next if $expr =~ m/\b[a-z_]\w*\b/i; # skip expressions containing function names etc if($expr =~ m/^0[xX]/) { @@ -280,7 +280,8 @@ sub write_errno_pm { print <<"EDQ"; # -*- buffer-read-only: t -*- # -# This file is auto-generated. ***ANY*** changes here will be lost +# This file is auto-generated by ext/Errno/Errno_pm.PL. +# ***ANY*** changes here will be lost. # package Errno; @@ -391,6 +392,7 @@ sub STORE { Carp::confess("ERRNO hash is read only!"); } +# This is the true return value *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space sub NEXTKEY { @@ -407,7 +409,9 @@ sub EXISTS { exists $err{$errname}; } -tie %!, __PACKAGE__; # Returns an object, objects are true. +sub _tie_it { + tie %{$_[0]}, __PACKAGE__; +} __END__ @@ -432,9 +436,8 @@ file. These are included in a second export tag, C<:WINSOCK>. C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero value only if C<$!> is set to that value. For example: - use Errno; - - unless (open(FH, "/fangorn/spouse")) { + my $fh; + unless (open($fh, "<", "/fangorn/spouse")) { if ($!{ENOENT}) { warn "Get a wife!\n"; } else { @@ -446,6 +449,9 @@ If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}> returns C<"">. You may use C<exists $!{EFOO}> to check whether the constant is available on the system. +Perl automatically loads C<Errno> the first time you use C<%!>, so you don't +need an explicit C<use>. + =head1 CAVEATS Importing a particular constant may not be very portable, because the diff --git a/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm b/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm index 61c66df7ed1..6090970adc9 100644 --- a/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm +++ b/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm @@ -4,11 +4,9 @@ use strict; require Exporter; use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body); -use vars qw($VERSION @ISA @EXPORT); - -@ISA = qw(Exporter); -@EXPORT = qw(writemain); -$VERSION = '1.05'; +our @ISA = qw(Exporter); +our @EXPORT = qw(writemain); +our $VERSION = '1.08'; # blead will run this with miniperl, hence we can't use autodie or File::Temp my $temp; @@ -36,10 +34,10 @@ sub writemain{ my(@exts) = @_; printf $fh <<'EOF!HEAD', xsi_header(); -/* miniperlmain.c +/* miniperlmain.c or perlmain.c - a generated file * * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003, - * 2004, 2005, 2006, 2007, by Larry Wall and others + * 2004, 2005, 2006, 2007, 2016 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -56,11 +54,18 @@ sub writemain{ /* This file contains the main() function for the perl interpreter. * Note that miniperlmain.c contains main() for the 'miniperl' binary, - * while perlmain.c contains main() for the 'perl' binary. + * while perlmain.c contains main() for the 'perl' binary. The typical + * difference being that the latter includes Dynaloader. * * Miniperl is like perl except that it does not support dynamic loading, * and in fact is used to build the dynamic modules needed for the 'real' * perl executable. + * + * The content of the body of this generated file is mostly contained + * in Miniperl.pm - edit that file if you want to change anything. + * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while + * perlmain.c is built automatically by Makefile (so the former is + * included in the tarball while the latter isn't). */ #ifdef OEMVS @@ -146,8 +151,7 @@ main(int argc, char **argv, char **env) PL_perl_destruct_level = 0; } PL_exit_flags |= PERL_EXIT_DESTRUCT_END; - exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL); - if (!exitstatus) + if (!perl_parse(my_perl, xs_init, argc, argv, (char **)NULL)) perl_run(my_perl); #ifndef PERL_MICRO @@ -217,7 +221,7 @@ __END__ =head1 NAME -ExtUtils::Miniperl - write the C code for perlmain.c +ExtUtils::Miniperl - write the C code for miniperlmain.c and perlmain.c =head1 SYNOPSIS @@ -230,18 +234,21 @@ ExtUtils::Miniperl - write the C code for perlmain.c =head1 DESCRIPTION -C<writemain()> takes an argument list of directories containing archive +C<writemain()> takes an argument list of zero or more directories +containing archive libraries that relate to perl modules and should be linked into a new -perl binary. It writes a corresponding F<perlmain.c> file that +perl binary. It writes a corresponding F<miniperlmain.c> or F<perlmain.c> +file that is a plain C file containing all the bootstrap code to make the modules associated with the libraries available from within perl. If the first argument to C<writemain()> is a reference to a scalar it is used as the filename to open for output. Any other reference is used as the filehandle to write to. Otherwise output defaults to C<STDOUT>. -The typical usage is from within a Makefile generated by -L<ExtUtils::MakeMaker>. So under normal circumstances you won't have to -deal with this module directly. +The typical usage is from within perl's own Makefile (to build +F<perlmain.c>) or from F<regen/miniperlmain.pl> (to build miniperlmain.c). +So under normal circumstances you won't have to deal with this module +directly. =head1 SEE ALSO diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm index c0b5a4720d9..07df4941a10 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm @@ -37,7 +37,7 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.26'; +$VERSION = '1.31'; sub import { require Exporter; @@ -75,6 +75,12 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) { # File::Glob::glob() is deprecated because its prototype is different from # CORE::glob() (use bsd_glob() instead) sub glob { + use 5.024; + use warnings (); + warnings::warnif (deprecated => + "File::Glob::glob() will disappear in perl 5.30. " . + "Use File::Glob::bsd_glob() instead.") unless state $warned ++; + splice @_, 1; # no flags goto &bsd_glob; } @@ -176,10 +182,15 @@ means this will loop forever: =head3 C<bsd_glob> This function, which is included in the two export tags listed above, -takes one or two arguments. The first is the glob pattern. The second is -a set of flags ORed together. The available flags are listed below under -L</POSIX FLAGS>. If the second argument is omitted, C<GLOB_CSH> (or -C<GLOB_CSH|GLOB_NOCASE> on VMS and DOSish systems) is used by default. +takes one or two arguments. The first is the glob pattern. The +second, if given, is a set of flags ORed together. The available +flags and the default set of flags are listed below under L</POSIX FLAGS>. + +Remember that to use the named constants for flags you must import +them, for example with C<:bsd_glob> described above. If not imported, +and C<use strict> is not in effect, then the constants will be +treated as bareword strings, which won't do what you what. + =head3 C<:nocase> and C<:case> @@ -196,7 +207,9 @@ uses this internally. =head2 POSIX FLAGS -The POSIX defined flags for bsd_glob() are: +If no flags argument is give then C<GLOB_CSH> is set, and on VMS and +Windows systems, C<GLOB_NOCASE> too. Otherwise the flags to use are +determined solely by the flags argument. The POSIX defined flags are: =over 4 diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs index e0a36814e09..9779d54ca6a 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs @@ -121,7 +121,7 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, boo /* chuck it all out, quick or slow */ if (gimme == G_ARRAY) { - if (!on_stack) { + if (!on_stack && AvFILLp(entries) + 1) { EXTEND(SP, AvFILLp(entries)+1); Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *); SP += AvFILLp(entries)+1; diff --git a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c index 821ef200ad6..0d042b4afb5 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c +++ b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c @@ -87,9 +87,7 @@ static char sscsid[]= "$OpenBSD: glob.c,v 1.8.10.1 2001/04/10 jason Exp $"; # endif #endif -#ifdef I_LIMITS #include <limits.h> -#endif #ifndef ARG_MAX # ifdef _SC_ARG_MAX @@ -563,8 +561,12 @@ glob0(const Char *pattern, glob_t *pglob) break; case BG_STAR: pglob->gl_flags |= GLOB_MAGCHAR; - /* collapse adjacent stars to one, - * to avoid exponential behavior + /* Collapse adjacent stars to one. + * This is required to ensure that a pattern like + * "a**" matches a name like "a", as without this + * check when the first star matched everything it would + * cause the second star to return a match fail. + * As long ** is folded here this does not happen. */ if (bufnext == patbuf || bufnext[-1] != M_ALL) *bufnext++ = M_ALL; @@ -909,35 +911,56 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp) /* - * pattern matching function for filenames. Each occurrence of the * - * pattern causes a recursion level. + * pattern matching function for filenames using state machine to avoid + * recursion. We maintain a "nextp" and "nextn" to allow us to backtrack + * without additional callframes, and to do cleanly prune the backtracking + * state when multiple '*' (start) matches are included in the pattern. + * + * Thanks to Russ Cox for the improved state machine logic to avoid quadratic + * matching on failure. + * + * https://research.swtch.com/glob + * + * An example would be a pattern + * ("a*" x 100) . "y" + * against a file name like + * ("a" x 100) . "x" + * */ static int match(Char *name, Char *pat, Char *patend, int nocase) { int ok, negate_range; Char c, k; + Char *nextp = NULL; + Char *nextn = NULL; + redo: while (pat < patend) { c = *pat++; switch (c & M_MASK) { case M_ALL: if (pat == patend) return(1); - do - if (match(name, pat, patend, nocase)) - return(1); - while (*name++ != BG_EOS) - ; - return(0); + if (*name == BG_EOS) + return 0; + nextn = name + 1; + nextp = pat - 1; + break; case M_ONE: + /* since * matches leftmost-shortest first * + * if we encounter the EOS then backtracking * + * will not help, so we can exit early here. */ if (*name++ == BG_EOS) - return(0); + return 0; break; case M_SET: ok = 0; + /* since * matches leftmost-shortest first * + * if we encounter the EOS then backtracking * + * will not help, so we can exit early here. */ if ((k = *name++) == BG_EOS) - return(0); + return 0; if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) ++pat; while (((c = *pat++) & M_MASK) != M_END) @@ -953,16 +976,25 @@ match(Char *name, Char *pat, Char *patend, int nocase) } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) ok = 1; if (ok == negate_range) - return(0); + goto fail; break; default: k = *name++; if (nocase ? (tolower(k) != tolower(c)) : (k != c)) - return(0); + goto fail; break; } } - return(*name == BG_EOS); + if (*name == BG_EOS) + return 1; + + fail: + if (nextn) { + pat = nextp; + name = nextn; + goto redo; + } + return 0; } /* Free allocated data belonging to a glob_t structure. */ diff --git a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm index a06fa13884b..a33b8b59b12 100644 --- a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm +++ b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm @@ -20,12 +20,16 @@ module you should really have a copy of the gdbm manualpage at hand. Most of the libgdbm.a functions are available through the GDBM_File interface. +Unlike Perl's built-in hashes, it is not safe to C<delete> the current +item from a GDBM_File tied hash while iterating over it with C<each>. +This is a limitation of the gdbm library. + =head1 AVAILABILITY gdbm is available from any GNU archive. The master site is C<ftp.gnu.org>, but you are strongly urged to use one of the many mirrors. You can obtain a list of mirror sites from -http://www.gnu.org/order/ftp.html. +L<http://www.gnu.org/order/ftp.html>. =head1 BUGS @@ -69,7 +73,7 @@ require XSLoader; ); # This module isn't dual life, so no need for dev version numbers. -$VERSION = '1.15'; +$VERSION = '1.17'; XSLoader::load(); diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs index 2fcb612525a..9cfd87a694b 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs @@ -431,7 +431,7 @@ OUTPUT: void CLONE(char* classname) CODE: - if (0 == strcmp(classname, "Hash::Util::FieldHash")) { + if (strEQ(classname, "Hash::Util::FieldHash")) { HUF_global(aTHX_ HUF_CLONE); HUF_fix_objects(aTHX); } diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm index 0d0b7921c3c..7b39cca450a 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Scalar::Util qw( reftype); -our $VERSION = '1.19'; +our $VERSION = '1.20'; require Exporter; our @ISA = qw(Exporter); diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t index 61d02ec6465..ab3d74ba57e 100755 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t @@ -103,9 +103,9 @@ sub numbers_first { # Sort helper: All digit entries sort in front of others is( $counter, 1, "list each doesn't trigger"); is( "@x", "abc 123", "the return is correct"); - $x = %h; + $x = scalar %h; is( $counter, 1, "hash in scalar context doesn't trigger"); - like( $x, qr!^\d+/\d+$!, "correct result"); + is( $x, 1, "correct result"); (@x) = %h; is( $counter, 1, "hash in list context doesn't trigger"); diff --git a/gnu/usr.bin/perl/ext/Hash-Util/Changes b/gnu/usr.bin/perl/ext/Hash-Util/Changes index ddef72cea6e..beb3f7eb409 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/Changes +++ b/gnu/usr.bin/perl/ext/Hash-Util/Changes @@ -1,5 +1,10 @@ Revision history for Perl extension Hash::Util. +0.20 + Add bucket_ratio, num_buckets, used_buckets as a back-compat + shin for 5.25 where we remove the bucket data from scalar(%hash) + by making it return the count of keys by default. + 0.17 Add bucket_stats_formatted() as utility method to Hash::Util Bug fixes to hash_stats() diff --git a/gnu/usr.bin/perl/ext/Hash-Util/Util.xs b/gnu/usr.bin/perl/ext/Hash-Util/Util.xs index 9481dc7997b..095a78c6e6d 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/Util.xs +++ b/gnu/usr.bin/perl/ext/Hash-Util/Util.xs @@ -7,6 +7,16 @@ MODULE = Hash::Util PACKAGE = Hash::Util void +_clear_placeholders(hashref) + HV *hashref + PROTOTYPE: \% + PREINIT: + HV *hv; + CODE: + hv = MUTABLE_HV(hashref); + hv_clear_placeholders(hv); + +void all_keys(hash,keys,placeholder) HV *hash AV *keys @@ -85,7 +95,8 @@ hash_value(string,...) U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen); if ( seedlen < PERL_HASH_SEED_BYTES ) { sv_dump(ST(1)); - Perl_croak(aTHX_ "seed len must be at least %d long only got %"UVuf" bytes", PERL_HASH_SEED_BYTES, (UV)seedlen); + Perl_croak(aTHX_ "seed len must be at least %d long only got %" + UVuf " bytes", PERL_HASH_SEED_BYTES, (UV)seedlen); } PERL_HASH_WITH_SEED(seedbuf, uv, pv, len); @@ -263,3 +274,55 @@ bucket_array(rhv) } XSRETURN(0); } + +void +bucket_ratio(rhv) + SV* rhv + PROTOTYPE: \% + PPCODE: +{ + if (SvROK(rhv)) { + rhv= SvRV(rhv); + if ( SvTYPE(rhv)==SVt_PVHV ) { +#if PERL_VERSION < 25 + SV *ret= Perl_hv_scalar(aTHX_ (HV*)rhv); +#else + SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv); +#endif + ST(0)= ret; + XSRETURN(1); + } + } + XSRETURN_UNDEF; +} + +void +num_buckets(rhv) + SV* rhv + PROTOTYPE: \% + PPCODE: +{ + if (SvROK(rhv)) { + rhv= SvRV(rhv); + if ( SvTYPE(rhv)==SVt_PVHV ) { + XSRETURN_UV(HvMAX((HV*)rhv)+1); + } + } + XSRETURN_UNDEF; +} + +void +used_buckets(rhv) + SV* rhv + PROTOTYPE: \% + PPCODE: +{ + if (SvROK(rhv)) { + rhv= SvRV(rhv); + if ( SvTYPE(rhv)==SVt_PVHV ) { + XSRETURN_UV(HvFILL((HV*)rhv)); + } + } + XSRETURN_UNDEF; +} + diff --git a/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm b/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm index a947b9a76ef..1a9e9ac8103 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm +++ b/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm @@ -34,10 +34,18 @@ our @EXPORT_OK = qw( lock_hashref_recurse unlock_hashref_recurse hash_traversal_mask + + bucket_ratio + used_buckets + num_buckets ); -our $VERSION = '0.19'; -require XSLoader; -XSLoader::load(); +BEGIN { + # make sure all our XS routines are available early so their prototypes + # are correctly applied in the following code. + our $VERSION = '0.22'; + require XSLoader; + XSLoader::load(); +} sub import { my $class = shift; @@ -168,7 +176,7 @@ Both routines return a reference to the hash operated on. sub lock_ref_keys { my($hash, @keys) = @_; - Internals::hv_clear_placeholders %$hash; + _clear_placeholders(%$hash); if( @keys ) { my %keys = map { ($_ => 1) } @keys; my %original_keys = map { ($_ => 1) } keys %$hash; @@ -203,6 +211,19 @@ sub unlock_ref_keys { sub lock_keys (\%;@) { lock_ref_keys(@_) } sub unlock_keys (\%) { unlock_ref_keys(@_) } +#=item B<_clear_placeholders> +# +# This function removes any placeholder keys from a hash. See Perl_hv_clear_placeholders() +# in hv.c for what it does exactly. It is currently exposed as XS by universal.c and +# injected into the Hash::Util namespace. +# +# It is not intended for use outside of this module, and may be changed +# or removed without notice or deprecation cycle. +# +#=cut +# +# sub _clear_placeholders {} # just in case someone searches... + =item B<lock_keys_plus> lock_keys_plus(%hash,@additional_keys) @@ -221,7 +242,7 @@ Returns a reference to %hash sub lock_ref_keys_plus { my ($hash,@keys) = @_; my @delete; - Internals::hv_clear_placeholders(%$hash); + _clear_placeholders(%$hash); foreach my $key (@keys) { unless (exists($hash->{$key})) { $hash->{$key}=undef; @@ -727,6 +748,29 @@ order. B<Note> that this does B<not> guarantee that B<two> hashes will produce the same key order for the same hash seed and traversal mask, items that collide into one bucket may have different orders regardless of this setting. +=item B<bucket_ratio> + +This function behaves the same way that scalar(%hash) behaved prior to +Perl 5.25. Specifically if the hash is tied, then it calls the SCALAR tied +hash method, if untied then if the hash is empty it return 0, otherwise it +returns a string containing the number of used buckets in the hash, +followed by a slash, followed by the total number of buckets in the hash. + + my %hash=("foo"=>1); + print Hash::Util::bucket_ratio(%hash); # prints "1/8" + +=item B<used_buckets> + +This function returns the count of used buckets in the hash. It is expensive +to calculate and the value is NOT cached, so avoid use of this function +in production code. + +=item B<num_buckets> + +This function returns the total number of buckets the hash holds, or would +hold if the array were created. (When a hash is freshly created the array +may not be allocated even though this value will be non-zero.) + =back =head2 Operating on references to hashes. diff --git a/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t b/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t index 4a12fd1764f..c52a8e4b884 100755 --- a/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t +++ b/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t @@ -606,9 +606,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my $array1= bucket_array({}); my $array2= bucket_array({1..10}); is("@info1","0 8 0"); - is("@info2[0,1]","5 8"); + like("@info2[0,1]",qr/5 (?:8|16)/); is("@stats1","0 8 0"); - is("@stats2[0,1]","5 8"); + like("@stats2[0,1]",qr/5 (?:8|16)/); my @keys1= sort map { ref $_ ? @$_ : () } @$array1; my @keys2= sort map { ref $_ ? @$_ : () } @$array2; is("@keys1",""); diff --git a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm index 033d8de1d7c..8ba76f2d512 100644 --- a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm +++ b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm @@ -72,7 +72,7 @@ our @EXPORT_OK = qw( YESSTR ); -our $VERSION = '0.13'; +our $VERSION = '0.17'; XSLoader::load(); @@ -90,7 +90,9 @@ I18N::Langinfo - query locale information =head1 DESCRIPTION The langinfo() function queries various locale information that can be -used to localize output and user interfaces. The langinfo() requires +used to localize output and user interfaces. It uses the current underlying +locale, regardless of whether or not it was called from within the scope of +S<C<use locale>>. The langinfo() requires one numeric argument that identifies the locale constant to query: if no argument is supplied, C<$_> is used. The numeric constants appropriate to be used as arguments are exportable from I18N::Langinfo. @@ -111,13 +113,19 @@ answers for a yes/no question in the current locale. In other words, in the "C" (or English) locale the above will probably print something like: - Sun? [yes/no] + Sun? [yes/no] but under a French locale - dim? [oui/non] + dim? [oui/non] -The usually available constants are +The usually available constants are as follows. + +=over 4 + +=item * + +For abbreviated and full length days of the week and months of the year: ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7 ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6 @@ -126,52 +134,141 @@ The usually available constants are MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12 -for abbreviated and full length days of the week and months of the year, +=item * + +For the date-time, date, and time formats used by the strftime() function +(see L<POSIX>): D_T_FMT D_FMT T_FMT -for the date-time, date, and time formats used by the strftime() function -(see L<POSIX>) +=item * + +For the locales for which it makes sense to have ante meridiem and post +meridiem time formats: AM_STR PM_STR T_FMT_AMPM -for the locales for which it makes sense to have ante meridiem and post -meridiem time formats, +=item * + +For the character code set being used (such as "ISO8859-1", "cp850", +"koi8-r", "sjis", "utf8", etc.), and for the currency string: - CODESET CRNCYSTR RADIXCHAR + CODESET CRNCYSTR -for the character code set being used (such as "ISO8859-1", "cp850", -"koi8-r", "sjis", "utf8", etc.), for the currency string, for the +=item * + +For an alternate representation of digits, for the radix character used between the integer and the fractional part -of decimal numbers (yes, this is redundant with POSIX::localeconv()) +of decimal numbers, the group separator string for large-ish floating point +numbers (yes, the final two are redundant with +L<POSIX::localeconv()|POSIX/localeconv>): + + ALT_DIGITS RADIXCHAR THOUSEP + +=item * + +For the affirmative and negative responses and expressions: YESSTR YESEXPR NOSTR NOEXPR -for the affirmative and negative responses and expressions, and +=item * + +For the eras based on typically some ruler, such as the Japanese Emperor +(naturally only defined in the appropriate locales): ERA ERA_D_FMT ERA_D_T_FMT ERA_T_FMT -for the Japanese Emperor eras (naturally only defined under Japanese locales). +=back -See your L<langinfo(3)> for more information about the available -constants. (Often this means having to look directly at the -F<langinfo.h> C header file.) +Starting in Perl 5.28, this module is available even on systems that lack a +native C<nl_langinfo>. On such systems, it uses various methods to construct +what that function, if present, would return. But there are potential +glitches. These are the items that could be different: + +=over + +=item C<ERA> + +Unimplemented, so returns C<"">. + +=item C<CODESET> + +Unimplemented, except on Windows, due to the vagaries of vendor locale names, +returning C<""> on non-Windows. + +=item C<YESEXPR> + +=item C<YESSTR> + +=item C<NOEXPR> + +=item C<NOSTR> -Note that unfortunately none of the above constants are guaranteed -to be available on a particular platform. To be on the safe side -you can wrap the import in an eval like this: +Only the values for English are returned. C<YESSTR> and C<NOSTR> have been +removed from POSIX 2008, and are retained here for backwards compatibility. +Your platform's C<nl_langinfo> may not support them. - eval { - require I18N::Langinfo; - I18N::Langinfo->import(qw(langinfo CODESET)); - $codeset = langinfo(CODESET()); # note the () - }; - if ($@) { ... failed ... } +=item C<D_FMT> + +Always evaluates to C<%x>, the locale's appropriate date representation. + +=item C<T_FMT> + +Always evaluates to C<%X>, the locale's appropriate time representation. + +=item C<D_T_FMT> + +Always evaluates to C<%c>, the locale's appropriate date and time +representation. + +=item C<CRNCYSTR> + +The return may be incorrect for those rare locales where the currency symbol +replaces the radix character. +Send email to L<mailto:perlbug@perl.org> if you have examples of it needing +to work differently. + +=item C<ALT_DIGITS> + +Currently this gives the same results as Linux does. +Send email to L<mailto:perlbug@perl.org> if you have examples of it needing +to work differently. + +=item C<ERA_D_FMT> + +=item C<ERA_T_FMT> + +=item C<ERA_D_T_FMT> + +=item C<T_FMT_AMPM> + +These are derived by using C<strftime()>, and not all versions of that function +know about them. C<""> is returned for these on such systems. + +=back + +See your L<nl_langinfo(3)> for more information about the available +constants. (Often this means having to look directly at the +F<langinfo.h> C header file.) =head2 EXPORT By default only the C<langinfo()> function is exported. +=head1 BUGS + +Before Perl 5.28, the returned values are unreliable for the C<RADIXCHAR> and +C<THOUSEP> locale constants. + +Starting in 5.28, changing locales on threaded builds is supported on systems +that offer thread-safe locale functions. These include POSIX 2008 systems and +Windows starting with Visual Studio 2005, and this module will work properly +in such situations. However, on threaded builds on Windows prior to Visual +Studio 2015, retrieving the items C<CRNCYSTR> and C<THOUSEP> can result in a +race with a thread that has converted to use the global locale. It is quite +uncommon for a thread to have done this. It would be possible to construct a +workaround for this; patches welcome: see L<perlapi/switch_to_global_locale>. + =head1 SEE ALSO L<perllocale>, L<POSIX/localeconv>, L<POSIX/setlocale>, L<nl_langinfo(3)>. @@ -180,13 +277,13 @@ The langinfo() is just a wrapper for the C nl_langinfo() interface. =head1 AUTHOR -Jarkko Hietaniemi, E<lt>jhi@hut.fiE<gt> +Jarkko Hietaniemi, E<lt>jhi@hut.fiE<gt>. Now maintained by Perl 5 porters. =head1 COPYRIGHT AND LICENSE Copyright 2001 by Jarkko Hietaniemi This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs index 582b7fa634c..904b424b192 100644 --- a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs +++ b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs @@ -1,4 +1,6 @@ #define PERL_NO_GET_CONTEXT +#define PERL_EXT +#define PERL_EXT_LANGINFO #include "EXTERN.h" #include "perl.h" @@ -7,6 +9,8 @@ #ifdef I_LANGINFO # define __USE_GNU 1 /* Enables YESSTR, otherwise only __YESSTR. */ # include <langinfo.h> +#else +# include <perl_langinfo.h> #endif #include "const-c.inc" @@ -20,17 +24,77 @@ INCLUDE: const-xs.inc SV* langinfo(code) int code + PREINIT: + const char * value; + STRLEN len; PROTOTYPE: _ CODE: #ifdef HAS_NL_LANGINFO if (code < 0) { SETERRNO(EINVAL, LIB_INVARG); RETVAL = &PL_sv_undef; - } else { - RETVAL = newSVpv(nl_langinfo(code), 0); - } -#else - croak("nl_langinfo() not implemented on this architecture"); + } else #endif + { + value = Perl_langinfo(code); + len = strlen(value); + RETVAL = newSVpvn(Perl_langinfo(code), len); + + /* Now see if the UTF-8 flag should be turned on */ +#ifdef USE_LOCALE_CTYPE /* No utf8 strings if not using LC_CTYPE */ + + /* If 'value' is ASCII or not legal UTF-8, the flag doesn't get + * turned on, so skip the followin code */ + if (is_utf8_non_invariant_string((U8 *) value, len)) { + int category; + + /* Check if the locale is a UTF-8 one. The returns from + * Perl_langinfo() are in different locale categories, so check the + * category corresponding to this item */ + switch (code) { + + /* This should always return ASCII, so we could instead + * legitimately panic here, but soldier on */ + case CODESET: + category = LC_CTYPE; + break; + + case RADIXCHAR: + case THOUSEP: +# ifdef USE_LOCALE_NUMERIC + category = LC_NUMERIC; +# else + /* Not ideal, but the best we can do on such a platform */ + category = LC_CTYPE; +# endif + break; + + case CRNCYSTR: +# ifdef USE_LOCALE_MONETARY + category = LC_MONETARY; +# else + category = LC_CTYPE; +# endif + break; + + default: +# ifdef USE_LOCALE_TIME + category = LC_TIME; +# else + category = LC_CTYPE; +# endif + break; + } + + /* Here the return is legal UTF-8. Turn on that flag if the + * locale is UTF-8. (Otherwise, could just be a coincidence.) + * */ + if (_is_cur_LC_category_utf8(category)) { + SvUTF8_on(RETVAL); + } + } +#endif /* USE_LOCALE_CTYPE */ + } + OUTPUT: - RETVAL + RETVAL diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t index 25cfdfb6aee..aa196e5cf20 100755 --- a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t +++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t @@ -210,7 +210,7 @@ foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { my $out = IO::Handle->new(); my $pid = eval { local $SIG{__WARN__} = sub { - open my $fh, '>/dev/tty'; + open my $fh, '>', '/dev/tty'; return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!; print $fh "@_"; die @_ diff --git a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL index a48c039fa88..fe2cb407f57 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL @@ -1,8 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'NDBM_File', - #LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], + LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', - INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm index 31840257a37..99799bc5209 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm @@ -7,7 +7,7 @@ require Tie::Hash; require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.14"; +our $VERSION = "1.15"; XSLoader::load(); diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs index eaa1923c36f..9b708119aee 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs @@ -175,6 +175,7 @@ odbm_STORE(db, key, value, flags = DBM_REPLACE) croak("odbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); } + PERL_UNUSED_VAR(flags); int odbm_DELETE(db, key) diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm index 1522c4c3780..9d97ef15401 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.34"; +$VERSION = "1.43"; use Carp; use Exporter (); @@ -312,7 +312,7 @@ invert_opset function. av2arylen rv2hv helem hslice kvhslice each values keys exists delete - aeach akeys avalues multideref + aeach akeys avalues multideref argelem argdefelem argcheck preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec int hex oct abs pow multiply i_multiply @@ -338,7 +338,7 @@ invert_opset function. warn die lineseq nextstate scope enter leave - rv2cv anoncode prototype coreargs anonconst + rv2cv anoncode prototype coreargs avhvswitch anonconst entersub leavesub leavesublv return method method_named method_super method_redir method_redir_super @@ -353,7 +353,7 @@ These memory related ops are not included in :base_core because they can easily be used to implement a resource attack (e.g., consume all available memory). - concat repeat join range + concat multiconcat repeat join range anonlist anonhash @@ -409,7 +409,7 @@ These are a hotchpotch of opcodes still waiting to be considered bless -- could be used to change ownership of objects (reblessing) - pushre regcmaybe regcreset regcomp subst substcont + regcmaybe regcreset regcomp subst substcont sprintf prtf -- can core dump diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs index 936ffba25ee..1401b25f1bb 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs @@ -51,7 +51,7 @@ op_names_init(pTHX) int i; STRLEN len; char **op_names; - char *bitmap; + U8 *bitmap; dMY_CXT; op_named_bits = newHV(); @@ -65,10 +65,11 @@ op_names_init(pTHX) put_op_bitspec(aTHX_ STR_WITH_LEN(":none"), sv_2mortal(new_opset(aTHX_ Nullsv))); opset_all = new_opset(aTHX_ Nullsv); - bitmap = SvPV(opset_all, len); + bitmap = (U8*)SvPV(opset_all, len); memset(bitmap, 0xFF, len-1); /* deal with last byte specially, see below */ /* Take care to set the right number of bits in the last byte */ - bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; + bitmap[len-1] = (PL_maxo & 0x07) ? ((~(0xFF << (PL_maxo & 0x07))) & 0xFF) + : 0xFF; put_op_bitspec(aTHX_ STR_WITH_LEN(":all"), opset_all); /* don't mortalise */ } @@ -254,7 +255,7 @@ PROTOTYPES: ENABLE BOOT: { MY_CXT_INIT; - assert(PL_maxo < OP_MASK_BUF_SIZE); + STATIC_ASSERT_STMT(PL_maxo < OP_MASK_BUF_SIZE); opset_len = (PL_maxo + 7) / 8; if (opcode_debug >= 1) warn("opset_len %ld\n", (long)opset_len); @@ -433,7 +434,7 @@ CODE: if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) croak("Not a Safe object"); - mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); + mask = *hv_fetchs((HV*)SvRV(safe), "Mask", 1); if (ONLY_THESE) /* *_only = new mask, else edit current */ sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); else diff --git a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL index 5a65173958f..5d5c009c3c9 100644 --- a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL +++ b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL @@ -20,6 +20,9 @@ if ($^O eq 'solaris') { if ($^O eq 'aix' && $Config{uselongdouble}) { push @libs, qw(c128); } +if ($^O eq 'cygwin' && $Config{usequadmath}) { + push @libs, qw(quadmath); +} WriteMakefile( NAME => 'POSIX', @libs ? ( 'LIBS' => [ join(" ", map { "-l$_" } @libs) ] ) : (), @@ -47,8 +50,9 @@ my @names = ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV FILENAME_MAX F_OK HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON - LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME - LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpnam MAX_CANON + LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION LC_MEASUREMENT + LC_MESSAGES LC_MONETARY LC_NUMERIC LC_PAPER LC_TELEPHONE LC_TIME + LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON MAX_INPUT MB_LEN_MAX MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL NAME_MAX NCCS NGROUPS_MAX NOFLSH OPEN_MAX OPOST PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK SCHAR_MAX @@ -66,7 +70,8 @@ my @names = _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION EAI_AGAIN EAI_BADFLAGS EAI_FAIL EAI_FAMILY EAI_MEMORY EAI_NONAME - EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM EAI_OVERFLOW), + EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM EAI_OVERFLOW + PRIO_PROCESS PRIO_PGRP PRIO_USER), {name=>"CLK_TCK", not_constant=>1}, {name=>"MB_CUR_MAX", not_constant=>1}, {name=>"EXIT_FAILURE", default=>["IV", "1"]}, @@ -74,8 +79,6 @@ my @names = {name=>"SIG_DFL", value=>"PTR2IV(SIG_DFL)", not_constant=>1}, {name=>"SIG_ERR", value=>"PTR2IV(SIG_ERR)", not_constant=>1}, {name=>"SIG_IGN", value=>"PTR2IV(SIG_IGN)", not_constant=>1}, - # L_tmpnam[e] was a typo--retained for compatibility - {name=>"L_tmpname", value=>"L_tmpnam"}, {name=>"NULL", value=>"0"}, {name=>"_POSIX_JOB_CONTROL", type=>"YES", default=>["IV", "0"]}, {name=>"_POSIX_SAVED_IDS", type=>"YES", default=>["IV", "0"]}, @@ -94,11 +97,17 @@ END #endif '}); -push @names, - {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1}, - {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1}, - {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1}, - {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1}; +if ($Config{d_double_has_inf}) { + push @names, + {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1}, + {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1}, +} + +if ($Config{d_double_has_nan}) { + push @names, + {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1}, + {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1}; +} push @names, {name=>$_, type=>"UV"} foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs index 5a82b8182ce..74973058417 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs @@ -1,4 +1,5 @@ #define PERL_EXT_POSIX +#define PERL_EXT #ifdef NETWARE #define _POSIX_ @@ -17,6 +18,9 @@ #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" + +static int not_here(const char *s); + #if defined(PERL_IMPLICIT_SYS) # undef signal # undef open @@ -31,15 +35,13 @@ #ifdef WIN32 #include <sys/errno2.h> #endif -#ifdef I_FLOAT #include <float.h> -#endif #ifdef I_FENV +#if !(defined(__vax__) && defined(__NetBSD__)) #include <fenv.h> #endif -#ifdef I_LIMITS -#include <limits.h> #endif +#include <limits.h> #include <locale.h> #include <math.h> #ifdef I_PWD @@ -48,15 +50,20 @@ #include <setjmp.h> #include <signal.h> #include <stdarg.h> - -#ifdef I_STDDEF #include <stddef.h> -#endif #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef I_SYS_TIME +# include <sys/time.h> +#endif + +#ifdef I_SYS_RESOURCE +# include <sys/resource.h> +#endif + #if defined(USE_QUADMATH) && defined(I_QUADMATH) # undef M_E @@ -704,7 +711,11 @@ static NV my_expm1(NV x) #ifndef c99_fdim static NV my_fdim(NV x, NV y) { +#ifdef NV_NAN return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0); +#else + return (x > y ? x - y : 0); +#endif } # define c99_fdim my_fdim #endif @@ -720,11 +731,13 @@ static NV my_fma(NV x, NV y, NV z) #ifndef c99_fmax static NV my_fmax(NV x, NV y) { +#ifdef NV_NAN if (Perl_isnan(x)) { return Perl_isnan(y) ? NV_NAN : y; } else if (Perl_isnan(y)) { return x; } +#endif return x > y ? x : y; } # define c99_fmax my_fmax @@ -733,11 +746,13 @@ static NV my_fmax(NV x, NV y) #ifndef c99_fmin static NV my_fmin(NV x, NV y) { +#ifdef NV_NAN if (Perl_isnan(x)) { return Perl_isnan(y) ? NV_NAN : y; } else if (Perl_isnan(y)) { return x; } +#endif return x < y ? x : y; } # define c99_fmin my_fmin @@ -768,8 +783,10 @@ static NV my_hypot(NV x, NV y) x = PERL_ABS(x); /* Take absolute values. */ if (y == 0) return x; +#ifdef NV_INF if (Perl_isnan(y)) return NV_INF; +#endif y = PERL_ABS(y); if (x < y) { /* Swap so that y is less. */ t = x; @@ -816,10 +833,18 @@ static NV my_lgamma(NV x); static NV my_tgamma(NV x) { const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */ +#ifdef NV_NAN if (Perl_isnan(x) || x < 0.0) return NV_NAN; +#endif +#ifdef NV_INF if (x == 0.0 || x == NV_INF) +#ifdef DOUBLE_IS_IEEE_FORMAT return x == -0.0 ? -NV_INF : NV_INF; +#else + return NV_INF; +#endif +#endif /* The function domain is split into three intervals: * (0, 0.001), [0.001, 12), and (12, infinity) */ @@ -891,6 +916,7 @@ static NV my_tgamma(NV x) return result; } +#ifdef NV_INF /* Third interval: [12, +Inf) */ #if LDBL_MANT_DIG == 113 /* IEEE quad prec */ if (x > 1755.548) { @@ -901,6 +927,7 @@ static NV my_tgamma(NV x) return NV_INF; } #endif +#endif return Perl_exp(c99_lgamma(x)); } @@ -909,10 +936,14 @@ static NV my_tgamma(NV x) #ifdef USE_MY_LGAMMA static NV my_lgamma(NV x) { +#ifdef NV_NAN if (Perl_isnan(x)) return NV_NAN; +#endif +#ifdef NV_INF if (x <= 0 || x == NV_INF) return NV_INF; +#endif if (x == 1.0 || x == 2.0) return 0; if (x < 12.0) @@ -953,10 +984,14 @@ static NV my_log1p(NV x) { /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain. * Taylor series, the first four terms (the last term quartic). */ +#ifdef NV_NAN if (x < -1.0) return NV_NAN; +#endif +#ifdef NV_INF if (x == -1.0) return -NV_INF; +#endif if (PERL_ABS(x) > 1e-4) return Perl_log(1.0 + x); else @@ -1032,7 +1067,7 @@ static NV my_rint(NV x) case FE_TOWARDZERO: return MY_ROUND_TRUNC(x); case FE_DOWNWARD: return MY_ROUND_DOWN(x); case FE_UPWARD: return MY_ROUND_UP(x); - default: return NV_NAN; + default: break; } #elif defined(HAS_FPGETROUND) switch (fpgetround()) { @@ -1040,11 +1075,10 @@ static NV my_rint(NV x) case FP_RZ: return MY_ROUND_TRUNC(x); case FP_RM: return MY_ROUND_DOWN(x); case FE_RP: return MY_ROUND_UP(x); - default: return NV_NAN; + default: break; } -#else - return NV_NAN; #endif + not_here("rint"); } #endif @@ -1118,6 +1152,8 @@ static NV my_trunc(NV x) # define c99_trunc my_trunc #endif +#ifdef NV_NAN + #undef NV_PAYLOAD_DEBUG /* NOTE: the NaN payload API implementation is hand-rolled, since the @@ -1154,9 +1190,11 @@ static NV my_trunc(NV x) #endif #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE) -# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE / 2) +# define NV_PAYLOAD_SIZEOF_ASSERT(a) \ + STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2) #else -# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE) +# define NV_PAYLOAD_SIZEOF_ASSERT(a) \ + STATIC_ASSERT_STMT(sizeof(a) == NVSIZE) #endif static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) @@ -1178,7 +1216,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) { NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */ #ifdef NV_PAYLOAD_DEBUG - Perl_warn(aTHX_ "t1 = %"NVgf" (payload %"NVgf")\n", t1, payload); + Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload); #endif if (t1 <= UV_MAX) { a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */ @@ -1208,7 +1246,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) #endif #ifdef NV_PAYLOAD_DEBUG for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { - Perl_warn(aTHX_ "a[%d] = 0x%"UVxf"\n", i, a[i]); + Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]); } #endif for (i = 0; i < (int)sizeof(p); i++) { @@ -1219,7 +1257,9 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */ ((U8 *)(nvp))[i] |= b; #ifdef NV_PAYLOAD_DEBUG - Perl_warn(aTHX_ "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"UVxf")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u); + Perl_warn(aTHX_ + "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08" + UVxf ")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u); #endif a[p[i] / UVSIZE] &= ~u; } @@ -1236,7 +1276,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) #endif for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { if (a[i]) { - Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]); + Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]); break; } } @@ -1267,7 +1307,7 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv) } for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) { #ifdef NV_PAYLOAD_DEBUG - Perl_warn(aTHX_ "a[%d] = %"UVxf"\n", i, a[i]); + Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]); #endif payload *= UV_MAX; payload += a[i]; @@ -1281,6 +1321,8 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv) return payload; } +#endif /* #ifdef NV_NAN */ + /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD @@ -1288,9 +1330,7 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv) #if defined(I_TERMIOS) #include <termios.h> #endif -#ifdef I_STDLIB #include <stdlib.h> -#endif #ifndef __ultrix__ #include <string.h> #endif @@ -1558,8 +1598,8 @@ static const struct lconv_offset lconv_strings[] = { /* The Linux man pages say these are the field names for the structure * components that are LC_NUMERIC; the rest being LC_MONETARY */ -# define isLC_NUMERIC_STRING(name) (strEQ(name, "decimal_point") \ - || strEQ(name, "thousands_sep") \ +# define isLC_NUMERIC_STRING(name) ( strEQ(name, "decimal_point") \ + || strEQ(name, "thousands_sep") \ \ /* There should be no harm done \ * checking for this, even if \ @@ -1663,6 +1703,11 @@ allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) { SV *const t = newSVrv(rv, packname); void *const p = sv_grow(t, size + 1); + /* Ensure at least one use of not_here() to avoid "defined but not + * used" warning. This is not at all related to allocate_struct(); I + * just needed somewhere to dump it - DAPM */ + if (0) { not_here(""); } + SvCUR_set(t, size); SvPOK_on(t); return p; @@ -1747,7 +1792,7 @@ fix_win32_tzenv(void) perl_tz_env = ""; if (crt_tz_env == NULL) crt_tz_env = ""; - if (strcmp(perl_tz_env, crt_tz_env) != 0) { + if (strNE(perl_tz_env, crt_tz_env)) { newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char)); if (newenv != NULL) { sprintf(newenv, "TZ=%s", perl_tz_env); @@ -1852,8 +1897,9 @@ getattr(termios_ref, fd = 0) OUTPUT: RETVAL -# If we define TCSANOW here then both a found and not found constant sub -# are created causing a Constant subroutine TCSANOW redefined warning + # If we define TCSANOW here then both a found and not found constant sub + # are created causing a Constant subroutine TCSANOW redefined warning + #ifndef TCSANOW # define DEF_SETATTR_ACTION 0 #else @@ -2079,15 +2125,67 @@ localeconv() localeconv(); /* A stub to call not_here(). */ #else struct lconv *lcbuf; +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */ + bool do_free = FALSE; + locale_t cur = NULL; +# elif defined(TS_W32_BROKEN_LOCALECONV) + const char * save_global; + const char * save_thread; +# endif + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but * LC_MONETARY is already in the correct locale */ - DECLARATION_FOR_LC_NUMERIC_MANIPULATION; +# ifdef USE_LOCALE_MONETARY + + const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY); +# endif +# ifdef USE_LOCALE_NUMERIC + + bool is_numeric_utf8; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC); +# endif + RETVAL = newHV(); sv_2mortal((SV*)RETVAL); - if ((lcbuf = localeconv())) { +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) \ + && defined(HAS_DUPLOCALE) + + cur = uselocale((locale_t) 0); + if (cur == LC_GLOBAL_LOCALE) { + cur = duplocale(LC_GLOBAL_LOCALE); + do_free = TRUE; + } + + lcbuf = localeconv_l(cur); +# else + LOCALE_LOCK_V; /* Prevent interference with other threads using + localeconv() */ +# ifdef TS_W32_BROKEN_LOCALECONV + /* This is a workaround for a Windows bug prior to VS 15, in which + * localeconv only looks at the global locale. We toggle to the global + * locale; populate the return; then toggle back. We have to use + * LC_ALL instead of the individual ones because of another bug in + * Windows */ + + save_thread = savepv(Perl_setlocale(LC_NUMERIC, NULL)); + + _configthreadlocale(_DISABLE_PER_THREAD_LOCALE); + + save_global = savepv(Perl_setlocale(LC_ALL, NULL)); + + Perl_setlocale(LC_ALL, save_thread); +# endif + lcbuf = localeconv(); +# endif + if (lcbuf) { const struct lconv_offset *strings = lconv_strings; const struct lconv_offset *integers = lconv_integers; const char *ptr = (const char *) lcbuf; @@ -2095,35 +2193,36 @@ localeconv() while (strings->name) { /* This string may be controlled by either LC_NUMERIC, or * LC_MONETARY */ - bool is_utf8_locale -#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name)) - ? LC_NUMERIC - : LC_MONETARY); -#elif defined(USE_LOCALE_NUMERIC) - = _is_cur_LC_category_utf8(LC_NUMERIC); -#elif defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8(LC_MONETARY); -#else - = FALSE; -#endif + const bool is_utf8_locale = +# if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) + (isLC_NUMERIC_STRING(strings->name)) + ? is_numeric_utf8 + : is_monetary_utf8; +# elif defined(USE_LOCALE_NUMERIC) + is_numeric_utf8; +# elif defined(USE_LOCALE_MONETARY) + is_monetary_utf8; +# else + FALSE; +# endif const char *value = *((const char **)(ptr + strings->offset)); if (value && *value) { + const STRLEN value_len = strlen(value); + + /* We mark it as UTF-8 if a utf8 locale and is valid and + * variant under UTF-8 */ + const bool is_utf8 = is_utf8_locale + && is_utf8_non_invariant_string( + (U8*) value, + value_len); (void) hv_store(RETVAL, - strings->name, - strlen(strings->name), - newSVpvn_utf8(value, - strlen(value), - - /* We mark it as UTF-8 if a utf8 locale - * and is valid and variant under UTF-8 */ - is_utf8_locale - && ! is_invariant_string((U8 *) value, 0) - && is_utf8_string((U8 *) value, 0)), - 0); - } + strings->name, + strlen(strings->name), + newSVpvn_utf8(value, value_len, is_utf8), + 0); + } strings++; } @@ -2136,7 +2235,26 @@ localeconv() integers++; } } - RESTORE_LC_NUMERIC_STANDARD(); +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) + if (do_free) { + freelocale(cur); + } +# else +# ifdef TS_W32_BROKEN_LOCALECONV + Perl_setlocale(LC_ALL, save_global); + + _configthreadlocale(_ENABLE_PER_THREAD_LOCALE); + + Perl_setlocale(LC_ALL, save_thread); + + Safefree(save_global); + Safefree(save_thread); +# endif + LOCALE_UNLOCK_V; +# endif + RESTORE_LC_NUMERIC(); #endif /* HAS_LOCALECONV */ OUTPUT: RETVAL @@ -2148,116 +2266,12 @@ setlocale(category, locale = 0) PREINIT: char * retval; CODE: -#ifdef USE_LOCALE_NUMERIC - /* A 0 (or NULL) locale means only query what the current one is. We - * have the LC_NUMERIC name saved, because we are normally switched - * into the C locale for it. Switch back so an LC_ALL query will yield - * the correct results; all other categories don't require special - * handling */ - if (locale == 0) { - if (category == LC_NUMERIC) { - XSRETURN_PV(PL_numeric_name); - } -# ifdef LC_ALL - else if (category == LC_ALL) { - SET_NUMERIC_UNDERLYING(); - } -# endif - } -#endif -#ifdef WIN32 /* Use wrapper on Windows */ - retval = Perl_my_setlocale(aTHX_ category, locale); -#else - retval = setlocale(category, locale); -#endif - DEBUG_L(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - _setlocale_debug_string(category, locale, retval))); - if (! retval) { - /* Should never happen that a query would return an error, but be - * sure and reset to C locale */ - if (locale == 0) { - SET_NUMERIC_STANDARD(); - } + retval = (char *) Perl_setlocale(category, locale); + if (! retval) { XSRETURN_UNDEF; } - /* Save retval since subsequent setlocale() calls may overwrite it. */ - retval = savepv(retval); - SAVEFREEPV(retval); - - /* For locale == 0, we may have switched to NUMERIC_UNDERLYING. Switch - * back */ - if (locale == 0) { - SET_NUMERIC_STANDARD(); - XSRETURN_PV(retval); - } - else { - RETVAL = retval; -#ifdef USE_LOCALE_CTYPE - if (category == LC_CTYPE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newctype; -#ifdef LC_ALL - if (category == LC_ALL) { - newctype = setlocale(LC_CTYPE, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - _setlocale_debug_string(LC_CTYPE, NULL, newctype))); - } - else -#endif - newctype = RETVAL; - new_ctype(newctype); - } -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (category == LC_COLLATE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newcoll; -#ifdef LC_ALL - if (category == LC_ALL) { - newcoll = setlocale(LC_COLLATE, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - _setlocale_debug_string(LC_COLLATE, NULL, newcoll))); - } - else -#endif - newcoll = RETVAL; - new_collate(newcoll); - } -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (category == LC_NUMERIC -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newnum; -#ifdef LC_ALL - if (category == LC_ALL) { - newnum = setlocale(LC_NUMERIC, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - _setlocale_debug_string(LC_NUMERIC, NULL, newnum))); - } - else -#endif - newnum = RETVAL; - new_numeric(newnum); - } -#endif /* USE_LOCALE_NUMERIC */ - } + RETVAL = retval; OUTPUT: RETVAL @@ -2297,7 +2311,11 @@ acos(x) y1 = 30 CODE: PERL_UNUSED_VAR(x); +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: RETVAL = Perl_acos(x); /* C89 math */ @@ -2592,7 +2610,12 @@ fpclassify(x) #ifdef Perl_signbit RETVAL = Perl_signbit(x); #else - RETVAL = (x < 0) || (x == -0.0); + RETVAL = (x < 0); +#ifdef DOUBLE_IS_IEEE_FORMAT + if (x == -0.0) { + RETVAL = TRUE; + } +#endif #endif break; } @@ -2603,7 +2626,13 @@ NV getpayload(nv) NV nv CODE: +#ifdef DOUBLE_HAS_NAN RETVAL = S_getpayload(nv); +#else + PERL_UNUSED_VAR(nv); + RETVAL = 0.0; + not_here("getpayload"); +#endif OUTPUT: RETVAL @@ -2612,7 +2641,13 @@ setpayload(nv, payload) NV nv NV payload CODE: +#ifdef DOUBLE_HAS_NAN S_setpayload(&nv, payload, FALSE); +#else + PERL_UNUSED_VAR(nv); + PERL_UNUSED_VAR(payload); + not_here("setpayload"); +#endif OUTPUT: nv @@ -2621,8 +2656,14 @@ setpayloadsig(nv, payload) NV nv NV payload CODE: +#ifdef DOUBLE_HAS_NAN nv = NV_NAN; S_setpayload(&nv, payload, TRUE); +#else + PERL_UNUSED_VAR(nv); + PERL_UNUSED_VAR(payload); + not_here("setpayloadsig"); +#endif OUTPUT: nv @@ -2630,7 +2671,13 @@ int issignaling(nv) NV nv CODE: +#ifdef DOUBLE_HAS_NAN RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv); +#else + PERL_UNUSED_VAR(nv); + RETVAL = 0.0; + not_here("issignaling"); +#endif OUTPUT: RETVAL @@ -2656,7 +2703,11 @@ copysign(x,y) CODE: PERL_UNUSED_VAR(x); PERL_UNUSED_VAR(y); +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: #ifdef c99_copysign @@ -2850,9 +2901,14 @@ nan(payload = 0) } #elif defined(c99_nan) { - STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", nv); + STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload); if ((IV)elen == -1) { +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0.0; + not_here("nan"); +#endif } else { RETVAL = c99_nan(PL_efloatbuf); } @@ -2870,7 +2926,11 @@ jn(x,y) ALIAS: yn = 1 CODE: +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: #ifdef bessel_jn @@ -2928,7 +2988,7 @@ sigaction(sig, optaction, oldaction = 0) const char *s = SvPVX_const(ST(0)); int i = whichsig(s); - if (i < 0 && memEQ(s, "SIG", 3)) + if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG")) i = whichsig(s + 3); if (i < 0) { if (ckWARN(WARN_SIGNAL)) @@ -3241,39 +3301,30 @@ write(fd, buffer, nbytes) char * buffer size_t nbytes -SV * -tmpnam() - PREINIT: - STRLEN i; - int len; - CODE: - RETVAL = newSVpvs(""); - SvGROW(RETVAL, L_tmpnam); - /* Yes, we know tmpnam() is bad. So bad that some compilers - * and linkers warn against using it. But it is here for - * completeness. POSIX.pod warns against using it. - * - * Then again, maybe this should be removed at some point. - * No point in enabling dangerous interfaces. */ - if (ckWARN_d(WARN_DEPRECATED)) { - HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI); - if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated"); - (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0); - } - } - len = strlen(tmpnam(SvPV(RETVAL, i))); - SvCUR_set(RETVAL, len); - OUTPUT: - RETVAL - void abort() +#ifdef I_WCHAR +# include <wchar.h> +#endif + int mblen(s, n) char * s size_t n + PREINIT: +#if defined(USE_ITHREADS) && defined(HAS_MBRLEN) + mbstate_t ps; +#endif + CODE: +#if defined(USE_ITHREADS) && defined(HAS_MBRLEN) + PERL_UNUSED_RESULT(mbrlen(NULL, 0, &ps)); /* Initialize state */ + RETVAL = mbrlen(s, n, &ps); /* Prefer reentrant version */ +#else + RETVAL = mblen(s, n); +#endif + OUTPUT: + RETVAL size_t mbstowcs(s, pwcs, n) @@ -3286,6 +3337,21 @@ mbtowc(pwc, s, n) wchar_t * pwc char * s size_t n + PREINIT: +#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) + mbstate_t ps; +#endif + CODE: +#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) + memset(&ps, 0, sizeof(ps));; + PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */ + errno = 0; + RETVAL = mbrtowc(pwc, s, n, &ps); /* Prefer reentrant version */ +#else + RETVAL = mbtowc(pwc, s, n); +#endif + OUTPUT: + RETVAL int wcstombs(s, pwcs, n) @@ -3313,6 +3379,7 @@ strtod(str) DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); num = strtod(str, &unparsed); + RESTORE_LC_NUMERIC(); PUSHs(sv_2mortal(newSVnv(num))); if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); @@ -3321,7 +3388,6 @@ strtod(str) else PUSHs(&PL_sv_undef); } - RESTORE_LC_NUMERIC_STANDARD(); #ifdef HAS_STRTOLD @@ -3335,6 +3401,7 @@ strtold(str) DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); num = strtold(str, &unparsed); + RESTORE_LC_NUMERIC(); PUSHs(sv_2mortal(newSVnv(num))); if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); @@ -3343,7 +3410,6 @@ strtold(str) else PUSHs(&PL_sv_undef); } - RESTORE_LC_NUMERIC_STANDARD(); #endif @@ -3385,7 +3451,7 @@ strtoul(str, base = 0) int base PREINIT: unsigned long num; - char *unparsed; + char *unparsed = NULL; PPCODE: PERL_UNUSED_VAR(str); PERL_UNUSED_VAR(base); @@ -3520,7 +3586,7 @@ asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) if (result == (time_t)-1) SvOK_off(TARG); else if (result == 0) - sv_setpvn(TARG, "0 but true", 10); + sv_setpvs(TARG, "0 but true"); else sv_setiv(TARG, (IV)result); } else { @@ -3578,18 +3644,22 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) /* allowing user-supplied (rather than literal) formats * is normally frowned upon as a potential security risk; * but this is part of the API so we have to allow it */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; sv = sv_newmortal(); if (buf) { STRLEN len = strlen(buf); sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL); - if (SvUTF8(fmt) - || (! is_invariant_string((U8*) buf, len) - && is_utf8_string((U8*) buf, len) + if ( SvUTF8(fmt) + || ( is_utf8_non_invariant_string((U8*) buf, len) #ifdef USE_LOCALE_TIME && _is_cur_LC_category_utf8(LC_TIME) +#else /* If can't check directly, at least can see if script is consistent, + under UTF-8, which gives us an extra measure of confidence. */ + + && isSCRIPT_RUN((const U8 *) buf, buf + len, + TRUE) /* Means assume UTF-8 */ #endif )) { SvUTF8_on(sv); diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm index 9731dc9a1af..ae33cad9924 100644 --- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm +++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.65_01'; +our $VERSION = '1.84'; require XSLoader; @@ -18,24 +18,13 @@ use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD my $loaded; -sub import { - my $pkg = shift; - - load_imports() unless $loaded++; - - # Grandfather old foo_h form to new :foo_h form - s/^(?=\w+_h$)/:/ for my @list = @_; - - local $Exporter::ExportLevel = 1; - Exporter::import($pkg,@list); -} - sub croak { require Carp; goto &Carp::croak } sub usage { croak "Usage: POSIX::$_[0]" } XSLoader::load(); my %replacement = ( + L_tmpnam => undef, atexit => 'END {}', atof => undef, atoi => undef, @@ -110,6 +99,7 @@ my %replacement = ( strspn => undef, strtok => undef, tmpfile => 'IO::File::new_tmpfile', + tmpnam => 'use File::Temp', ungetc => 'IO::Handle::ungetc', vfprintf => undef, vprintf => undef, @@ -117,74 +107,103 @@ my %replacement = ( ); my %reimpl = ( + abs => 'x => CORE::abs($_[0])', + alarm => 'seconds => CORE::alarm($_[0])', assert => 'expr => croak "Assertion failed" if !$_[0]', - tolower => 'string => lc($_[0])', - toupper => 'string => uc($_[0])', - closedir => 'dirhandle => CORE::closedir($_[0])', - opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef', - readdir => 'dirhandle => CORE::readdir($_[0])', - rewinddir => 'dirhandle => CORE::rewinddir($_[0])', - errno => '$! + 0', - creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])', - fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])', - getgrgid => 'gid => CORE::getgrgid($_[0])', - getgrnam => 'name => CORE::getgrnam($_[0])', atan2 => 'x, y => CORE::atan2($_[0], $_[1])', + chdir => 'directory => CORE::chdir($_[0])', + chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', + chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])', + closedir => 'dirhandle => CORE::closedir($_[0])', cos => 'x => CORE::cos($_[0])', + creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])', + errno => '$! + 0', + exit => 'status => CORE::exit($_[0])', exp => 'x => CORE::exp($_[0])', fabs => 'x => CORE::abs($_[0])', - log => 'x => CORE::log($_[0])', - pow => 'x, exponent => $_[0] ** $_[1]', - sin => 'x => CORE::sin($_[0])', - sqrt => 'x => CORE::sqrt($_[0])', - getpwnam => 'name => CORE::getpwnam($_[0])', - getpwuid => 'uid => CORE::getpwuid($_[0])', - kill => 'pid, sig => CORE::kill $_[1], $_[0]', - raise => 'sig => CORE::kill $_[0], $$; # Is this good enough', + fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])', + fork => 'CORE::fork', + fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. getc => 'handle => CORE::getc($_[0])', getchar => 'CORE::getc(STDIN)', - gets => 'scalar <STDIN>', - remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])', - rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])', - rewind => 'filehandle => CORE::seek($_[0],0,0)', - abs => 'x => CORE::abs($_[0])', - exit => 'status => CORE::exit($_[0])', - getenv => 'name => $ENV{$_[0]}', - system => 'command => CORE::system($_[0])', - strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"', - strstr => 'big, little => CORE::index($_[0], $_[1])', - chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', - fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. - mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])', - stat => 'filename => CORE::stat($_[0])', - umask => 'mask => CORE::umask($_[0])', - wait => 'CORE::wait()', - waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])', - gmtime => 'time => CORE::gmtime($_[0])', - localtime => 'time => CORE::localtime($_[0])', - time => 'CORE::time', - alarm => 'seconds => CORE::alarm($_[0])', - chdir => 'directory => CORE::chdir($_[0])', - chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])', - fork => 'CORE::fork', getegid => '$) + 0', + getenv => 'name => $ENV{$_[0]}', geteuid => '$> + 0', getgid => '$( + 0', + getgrgid => 'gid => CORE::getgrgid($_[0])', + getgrnam => 'name => CORE::getgrnam($_[0])', getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)', getlogin => 'CORE::getlogin()', getpgrp => 'CORE::getpgrp', getpid => '$$', getppid => 'CORE::getppid', + getpwnam => 'name => CORE::getpwnam($_[0])', + getpwuid => 'uid => CORE::getpwuid($_[0])', + gets => 'scalar <STDIN>', getuid => '$<', + gmtime => 'time => CORE::gmtime($_[0])', isatty => 'filehandle => -t $_[0]', + kill => 'pid, sig => CORE::kill $_[1], $_[0]', link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])', + localtime => 'time => CORE::localtime($_[0])', + log => 'x => CORE::log($_[0])', + mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])', + opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef', + pow => 'x, exponent => $_[0] ** $_[1]', + raise => 'sig => CORE::kill $_[0], $$; # Is this good enough', + readdir => 'dirhandle => CORE::readdir($_[0])', + remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])', + rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])', + rewind => 'filehandle => CORE::seek($_[0],0,0)', + rewinddir => 'dirhandle => CORE::rewinddir($_[0])', rmdir => 'directoryname => CORE::rmdir($_[0])', + sin => 'x => CORE::sin($_[0])', + sqrt => 'x => CORE::sqrt($_[0])', + stat => 'filename => CORE::stat($_[0])', + strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"', + strstr => 'big, little => CORE::index($_[0], $_[1])', + system => 'command => CORE::system($_[0])', + time => 'CORE::time', + umask => 'mask => CORE::umask($_[0])', unlink => 'filename => CORE::unlink($_[0])', utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])', + wait => 'CORE::wait()', + waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])', ); +sub import { + my $pkg = shift; + + load_imports() unless $loaded++; + + # Grandfather old foo_h form to new :foo_h form + s/^(?=\w+_h$)/:/ for my @list = @_; + + my @unimpl = sort grep { exists $replacement{$_} } @list; + if (@unimpl) { + for my $u (@unimpl) { + warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u); + } + croak(sprintf("Unimplemented: %s", + join(" ", map { "POSIX::$_()" } @unimpl))); + } + + local $Exporter::ExportLevel = 1; + Exporter::import($pkg,@list); +} + eval join ';', map "sub $_", keys %replacement, keys %reimpl; +sub unimplemented_message { + my $func = shift; + my $how = $replacement{$func}; + return "C-specific, stopped" unless defined $how; + return "$$how" if ref $how; + return "$how instead" if $how =~ /^use /; + return "Use method $how() instead" if $how =~ /::/; + return "C-specific: use $how instead"; +} + sub AUTOLOAD { my ($func) = ($AUTOLOAD =~ /.*::(.*)/); @@ -207,12 +226,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } if (exists $replacement{$func}) { - my $how = $replacement{$func}; - croak "Unimplemented: POSIX::$func() is C-specific, stopped" - unless defined $how; - croak "Unimplemented: POSIX::$func() is $$how" if ref $how; - croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/; - croak "Unimplemented: POSIX::$func() is C-specific: use $how instead"; + croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func); } constant($func); @@ -238,8 +252,7 @@ my %default_export_tags = ( # cf. exports policy below assert_h => [qw(assert NDEBUG)], - ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)], + ctype_h => [], dirent_h => [], @@ -293,7 +306,8 @@ my %default_export_tags = ( # cf. exports policy below _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES - LC_MONETARY LC_NUMERIC LC_TIME NULL + LC_MONETARY LC_NUMERIC LC_TIME LC_IDENTIFICATION + LC_MEASUREMENT LC_PAPER LC_TELEPHONE LC_ADDRESS NULL localeconv setlocale)], math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL @@ -322,7 +336,7 @@ my %default_export_tags = ( # cf. exports policy below stddef_h => [qw(NULL offsetof)], stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX TMP_MAX stderr stdin stdout clearerr fclose fdopen feof ferror fflush fgetc fgetpos fgets fopen fprintf fputc fputs fread freopen @@ -413,12 +427,23 @@ my %other_export_tags = ( # cf. exports policy below Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1 - jn lgamma log1p log2 logb lrint nan nearbyint nextafter nexttoward + jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn )], + netdb_h => [qw(EAI_AGAIN EAI_BADFLAGS EAI_FAIL + EAI_FAMILY EAI_MEMORY EAI_NONAME + EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE + EAI_SYSTEM)], + stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ], + sys_resource_h => [qw(PRIO_PROCESS PRIO_PGRP PRIO_USER)], + + sys_socket_h => [qw( + MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL + )], + nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ], signal_h_si_code => [qw( @@ -450,10 +475,7 @@ my %other_export_tags = ( # cf. exports policy below # you do not want to add symbols to the following list. add a new tag instead our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write - printf sprintf lround), - # lround() should really be in the :math_h_c99 tag, but - # we're too far into the 5.24 code freeze for that to be - # done now. This can be revisited in the 5.25.x cycle. + printf sprintf), grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok); our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags ); diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod index 1d263a7bc40..a319b0df3a3 100644 --- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod +++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod @@ -24,7 +24,7 @@ interfaces. This document gives a condensed list of the features available in the POSIX module. Consult your operating system's manpages for general information on most features. Consult L<perlfunc> for functions which are noted as being -identical to Perl's builtin functions. +identical or almost identical to Perl's builtin functions. The first section describes POSIX functions from the 1003.1 specification. The second section describes some classes for signal objects, TTY objects, @@ -81,8 +81,13 @@ if the handler does not return normally (it e.g. does a C<longjmp>). =item C<abs> -This is identical to Perl's builtin C<abs()> function, returning -the absolute value of its numerical argument. +This is identical to Perl's builtin C<abs()> function, returning the absolute +value of its numerical argument (except that C<POSIX::abs()> must be provided +an explicit value (rather than relying on an implicit C<$_>): + + $absolute_value = POSIX::abs(42); # good + + $absolute_value = POSIX::abs(); # throws exception =item C<access> @@ -110,8 +115,13 @@ L<Math::Trig>. =item C<alarm> -This is identical to Perl's builtin C<alarm()> function, -either for arming or disarming the C<SIGARLM> timer. +This is identical to Perl's builtin C<alarm()> function, either for arming or +disarming the C<SIGARLM> timer, except that C<POSIX::alarm()> must be provided +an explicit value (rather than relying on an implicit C<$_>): + + POSIX::alarm(3) # good + + POSIX::alarm() # throws exception =item C<asctime> @@ -203,13 +213,27 @@ integer value greater than or equal to the given numerical argument. =item C<chdir> -This is identical to Perl's builtin C<chdir()> function, allowing -one to change the working (default) directory, see L<perlfunc/chdir>. +This is identical to Perl's builtin C<chdir()> function, allowing one to +change the working (default) directory -- see L<perlfunc/chdir> -- with the +exception that C<POSIX::chdir()> must be provided an explicit value (rather +than relying on an implicit C<$_>): + + $rv = POSIX::chdir('path/to/dir'); # good + + $rv = POSIX::chdir(); # throws exception =item C<chmod> This is identical to Perl's builtin C<chmod()> function, allowing -one to change file and directory permissions, see L<perlfunc/chmod>. +one to change file and directory permissions -- see L<perlfunc/chmod> -- with +the exception that C<POSIX::chmod()> can only change one file at a time +(rather than a list of files): + + $c = chmod 0664, $file1, $file2; # good + + $c = POSIX::chmod 0664, $file1; # throws exception + + $c = POSIX::chmod 0664, $file1, $file2; # throws exception =item C<chown> @@ -915,6 +939,14 @@ containing the current underlying locale's formatting values. Users of this fun should also read L<perllocale>, which provides a comprehensive discussion of Perl locale handling, including L<a section devoted to this function|perllocale/The localeconv function>. +Prior to Perl 5.28, or when operating in a non thread-safe environment, +it should not be used in a threaded application unless it's certain that +the underlying locale is C or POSIX. This is because it otherwise +changes the locale, which globally affects all threads simultaneously. +Windows platforms starting with Visual Studio 2005 are mostly +thread-safe, but use of this function in those prior to Visual Studio +2015 can interefere with a thread that has called +L<perlapi/switch_to_global_locale>. Here is how to query the database for the B<de> (Deutsch or German) locale. @@ -958,7 +990,15 @@ POSIX.1-2008 and are only available on systems that support them. =item C<localtime> This is identical to Perl's builtin C<localtime()> function for -converting seconds since the epoch to a date see L<perlfunc/localtime>. +converting seconds since the epoch to a date see L<perlfunc/localtime> except +that C<POSIX::localtime()> must be provided an explicit value (rather than +relying on an implicit C<$_>): + + @localtime = POSIX::localtime(time); # good + + @localtime = localtime(); # good + + @localtime = POSIX::localtime(); # throws exception =item C<log> @@ -1013,7 +1053,7 @@ See also L</ceil>, L</floor>, L</trunc>. Owing to an oversight, this is not currently exported by default, or as part of the C<:math_h_c99> export tag; importing it must therefore be done by explicit -name. This will be changed in Perl 5.26. +name. =item C<malloc> @@ -1671,6 +1711,10 @@ for collating (comparing) strings transformed using the C<strxfrm()> function. Not really needed since Perl can do this transparently, see L<perllocale>. +Beware that in a UTF-8 locale, anything you pass to this function must +be in UTF-8; and when not in a UTF-8 locale, anything passed must not be +UTF-8 encoded. + =item C<strcpy> Not implemented. C<strcpy()> is C-specific, use C<=> instead, see L<perlop>. @@ -1768,7 +1812,10 @@ may not check for overflow, and therefore will never set C<$!>. C<strtod> respects any POSIX C<setlocale()> C<LC_TIME> settings, regardless of whether or not it is called from Perl code that is within -the scope of S<C<use locale>>. +the scope of S<C<use locale>>. This means it should not be used in a +threaded application unless it's certain that the underlying locale is C +or POSIX. This is because it otherwise changes the locale, which +globally affects all threads simultaneously. To parse a string C<$str> as a floating point number use @@ -1843,6 +1890,10 @@ Used in conjunction with the C<strcoll()> function, see L</strcoll>. Not really needed since Perl can do this transparently, see L<perllocale>. +Beware that in a UTF-8 locale, anything you pass to this function must +be in UTF-8; and when not in a UTF-8 locale, anything passed must not be +UTF-8 encoded. + =item C<sysconf> Retrieves values of system configurable variables. @@ -1941,13 +1992,9 @@ Not implemented. Use method C<IO::File::new_tmpfile()> instead, or see L<File:: =item C<tmpnam> -Returns a name for a temporary file. - - $tmpfile = POSIX::tmpnam(); - For security reasons, which are probably detailed in your system's documentation for the C library C<tmpnam()> function, this interface -should not be used; instead see L<File::Temp>. +is no longer available; instead use L<File::Temp>. =item C<tolower> @@ -2429,6 +2476,18 @@ C<_POSIX_TZNAME_MAX> C<_POSIX_VDISABLE> C<_POSIX_VERSION> =back +=head1 RESOURCE CONSTANTS + +Imported with the C<:sys_resource_h> tag. + +=over 8 + +=item Constants + +C<PRIO_PROCESS> C<PRIO_PGRP> C<PRIO_USER> + +=back + =head1 SYSTEM CONFIGURATION =over 8 @@ -2589,7 +2648,7 @@ C<EXIT_FAILURE> C<EXIT_SUCCESS> C<MB_CUR_MAX> C<RAND_MAX> =item Constants -C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<L_tmpname> C<TMP_MAX> +C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<TMP_MAX> =back diff --git a/gnu/usr.bin/perl/ext/POSIX/t/export.t b/gnu/usr.bin/perl/ext/POSIX/t/export.t index 5c37f83a07b..50648c8b336 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/export.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/export.t @@ -45,11 +45,13 @@ my %expect = ( FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK - INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE - LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG + INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON + LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NUMERIC LC_PAPER + LC_TELEPHONE LC_TIME LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX - LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON + LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC @@ -90,8 +92,7 @@ my %expect = ( fgets floor fmod fopen fpathconf fprintf fputc fputs fread free freopen frexp fscanf fseek fsetpos fstat fsync ftell fwrite getchar getcwd getegid getenv geteuid getgid getgroups - getpid gets getuid isalnum isalpha isatty iscntrl isdigit - isgraph islower isprint ispunct isspace isupper isxdigit labs + getpid gets getuid isatty labs ldexp ldiv localeconv log10 longjmp lseek malloc mblen mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo mktime modf offsetof pathconf pause perror pow putc putchar @@ -103,7 +104,7 @@ my %expect = ( strncpy strpbrk strrchr strspn strstr strtod strtok strtol strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile - tmpnam tolower toupper ttyname tzname tzset uname ungetc + tmpnam ttyname tzname tzset uname ungetc vfprintf vprintf vsprintf wcstombs wctomb ), # this stuff was added in 5.21 @@ -130,6 +131,16 @@ my %expect = ( # it is OK to add new constants, but new functions may only go in EXPORT_OK ], EXPORT_OK => [sort + # this stuff was added in 5.9, but not exported until 5.25 + qw( + MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK + MSG_TRUNC MSG_WAITALL + ), + # this stuff was added in 5.11, but not exported until 5.25 + qw( + EAI_AGAIN EAI_BADFLAGS EAI_FAIL EAI_FAMILY EAI_MEMORY + EAI_NONAME EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM + ), # this stuff was in 5.20.2 qw( abs alarm atan2 chdir chmod chown close closedir cos exit @@ -138,9 +149,12 @@ my %expect = ( localtime log mkdir nice open opendir pipe printf rand read readdir rename rewinddir rmdir sin sleep sprintf sqrt srand stat system time times umask unlink utime wait - waitpid write + waitpid write L_tmpnam ), # this stuff was added in 5.21 + # (though an oversight meant that lround wasn't listed here + # initially; it was added to @EXPORT_OK in 5.23, and to the + # :math_h_c99 tag in 5.25) qw( FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD fegetround fesetround @@ -148,7 +162,7 @@ my %expect = ( acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf isless islessequal islessgreater isnan - isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint nan + isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn strtold ), @@ -166,14 +180,14 @@ my %expect = ( POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ ), - # this was implemented in 5.21, but not exported; it was added to - # @EXPORT_OK late in 5.23, and will be added to :math_h_c99 tag early - # in 5.25 - qw( lround ), + # added in 5.27 + qw( + PRIO_PROCESS PRIO_PGRP PRIO_USER + ), ], ); -plan (tests => 2 * keys %expect); +plan (tests => 2 * keys(%expect) + keys(%POSIX::)); while (my ($var, $expect) = each %expect) { my $have = *{$POSIX::{$var}}{ARRAY}; @@ -181,3 +195,23 @@ while (my ($var, $expect) = each %expect) { "Correct number of entries for \@POSIX::$var"); is_deeply([sort @$have], $expect, "Correct entries for \@POSIX::$var"); } + +my %no_export_needed = map +($_ => 1), + qw(AUTOLOAD bootstrap constant croak import load_imports + unimplemented_message usage); + +my %exported = map +($_ => 1), + (@POSIX::EXPORT, @POSIX::EXPORT_OK, map @$_, values %POSIX::EXPORT_TAGS); + +for my $name (sort keys %POSIX::) { + my $code = do { no strict 'refs'; \&{"POSIX::$name"} }; + if (!defined &$code) { + pass("$name need not be exported as it does not name a subroutine"); + } + elsif ($no_export_needed{$name}) { + pass("$name need not be exported as it is part of the internals"); + } + else { + ok($exported{$name}, "subroutine POSIX::$name is exported somehow"); + } +} diff --git a/gnu/usr.bin/perl/ext/POSIX/t/math.t b/gnu/usr.bin/perl/ext/POSIX/t/math.t index 54067d1f02d..0426e03ae18 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/math.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/math.t @@ -4,7 +4,6 @@ use strict; use POSIX ':math_h_c99'; use POSIX ':nan_payload'; -use POSIX 'lround'; use Test::More; use Config; @@ -60,8 +59,14 @@ SKIP: { skip "no fpclassify", 4 unless $Config{d_fpclassify}; is(fpclassify(1), FP_NORMAL, "fpclassify 1"); is(fpclassify(0), FP_ZERO, "fpclassify 0"); - is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); - is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); + SKIP: { + skip("no inf", 1) unless $Config{d_double_has_inf}; + is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); + } + SKIP: { + skip("no nan", 1) unless $Config{d_double_has_nan}; + is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); + } } sub near { @@ -97,30 +102,42 @@ SKIP: { is(ilogb(255), 7, "ilogb 255"); is(ilogb(256), 8, "ilogb 256"); ok(isfinite(1), "isfinite 1"); - ok(!isfinite(Inf), "isfinite Inf"); - ok(!isfinite(NaN), "isfinite NaN"); - ok(isinf(INFINITY), "isinf INFINITY"); - ok(isinf(Inf), "isinf Inf"); - ok(!isinf(NaN), "isinf NaN"); ok(!isinf(42), "isinf 42"); - ok(isnan(NAN), "isnan NAN"); - ok(isnan(NaN), "isnan NaN"); - ok(!isnan(Inf), "isnan Inf"); ok(!isnan(42), "isnan Inf"); - cmp_ok(nan(), '!=', nan(), 'nan'); + SKIP: { + skip("no inf", 4) unless $Config{d_double_has_inf}; + ok(!isfinite(Inf), "isfinite Inf"); + ok(isinf(INFINITY), "isinf INFINITY"); + ok(isinf(Inf), "isinf Inf"); + ok(!isnan(Inf), "isnan Inf"); + } + SKIP: { + skip("no nan", 5) unless $Config{d_double_has_nan}; + ok(!isfinite(NaN), "isfinite NaN"); + ok(!isinf(NaN), "isinf NaN"); + ok(isnan(NAN), "isnan NAN"); + ok(isnan(NaN), "isnan NaN"); + cmp_ok(nan(), '!=', nan(), 'nan'); + } near(log1p(2), 1.09861228866811, "log1p", 1e-9); near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9); near(log2(8), 3, "log2", 1e-9); is(signbit(2), 0, "signbit 2"); # zero ok(signbit(-2), "signbit -2"); # non-zero + is(signbit(0), 0, "signbit 0"); # zero + is(signbit(0.5), 0, "signbit 0.5"); # zero + ok(signbit(-0.5), "signbit -0.5"); # non-zero is(round(2.25), 2, "round 2.25"); is(round(-2.25), -2, "round -2.25"); is(round(2.5), 3, "round 2.5"); is(round(-2.5), -3, "round -2.5"); is(round(2.75), 3, "round 2.75"); is(round(-2.75), -3, "round 2.75"); - is(lround(-2.75), -3, "lround -0.25"); - is(signbit(lround(-0.25)), 0, "lround -0.25 -> +0"); # unlike round() + is(lround(-2.75), -3, "lround -2.75"); + is(lround(-0.25), 0, "lround -0.25"); + is(lround(-0.50), -1, "lround -0.50"); + is(signbit(lround(-0.25)), 0, "signbit lround -0.25 zero"); + ok(signbit(lround(-0.50)), "signbit lround -0.50 non-zero"); # non-zero is(trunc(2.25), 2, "trunc 2.25"); is(trunc(-2.25), -2, "trunc -2.25"); is(trunc(2.5), 2, "trunc 2.5"); @@ -130,10 +147,14 @@ SKIP: { ok(isless(1, 2), "isless 1 2"); ok(!isless(2, 1), "isless 2 1"); ok(!isless(1, 1), "isless 1 1"); - ok(!isless(1, NaN), "isless 1 NaN"); ok(isgreater(2, 1), "isgreater 2 1"); ok(islessequal(1, 1), "islessequal 1 1"); - ok(isunordered(1, NaN), "isunordered 1 NaN"); + + SKIP: { + skip("no nan", 2) unless $Config{d_double_has_nan}; + ok(!isless(1, NaN), "isless 1 NaN"); + ok(isunordered(1, NaN), "isunordered 1 NaN"); + } near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7); near(erf(1), 0.842700792949715, "erf 1", 1.5e-7); @@ -151,66 +172,70 @@ SKIP: { near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7); near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7); - # These don't work on old mips/hppa platforms because == Inf (or == -Inf). - # ok(isnan(setpayload(0)), "setpayload zero"); - # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)"); - # - # These don't work on most platforms because == Inf (or == -Inf). - # ok(isnan(setpayloadsig(0)), "setpayload zero"); - # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)"); - - # Verify that the payload set be setpayload() - # (1) still is a nan - # (2) but the payload can be retrieved - # (3) but is not signaling - my $x = 0; - setpayload($x, 0x12345); - ok(isnan($x), "setpayload + isnan"); - is(getpayload($x), 0x12345, "setpayload + getpayload"); - ok(!issignaling($x), "setpayload + issignaling"); - - # Verify that the signaling payload set be setpayloadsig() - # (1) still is a nan - # (2) but the payload can be retrieved - # (3) and is signaling - setpayloadsig($x, 0x12345); - ok(isnan($x), "setpayloadsig + isnan"); - is(getpayload($x), 0x12345, "setpayloadsig + getpayload"); SKIP: { - # https://rt.perl.org/Ticket/Display.html?id=125710 - # In the 32-bit x86 ABI cannot preserve the signaling bit - # (the x87 simply does not preserve that). But using the - # 80-bit extended format aka long double, the bit is preserved. - # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484 - my $could_be_x86_32 = - # This is a really weak test: there are other 32-bit - # little-endian platforms than just Intel (some embedded - # processors, for example), but we use this just for not - # bothering with the test if things look iffy. - # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/, - # but that feels quite shaky. - $Config{byteorder} =~ /1234/ && - $Config{longdblkind} == 3 && - $Config{ptrsize} == 4; - skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble}; - ok(issignaling($x), "setpayloadsig + issignaling"); - } + skip("no inf/nan", 19) unless $Config{d_double_has_inf} && $Config{d_double_has_nan}; - # Try a payload more than one byte. - is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload"); + # These don't work on old mips/hppa platforms + # because nan with payload zero == Inf (or == -Inf). + # ok(isnan(setpayload(0)), "setpayload zero"); + # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)"); + # + # These don't work on most platforms because == Inf (or == -Inf). + # ok(isnan(setpayloadsig(0)), "setpayload zero"); + # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)"); - # Try payloads of 2^k, most importantly at and beyond 2^32. These - # tests will fail if NV is just 32-bit float, but that Should Not - # Happen (tm). - is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31"); - is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32"); - is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33"); + # Verify that the payload set be setpayload() + # (1) still is a nan + # (2) but the payload can be retrieved + # (3) but is not signaling + my $x = 0; + setpayload($x, 0x12345); + ok(isnan($x), "setpayload + isnan"); + is(getpayload($x), 0x12345, "setpayload + getpayload"); + ok(!issignaling($x), "setpayload + issignaling"); + + # Verify that the signaling payload set be setpayloadsig() + # (1) still is a nan + # (2) but the payload can be retrieved + # (3) and is signaling + setpayloadsig($x, 0x12345); + ok(isnan($x), "setpayloadsig + isnan"); + is(getpayload($x), 0x12345, "setpayloadsig + getpayload"); + SKIP: { + # https://rt.perl.org/Ticket/Display.html?id=125710 + # In the 32-bit x86 ABI cannot preserve the signaling bit + # (the x87 simply does not preserve that). But using the + # 80-bit extended format aka long double, the bit is preserved. + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484 + my $could_be_x86_32 = + # This is a really weak test: there are other 32-bit + # little-endian platforms than just Intel (some embedded + # processors, for example), but we use this just for not + # bothering with the test if things look iffy. + # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/, + # but that feels quite shaky. + $Config{byteorder} =~ /1234/ && + $Config{longdblkind} == 3 && + $Config{ptrsize} == 4; + skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble}; + ok(issignaling($x), "setpayloadsig + issignaling"); + } - # Payloads just lower than 2^k. - is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1"); - is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1"); + # Try a payload more than one byte. + is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload"); - # Payloads not divisible by two (and larger than 2**32). + # Try payloads of 2^k, most importantly at and beyond 2^32. These + # tests will fail if NV is just 32-bit float, but that Should Not + # Happen (tm). + is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31"); + is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32"); + is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33"); + + # Payloads just lower than 2^k. + is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1"); + is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1"); + + # Payloads not divisible by two (and larger than 2**32). SKIP: { # solaris gets 10460353202 from getpayload() when it should @@ -231,17 +256,18 @@ SKIP: { # probably just by blind luck. skip($^O, 1) if $^O eq 'solaris'; is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21"); - } - is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime"); + } + is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime"); - # Truncates towards zero. - is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload"); + # Truncates towards zero. + is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload"); - # Not signaling. - ok(!issignaling(0), "issignaling zero"); - ok(!issignaling(+Inf), "issignaling +Inf"); - ok(!issignaling(-Inf), "issignaling -Inf"); - ok(!issignaling(NaN), "issignaling NaN"); + # Not signaling. + ok(!issignaling(0), "issignaling zero"); + ok(!issignaling(+Inf), "issignaling +Inf"); + ok(!issignaling(-Inf), "issignaling -Inf"); + ok(!issignaling(NaN), "issignaling NaN"); + } } # SKIP done_testing(); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/posix.t b/gnu/usr.bin/perl/ext/POSIX/t/posix.t index bd5c3009fcf..1b2dd4010b8 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/posix.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/posix.t @@ -10,7 +10,7 @@ BEGIN { require 'loc_tools.pl'; } -use Test::More tests => 94; +use Test::More tests => 93; use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write errno localeconv dup dup2 lseek access); @@ -25,7 +25,6 @@ $| = 1; $Is_W32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; -$Is_MacOS = $^O eq 'MacOS'; $Is_VMS = $^O eq 'VMS'; $Is_OS2 = $^O eq 'os2'; $Is_UWin = $^O eq 'uwin'; @@ -91,55 +90,51 @@ SKIP: { ok(! $sigset->ismember(1), 'POSIX::SigSet->delset' ); ok( $sigset->ismember(3), 'POSIX::SigSet->ismember' ); - SKIP: { - skip("no kill() support on Mac OS", 4) if $Is_MacOS; - - my $sigint_called = 0; - - my $mask = new POSIX::SigSet &SIGINT; - my $action = new POSIX::SigAction 'main::SigHUP', $mask, 0; - sigaction(&SIGHUP, $action); - $SIG{'INT'} = 'SigINT'; - - # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5. - # But not NetBSD 1.6 & 1.6.1: the test makes perl crash. - # So the kill() must not be done with this config in order to - # finish the test. - # For others (darwin & freebsd), let the test fail without crashing. - # the test passes at least from freebsd 8.1 - my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/; - my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals"; - if (!$todo) { - kill 'HUP', $$; - } else { - print "not ok 9 - sigaction SIGHUP ",$why_todo,"\n"; - print "not ok 10 - sig mask delayed SIGINT ",$why_todo,"\n"; - } - sleep 1; - - $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8) - || ($^O eq 'darwin' && $Config{osvers} < '6.6'); - printf "%s 11 - masked SIGINT received %s\n", - $sigint_called ? "ok" : "not ok", - $todo ? $why_todo : ''; - - print "ok 12 - signal masks successful\n"; - - sub SigHUP { - print "ok 9 - sigaction SIGHUP\n"; - kill 'INT', $$; - sleep 2; - print "ok 10 - sig mask delayed SIGINT\n"; - } + my $sigint_called = 0; + + my $mask = new POSIX::SigSet &SIGINT; + my $action = new POSIX::SigAction 'main::SigHUP', $mask, 0; + sigaction(&SIGHUP, $action); + $SIG{'INT'} = 'SigINT'; + + # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5. + # But not NetBSD 1.6 & 1.6.1: the test makes perl crash. + # So the kill() must not be done with this config in order to + # finish the test. + # For others (darwin & freebsd), let the test fail without crashing. + # the test passes at least from freebsd 8.1 + my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/; + my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals"; + if (!$todo) { + kill 'HUP', $$; + } else { + print "not ok 9 - sigaction SIGHUP ",$why_todo,"\n"; + print "not ok 10 - sig mask delayed SIGINT ",$why_todo,"\n"; + } + sleep 1; - sub SigINT { - $sigint_called++; - } + $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8) + || ($^O eq 'darwin' && $Config{osvers} < '6.6'); + printf "%s 11 - masked SIGINT received %s\n", + $sigint_called ? "ok" : "not ok", + $todo ? $why_todo : ''; - # The order of the above tests is very important, so - # we use literal prints and hard coded numbers. - next_test() for 1..4; + print "ok 12 - signal masks successful\n"; + + sub SigHUP { + print "ok 9 - sigaction SIGHUP\n"; + kill 'INT', $$; + sleep 2; + print "ok 10 - sig mask delayed SIGINT\n"; + } + + sub SigINT { + $sigint_called++; } + + # The order of the above tests is very important, so + # we use literal prints and hard coded numbers. + next_test() for 1..4; } SKIP: { @@ -155,7 +150,7 @@ if ( $unix_mode ) { $pat = qr#[\\/]POSIX$#i; } else { - $pat = qr/\.POSIX]/i; + $pat = qr/\.POSIX\]/i; } like( getcwd(), qr/$pat/, 'getcwd' ); @@ -283,11 +278,8 @@ try_strftime("Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); } } -SKIP: { - skip("no kill() support on Mac OS", 1) if $Is_MacOS; - is (eval "kill 0", 0, "check we have CORE::kill") - or print "\$\@ is " . _qq($@) . "\n"; -} +is (eval "kill 0", 0, "check we have CORE::kill") + or print "\$\@ is " . _qq($@) . "\n"; # Check that we can import the POSIX kill routine POSIX->import ('kill'); @@ -299,13 +291,13 @@ like ($@, qr/^Usage: POSIX::kill\(pid, sig\)/, "check its usage message"); # Check unimplemented. $result = eval {POSIX::offsetof}; is ($result, undef, "offsetof should fail"); -like ($@, qr/^Unimplemented: POSIX::offsetof\(\) is C-specific/, +like ($@, qr/^Unimplemented: POSIX::offsetof\(\): C-specific/, "check its unimplemented message"); # Check reimplemented. $result = eval {POSIX::fgets}; is ($result, undef, "fgets should fail"); -like ($@, qr/^Use method IO::Handle::gets\(\) instead/, +like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/, "check its redef message"); eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK }; @@ -402,19 +394,10 @@ SKIP: { cmp_ok($!, '==', POSIX::ENOTDIR); } -{ # tmpnam() is deprecated - my @warn; - local $SIG{__WARN__} = sub { push @warn, "@_"; note "@_"; }; - my $x = sub { POSIX::tmpnam() }; - my $foo = $x->(); - $foo = $x->(); - is(@warn, 1, "POSIX::tmpnam() should warn only once per location"); - like($warn[0], qr!^Calling POSIX::tmpnam\(\) is deprecated at t/posix.t line \d+\.$!, - "check POSIX::tmpnam warns by default"); - no warnings "deprecated"; - undef $warn; - my $foo = POSIX::tmpnam(); - is($warn, undef, "... but the warning can be disabled"); +{ # tmpnam() has been removed as unsafe + my $x = eval { POSIX::tmpnam() }; + is($x, undef, 'tmpnam has been removed'); + like($@, qr/use File::Temp/, 'tmpnam advises File::Temp'); } # Check that output is not flushed by _exit. This test should be last @@ -424,7 +407,7 @@ if ($^O eq 'vos') { } else { $| = 0; # The following line assumes buffered output, which may be not true: - print '@#!*$@(!@#$' unless ($Is_MacOS || $Is_OS2 || $Is_UWin || $Is_OS390 || + print '@#!*$@(!@#$' unless ($Is_OS2 || $Is_UWin || $Is_OS390 || $Is_VMS || (defined $ENV{PERLIO} && $ENV{PERLIO} eq 'unix' && diff --git a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t index b96812f3470..73c66f9404d 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t @@ -5,7 +5,7 @@ BEGIN{ use Config; eval 'use POSIX'; if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || - $^O eq 'MacOS' || ($^O eq 'VMS' && !$Config{'d_sigaction'})) { + ($^O eq 'VMS' && !$Config{'d_sigaction'})) { print "1..0\n"; exit 0; } @@ -14,7 +14,7 @@ BEGIN{ use Test::More tests => 36; use strict; -use vars qw/$bad $bad7 $ok10 $bad18 $ok/; +our ( $bad, $bad7, $ok10, $bad18, $ok ); $^W=1; @@ -202,7 +202,11 @@ SKIP: { $skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()" if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./ || - ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./); + ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./ + || + ($^O eq 'gnu') + || + ($^O eq 'dragonfly')); my $tests = keys %{{ %siginfo, %opt_val }}; eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO'; skip("no SA_SIGINFO", $tests) if $@; diff --git a/gnu/usr.bin/perl/ext/POSIX/t/time.t b/gnu/usr.bin/perl/ext/POSIX/t/time.t index 6a906e031d6..4b10eb83350 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/time.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/time.t @@ -22,7 +22,7 @@ SKIP: { # actually do anything. Cygwin works in some places, but not others. The # other Win32's below are guesses. skip "No tzset()", 2 - if $^O eq "MacOS" || $^O eq "VMS" || $^O eq "cygwin" || $^O eq "djgpp" || + if $^O eq "VMS" || $^O eq "cygwin" || $^O eq "djgpp" || $^O eq "MSWin32" || $^O eq "dos" || $^O eq "interix"; tzset(); my @tzname = tzname(); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t index f09b92595f1..e41b3194c9e 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t @@ -28,9 +28,7 @@ if (locales_enabled('LC_MESSAGES')) { local $! = 1; my $english_message = "$!"; # Should be C locale since not in scope of # "use locale" - for $non_english_locale (find_locales(&POSIX::LC_MESSAGES, - 'reasonable_locales_only')) - { + for $non_english_locale (find_locales(&POSIX::LC_MESSAGES)) { use locale; setlocale(&POSIX::LC_MESSAGES, $non_english_locale); $! = 1; @@ -164,9 +162,6 @@ SKIP: { cmp_ok($present, '<=', $future, 'time'); } -is(POSIX::tolower('Perl Rules'), 'perl rules', 'tolower'); -is(POSIX::toupper('oi!'), 'OI!', 'toupper'); - is(-e NOT_HERE, undef, NOT_HERE . ' does not exist'); foreach ([undef, 0, 'chdir', NOT_HERE], diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm index 13cb20b3bd9..3d740b181a9 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm @@ -1,7 +1,7 @@ package PerlIO::encoding; use strict; -our $VERSION = '0.24'; +our $VERSION = '0.26'; our $DEBUG = 0; $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n"; diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs index ee0836ff730..941d7862666 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs @@ -203,7 +203,7 @@ PerlIOEncode_get_base(pTHX_ PerlIO * f) e->base.bufsiz = 1024; if (!e->bufsv) { e->bufsv = newSV(e->base.bufsiz); - sv_setpvn(e->bufsv, "", 0); + SvPVCLEAR(e->bufsv); } e->base.buf = (STDCHAR *) SvPVX(e->bufsv); if (!e->base.ptr) @@ -307,42 +307,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) goto end_of_file; } } - if (SvCUR(e->dataSV)) { - /* something left over from last time - create a normal - SV with new data appended - */ - if (use + SvCUR(e->dataSV) > e->base.bufsiz) { - if (e->flags & NEEDS_LINES) { - /* Have to grow buffer */ - e->base.bufsiz = use + SvCUR(e->dataSV); - PerlIOEncode_get_base(aTHX_ f); - } - else { - use = e->base.bufsiz - SvCUR(e->dataSV); - } - } - sv_catpvn(e->dataSV,(char*)ptr,use); - } - else { - /* Create a "dummy" SV to represent the available data from layer below */ - if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) { - Safefree(SvPVX_mutable(e->dataSV)); - } - if (use > (SSize_t)e->base.bufsiz) { - if (e->flags & NEEDS_LINES) { - /* Have to grow buffer */ - e->base.bufsiz = use; - PerlIOEncode_get_base(aTHX_ f); - } - else { - use = e->base.bufsiz; + if (!SvCUR(e->dataSV)) + SvPVCLEAR(e->dataSV); + if (use + SvCUR(e->dataSV) > e->base.bufsiz) { + if (e->flags & NEEDS_LINES) { + /* Have to grow buffer */ + e->base.bufsiz = use + SvCUR(e->dataSV); + PerlIOEncode_get_base(aTHX_ f); } + else { + use = e->base.bufsiz - SvCUR(e->dataSV); } - SvPV_set(e->dataSV, (char *) ptr); - SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */ - SvCUR_set(e->dataSV,use); - SvPOK_only(e->dataSV); } + sv_catpvn(e->dataSV,(char*)ptr,use); SvUTF8_off(e->dataSV); PUSHMARK(sp); XPUSHs(e->enc); diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t index cba14a82439..41cefcb1377 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t @@ -16,7 +16,7 @@ BEGIN { require "../../t/charset_tools.pl"; } -use Test::More tests => 24; +use Test::More tests => 27; my $grk = "grk$$"; my $utf = "utf$$"; @@ -25,7 +25,7 @@ my $fail2 = "fb$$"; my $russki = "koi8r$$"; my $threebyte = "3byte$$"; -if (open(GRK, ">$grk")) { +if (open(GRK, '>', $grk)) { binmode(GRK, ":bytes"); # alpha beta gamma in ISO 8859-7 print GRK "\xe1\xe2\xe3"; @@ -40,7 +40,7 @@ if (open(GRK, ">$grk")) { close($i); } -if (open(UTF, "<$utf")) { +if (open(UTF, '<', $utf)) { binmode(UTF, ":bytes"); # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3) @@ -57,7 +57,7 @@ if (open(UTF, "<$utf")) { close($i); } -if (open(GRK, "<$grk")) { +if (open(GRK, '<', $grk)) { binmode(GRK, ":bytes"); is(scalar <GRK>, "\xe1\xe2\xe3"); close GRK; @@ -68,10 +68,10 @@ $SIG{__WARN__} = sub {$warn .= $_[0]}; is (open(FAIL, ">:encoding(NoneSuch)", $fail1), undef, 'Open should fail'); like($warn, qr/^Cannot find encoding "NoneSuch" at/); -is(open(RUSSKI, ">$russki"), 1); +is(open(RUSSKI, '>', $russki), 1); print RUSSKI "\x3c\x3f\x78"; close RUSSKI or die "Could not close: $!"; -open(RUSSKI, "$russki"); +open(RUSSKI, '<', $russki); binmode(RUSSKI, ":raw"); my $buf1; read(RUSSKI, $buf1, 1); @@ -231,6 +231,16 @@ is $x, "To hymn him who heard her herd herd\n", } # SKIP +# decoding shouldn't mutate the original bytes [perl #132833] +{ + my $b = "a\0b\0\n\0"; + open my $fh, "<:encoding(UTF16-LE)", \$b or die; + is scalar(<$fh>), "ab\n"; + is $b, "a\0b\0\n\0"; + close $fh or die; + is $b, "a\0b\0\n\0"; +} + END { 1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte); } diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t index 17c241c17a0..3abdfd3f37c 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t @@ -16,7 +16,7 @@ BEGIN { import Encode qw(:fallback_all); } -use Test::More tests => 9; +use Test::More tests => 10; # $PerlIO::encoding = 0; # WARN_ON_ERR|PERLQQ; @@ -33,7 +33,7 @@ my $file = "fallback$$.txt"; like($message, qr/does not map to iso-8859-1/o, "FB_WARN message"); } -open($fh,$file) || die "File cannot be re-opened"; +open($fh,'<',$file) || die "File cannot be re-opened"; my $line = <$fh>; is($line,"\\x{20ac}0.02\n","perlqq escapes"); close($fh); @@ -45,14 +45,14 @@ my $str = "\x{20AC}"; print $fh $str,"0.02\n"; close($fh); -open($fh,$file) || die "File cannot be re-opened"; +open($fh,'<',$file) || die "File cannot be re-opened"; my $line = <$fh>; is($line,"€0.02\n","HTML escapes"); close($fh); { no utf8; - open($fh,">$file") || die "File cannot be re-opened"; + open($fh,'>',$file) || die "File cannot be re-opened"; binmode($fh); print $fh "\xA30.02\n"; close($fh); @@ -64,13 +64,20 @@ printf "# %x\n",ord($line); is($line,"\\xA30.02\n","Escaped non-mapped char"); close($fh); -$PerlIO::encoding::fallback = Encode::WARN_ON_ERROR; +{ + my $message = ''; + local $SIG{__WARN__} = sub { $message = $_[0] }; -ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII"); -my $line = <$fh>; -printf "# %x\n",ord($line); -is($line,"\x{FFFD}0.02\n","Unicode replacement char"); -close($fh); + $PerlIO::encoding::fallback = Encode::WARN_ON_ERR; + + ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII"); + my $line = <$fh>; + printf "# %x\n",ord($line); + is($line,"\x{FFFD}0.02\n","Unicode replacement char"); + close($fh); + + like($message, qr/does not map to Unicode/o, "FB_WARN message"); +} END { 1 while unlink($file); diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm index 4ed4e4060da..61b62ea3a2e 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm @@ -1,5 +1,5 @@ package PerlIO::scalar; -our $VERSION = '0.24'; +our $VERSION = '0.29'; require XSLoader; XSLoader::load(); 1; diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs index f3dff499bd6..10a4185899f 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs @@ -15,6 +15,18 @@ typedef struct { Off_t posn; } PerlIOScalar; +IV +PerlIOScalar_eof(pTHX_ PerlIO * f) +{ + if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { + PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); + STRLEN len; + (void)SvPV(s->var, len); + return len - (STRLEN)(s->posn) <= 0; + } + return 1; +} + static IV PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * tab) @@ -31,7 +43,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, && mode && *mode != 'r') { if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify); - SETERRNO(EINVAL, SS_IVCHAN); + SETERRNO(EACCES, RMS_PRV); return -1; } s->var = SvREFCNT_inc(SvRV(arg)); @@ -174,8 +186,8 @@ PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) * seems safe) and that the size of the buffer in our SV is * always less than half the size of the address space */ - assert(sizeof(Off_t) >= sizeof(len)); - assert((Off_t)len >= 0); + STATIC_ASSERT_STMT(sizeof(Off_t) >= sizeof(len)); + assert(len < ((~(STRLEN)0) >> 1)); if ((Off_t)len <= s->posn) return 0; got = len - (STRLEN)(s->posn); @@ -406,7 +418,7 @@ static PERLIO_FUNCS_DECL(PerlIO_scalar) = { PerlIOScalar_close, PerlIOScalar_flush, PerlIOScalar_fill, - PerlIOBase_eof, + PerlIOScalar_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t b/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t index 3dfcced38d3..bd06d641cd2 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t @@ -13,10 +13,11 @@ BEGIN { } use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. +use Errno qw(EACCES); $| = 1; -use Test::More tests => 122; +use Test::More tests => 123; my $fh; my $var = "aaa\n"; @@ -185,6 +186,7 @@ EOF my $ro = \43; ok(!(defined open(F, '>', $ro)), $!); + is($!+0, EACCES, "check we get a read-onlyish error code"); close F; # but we can read from it ok(open(F, '<', $ro), $!); diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/via.pm b/gnu/usr.bin/perl/ext/PerlIO-via/via.pm index e477dcca193..30083feae80 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-via/via.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-via/via.pm @@ -1,5 +1,5 @@ package PerlIO::via; -our $VERSION = '0.16'; +our $VERSION = '0.17'; require XSLoader; XSLoader::load(); 1; diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/via.xs b/gnu/usr.bin/perl/ext/PerlIO-via/via.xs index 8a7f1fc9ed4..d91c6855fcf 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-via/via.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-via/via.xs @@ -38,6 +38,8 @@ typedef struct CV *UTF8; } PerlIOVia; +static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 }; + #define MYMethod(x) #x,&s->x static CV * @@ -131,8 +133,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * tab) { IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); + + if (SvTYPE(arg) >= SVt_PVMG + && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) { + return code; + } + if (code == 0) { - PerlIOVia *s = PerlIOSelf(f, PerlIOVia); + PerlIOVia *s = PerlIOSelf(f, PerlIOVia); if (!arg) { if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), @@ -583,9 +591,28 @@ static SV * PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); - PERL_UNUSED_ARG(param); + SV *arg; PERL_UNUSED_ARG(flags); - return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv); + + /* During cloning, return an undef token object so that _pushed() knows + * that it should not call methods and wait for _dup() to actually dup the + * object. */ + if (param) { + SV *sv = newSV(0); + sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0); + return sv; + } + + arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv); + if (arg) { + /* arg is a temp, and PerlIOBase_dup() will explicitly free it */ + SvREFCNT_inc(arg); + } + else { + arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash)); + } + + return arg; } static PerlIO * @@ -593,10 +620,30 @@ PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, int flags) { if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { - /* Most of the fields will lazily set themselves up as needed - stash and obj have been set up by the implied push - */ +#ifdef USE_ITHREADS + if (param) { + /* For a non-interpreter dup stash and obj have been set up + by the implied push. + + But if this is a clone for a new interpreter we need to + translate the objects to their dups. + */ + + PerlIOVia *fs = PerlIOSelf(f, PerlIOVia); + PerlIOVia *os = PerlIOSelf(o, PerlIOVia); + + fs->obj = sv_dup_inc(os->obj, param); + fs->stash = (HV*)sv_dup((SV*)os->stash, param); + fs->var = sv_dup_inc(os->var, param); + fs->cnt = os->cnt; + + /* fh, io, cached CVs left as NULL, PerlIOVia_method() + will reinitialize them if needed */ + } +#endif + /* for a non-threaded dup fs->obj and stash should be set by _pushed() */ } + return f; } diff --git a/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL b/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL index af5d37a5f8c..04b1a90e3cc 100644 --- a/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL +++ b/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL @@ -161,7 +161,7 @@ Pod::Functions - Group Perl's functions a la perlfunc.pod =head1 SYNOPSIS use Pod::Functions; - + my @misc_ops = @{ $Kinds{ 'Misc' } }; my $misc_dsc = $Type_Description{ 'Misc' }; @@ -207,7 +207,7 @@ L<perlfunc/"Perl Functions by Category"> section. =cut -our $VERSION = '1.10'; +our $VERSION = '1.13'; require Exporter; diff --git a/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm b/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm index cef329e1ef9..64cf376f3c9 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm +++ b/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm @@ -2,11 +2,10 @@ package Pod::Html; use strict; require Exporter; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = 1.2201; -@ISA = qw(Exporter); -@EXPORT = qw(pod2html htmlify); -@EXPORT_OK = qw(anchorify); +our $VERSION = 1.24; +our @ISA = qw(Exporter); +our @EXPORT = qw(pod2html htmlify); +our @EXPORT_OK = qw(anchorify relativize_url); use Carp; use Config; @@ -16,6 +15,7 @@ use File::Spec; use File::Spec::Unix; use Getopt::Long; use Pod::Simple::Search; +use Pod::Simple::SimpleTree (); use locale; # make \w work right in non-ASCII lands =head1 NAME @@ -223,6 +223,19 @@ This program is distributed under the Artistic License. =cut +# This sub duplicates the guts of Pod::Simple::FromTree. We could have +# used that module, except that it would have been a non-core dependency. +sub feed_tree_to_parser { + my($parser, $tree) = @_; + if(ref($tree) eq "") { + $parser->_handle_text($tree); + } elsif(!($tree->[0] eq "X" && $parser->nix_X_codes)) { + $parser->_handle_element_start($tree->[0], $tree->[1]); + feed_tree_to_parser($parser, $_) foreach @{$tree}[2..$#$tree]; + $parser->_handle_element_end($tree->[0]); + } +} + my $Cachedir; my $Dircache; my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl); @@ -274,7 +287,7 @@ sub init_globals { $Doindex = 1; # non-zero if we should generate an index $Backlink = 0; # no backlinks added by default $Header = 0; # produce block header/footer - $Title = ''; # title to give the pod(s) + $Title = undef; # title to give the pod(s) } sub pod2html { @@ -340,25 +353,60 @@ sub pod2html { close $cache or die "error closing $Dircache: $!"; } - # set options for the parser - my $parser = Pod::Simple::XHTML::LocalPodLinks->new(); + my $input; + unless (@ARGV && $ARGV[0]) { + if ($Podfile and $Podfile ne '-') { + $input = $Podfile; + } else { + $input = '-'; # XXX: make a test case for this + } + } else { + $Podfile = $ARGV[0]; + $input = *ARGV; + } + + # set options for input parser + my $parser = Pod::Simple::SimpleTree->new; + $parser->codes_in_verbatim(0); + $parser->accept_targets(qw(html HTML)); + $parser->no_errata_section(!$Poderrors); # note the inverse + + warn "Converting input file $Podfile\n" if $Verbose; + my $podtree = $parser->parse_file($input)->root; + + unless(defined $Title) { + if($podtree->[0] eq "Document" && ref($podtree->[2]) eq "ARRAY" && + $podtree->[2]->[0] eq "head1" && @{$podtree->[2]} == 3 && + ref($podtree->[2]->[2]) eq "" && $podtree->[2]->[2] eq "NAME" && + ref($podtree->[3]) eq "ARRAY" && $podtree->[3]->[0] eq "Para" && + @{$podtree->[3]} >= 3 && + !(grep { ref($_) ne "" } + @{$podtree->[3]}[2..$#{$podtree->[3]}]) && + (@$podtree == 4 || + (ref($podtree->[4]) eq "ARRAY" && + $podtree->[4]->[0] eq "head1"))) { + $Title = join("", @{$podtree->[3]}[2..$#{$podtree->[3]}]); + } + } + + $Title //= ""; + $Title = html_escape($Title); + + # set options for the HTML generator + $parser = Pod::Simple::XHTML::LocalPodLinks->new(); $parser->codes_in_verbatim(0); $parser->anchor_items(1); # the old Pod::Html always did $parser->backlink($Backlink); # linkify =head1 directives + $parser->force_title($Title); $parser->htmldir($Htmldir); $parser->htmlfileurl($Htmlfileurl); $parser->htmlroot($Htmlroot); $parser->index($Doindex); - $parser->no_errata_section(!$Poderrors); # note the inverse $parser->output_string(\my $output); # written to file later $parser->pages(\%Pages); $parser->quiet($Quiet); $parser->verbose($Verbose); - # XXX: implement default title generator in pod::simple::xhtml - # copy the way the old Pod::Html did it - $Title = html_escape($Title); - # We need to add this ourselves because we use our own header, not # ::XHTML's header. We need to set $parser->backlink to linkify # the =head1 directives @@ -405,20 +453,7 @@ $block </html> HTMLFOOT - my $input; - unless (@ARGV && $ARGV[0]) { - if ($Podfile and $Podfile ne '-') { - $input = $Podfile; - } else { - $input = '-'; # XXX: make a test case for this - } - } else { - $Podfile = $ARGV[0]; - $input = *ARGV; - } - - warn "Converting input file $Podfile\n" if $Verbose; - $parser->parse_file($input); + feed_tree_to_parser($parser, $podtree); # Write output to file $Htmlfile = "-" unless $Htmlfile; # stdout @@ -486,7 +521,7 @@ sub parse_command_line { my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header, $opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile, $opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot, - $opt_quiet,$opt_recurse,$opt_title,$opt_verbose,$opt_libpods); + $opt_quiet,$opt_recurse,$opt_title,$opt_verbose); unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; my $result = GetOptions( @@ -500,7 +535,6 @@ sub parse_command_line { 'htmlroot=s' => \$opt_htmlroot, 'index!' => \$opt_index, 'infile=s' => \$opt_infile, - 'libpods=s' => \$opt_libpods, # deprecated 'outfile=s' => \$opt_outfile, 'poderrors!' => \$opt_poderrors, 'podpath=s' => \$opt_podpath, @@ -516,7 +550,6 @@ sub parse_command_line { $opt_help = ""; # just to make -w shut-up. @Podpath = split(":", $opt_podpath) if defined $opt_podpath; - warn "--libpods is no longer supported" if defined $opt_libpods; $Backlink = $opt_backlink if defined $opt_backlink; $Cachedir = _unixify($opt_cachedir) if defined $opt_cachedir; @@ -622,26 +655,18 @@ sub html_escape { $rest =~ s/</</g; $rest =~ s/>/>/g; $rest =~ s/"/"/g; - # ' is only in XHTML, not HTML4. Be conservative - #$rest =~ s/'/'/g; + $rest =~ s/([[:^print:]])/sprintf("&#x%x;", ord($1))/aeg; return $rest; } # # htmlify - converts a pod section specification to a suitable section -# specification for HTML. Note that we keep spaces and special characters -# except ", ? (Netscape problem) and the hyphen (writer's problem...). +# specification for HTML. We adopt the mechanism used by the formatter +# that we use. # sub htmlify { my( $heading) = @_; - $heading =~ s/(\s+)/ /g; - $heading =~ s/\s+\Z//; - $heading =~ s/\A\s+//; - # The hyphen is a disgrace to the English language. - # $heading =~ s/[-"?]//g; - $heading =~ s/["?]//g; - $heading = lc( $heading ); - return $heading; + return Pod::Simple::XHTML->can("idify")->(undef, $heading, 1); } # @@ -769,7 +794,7 @@ sub resolve_pod_page_link { # then $self->htmlroot eq '' (by definition of htmlfileurl) so # $self->htmldir needs to be prepended to link to get the absolute path # that will be relativized - $url = relativize_url( + $url = Pod::Html::relativize_url( File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url), $self->htmlfileurl # already unixified ); @@ -778,6 +803,8 @@ sub resolve_pod_page_link { return $url . ".html$section"; } +package Pod::Html; + # # relativize_url - convert an absolute URL to one relative to a base URL. # Assumes both end in a filename. diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t index bc033c46e27..74e04e042f4 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w # -*- perl -*- BEGIN { - require "t/pod2html-lib.pl"; + require "./t/pod2html-lib.pl"; } END { @@ -35,7 +35,7 @@ __DATA__ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> -<title></title> +<title>htmlcrossref - Test HTML cross reference links</title> <meta http-equiv="content-type" content="text/html; charset=utf-8" /> <link rev="made" href="mailto:[PERLADMIN]" /> </head> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t index 70eae7e2bb3..4e1b9233332 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w # -*- perl -*- BEGIN { - require "t/pod2html-lib.pl"; + require "./t/pod2html-lib.pl"; } END { @@ -31,7 +31,7 @@ __DATA__ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> -<title></title> +<title>htmlcrossref - Test HTML cross reference links</title> <meta http-equiv="content-type" content="text/html; charset=utf-8" /> <link rev="made" href="mailto:[PERLADMIN]" /> </head> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t index cfa0abcfcfb..5edab486d02 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w # -*- perl -*- BEGIN { - require "t/pod2html-lib.pl"; + require "./t/pod2html-lib.pl"; } END { @@ -31,7 +31,7 @@ __DATA__ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> -<title></title> +<title>htmlcrossref - Test HTML cross reference links</title> <meta http-equiv="content-type" content="text/html; charset=utf-8" /> <link rev="made" href="mailto:[PERLADMIN]" /> </head> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t index 06914d10c0d..1e3a304b368 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w # -*- perl -*- BEGIN { - require "t/pod2html-lib.pl"; + require "./t/pod2html-lib.pl"; } use strict; @@ -14,7 +14,7 @@ __DATA__ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> -<title></title> +<title>Test HTML Rendering</title> <meta http-equiv="content-type" content="text/html; charset=utf-8" /> <link rev="made" href="mailto:[PERLADMIN]" /> </head> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl b/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl index 27e3e94b967..dfe309ab84f 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl @@ -70,7 +70,7 @@ sub convert_n_test { } # result - open my $in, $outfile or die "cannot open $outfile: $!"; + open my $in, '<', $outfile or die "cannot open $outfile: $!"; $result = <$in>; close $in; } @@ -88,7 +88,7 @@ sub convert_n_test { open my $tmpfile, ">", $expectfile or die $!; print $tmpfile $expect; close $tmpfile; - open my $diff_fh, "$diff $diffopt $expectfile $outfile |" or die $!; + open my $diff_fh, "-|", "$diff $diffopt $expectfile $outfile" or die $!; print STDERR "# $_" while <$diff_fh>; close $diff_fh; unlink $expectfile; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/COMPARE b/gnu/usr.bin/perl/ext/SDBM_File/COMPARE deleted file mode 100644 index a595e831d26..00000000000 --- a/gnu/usr.bin/perl/ext/SDBM_File/COMPARE +++ /dev/null @@ -1,88 +0,0 @@ - -Script started on Thu Sep 28 15:41:06 1989 -% uname -a -titan titan 4_0 UMIPS mips -% make all x-dbm - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbm.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c sdbm.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c pair.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c hash.c - ar cr libsdbm.a sdbm.o pair.o hash.o - ranlib libsdbm.a - cc -o dbm dbm.o libsdbm.a - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dba.c - cc -o dba dba.o - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbd.c - cc -o dbd dbd.o - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -o x-dbm dbm.o -% -% -% wc history - 65110 218344 3204883 history -% -% /bin/time dbm build foo <history - -real 5:56.9 -user 13.3 -sys 26.3 -% ls -s -total 14251 - 5 README 2 dbd.c 1 hash.c 1 pair.h - 0 SCRIPT 5 dbd.o 1 hash.o 5 pair.o - 1 WISHLIST 62 dbm 3130 history 1 port.h - 46 dba 5 dbm.c 11 howtodbm.txt 11 sdbm.c - 3 dba.c 8 dbm.o 14 libsdbm.a 2 sdbm.h - 6 dba.o 4 foo.dir 1 makefile 8 sdbm.o - 46 dbd 10810 foo.pag 6 pair.c 60 x-dbm -% ls -l foo.* --rw-r--r-- 1 oz 4096 Sep 28 15:48 foo.dir --rw-r--r-- 1 oz 11069440 Sep 28 15:48 foo.pag -% -% /bin/time x-dbm build bar <history - -real 5:59.4 -user 24.7 -sys 29.1 -% -% ls -s -total 27612 - 5 README 46 dbd 1 hash.c 5 pair.o - 1 SCRIPT 2 dbd.c 1 hash.o 1 port.h - 1 WISHLIST 5 dbd.o 3130 history 11 sdbm.c - 4 bar.dir 62 dbm 11 howtodbm.txt 2 sdbm.h -13356 bar.pag 5 dbm.c 14 libsdbm.a 8 sdbm.o - 46 dba 8 dbm.o 1 makefile 60 x-dbm - 3 dba.c 4 foo.dir 6 pair.c - 6 dba.o 10810 foo.pag 1 pair.h -% -% ls -l bar.* --rw-r--r-- 1 oz 4096 Sep 28 15:54 bar.dir --rw-r--r-- 1 oz 13676544 Sep 28 15:54 bar.pag -% -% dba foo | tail -#10801: ok. no entries. -#10802: ok. no entries. -#10803: ok. no entries. -#10804: ok. no entries. -#10805: ok. no entries. -#10806: ok. no entries. -#10807: ok. no entries. -#10808: ok. no entries. -#10809: ok. 11 entries 67% used free 337. -10810 pages (6036 holes): 65073 entries -% -% dba bar | tail -#13347: ok. no entries. -#13348: ok. no entries. -#13349: ok. no entries. -#13350: ok. no entries. -#13351: ok. no entries. -#13352: ok. no entries. -#13353: ok. no entries. -#13354: ok. no entries. -#13355: ok. 7 entries 33% used free 676. -13356 pages (8643 holes): 65073 entries -% -% exit -script done on Thu Sep 28 16:08:45 1989 - diff --git a/gnu/usr.bin/perl/ext/SDBM_File/linux.patches b/gnu/usr.bin/perl/ext/SDBM_File/linux.patches deleted file mode 100644 index cb7b1b7d8eb..00000000000 --- a/gnu/usr.bin/perl/ext/SDBM_File/linux.patches +++ /dev/null @@ -1,67 +0,0 @@ -*** sdbm.dist/./dbu.c Mon Feb 17 21:18:52 1992 ---- sdbm/./dbu.c Mon Feb 17 21:11:20 1992 -*************** -*** 12,18 **** - #endif - - extern int getopt(); -! extern char *strchr(); - extern void oops(); - - char *progname; ---- 12,18 ---- - #endif - - extern int getopt(); -! /* extern char *strchr(); */ - extern void oops(); - - char *progname; -*** sdbm.dist/./makefile Mon Feb 17 21:18:56 1992 ---- sdbm/./makefile Mon Feb 17 21:10:46 1992 -*************** -*** 2,8 **** - # makefile for public domain ndbm-clone: sdbm - # DUFF: use duff's device (loop unroll) in parts of the code - # -! CFLAGS = -O -DSDBM -DDUFF -DBSD42 - #LDFLAGS = -p - - OBJS = sdbm.o pair.o hash.o ---- 2,8 ---- - # makefile for public domain ndbm-clone: sdbm - # DUFF: use duff's device (loop unroll) in parts of the code - # -! CFLAGS = -O -DSDBM -DDUFF - #LDFLAGS = -p - - OBJS = sdbm.o pair.o hash.o -*** sdbm.dist/./sdbm.c Mon Feb 17 21:19:17 1992 ---- sdbm/./sdbm.c Mon Feb 17 21:12:59 1992 -*************** -*** 25,30 **** ---- 25,31 ---- - #endif - #include <errno.h> - #include <string.h> -+ #include <unistd.h> - - #ifdef __STDC__ - #include <stddef.h> -*************** -*** 43,49 **** - - extern char *malloc proto((unsigned int)); - extern void free proto((void *)); -! extern long lseek(); - - /* - * forward ---- 44,50 ---- - - extern char *malloc proto((unsigned int)); - extern void free proto((void *)); -! /* extern long lseek(); */ - - /* - * forward diff --git a/gnu/usr.bin/perl/ext/SDBM_File/makefile.sdbm b/gnu/usr.bin/perl/ext/SDBM_File/makefile.sdbm deleted file mode 100644 index c959c1fab55..00000000000 --- a/gnu/usr.bin/perl/ext/SDBM_File/makefile.sdbm +++ /dev/null @@ -1,55 +0,0 @@ -# -# makefile for public domain ndbm-clone: sdbm -# DUFF: use duff's device (loop unroll) in parts of the code -# -CFLAGS = -O -DSDBM -DDUFF -DBSD42 -pic -#LDFLAGS = -p - -OBJS = sdbm.o pair.o hash.o -SRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c -HDRS = tune.h sdbm.h pair.h -MISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \ - readme.ms readme.ps - -all: dbu dba dbd dbe - -dbu: dbu.o sdbm util.o - cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a - -dba: dba.o util.o - cc $(LDFLAGS) -o dba dba.o util.o -dbd: dbd.o util.o - cc $(LDFLAGS) -o dbd dbd.o util.o -dbe: dbe.o sdbm - cc $(LDFLAGS) -o dbe dbe.o libsdbm.a - -sdbm: $(OBJS) - ar cr libsdbm.a $(OBJS) - ranlib libsdbm.a -### cp libsdbm.a /usr/lib/libsdbm.a - -dba.o: sdbm.h -dbu.o: sdbm.h -util.o:sdbm.h - -$(OBJS): sdbm.h tune.h pair.h - -# -# dbu using berkelezoid ndbm routines [if you have them] for testing -# -#x-dbu: dbu.o util.o -# cc $(CFLAGS) -o x-dbu dbu.o util.o -lint: - lint -abchx $(SRCS) - -clean: - rm -f *.o mon.out core - -purge: clean - rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag - -shar: - shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR - -readme: - nroff -ms readme.ms | col -b >README diff --git a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm index 42e9293c3fa..8b5dde14457 100644 --- a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm +++ b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm @@ -11,10 +11,12 @@ our @EXPORT = qw/ hostname /; our $VERSION; +use warnings (); + our $host; BEGIN { - $VERSION = '1.20'; + $VERSION = '1.22'; { local $SIG{__DIE__}; eval { @@ -27,6 +29,7 @@ BEGIN { sub hostname { + @_ and warnings::warnif("deprecated", "hostname() doesn't accept any arguments. This will become fatal in Perl 5.32"); # method 1 - we already know it return $host if defined $host; diff --git a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm index b8c9c1bf376..ddee77fd323 100644 --- a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm +++ b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm @@ -2,12 +2,11 @@ package VMS::DCLsym; use Carp; use DynaLoader; -use vars qw( @ISA $VERSION ); use strict; # Package globals -@ISA = ( 'DynaLoader' ); -$VERSION = '1.06'; +our @ISA = ( 'DynaLoader' ); +our $VERSION = '1.09'; # remember to update version in POD! my(%Locsyms) = ( ':ID' => 'LOCAL' ); my(%Gblsyms) = ( ':ID' => 'GLOBAL'); my $DoCache = 1; @@ -105,7 +104,7 @@ sub FIRSTKEY { if (!$DoCache || !$Cache_set) { # We should eventually replace this with a C routine which walks the # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . . - open(P,'Show Symbol * |'); + open(P, '-|', 'Show Symbol *'); while (<P>) { ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/ or carp "VMS::DCLsym: unparseable line $_"; @@ -186,8 +185,8 @@ defines a new symbol (or overwrites the old value of an existing symbol), and deleting an element deletes the corresponding symbol. Setting an element to C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out -whether a default symbol table has been specified for this hash (see C<table> -below), or set either or these keys to specify a default symbol table. +whether a default symbol table has been specified for this hash (see the next +paragraph), or set either or these keys to specify a default symbol table. When you call the C<tie> function to bind an associative array to this package, you may specify as an optional argument the symbol table in which you wish to @@ -265,7 +264,7 @@ Charles Bailey bailey@newman.upenn.edu =head1 VERSION -1.05 12-Feb-2011 +1.09 =head1 BUGS diff --git a/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t b/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t index 6d421e1ad92..cfb0aaa795b 100644 --- a/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t +++ b/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t @@ -137,6 +137,7 @@ foo-bar-0^.01/ vmsify [.foo-bar-0_01] [.foo-bar-0^.01] +foo.tmp vmsify ^+foo.tmp ^ ../foo\ \ bar/ vmsify [-.foo^_^_bar] ^ ./foo.tmp vmsify []foo.tmp ^ +x/r*??????? vmsify [.x]r*??????? ^ # Fileifying directory specs __down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 ^ diff --git a/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm b/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm index 875579e20e3..07ff377dcfc 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm +++ b/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.80'; +our $VERSION = '0.98'; require XSLoader; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs b/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs index 4d41654926c..a30659f14f9 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs +++ b/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs @@ -3,16 +3,25 @@ /* We want to be able to test things that aren't API yet. */ #define PERL_EXT +/* Do *not* define PERL_NO_GET_CONTEXT. This is the one place where we get + to test implicit Perl_get_context(). */ + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + +typedef FILE NativeFile; + #include "fakesdio.h" /* Causes us to use PerlIO below */ typedef SV *SVREF; typedef PTR_TBL_t *XS__APItest__PtrTable; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) -#define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) +#define croak_fail_nep(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) +#define croak_fail_nei(h, w) croak("fail %d!=%d at " __FILE__ " line %d", (int)(h), (int)(w), __LINE__) #ifdef EBCDIC @@ -90,7 +99,19 @@ typedef struct { START_MY_CXT +int +S_myset_set(pTHX_ SV* sv, MAGIC* mg) +{ + SV *isv = (SV*)mg->mg_ptr; + + PERL_UNUSED_ARG(sv); + SvIVX(isv)++; + return 0; +} + MGVTBL vtbl_foo, vtbl_bar; +MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 }; + /* indirect functions to test the [pa]MY_CXT macros */ @@ -154,8 +175,8 @@ test_freeent(freeent_function *f) { #else /* Storing then deleting something should ensure that a hash entry is available. */ - (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0); - (void) hv_delete(test_hash, "", 0, 0); + (void) hv_stores(test_hash, "", &PL_sv_yes); + (void) hv_deletes(test_hash, "", 0); /* We need to "inline" new_he here as it's static, and the functions we test expect to be able to call del_HE on the HE */ @@ -182,7 +203,7 @@ test_freeent(freeent_function *f) { i = 0; do { - mPUSHu(results[i]); + mXPUSHu(results[i]); } while (++i < (int)(sizeof(results)/sizeof(results[0]))); /* Goodbye to our extra reference. */ @@ -1145,88 +1166,88 @@ static int THX_keyword_active(pTHX_ SV *hintkey_sv) static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { - if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) && + if (memEQs(keyword_ptr, keyword_len, "rpn") && keyword_active(hintkey_rpn_sv)) { *op_ptr = parse_keyword_rpn(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) && + } else if (memEQs(keyword_ptr, keyword_len, "calcrpn") && keyword_active(hintkey_calcrpn_sv)) { *op_ptr = parse_keyword_calcrpn(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) && + } else if (memEQs(keyword_ptr, keyword_len, "stufftest") && keyword_active(hintkey_stufftest_sv)) { *op_ptr = parse_keyword_stufftest(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 12 && - strnEQ(keyword_ptr, "swaptwostmts", 12) && + } else if (memEQs(keyword_ptr, keyword_len, "swaptwostmts") && keyword_active(hintkey_swaptwostmts_sv)) { *op_ptr = parse_keyword_swaptwostmts(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) && + } else if (memEQs(keyword_ptr, keyword_len, "looprest") && keyword_active(hintkey_looprest_sv)) { *op_ptr = parse_keyword_looprest(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) && + } else if (memEQs(keyword_ptr, keyword_len, "scopelessblock") && keyword_active(hintkey_scopelessblock_sv)) { *op_ptr = parse_keyword_scopelessblock(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) && + } else if (memEQs(keyword_ptr, keyword_len, "stmtasexpr") && keyword_active(hintkey_stmtasexpr_sv)) { *op_ptr = parse_keyword_stmtasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) && + } else if (memEQs(keyword_ptr, keyword_len, "stmtsasexpr") && keyword_active(hintkey_stmtsasexpr_sv)) { *op_ptr = parse_keyword_stmtsasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) && + } else if (memEQs(keyword_ptr, keyword_len, "loopblock") && keyword_active(hintkey_loopblock_sv)) { *op_ptr = parse_keyword_loopblock(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) && + } else if (memEQs(keyword_ptr, keyword_len, "blockasexpr") && keyword_active(hintkey_blockasexpr_sv)) { *op_ptr = parse_keyword_blockasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) && + } else if (memEQs(keyword_ptr, keyword_len, "swaplabel") && keyword_active(hintkey_swaplabel_sv)) { *op_ptr = parse_keyword_swaplabel(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) && + } else if (memEQs(keyword_ptr, keyword_len, "labelconst") && keyword_active(hintkey_labelconst_sv)) { *op_ptr = parse_keyword_labelconst(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) && + } else if (memEQs(keyword_ptr, keyword_len, "arrayfullexpr") && keyword_active(hintkey_arrayfullexpr_sv)) { *op_ptr = parse_keyword_arrayfullexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) && + } else if (memEQs(keyword_ptr, keyword_len, "arraylistexpr") && keyword_active(hintkey_arraylistexpr_sv)) { *op_ptr = parse_keyword_arraylistexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) && + } else if (memEQs(keyword_ptr, keyword_len, "arraytermexpr") && keyword_active(hintkey_arraytermexpr_sv)) { *op_ptr = parse_keyword_arraytermexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) && + } else if (memEQs(keyword_ptr, keyword_len, "arrayarithexpr") && keyword_active(hintkey_arrayarithexpr_sv)) { *op_ptr = parse_keyword_arrayarithexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) && + } else if (memEQs(keyword_ptr, keyword_len, "arrayexprflags") && keyword_active(hintkey_arrayexprflags_sv)) { *op_ptr = parse_keyword_arrayexprflags(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) && + } else if (memEQs(keyword_ptr, keyword_len, "DEFSV") && keyword_active(hintkey_DEFSV_sv)) { *op_ptr = parse_keyword_DEFSV(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) && + } else if (memEQs(keyword_ptr, keyword_len, "with_vars") && keyword_active(hintkey_with_vars_sv)) { *op_ptr = parse_keyword_with_vars(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) && + } else if (memEQs(keyword_ptr, keyword_len, "join_with_space") && keyword_active(hintkey_join_with_space_sv)) { *op_ptr = parse_join_with_space(); return KEYWORD_PLUGIN_EXPR; } else { + assert(next_keyword_plugin != my_keyword_plugin); return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } } @@ -1243,8 +1264,8 @@ static void peep_xop(pTHX_ OP *o, OP *oldop) { dMY_CXT; - av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o))); - av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop))); + av_push(MY_CXT.xop_record, newSVpvf("peep:%" UVxf, PTR2UV(o))); + av_push(MY_CXT.xop_record, newSVpvf("oldop:%" UVxf, PTR2UV(oldop))); } static I32 @@ -1359,29 +1380,95 @@ bytes_cmp_utf8(bytes, utf8) RETVAL AV * -test_utf8n_to_uvchr(s, len, flags) +test_utf8_to_bytes(bytes, len) + U8 * bytes + STRLEN len + PREINIT: + char * ret; + CODE: + RETVAL = newAV(); + sv_2mortal((SV*)RETVAL); - SV *s - SV *len - SV *flags + ret = (char *) utf8_to_bytes(bytes, &len); + av_push(RETVAL, newSVpv(ret, 0)); + + /* utf8_to_bytes uses (STRLEN)-1 to signal errors, and we want to + * return that as -1 to perl, so cast to SSize_t in case + * sizeof(IV) > sizeof(STRLEN) */ + av_push(RETVAL, newSViv((SSize_t)len)); + av_push(RETVAL, newSVpv((const char *) bytes, 0)); + + OUTPUT: + RETVAL + +AV * +test_utf8n_to_uvchr_msgs(s, len, flags) + char *s + STRLEN len + U32 flags PREINIT: STRLEN retlen; UV ret; - STRLEN slen; + U32 errors; + AV *msgs = NULL; CODE: - /* Call utf8n_to_uvchr() with the inputs. It always asks for the - * actual length to be returned + RETVAL = newAV(); + sv_2mortal((SV*)RETVAL); + + ret = utf8n_to_uvchr_msgs((U8*) s, + len, + &retlen, + flags, + &errors, + &msgs); + + /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */ + av_push(RETVAL, newSVuv(ret)); + if (retlen == (STRLEN) -1) { + av_push(RETVAL, newSViv(-1)); + } + else { + av_push(RETVAL, newSVuv(retlen)); + } + av_push(RETVAL, newSVuv(errors)); + + /* And any messages in [3] */ + if (msgs) { + av_push(RETVAL, newRV_noinc((SV*)msgs)); + } + + OUTPUT: + RETVAL + +AV * +test_utf8n_to_uvchr_error(s, len, flags) + + char *s + STRLEN len + U32 flags + PREINIT: + STRLEN retlen; + UV ret; + U32 errors; + + CODE: + /* Now that utf8n_to_uvchr() is a trivial wrapper for + * utf8n_to_uvchr_error(), call the latter with the inputs. It always + * asks for the actual length to be returned and errors to be returned * * Length to assume <s> is; not checked, so could have buffer overflow */ RETVAL = newAV(); sv_2mortal((SV*)RETVAL); - ret - = utf8n_to_uvchr((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags)); + ret = utf8n_to_uvchr_error((U8*) s, + len, + &retlen, + flags, + &errors); - /* Returns the return value in [0]; <retlen> in [1] */ + /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */ av_push(RETVAL, newSVuv(ret)); if (retlen == (STRLEN) -1) { av_push(RETVAL, newSViv(-1)); @@ -1389,6 +1476,7 @@ test_utf8n_to_uvchr(s, len, flags) else { av_push(RETVAL, newSVuv(retlen)); } + av_push(RETVAL, newSVuv(errors)); OUTPUT: RETVAL @@ -1400,7 +1488,6 @@ test_valid_utf8_to_uvchr(s) PREINIT: STRLEN retlen; UV ret; - STRLEN slen; CODE: /* Call utf8n_to_uvchr() with the inputs. It always asks for the @@ -1411,8 +1498,7 @@ test_valid_utf8_to_uvchr(s) RETVAL = newAV(); sv_2mortal((SV*)RETVAL); - ret - = valid_utf8_to_uvchr((U8*) SvPV(s, slen), &retlen); + ret = valid_utf8_to_uvchr((U8*) SvPV_nolen(s), &retlen); /* Returns the return value in [0]; <retlen> in [1] */ av_push(RETVAL, newSVuv(ret)); @@ -1427,7 +1513,7 @@ test_uvchr_to_utf8_flags(uv, flags) SV *uv SV *flags PREINIT: - U8 dest[UTF8_MAXBYTES]; + U8 dest[UTF8_MAXBYTES + 1]; U8 *ret; CODE: @@ -1441,6 +1527,36 @@ test_uvchr_to_utf8_flags(uv, flags) OUTPUT: RETVAL +AV * +test_uvchr_to_utf8_flags_msgs(uv, flags) + + SV *uv + SV *flags + PREINIT: + U8 dest[UTF8_MAXBYTES + 1]; + U8 *ret; + + CODE: + HV *msgs = NULL; + RETVAL = newAV(); + sv_2mortal((SV*)RETVAL); + + ret = uvchr_to_utf8_flags_msgs(dest, SvUV(uv), SvUV(flags), &msgs); + + if (ret) { + av_push(RETVAL, newSVpvn((char *) dest, ret - dest)); + } + else { + av_push(RETVAL, &PL_sv_undef); + } + + if (msgs) { + av_push(RETVAL, newRV_noinc((SV*)msgs)); + } + + OUTPUT: + RETVAL + MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload void @@ -1828,7 +1944,7 @@ refcounted_he_exists(key, level=0) IV level CODE: if (level) { - croak("level must be zero, not %"IVdf, level); + croak("level must be zero, not %" IVdf, level); } RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder); OUTPUT: @@ -1840,7 +1956,7 @@ refcounted_he_fetch(key, level=0) IV level CODE: if (level) { - croak("level must be zero, not %"IVdf, level); + croak("level must be zero, not %" IVdf, level); } RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0); SvREFCNT_inc(RETVAL); @@ -2048,8 +2164,8 @@ xop_build_optree () unop->op_next = NULL; kid->op_next = (OP*)unop; - av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop))); - av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid))); + av_push(MY_CXT.xop_record, newSVpvf("unop:%" UVxf, PTR2UV(unop))); + av_push(MY_CXT.xop_record, newSVpvf("kid:%" UVxf, PTR2UV(kid))); av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop))); av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop))); @@ -2293,6 +2409,7 @@ PREINIT: I32 retcnt; SV * errsv; char * errstr; + STRLEN errlen; SV * miscsv = sv_newmortal(); HV * hv = (HV*)sv_2mortal((SV*)newHV()); CODE: @@ -2318,17 +2435,24 @@ CODE: 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 */ + retcnt = call_sv(&PL_sv_yes, G_EVAL); SPAGAIN; SP -= retcnt; + errsv = ERRSV; + errstr = SvPV(errsv, errlen); + if(memBEGINs(errstr, errlen, "Undefined subroutine &main::1 called at")) { + PUSHMARK(SP); + retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ + 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)) { + errstr = SvPV(errsv, errlen); + if(memBEGINs(errstr, errlen, "Undefined subroutine &main:: called at")) { PUSHMARK(SP); retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ SPAGAIN; @@ -2339,9 +2463,8 @@ CODE: 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)) { + errstr = SvPV(errsv, errlen); + if(memBEGINs(errstr, errlen, "Can't use an undefined value as a subroutine reference at")) { PUSHMARK(SP); retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ SPAGAIN; @@ -2352,9 +2475,8 @@ CODE: SPAGAIN; SP -= retcnt; errsv = ERRSV; - errstr = SvPV_nolen(errsv); - if(strnEQ(errstr, "Not a CODE reference at", - sizeof("Not a CODE reference at") - 1)) { + errstr = SvPV(errsv, errlen); + if(memBEGINs(errstr, errlen, "Not a CODE reference at")) { PUSHMARK(SP); retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */ SPAGAIN; @@ -2396,6 +2518,23 @@ call_pv(subname, flags, ...) PUSHs(sv_2mortal(newSViv(i))); void +call_argv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + char *tmpary[4]; + PPCODE: + for (i=0; i<items-2; i++) + tmpary[i] = SvPV_nolen(ST(i+2)); /* ignore first two args */ + tmpary[i] = NULL; + PUTBACK; + i = call_argv(subname, flags, tmpary); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void call_method(methname, flags, ...) char* methname I32 flags @@ -2551,6 +2690,9 @@ gv_fetchmethod_flags_type(stash, methname, type, flags) gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname)); break; } + case 4: + gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname), + flags, SvUTF8(methname)); } XPUSHs( gv ? (SV*)gv : &PL_sv_undef); @@ -2848,7 +2990,7 @@ utf16_to_utf8 (sv, ...) len = SvUV(ST(1)); } /* Mortalise this right now, as we'll be testing croak()s */ - dest = sv_2mortal(newSV(len * 3 / 2 + 1)); + dest = sv_2mortal(newSV(len * 2 + 1)); if (ix) { utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got); } else { @@ -3047,34 +3189,60 @@ test_cv_getset_call_checker() CV *troc_cv, *tsh_cv; Perl_call_checker ckfun; SV *ckobj; + U32 ckflags; CODE: -#define check_cc(cv, xckfun, xckobj) \ +#define check_cc(cv, xckfun, xckobj, xckflags) \ do { \ cv_get_call_checker((cv), &ckfun, &ckobj); \ - if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \ - if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + cv_get_call_checker_flags((cv), CALL_CHECKER_REQUIRE_GV, &ckfun, &ckobj, &ckflags); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckflags != CALL_CHECKER_REQUIRE_GV) croak_fail_nei(ckflags, CALL_CHECKER_REQUIRE_GV); \ + cv_get_call_checker_flags((cv), 0, &ckfun, &ckobj, &ckflags); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckflags != (xckflags)) croak_fail_nei(ckflags, (xckflags)); \ } while(0) troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0); tsh_cv = get_cv("XS::APItest::test_savehints", 0); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); + check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); - check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail(); if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 0); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + (SV*)tsh_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); + if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + (SV*)tsh_cv, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); + if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); #undef check_cc void @@ -3272,13 +3440,13 @@ test_coplabel() cop = &PL_compiling; Perl_cop_store_label(aTHX_ cop, "foo", 3, 0); label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8); - if (strcmp(label,"foo")) croak("fail # cop_fetch_label label"); + if (strNE(label,"foo")) croak("fail # cop_fetch_label label"); if (len != 3) croak("fail # cop_fetch_label len"); if (utf8) croak("fail # cop_fetch_label utf8"); /* SMALL GERMAN UMLAUT A */ Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8); label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8); - if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label"); + if (strNE(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label"); if (len != 4) croak("fail # cop_fetch_label len"); if (!utf8) croak("fail # cop_fetch_label utf8"); @@ -3409,7 +3577,7 @@ test_op_list() #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv)) #define check_op(o, expect) \ do { \ - if (strcmp(test_op_list_describe(o), (expect))) \ + if (strNE(test_op_list_describe(o), (expect))) \ croak("fail %s %s", test_op_list_describe(o), (expect)); \ } while(0) a = op_append_elem(OP_LIST, NULL, NULL); @@ -3830,8 +3998,7 @@ BOOT: hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV"); hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars"); hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space"); - next_keyword_plugin = PL_keyword_plugin; - PL_keyword_plugin = my_keyword_plugin; + wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin); } void @@ -4087,10 +4254,11 @@ lexical_import(SV *name, CV *cv) SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl); SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1]; SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); - off = pad_add_name_sv(sv_2mortal(newSVpvf("&%"SVf,name)), + off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)), padadd_STATE, 0, 0); SvREFCNT_dec(PL_curpad[off]); PL_curpad[off] = SvREFCNT_inc(cv); + intro_my(); LEAVE; } @@ -4183,6 +4351,75 @@ test_sv_catpvf(SV *fmtsv) sv = sv_2mortal(newSVpvn("", 0)); sv_catpvf(sv, fmt, 5, 6, 7, 8); +void +load_module(flags, name, ...) + U32 flags + SV *name +CODE: + if (items == 2) { + Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL); + } else if (items == 3) { + Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2))); + } else + Perl_croak(aTHX_ "load_module can't yet support %" IVdf " items", + (IV)items); + +SV * +string_without_null(SV *sv) + CODE: + { + STRLEN len; + const char *s = SvPV(sv, len); + RETVAL = newSVpvn_flags(s, len, SvUTF8(sv)); + *SvEND(RETVAL) = 0xff; + } + OUTPUT: + RETVAL + +CV * +get_cv(SV *sv) + CODE: + { + STRLEN len; + const char *s = SvPV(sv, len); + RETVAL = get_cvn_flags(s, len, 0); + } + OUTPUT: + RETVAL + +CV * +get_cv_flags(SV *sv, UV flags) + CODE: + { + STRLEN len; + const char *s = SvPV(sv, len); + RETVAL = get_cvn_flags(s, len, flags); + } + OUTPUT: + RETVAL + +void +unshift_and_set_defav(SV *sv,...) + CODE: + av_unshift(GvAVn(PL_defgv), 1); + av_store(GvAV(PL_defgv), 0, newSVuv(42)); + sv_setuv(sv, 43); + +PerlIO * +PerlIO_stderr() + +OutputStream +PerlIO_stdout() + +InputStream +PerlIO_stdin() + +#undef FILE +#define FILE NativeFile + +FILE * +PerlIO_exportFILE(PerlIO *f, const char *mode) + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int @@ -4285,6 +4522,18 @@ test_get_vtbl() OUTPUT: RETVAL + + # attach ext magic to the SV pointed to by rsv that only has set magic, + # where that magic's job is to increment thingy + +void +sv_magic_myset(SV *rsv, SV *thingy) +CODE: + sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset, + (const char *)thingy, 0); + + + bool test_isBLANK_uni(UV ord) CODE: @@ -4293,6 +4542,13 @@ test_isBLANK_uni(UV ord) RETVAL bool +test_isBLANK_uvchr(UV ord) + CODE: + RETVAL = isBLANK_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isBLANK_LC_uvchr(UV ord) CODE: RETVAL = isBLANK_LC_uvchr(ord); @@ -4300,6 +4556,13 @@ test_isBLANK_LC_uvchr(UV ord) RETVAL bool +test_isBLANK(UV ord) + CODE: + RETVAL = isBLANK(ord); + OUTPUT: + RETVAL + +bool test_isBLANK_A(UV ord) CODE: RETVAL = isBLANK_A(ord); @@ -4321,16 +4584,36 @@ test_isBLANK_LC(UV ord) RETVAL bool -test_isBLANK_utf8(unsigned char * p) +test_isBLANK_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isBLANK_utf8(p); + + /* In this function and those that follow, the boolean 'type' + * indicates if to pass a malformed UTF-8 string to the tested macro + * (malformed by making it too short) */ + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isBLANK_utf8_safe(p, e); + } + else { + RETVAL = isBLANK_utf8(p); + } OUTPUT: RETVAL bool -test_isBLANK_LC_utf8(unsigned char * p) +test_isBLANK_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isBLANK_LC_utf8(p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isBLANK_LC_utf8_safe(p, e); + } + else { + RETVAL = isBLANK_LC_utf8(p); + } OUTPUT: RETVAL @@ -4342,9 +4625,24 @@ test_isVERTWS_uni(UV ord) RETVAL bool -test_isVERTWS_utf8(unsigned char * p) +test_isVERTWS_uvchr(UV ord) CODE: - RETVAL = isVERTWS_utf8(p); + RETVAL = isVERTWS_uvchr(ord); + OUTPUT: + RETVAL + +bool +test_isVERTWS_utf8(U8 * p, int type) + PREINIT: + const U8 * e; + CODE: + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isVERTWS_utf8_safe(p, e); + } + else { + RETVAL = isVERTWS_utf8(p); + } OUTPUT: RETVAL @@ -4356,6 +4654,13 @@ test_isUPPER_uni(UV ord) RETVAL bool +test_isUPPER_uvchr(UV ord) + CODE: + RETVAL = isUPPER_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isUPPER_LC_uvchr(UV ord) CODE: RETVAL = isUPPER_LC_uvchr(ord); @@ -4363,6 +4668,13 @@ test_isUPPER_LC_uvchr(UV ord) RETVAL bool +test_isUPPER(UV ord) + CODE: + RETVAL = isUPPER(ord); + OUTPUT: + RETVAL + +bool test_isUPPER_A(UV ord) CODE: RETVAL = isUPPER_A(ord); @@ -4384,16 +4696,32 @@ test_isUPPER_LC(UV ord) RETVAL bool -test_isUPPER_utf8(unsigned char * p) +test_isUPPER_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isUPPER_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isUPPER_utf8_safe(p, e); + } + else { + RETVAL = isUPPER_utf8(p); + } OUTPUT: RETVAL bool -test_isUPPER_LC_utf8(unsigned char * p) +test_isUPPER_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isUPPER_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isUPPER_LC_utf8_safe(p, e); + } + else { + RETVAL = isUPPER_LC_utf8(p); + } OUTPUT: RETVAL @@ -4405,6 +4733,13 @@ test_isLOWER_uni(UV ord) RETVAL bool +test_isLOWER_uvchr(UV ord) + CODE: + RETVAL = isLOWER_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isLOWER_LC_uvchr(UV ord) CODE: RETVAL = isLOWER_LC_uvchr(ord); @@ -4412,6 +4747,13 @@ test_isLOWER_LC_uvchr(UV ord) RETVAL bool +test_isLOWER(UV ord) + CODE: + RETVAL = isLOWER(ord); + OUTPUT: + RETVAL + +bool test_isLOWER_A(UV ord) CODE: RETVAL = isLOWER_A(ord); @@ -4433,16 +4775,32 @@ test_isLOWER_LC(UV ord) RETVAL bool -test_isLOWER_utf8(unsigned char * p) +test_isLOWER_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isLOWER_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isLOWER_utf8_safe(p, e); + } + else { + RETVAL = isLOWER_utf8(p); + } OUTPUT: RETVAL bool -test_isLOWER_LC_utf8(unsigned char * p) +test_isLOWER_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isLOWER_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isLOWER_LC_utf8_safe(p, e); + } + else { + RETVAL = isLOWER_LC_utf8(p); + } OUTPUT: RETVAL @@ -4454,6 +4812,13 @@ test_isALPHA_uni(UV ord) RETVAL bool +test_isALPHA_uvchr(UV ord) + CODE: + RETVAL = isALPHA_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isALPHA_LC_uvchr(UV ord) CODE: RETVAL = isALPHA_LC_uvchr(ord); @@ -4461,6 +4826,13 @@ test_isALPHA_LC_uvchr(UV ord) RETVAL bool +test_isALPHA(UV ord) + CODE: + RETVAL = isALPHA(ord); + OUTPUT: + RETVAL + +bool test_isALPHA_A(UV ord) CODE: RETVAL = isALPHA_A(ord); @@ -4482,16 +4854,32 @@ test_isALPHA_LC(UV ord) RETVAL bool -test_isALPHA_utf8(unsigned char * p) +test_isALPHA_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALPHA_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHA_utf8_safe(p, e); + } + else { + RETVAL = isALPHA_utf8(p); + } OUTPUT: RETVAL bool -test_isALPHA_LC_utf8(unsigned char * p) +test_isALPHA_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALPHA_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHA_LC_utf8_safe(p, e); + } + else { + RETVAL = isALPHA_LC_utf8(p); + } OUTPUT: RETVAL @@ -4503,6 +4891,13 @@ test_isWORDCHAR_uni(UV ord) RETVAL bool +test_isWORDCHAR_uvchr(UV ord) + CODE: + RETVAL = isWORDCHAR_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isWORDCHAR_LC_uvchr(UV ord) CODE: RETVAL = isWORDCHAR_LC_uvchr(ord); @@ -4510,6 +4905,13 @@ test_isWORDCHAR_LC_uvchr(UV ord) RETVAL bool +test_isWORDCHAR(UV ord) + CODE: + RETVAL = isWORDCHAR(ord); + OUTPUT: + RETVAL + +bool test_isWORDCHAR_A(UV ord) CODE: RETVAL = isWORDCHAR_A(ord); @@ -4531,16 +4933,32 @@ test_isWORDCHAR_LC(UV ord) RETVAL bool -test_isWORDCHAR_utf8(unsigned char * p) +test_isWORDCHAR_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isWORDCHAR_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_utf8(p); + } OUTPUT: RETVAL bool -test_isWORDCHAR_LC_utf8(unsigned char * p) +test_isWORDCHAR_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isWORDCHAR_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_LC_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_LC_utf8(p); + } OUTPUT: RETVAL @@ -4552,6 +4970,13 @@ test_isALPHANUMERIC_uni(UV ord) RETVAL bool +test_isALPHANUMERIC_uvchr(UV ord) + CODE: + RETVAL = isALPHANUMERIC_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isALPHANUMERIC_LC_uvchr(UV ord) CODE: RETVAL = isALPHANUMERIC_LC_uvchr(ord); @@ -4559,6 +4984,13 @@ test_isALPHANUMERIC_LC_uvchr(UV ord) RETVAL bool +test_isALPHANUMERIC(UV ord) + CODE: + RETVAL = isALPHANUMERIC(ord); + OUTPUT: + RETVAL + +bool test_isALPHANUMERIC_A(UV ord) CODE: RETVAL = isALPHANUMERIC_A(ord); @@ -4580,16 +5012,39 @@ test_isALPHANUMERIC_LC(UV ord) RETVAL bool -test_isALPHANUMERIC_utf8(unsigned char * p) +test_isALPHANUMERIC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALPHANUMERIC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHANUMERIC_utf8_safe(p, e); + } + else { + RETVAL = isALPHANUMERIC_utf8(p); + } OUTPUT: RETVAL bool -test_isALPHANUMERIC_LC_utf8(unsigned char * p) +test_isALPHANUMERIC_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALPHANUMERIC_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHANUMERIC_LC_utf8_safe(p, e); + } + else { + RETVAL = isALPHANUMERIC_LC_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isALNUM(UV ord) + CODE: + RETVAL = isALNUM(ord); OUTPUT: RETVAL @@ -4615,16 +5070,32 @@ test_isALNUM_LC(UV ord) RETVAL bool -test_isALNUM_utf8(unsigned char * p) +test_isALNUM_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALNUM_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_utf8(p); + } OUTPUT: RETVAL bool -test_isALNUM_LC_utf8(unsigned char * p) +test_isALNUM_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isALNUM_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_LC_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_LC_utf8(p); + } OUTPUT: RETVAL @@ -4636,6 +5107,13 @@ test_isDIGIT_uni(UV ord) RETVAL bool +test_isDIGIT_uvchr(UV ord) + CODE: + RETVAL = isDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isDIGIT_LC_uvchr(UV ord) CODE: RETVAL = isDIGIT_LC_uvchr(ord); @@ -4643,16 +5121,39 @@ test_isDIGIT_LC_uvchr(UV ord) RETVAL bool -test_isDIGIT_utf8(unsigned char * p) +test_isDIGIT_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isDIGIT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isDIGIT_utf8_safe(p, e); + } + else { + RETVAL = isDIGIT_utf8(p); + } OUTPUT: RETVAL bool -test_isDIGIT_LC_utf8(unsigned char * p) +test_isDIGIT_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isDIGIT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isDIGIT_LC_utf8_safe(p, e); + } + else { + RETVAL = isDIGIT_LC_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isDIGIT(UV ord) + CODE: + RETVAL = isDIGIT(ord); OUTPUT: RETVAL @@ -4678,6 +5179,27 @@ test_isDIGIT_LC(UV ord) RETVAL bool +test_isOCTAL(UV ord) + CODE: + RETVAL = isOCTAL(ord); + OUTPUT: + RETVAL + +bool +test_isOCTAL_A(UV ord) + CODE: + RETVAL = isOCTAL_A(ord); + OUTPUT: + RETVAL + +bool +test_isOCTAL_L1(UV ord) + CODE: + RETVAL = isOCTAL_L1(ord); + OUTPUT: + RETVAL + +bool test_isIDFIRST_uni(UV ord) CODE: RETVAL = isIDFIRST_uni(ord); @@ -4685,6 +5207,13 @@ test_isIDFIRST_uni(UV ord) RETVAL bool +test_isIDFIRST_uvchr(UV ord) + CODE: + RETVAL = isIDFIRST_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isIDFIRST_LC_uvchr(UV ord) CODE: RETVAL = isIDFIRST_LC_uvchr(ord); @@ -4692,6 +5221,13 @@ test_isIDFIRST_LC_uvchr(UV ord) RETVAL bool +test_isIDFIRST(UV ord) + CODE: + RETVAL = isIDFIRST(ord); + OUTPUT: + RETVAL + +bool test_isIDFIRST_A(UV ord) CODE: RETVAL = isIDFIRST_A(ord); @@ -4713,16 +5249,32 @@ test_isIDFIRST_LC(UV ord) RETVAL bool -test_isIDFIRST_utf8(unsigned char * p) +test_isIDFIRST_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isIDFIRST_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDFIRST_utf8_safe(p, e); + } + else { + RETVAL = isIDFIRST_utf8(p); + } OUTPUT: RETVAL bool -test_isIDFIRST_LC_utf8(unsigned char * p) +test_isIDFIRST_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isIDFIRST_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDFIRST_LC_utf8_safe(p, e); + } + else { + RETVAL = isIDFIRST_LC_utf8(p); + } OUTPUT: RETVAL @@ -4734,6 +5286,13 @@ test_isIDCONT_uni(UV ord) RETVAL bool +test_isIDCONT_uvchr(UV ord) + CODE: + RETVAL = isIDCONT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isIDCONT_LC_uvchr(UV ord) CODE: RETVAL = isIDCONT_LC_uvchr(ord); @@ -4741,6 +5300,13 @@ test_isIDCONT_LC_uvchr(UV ord) RETVAL bool +test_isIDCONT(UV ord) + CODE: + RETVAL = isIDCONT(ord); + OUTPUT: + RETVAL + +bool test_isIDCONT_A(UV ord) CODE: RETVAL = isIDCONT_A(ord); @@ -4762,16 +5328,32 @@ test_isIDCONT_LC(UV ord) RETVAL bool -test_isIDCONT_utf8(unsigned char * p) +test_isIDCONT_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isIDCONT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDCONT_utf8_safe(p, e); + } + else { + RETVAL = isIDCONT_utf8(p); + } OUTPUT: RETVAL bool -test_isIDCONT_LC_utf8(unsigned char * p) +test_isIDCONT_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isIDCONT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDCONT_LC_utf8_safe(p, e); + } + else { + RETVAL = isIDCONT_LC_utf8(p); + } OUTPUT: RETVAL @@ -4783,6 +5365,13 @@ test_isSPACE_uni(UV ord) RETVAL bool +test_isSPACE_uvchr(UV ord) + CODE: + RETVAL = isSPACE_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isSPACE_LC_uvchr(UV ord) CODE: RETVAL = isSPACE_LC_uvchr(ord); @@ -4790,6 +5379,13 @@ test_isSPACE_LC_uvchr(UV ord) RETVAL bool +test_isSPACE(UV ord) + CODE: + RETVAL = isSPACE(ord); + OUTPUT: + RETVAL + +bool test_isSPACE_A(UV ord) CODE: RETVAL = isSPACE_A(ord); @@ -4811,16 +5407,32 @@ test_isSPACE_LC(UV ord) RETVAL bool -test_isSPACE_utf8(unsigned char * p) +test_isSPACE_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isSPACE_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isSPACE_utf8_safe(p, e); + } + else { + RETVAL = isSPACE_utf8(p); + } OUTPUT: RETVAL bool -test_isSPACE_LC_utf8(unsigned char * p) +test_isSPACE_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isSPACE_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isSPACE_LC_utf8_safe(p, e); + } + else { + RETVAL = isSPACE_LC_utf8(p); + } OUTPUT: RETVAL @@ -4832,6 +5444,13 @@ test_isASCII_uni(UV ord) RETVAL bool +test_isASCII_uvchr(UV ord) + CODE: + RETVAL = isASCII_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isASCII_LC_uvchr(UV ord) CODE: RETVAL = isASCII_LC_uvchr(ord); @@ -4839,6 +5458,13 @@ test_isASCII_LC_uvchr(UV ord) RETVAL bool +test_isASCII(UV ord) + CODE: + RETVAL = isASCII(ord); + OUTPUT: + RETVAL + +bool test_isASCII_A(UV ord) CODE: RETVAL = isASCII_A(ord); @@ -4860,16 +5486,38 @@ test_isASCII_LC(UV ord) RETVAL bool -test_isASCII_utf8(unsigned char * p) +test_isASCII_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isASCII_utf8( p); +#ifndef DEBUGGING + PERL_UNUSED_VAR(e); +#endif + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isASCII_utf8_safe(p, e); + } + else { + RETVAL = isASCII_utf8(p); + } OUTPUT: RETVAL bool -test_isASCII_LC_utf8(unsigned char * p) +test_isASCII_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isASCII_LC_utf8( p); +#ifndef DEBUGGING + PERL_UNUSED_VAR(e); +#endif + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isASCII_LC_utf8_safe(p, e); + } + else { + RETVAL = isASCII_LC_utf8(p); + } OUTPUT: RETVAL @@ -4881,6 +5529,13 @@ test_isCNTRL_uni(UV ord) RETVAL bool +test_isCNTRL_uvchr(UV ord) + CODE: + RETVAL = isCNTRL_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isCNTRL_LC_uvchr(UV ord) CODE: RETVAL = isCNTRL_LC_uvchr(ord); @@ -4888,6 +5543,13 @@ test_isCNTRL_LC_uvchr(UV ord) RETVAL bool +test_isCNTRL(UV ord) + CODE: + RETVAL = isCNTRL(ord); + OUTPUT: + RETVAL + +bool test_isCNTRL_A(UV ord) CODE: RETVAL = isCNTRL_A(ord); @@ -4909,16 +5571,32 @@ test_isCNTRL_LC(UV ord) RETVAL bool -test_isCNTRL_utf8(unsigned char * p) +test_isCNTRL_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isCNTRL_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isCNTRL_utf8_safe(p, e); + } + else { + RETVAL = isCNTRL_utf8(p); + } OUTPUT: RETVAL bool -test_isCNTRL_LC_utf8(unsigned char * p) +test_isCNTRL_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isCNTRL_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isCNTRL_LC_utf8_safe(p, e); + } + else { + RETVAL = isCNTRL_LC_utf8(p); + } OUTPUT: RETVAL @@ -4930,6 +5608,13 @@ test_isPRINT_uni(UV ord) RETVAL bool +test_isPRINT_uvchr(UV ord) + CODE: + RETVAL = isPRINT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPRINT_LC_uvchr(UV ord) CODE: RETVAL = isPRINT_LC_uvchr(ord); @@ -4937,6 +5622,13 @@ test_isPRINT_LC_uvchr(UV ord) RETVAL bool +test_isPRINT(UV ord) + CODE: + RETVAL = isPRINT(ord); + OUTPUT: + RETVAL + +bool test_isPRINT_A(UV ord) CODE: RETVAL = isPRINT_A(ord); @@ -4958,16 +5650,32 @@ test_isPRINT_LC(UV ord) RETVAL bool -test_isPRINT_utf8(unsigned char * p) +test_isPRINT_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPRINT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPRINT_utf8_safe(p, e); + } + else { + RETVAL = isPRINT_utf8(p); + } OUTPUT: RETVAL bool -test_isPRINT_LC_utf8(unsigned char * p) +test_isPRINT_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPRINT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPRINT_LC_utf8_safe(p, e); + } + else { + RETVAL = isPRINT_LC_utf8(p); + } OUTPUT: RETVAL @@ -4979,6 +5687,13 @@ test_isGRAPH_uni(UV ord) RETVAL bool +test_isGRAPH_uvchr(UV ord) + CODE: + RETVAL = isGRAPH_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isGRAPH_LC_uvchr(UV ord) CODE: RETVAL = isGRAPH_LC_uvchr(ord); @@ -4986,6 +5701,13 @@ test_isGRAPH_LC_uvchr(UV ord) RETVAL bool +test_isGRAPH(UV ord) + CODE: + RETVAL = isGRAPH(ord); + OUTPUT: + RETVAL + +bool test_isGRAPH_A(UV ord) CODE: RETVAL = isGRAPH_A(ord); @@ -5007,16 +5729,32 @@ test_isGRAPH_LC(UV ord) RETVAL bool -test_isGRAPH_utf8(unsigned char * p) +test_isGRAPH_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isGRAPH_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isGRAPH_utf8_safe(p, e); + } + else { + RETVAL = isGRAPH_utf8(p); + } OUTPUT: RETVAL bool -test_isGRAPH_LC_utf8(unsigned char * p) +test_isGRAPH_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isGRAPH_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isGRAPH_LC_utf8_safe(p, e); + } + else { + RETVAL = isGRAPH_LC_utf8(p); + } OUTPUT: RETVAL @@ -5028,6 +5766,13 @@ test_isPUNCT_uni(UV ord) RETVAL bool +test_isPUNCT_uvchr(UV ord) + CODE: + RETVAL = isPUNCT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPUNCT_LC_uvchr(UV ord) CODE: RETVAL = isPUNCT_LC_uvchr(ord); @@ -5035,6 +5780,13 @@ test_isPUNCT_LC_uvchr(UV ord) RETVAL bool +test_isPUNCT(UV ord) + CODE: + RETVAL = isPUNCT(ord); + OUTPUT: + RETVAL + +bool test_isPUNCT_A(UV ord) CODE: RETVAL = isPUNCT_A(ord); @@ -5056,16 +5808,32 @@ test_isPUNCT_LC(UV ord) RETVAL bool -test_isPUNCT_utf8(unsigned char * p) +test_isPUNCT_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPUNCT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPUNCT_utf8_safe(p, e); + } + else { + RETVAL = isPUNCT_utf8(p); + } OUTPUT: RETVAL bool -test_isPUNCT_LC_utf8(unsigned char * p) +test_isPUNCT_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPUNCT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPUNCT_LC_utf8_safe(p, e); + } + else { + RETVAL = isPUNCT_LC_utf8(p); + } OUTPUT: RETVAL @@ -5077,6 +5845,13 @@ test_isXDIGIT_uni(UV ord) RETVAL bool +test_isXDIGIT_uvchr(UV ord) + CODE: + RETVAL = isXDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isXDIGIT_LC_uvchr(UV ord) CODE: RETVAL = isXDIGIT_LC_uvchr(ord); @@ -5084,6 +5859,13 @@ test_isXDIGIT_LC_uvchr(UV ord) RETVAL bool +test_isXDIGIT(UV ord) + CODE: + RETVAL = isXDIGIT(ord); + OUTPUT: + RETVAL + +bool test_isXDIGIT_A(UV ord) CODE: RETVAL = isXDIGIT_A(ord); @@ -5105,16 +5887,32 @@ test_isXDIGIT_LC(UV ord) RETVAL bool -test_isXDIGIT_utf8(unsigned char * p) +test_isXDIGIT_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isXDIGIT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isXDIGIT_utf8_safe(p, e); + } + else { + RETVAL = isXDIGIT_utf8(p); + } OUTPUT: RETVAL bool -test_isXDIGIT_LC_utf8(unsigned char * p) +test_isXDIGIT_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isXDIGIT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isXDIGIT_LC_utf8_safe(p, e); + } + else { + RETVAL = isXDIGIT_LC_utf8(p); + } OUTPUT: RETVAL @@ -5126,6 +5924,13 @@ test_isPSXSPC_uni(UV ord) RETVAL bool +test_isPSXSPC_uvchr(UV ord) + CODE: + RETVAL = isPSXSPC_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPSXSPC_LC_uvchr(UV ord) CODE: RETVAL = isPSXSPC_LC_uvchr(ord); @@ -5133,6 +5938,13 @@ test_isPSXSPC_LC_uvchr(UV ord) RETVAL bool +test_isPSXSPC(UV ord) + CODE: + RETVAL = isPSXSPC(ord); + OUTPUT: + RETVAL + +bool test_isPSXSPC_A(UV ord) CODE: RETVAL = isPSXSPC_A(ord); @@ -5154,16 +5966,32 @@ test_isPSXSPC_LC(UV ord) RETVAL bool -test_isPSXSPC_utf8(unsigned char * p) +test_isPSXSPC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPSXSPC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPSXSPC_utf8_safe(p, e); + } + else { + RETVAL = isPSXSPC_utf8(p); + } OUTPUT: RETVAL bool -test_isPSXSPC_LC_utf8(unsigned char * p) +test_isPSXSPC_LC_utf8(U8 * p, int type) + PREINIT: + const U8 * e; CODE: - RETVAL = isPSXSPC_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPSXSPC_LC_utf8_safe(p, e); + } + else { + RETVAL = isPSXSPC_LC_utf8(p); + } OUTPUT: RETVAL @@ -5258,6 +6086,273 @@ test_isUTF8_POSSIBLY_PROBLEMATIC(char ch) OUTPUT: RETVAL +STRLEN +test_isUTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isUTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +STRLEN +test_isUTF8_CHAR_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = isUTF8_CHAR_flags((U8 *) s, (U8 *) s + len, flags); + OUTPUT: + RETVAL + +STRLEN +test_isSTRICT_UTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isSTRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +STRLEN +test_isC9_STRICT_UTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isC9_STRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +IV +test_is_utf8_valid_partial_char_flags(char *s, STRLEN len, U32 flags) + CODE: + /* RETVAL should be bool (here and in tests below), but making it IV + * allows us to test it returning 0 or 1 */ + RETVAL = is_utf8_valid_partial_char_flags((U8 *) s, (U8 *) s + len, flags); + OUTPUT: + RETVAL + +IV +test_is_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +#define WORDSIZE sizeof(PERL_UINTMAX_T) + +AV * +test_is_utf8_invariant_string_loc(U8 *s, STRLEN offset, STRLEN len) + PREINIT: + AV *av; + const U8 * ep = NULL; + PERL_UINTMAX_T* copy; + CODE: + /* 'offset' is number of bytes past a word boundary the testing of 's' + * is to start at. Allocate space that does start at the word + * boundary, and copy 's' to the correct offset past it. Then call the + * tested function with that position */ + Newx(copy, 1 + ((len + WORDSIZE - 1) / WORDSIZE), PERL_UINTMAX_T); + Copy(s, (U8 *) copy + offset, len, U8); + av = newAV(); + av_push(av, newSViv(is_utf8_invariant_string_loc((U8 *) copy + offset, len, &ep))); + av_push(av, newSViv(ep - ((U8 *) copy + offset))); + RETVAL = av; + Safefree(copy); + OUTPUT: + RETVAL + +STRLEN +test_variant_under_utf8_count(U8 *s, STRLEN offset, STRLEN len) + PREINIT: + PERL_UINTMAX_T * copy; + CODE: + Newx(copy, 1 + ((len + WORDSIZE - 1) / WORDSIZE), PERL_UINTMAX_T); + Copy(s, (U8 *) copy + offset, len, U8); + RETVAL = variant_under_utf8_count((U8 *) copy + offset, (U8 *) copy + offset + len); + Safefree(copy); + OUTPUT: + RETVAL + +STRLEN +test_utf8_length(U8 *s, STRLEN offset, STRLEN len) +CODE: + RETVAL = utf8_length(s + offset, s + len); +OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_utf8_string_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = is_utf8_string_flags((U8 *) s, len, flags); + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loc_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loc_flags((U8 *) s, len, &ep, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loclen_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loclen_flags((U8 *) s, len, &ep, &ret_len, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_strict_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_strict_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +AV * +test_is_strict_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_strict_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_strict_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_c9strict_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_c9strict_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +AV * +test_is_c9strict_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_c9strict_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_c9strict_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_c9strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_utf8_fixed_width_buf_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = is_utf8_fixed_width_buf_flags((U8 *) s, len, flags); + OUTPUT: + RETVAL + +AV * +test_is_utf8_fixed_width_buf_loc_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_fixed_width_buf_loc_flags((U8 *) s, len, &ep, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_fixed_width_buf_loclen_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_fixed_width_buf_loclen_flags((U8 *) s, len, &ep, &ret_len, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_utf8_hop_safe(SV *s_sv, STRLEN s_off, IV off) + PREINIT: + STRLEN len; + U8 *p; + U8 *r; + CODE: + p = (U8 *)SvPV(s_sv, len); + r = utf8_hop_safe(p + s_off, off, p, p + len); + RETVAL = r - p; + OUTPUT: + RETVAL + UV test_toLOWER(UV ord) CODE: @@ -5300,17 +6395,51 @@ test_toLOWER_uni(UV ord) RETVAL AV * -test_toLOWER_utf8(SV * p) +test_toLOWER_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toLOWER_uvchr(ord, s, &len))); + + utf8 = newSVpvn((char *) s, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_toLOWER_utf8(SV * p, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const U8 * e; + UV resultant_cp = UV_MAX; /* Initialized because of dumb compilers */ CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toLOWER_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toLOWER_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toLOWER_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_lower(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -5356,17 +6485,51 @@ test_toFOLD_uni(UV ord) RETVAL AV * -test_toFOLD_utf8(SV * p) +test_toFOLD_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toFOLD_uvchr(ord, s, &len))); + + utf8 = newSVpvn((char *) s, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_toFOLD_utf8(SV * p, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const U8 * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toFOLD_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toFOLD_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toFOLD_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_fold(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -5412,17 +6575,51 @@ test_toUPPER_uni(UV ord) RETVAL AV * -test_toUPPER_utf8(SV * p) +test_toUPPER_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toUPPER_uvchr(ord, s, &len))); + + utf8 = newSVpvn((char *) s, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_toUPPER_utf8(SV * p, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const U8 * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toUPPER_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toUPPER_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toUPPER_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_upper(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -5461,17 +6658,51 @@ test_toTITLE_uni(UV ord) RETVAL AV * -test_toTITLE_utf8(SV * p) +test_toTITLE_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toTITLE_uvchr(ord, s, &len))); + + utf8 = newSVpvn((char *) s, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_toTITLE_utf8(SV * p, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const U8 * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toTITLE_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toTITLE_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toTITLE_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_title(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -5498,6 +6729,13 @@ test_Gconvert(SV * number, SV * num_digits) OUTPUT: RETVAL +SV * +test_Perl_langinfo(SV * item) + CODE: + RETVAL = newSVpv(Perl_langinfo(SvIV(item)), 0); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs void @@ -5541,12 +6779,12 @@ Comctl32Version() if(!dll) croak("Comctl32Version: comctl32.dll not in process???"); hrsc = FindResource(dll, MAKEINTRESOURCE(VS_VERSION_INFO), - MAKEINTRESOURCE(VS_FILE_INFO)); + MAKEINTRESOURCE((Size_t)VS_FILE_INFO)); if(!hrsc) croak("Comctl32Version: comctl32.dll no version???"); ver = LoadResource(dll, hrsc); len = SizeofResource(dll, hrsc); - vercopy = _alloca(len); + vercopy = (void *)sv_grow(sv_newmortal(),len); memcpy(vercopy, ver, len); if (VerQueryValue(vercopy, "\\", (void**)&info, &len)) { int dwValueMS1 = (info->dwFileVersionMS>>16); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL b/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL index 5b4d100659c..d79ba1150e0 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL +++ b/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL @@ -24,13 +24,15 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL + GV_NOADD_NOINIT IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING + PERL_LOADMOD_DENY PERL_LOADMOD_NOIMPORT PERL_LOADMOD_IMPORT_OPS ), {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}); -open my $fh, '../../overload.h' or die "Can't open ../../overload.h: $!"; +open my $fh, '<', '../../overload.h' or die "Can't open ../../overload.h: $!"; while (<$fh>) { push @names, {name => $1, macro => 1} if /^\s+([A-Za-z_0-9]+_amg),/; } @@ -58,7 +60,8 @@ sub MY::postamble DTRACE_D = ../../perldtrace.d dtrace\$(OBJ_EXT): \$(DTRACE_D) core\$(OBJ_EXT) - $Config{dtrace} -G -s \$(DTRACE_D) -o dtrace\$(OBJ_EXT) core\$(OBJ_EXT) + $Config{dtrace} -G -s \$(DTRACE_D) -o dtrace\$(OBJ_EXT) core\$(OBJ_EXT) || \\ + ( \$(ECHO) >dtrace.c && \$(CCCMD) \$(CCCDLFLAGS) dtrace.c && rm -f dtrace.c ) POSTAMBLE return $post; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc b/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc index 412074a28f2..074fe60d310 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc +++ b/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc @@ -19,7 +19,7 @@ CAT2(sv_setsv_cow_hashkey_, SUFFIX) () { if(!SvIsCOW(source)) { SvREFCNT_dec(source); Perl_croak(aTHX_ "Creating a shared hash key scalar failed when " - STRINGIFY(SUFFIX) " got flags %"UVxf, (UV)SvFLAGS(source)); + STRINGIFY(SUFFIX) " got flags %" UVxf, (UV)SvFLAGS(source)); } sv_setsv(destination, source); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs b/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs index 0ce9e080fff..fac81ba3e0d 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs +++ b/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs @@ -40,7 +40,7 @@ grok_atoUV(number, endsv) const char *pv = SvPV(number, len); UV value = 0xdeadbeef; bool result; - const char* endptr; + const char* endptr = NULL; PPCODE: EXTEND(SP,2); if (endsv == &PL_sv_undef) { diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/call.t b/gnu/usr.bin/perl/ext/XS-APItest/t/call.t index 15b09653edb..8192b9bd36a 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/call.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/call.t @@ -11,7 +11,7 @@ use strict; BEGIN { require '../../t/test.pl'; - plan(455); + plan(527); use_ok('XS::APItest') }; @@ -33,7 +33,7 @@ sub i { $call_sv_count++; } call_sv_C(); -is($call_sv_count, 6, "call_sv_C passes"); +is($call_sv_count, 7, "call_sv_C passes"); sub d { die "its_dead_jim\n"; @@ -80,6 +80,9 @@ for my $test ( ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected), "$description call_pv('f')"); + ok(eq_array( [ call_argv('f', $flags, @$args) ], $expected), + "$description call_argv('f')") or warn "@{[call_argv('f', $flags, @$args)]}"; + ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], $expected), "$description eval_sv('f(args)')"); @@ -113,6 +116,14 @@ for my $test ( $@ = "before\n"; $warn = ""; + ok(eq_array( [ call_argv('d', $flags|G_EVAL|$keep, @$args) ], + $returnval), + "$desc G_EVAL call_argv('d')"); + is($@, $exp_err, "$desc G_EVAL call_argv('d') - \$@"); + is($warn, $exp_warn, "$desc G_EVAL call_argv('d') - warning"); + + $@ = "before\n"; + $warn = ""; ok(eq_array( [ eval_sv('d()', $flags|$keep) ], $returnval), "$desc eval_sv('d()')"); @@ -134,6 +145,9 @@ for my $test ( ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ], $expected), "$description G_NOARGS call_pv('f')"); + ok(eq_array( [ sub { call_argv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_argv('f')"); + ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], $expected), "$description G_NOARGS eval_sv('f(@_)')"); @@ -146,6 +160,9 @@ for my $test ( ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ], [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }"); + ok(eq_array( [ eval { call_argv('d', $flags, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_argv('d') }"); + ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], [ @$returnval, "its_dead_jim\n", '' ]), diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t b/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t index bdff1a8fe62..7670e9b3afa 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t @@ -321,11 +321,10 @@ sub general_tests { $tests->{pad_size}{invariant}{msg}; for my $var (@{$tests->{vars}}) { - no warnings 'experimental::smartmatch'; if ($var->{type} eq 'ok') { - ok $var->{name} ~~ $names_av, $var->{msg}; + ok +(grep { $_ eq $var->{name} } @$names_av), $var->{msg}; } else { - ok !($var->{name} ~~ $names_av), $var->{msg}; + ok !(grep { $_ eq $var->{name} } @$names_av), $var->{msg}; } } diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t b/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t index c3169ce7ccb..b6ad905b60a 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t @@ -4,7 +4,6 @@ use strict; use Test::More; use Config; use XS::APItest; -use feature 'switch'; no warnings 'experimental::smartmatch'; use constant TRUTH => '0 but true'; @@ -31,21 +30,15 @@ foreach my $leader ('', ' ', ' ') { { my (@UV, @NV); - given ($Config{ivsize}) { - when (4) { - @UV = qw(429496729 4294967290 4294967294 4294967295); - @NV = qw(4294967296 4294967297 4294967300 4294967304); - } - when (8) { - @UV = qw(1844674407370955161 18446744073709551610 - 18446744073709551614 18446744073709551615); - @NV = qw(18446744073709551616 18446744073709551617 - 18446744073709551620 18446744073709551624); - } - default { - die "Unknown IV size $_"; - } - } + if ($Config{ivsize} == 4) { + @UV = qw(429496729 4294967290 4294967294 4294967295); + @NV = qw(4294967296 4294967297 4294967300 4294967304); + } elsif ($Config{ivsize} == 8) { + @UV = qw(1844674407370955161 18446744073709551610 + 18446744073709551614 18446744073709551615); + @NV = qw(18446744073709551616 18446744073709551617 + 18446744073709551620 18446744073709551624); + } else { die "Unknown IV size $Config{ivsize}" } foreach (@UV) { my $string = $leader . $_ . $trailer; my ($flags, $value) = grok_number($string); @@ -103,6 +96,14 @@ my @groks = [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], ); +my $non_ieee_fp = ($Config{doublekind} == 9 || + $Config{doublekind} == 10 || + $Config{doublekind} == 11); + +if ($non_ieee_fp) { + @groks = grep { $_->[0] !~ /^(?:inf|nan)/i } @groks; +} + for my $grok (@groks) { my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]); is($out_uv, $grok->[2], "'$grok->[0]' flags $grok->[1] - check number"); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t deleted file mode 100644 index 359769a1993..00000000000 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t +++ /dev/null @@ -1,445 +0,0 @@ -#!perl -w - -BEGIN { - require 'loc_tools.pl'; # Contains locales_enabled() and - # find_utf8_ctype_locale() -} - -use strict; -use Test::More; -use Config; - -use XS::APItest; - -use Unicode::UCD qw(prop_invlist prop_invmap); - -sub truth($) { # Converts values so is() works - return (shift) ? 1 : 0; -} - -my $locale; -my $utf8_locale; -if(locales_enabled('LC_ALL')) { - require POSIX; - $locale = POSIX::setlocale( &POSIX::LC_ALL, "C"); - if (defined $locale && $locale eq 'C') { - use locale; # make \w work right in non-ASCII lands - - # Some locale implementations don't have the 128-255 characters all - # mean nothing. Skip the locale tests in that situation - for my $i (128 .. 255) { - if (chr(utf8::unicode_to_native($i)) =~ /[[:print:]]/) { - undef $locale; - last; - } - } - - $utf8_locale = find_utf8_ctype_locale(); - } -} - -my %properties = ( - # name => Lookup-property name - alnum => 'Word', - wordchar => 'Word', - alphanumeric => 'Alnum', - alpha => 'XPosixAlpha', - ascii => 'ASCII', - blank => 'Blank', - cntrl => 'Control', - digit => 'Digit', - graph => 'Graph', - idfirst => '_Perl_IDStart', - idcont => '_Perl_IDCont', - lower => 'XPosixLower', - print => 'Print', - psxspc => 'XPosixSpace', - punct => 'XPosixPunct', - quotemeta => '_Perl_Quotemeta', - space => 'XPerlSpace', - vertws => 'VertSpace', - upper => 'XPosixUpper', - xdigit => 'XDigit', - ); - -my @warnings; -local $SIG{__WARN__} = sub { push @warnings, @_ }; - -use charnames (); -foreach my $name (sort keys %properties) { - my $property = $properties{$name}; - my @invlist = prop_invlist($property, '_perl_core_internal_ok'); - if (! @invlist) { - - # An empty return could mean an unknown property, or merely that it is - # empty. Call in scalar context to differentiate - if (! prop_invlist($property, '_perl_core_internal_ok')) { - fail("No inversion list found for $property"); - next; - } - } - - # Include all the Latin1 code points, plus 0x100. - my @code_points = (0 .. 256); - - # Then include the next few boundaries above those from this property - my $above_latins = 0; - foreach my $range_start (@invlist) { - next if $range_start < 257; - push @code_points, $range_start - 1, $range_start; - $above_latins++; - last if $above_latins > 5; - } - - # This makes sure we are using the Perl definition of idfirst and idcont, - # and not the Unicode. There are a few differences. - push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/; - if ($name eq "idcont") { # And some that are continuation but not start - push @code_points, ord("\N{GREEK ANO TELEIA}"), - ord("\N{COMBINING GRAVE ACCENT}"); - } - - # And finally one non-Unicode code point. - push @code_points, 0x110000; # Above Unicode, no prop should match - no warnings 'non_unicode'; - - for my $j (@code_points) { - my $i = utf8::native_to_unicode($j); - my $function = uc($name); - - my $matches = Unicode::UCD::search_invlist(\@invlist, $i); - if (! defined $matches) { - $matches = 0; - } - else { - $matches = truth(! ($matches % 2)); - } - - my $ret; - my $char_name = charnames::viacode($i) // "No name"; - my $display_name = sprintf "\\x{%02X, %s}", $i, $char_name; - - if ($name eq 'quotemeta') { # There is only one macro for this, and is - # defined only for Latin1 range - $ret = truth eval "test_is${function}($i)"; - if ($@) { - fail $@; - } - else { - my $truth = truth($matches && $i < 256); - is ($ret, $truth, "is${function}( $display_name ) == $truth"); - } - next; - } - - # vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not - # defined as they were added later, after WORDCHAR was created to be a - # clearer synonym for ALNUM - if ($name ne 'vertws') { - if ($name ne 'alnum') { - $ret = truth eval "test_is${function}_A($i)"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches && utf8::native_to_unicode($i) < 128); - is ($ret, $truth, "is${function}_A( $display_name ) == $truth"); - } - $ret = truth eval "test_is${function}_L1($i)"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches && $i < 256); - is ($ret, $truth, "is${function}_L1( $display_name ) == $truth"); - } - } - - if (defined $locale) { - use locale; - POSIX::setlocale( &POSIX::LC_ALL, "C"); - $ret = truth eval "test_is${function}_LC($i)"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches && utf8::native_to_unicode($i) < 128); - is ($ret, $truth, "is${function}_LC( $display_name ) == $truth (C locale)"); - } - } - - if (defined $utf8_locale) { - use locale; - - POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale); - $ret = truth eval "test_is${function}_LC($i)"; - if ($@) { - fail($@); - } - else { - - # UTF-8 locale works on full range 0-255 - my $truth = truth($matches && $i < 256); - is ($ret, $truth, "is${function}_LC( $display_name ) == $truth ($utf8_locale)"); - } - } - } - - $ret = truth eval "test_is${function}_uni($i)"; - if ($@) { - fail($@); - } - else { - is ($ret, $matches, "is${function}_uni( $display_name ) == $matches"); - } - - if (defined $locale && $name ne 'vertws') { - use locale; - POSIX::setlocale( &POSIX::LC_ALL, "C"); - $ret = truth eval "test_is${function}_LC_uvchr('$i')"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches && (utf8::native_to_unicode($i) < 128 || $i > 255)); - is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth (C locale)"); - } - } - - if (defined $utf8_locale && $name ne 'vertws') { - use locale; - - POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale); - $ret = truth eval "test_is${function}_LC_uvchr('$i')"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches); - is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth ($utf8_locale)"); - } - } - - my $char = chr($i); - utf8::upgrade($char); - $char = quotemeta $char if $char eq '\\' || $char eq "'"; - $ret = truth eval "test_is${function}_utf8('$char')"; - if ($@) { - fail($@); - } - else { - is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches"); - } - - if ($name ne 'vertws' && defined $locale) { - use locale; - POSIX::setlocale( &POSIX::LC_ALL, "C"); - $ret = truth eval "test_is${function}_LC_utf8('$char')"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches && (utf8::native_to_unicode($i) < 128 || $i > 255)); - is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth (C locale)"); - } - } - - if ($name ne 'vertws' && defined $utf8_locale) { - use locale; - - POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale); - $ret = truth eval "test_is${function}_LC_utf8('$char')"; - if ($@) { - fail($@); - } - else { - my $truth = truth($matches); - is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth ($utf8_locale)"); - } - } - } -} - -my %to_properties = ( - FOLD => 'Case_Folding', - LOWER => 'Lowercase_Mapping', - TITLE => 'Titlecase_Mapping', - UPPER => 'Uppercase_Mapping', - ); - - -foreach my $name (sort keys %to_properties) { - my $property = $to_properties{$name}; - my ($list_ref, $map_ref, $format, $missing) - = prop_invmap($property, ); - if (! $list_ref || ! $map_ref) { - fail("No inversion map found for $property"); - next; - } - if ($format !~ / ^ a l? $ /x) { - fail("Unexpected inversion map format ('$format') found for $property"); - next; - } - - # Include all the Latin1 code points, plus 0x100. - my @code_points = (0 .. 256); - - # Then include the next few multi-char folds above those from this - # property, and include the next few single folds as well - my $above_latins = 0; - my $multi_char = 0; - for my $i (0 .. @{$list_ref} - 1) { - my $range_start = $list_ref->[$i]; - next if $range_start < 257; - if (ref $map_ref->[$i] && $multi_char < 5) { - push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1; - push @code_points, $range_start; - $multi_char++; - } - elsif ($above_latins < 5) { - push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1; - push @code_points, $range_start; - $above_latins++; - } - last if $above_latins >= 5 && $multi_char >= 5; - } - - # And finally one non-Unicode code point. - push @code_points, 0x110000; # Above Unicode, no prop should match - no warnings 'non_unicode'; - - # $j is native; $i unicode. - for my $j (@code_points) { - my $i = utf8::native_to_unicode($j); - my $function = $name; - - my $index = Unicode::UCD::search_invlist(\@{$list_ref}, $j); - - my $ret; - my $char_name = charnames::viacode($j) // "No name"; - my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name; - - # Test the base function - $ret = eval "test_to${function}($j)"; - if ($@) { - fail($@); - } - else { - my $should_be = ($i < 128 && $map_ref->[$index] != $missing) - ? $map_ref->[$index] + $j - $list_ref->[$index] - : $j; - is ($ret, $should_be, sprintf("to${function}( $display_name ) == 0x%02X", $should_be)); - } - - # Test _L1 - if ($name eq 'LOWER') { - $ret = eval "test_to${function}_L1($j)"; - if ($@) { - fail($@); - } - else { - my $should_be = ($i < 256 && $map_ref->[$index] != $missing) - ? $map_ref->[$index] + $j - $list_ref->[$index] - : $j; - is ($ret, $should_be, sprintf("to${function}_L1( $display_name ) == 0x%02X", $should_be)); - } - } - - if ($name ne 'TITLE') { # Test _LC; titlecase is not defined in locales. - if (defined $locale) { - use locale; - POSIX::setlocale( &POSIX::LC_ALL, "C"); - $ret = eval "test_to${function}_LC($j)"; - if ($@) { - fail($@); - } - else { - my $should_be = ($i < 128 && $map_ref->[$index] != $missing) - ? $map_ref->[$index] + $j - $list_ref->[$index] - : $j; - is ($ret, $should_be, sprintf("to${function}_LC( $display_name ) == 0x%02X (C locale)", $should_be)); - } - } - - if (defined $utf8_locale) { - use locale; - - SKIP: { - skip "to${property}_LC does not work for LATIN SMALL LETTER SHARP S", 1 - if $j == 0xDF && ($name eq 'FOLD' || $name eq 'UPPER'); - - POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale); - $ret = eval "test_to${function}_LC($j)"; - if ($@) { - fail($@); - } - else { - my $should_be = ($i < 256 - && ! ref $map_ref->[$index] - && $map_ref->[$index] != $missing - ) - ? $map_ref->[$index] + $j - $list_ref->[$index] - : $j; - is ($ret, $should_be, sprintf("to${function}_LC( $display_name ) == 0x%02X ($utf8_locale)", $should_be)); - } - } - } - } - - # The _uni and _utf8 functions return both the ordinal of the first - # code point of the result, and the result in utf8. The .xs tests - # return these in an array, in [0] and [1] respectively, with [2] the - # length of the utf8 in bytes. - my $utf8_should_be = ""; - my $first_ord_should_be; - if (ref $map_ref->[$index]) { # A multi-char result - for my $j (0 .. @{$map_ref->[$index]} - 1) { - $utf8_should_be .= chr $map_ref->[$index][$j]; - } - - $first_ord_should_be = $map_ref->[$index][0]; - } - else { # A single-char result - $first_ord_should_be = ($map_ref->[$index] != $missing) - ? $map_ref->[$index] + $j - $list_ref->[$index] - : $j; - $utf8_should_be = chr $first_ord_should_be; - } - utf8::upgrade($utf8_should_be); - - # Test _uni - my $s; - my $len; - $ret = eval "test_to${function}_uni($j)"; - if ($@) { - fail($@); - } - else { - is ($ret->[0], $first_ord_should_be, sprintf("to${function}_uni( $display_name ) == 0x%02X", $first_ord_should_be)); - is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_uni( $display_name )")); - use bytes; - is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )")); - } - - # Test _utf8 - my $char = chr($j); - utf8::upgrade($char); - $char = quotemeta $char if $char eq '\\' || $char eq "'"; - $ret = eval "test_to${function}_utf8('$char')"; - if ($@) { - fail($@); - } - else { - is ($ret->[0], $first_ord_should_be, sprintf("to${function}_utf8( $display_name ) == 0x%02X", $first_ord_should_be)); - is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_utf8( $display_name )")); - use bytes; - is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )")); - } - - } -} - -# This is primarily to make sure that no non-Unicode warnings get generated -is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings); - -done_testing; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t b/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t index 8f1c2c409d5..e47cd887cbd 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t @@ -33,4 +33,33 @@ use Scalar::Util 'weaken'; eval { sv_magic(\!0, $foo) }; is $@, "", 'PERL_MAGIC_ext is permitted on read-only things'; +# assigning to an array/hash with only set magic should call that magic + +{ + my (@a, %h, $i); + + sv_magic_myset(\@a, $i); + sv_magic_myset(\%h, $i); + + $i = 0; + @a = (1,2); + is($i, 2, "array with set magic"); + + $i = 0; + @a = (); + is($i, 0, "array () with set magic"); + + { + local $TODO = "HVs don't call set magic - not sure if should"; + + $i = 0; + %h = qw(a 1 b 2); + is($i, 4, "hash with set magic"); + } + + $i = 0; + %h = qw(); + is($i, 0, "hash () with set magic"); +} + done_testing; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t b/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t index 8f43ee2532a..968fdc46276 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t @@ -34,7 +34,7 @@ print_flush(); # Now redirect STDOUT and read from the file ok open(STDOUT, ">&", $oldout), "restore STDOUT"; -ok open(my $foo, "<foo.out"), "open foo.out"; +ok open(my $foo, '<', 'foo.out'), "open foo.out"; #print "# Test output by reading from file\n"; # now test the output my @output = map { chomp; $_ } <$foo>; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t b/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t index 25eb2349fb6..2e056699c34 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t @@ -18,11 +18,13 @@ $| = 1; is (DPeek ($^), 'PVMG()', '$^'); is (DPeek ($=), 'PVMG()', '$='); is (DPeek ($-), 'PVMG()', '$-'); + + # This tests expects that $! will have been used as a string recently. + my $foo = "$!"; like (DPeek ($!), qr'^PVMG\("', '$!'); -if ($^O eq 'VMS') { - # VMS defines COMPLEX_STATUS and upgrades $? to PVLV - is (DPeek ($?), 'PVLV()', '$?'); -} else { + +{ + local $?; # Reset anything Test::* has done to it. is (DPeek ($?), 'PVMG()', '$?'); } is (DPeek ($|), 'PVMG(1)', '$|'); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t index 9b5ed9b58a3..1edc02d6434 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t @@ -2,120 +2,175 @@ use strict; use Test::More; -$|=1; -no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit - # machines, and that is tested elsewhere +# This file tests various functions and macros in the API related to UTF-8. + +BEGIN { + use_ok('XS::APItest'); + require 'charset_tools.pl'; + require './t/utf8_setup.pl'; +}; + +$|=1; use XS::APItest; +use Config; +my $word_length = defined $Config{quadkind} ? 8 : 4; + +# Below we test some byte-oriented functions that look for UTF-8 variant bytes +# and we know can work on full words at a time. Hence this is not black box +# testing. We know how long a word is. Suppose it is 4. We set things up so +# that we have a string containing 3 bytes followed by 4, followed by 3, and +# we tell our APItest functions to position the string so it starts at 1 byte +# past a word boundary. That way the first 3 bytes are the final ones of a +# word, and the final 3 are the initial ones of a non-complete word. This +# assumes that the initial and final non-full word bytes are treated +# individually, so we don't have to test the various combinations of partially +# filled words. + +my $offset = 1; # Start 1 byte past word boundary. + +# We choose an invariant and a variant that are at the boundaries between +# those two types on ASCII platforms. And, just in case the EBCDIC ever +# changes to do per-word, we choose arbitrarily an invariant that has most of +# its bits set natively, and a variant that has most unset. First create +# versions for display in the test names. +my $display_invariant = isASCII ? "7F" : sprintf "%02X", utf8::unicode_to_native(0x9F); +my $display_variant = isASCII ? "80" : sprintf "%02X", utf8::unicode_to_native(0xA0); +my $invariant = chr hex $display_invariant; +my $variant = chr hex $display_variant; + +# We create a string with the correct number of bytes. The -1 is to make the +# final portion not quite fill a full word and $offset to do the same for the +# initial portion.) +my $string_length = 3 * $word_length - 1 - $offset; +my $all_invariants = $invariant x $string_length; +my $display_all_invariants = $display_invariant x $string_length; + +my $ret_ref = test_is_utf8_invariant_string_loc($all_invariants, $offset, + length $all_invariants); +pass("The tests below are for is_utf8_invariant_string_loc() with string" + . " starting $offset bytes after a word boundary"); +is($ret_ref->[0], 1, "$display_all_invariants contains no variants"); + +# Just create a string with a single variant, in all the possible positions. +for my $pos (0.. length($all_invariants) - 1) { + my $test_string = $all_invariants; + my $test_display = $display_all_invariants; + + substr($test_string, $pos, 1) = $variant; + substr($test_display, $pos * 2, 2) = $display_variant; + my $ret_ref = test_is_utf8_invariant_string_loc($test_string, $offset, + length $test_string); + if (is($ret_ref->[0], 0, "$test_display has a variant")) { + is($ret_ref->[1], $pos, " at position $pos"); + } +} -my $pound_sign = chr utf8::unicode_to_native(163); +# Now work on variant_under_utf8_count(). +pass("The tests below are for variant_under_utf8_count() with string" + . " starting $offset bytes after a word boundary"); +is(test_variant_under_utf8_count($all_invariants, $offset, + length $all_invariants), + 0, + "$display_all_invariants contains 0 variants"); + +# First, put a variant in each possible position in the flanking partial words +for my $pos (0 .. $word_length - $offset, + 2 * $word_length .. length($all_invariants) - 1) +{ + my $test_string = $all_invariants; + my $test_display = $display_all_invariants; + + substr($test_string, $pos, 1) = $variant; + substr($test_display, $pos * 2, 2) = $display_variant; + is(test_variant_under_utf8_count($test_string, $offset, length $test_string), + 1, + "$test_display contains 1 variant"); +} -sub isASCII { ord "A" == 65 } +# Then try all possible combinations of variant/invariant in the full word in +# the middle (We've already tested the case with 0 variants, so start at 1.) +for my $bit_pattern (1 .. (1 << $word_length) - 1) { + my $bits = $bit_pattern; + my $display_word = ""; + my $test_word = ""; + my $count = 0; + + # Every 1 bit gets the variant for this particular $bit_pattern. + for my $bit (0 .. 7) { + if ($bits & 1) { + $count++; + $test_word .= $variant; + $display_word .= $display_variant; + } + else { + $test_word .= $invariant; + $display_word .= $display_invariant; + } + $bits >>= 1; + } -sub display_bytes { - my $string = shift; - return '"' - . join("", map { sprintf("\\x%02x", ord $_) } split "", $string) - . '"'; + my $test_string = $variant x ($word_length - 1) + . $test_word + . $variant x ($word_length - 1); + my $display_string = $display_variant x ($word_length - 1) + . $display_word + . $display_variant x ($word_length - 1); + my $expected_count = $count + 2 * $word_length - 2; + is(test_variant_under_utf8_count($test_string, $offset, + length $test_string), $expected_count, + "$display_string contains $expected_count variants"); } + +my $pound_sign = chr utf8::unicode_to_native(163); + # This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl # because that uses the same functions we are testing here. So UTF-EBCDIC -# strings are hard-coded as I8 strings in this file instead, and we use array -# lookup to translate into the appropriate code page. - -my @i8_to_native = ( # Only code page 1047 so far. -# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F -0x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F, -0x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F, -0x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61, -0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F, -0x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6, -0xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D, -0x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96, -0x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07, -0x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B, -0x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF, -0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56, -0x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73, -0x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C, -0x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6, -0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB, -0xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE, -); - -*I8_to_native = (isASCII) - ? sub { return shift } - : sub { return join "", map { chr $i8_to_native[ord $_] } - split "", shift }; - -my $is64bit = length sprintf("%x", ~0) > 8; - - -# Test utf8n_to_uvchr(). These provide essentially complete code coverage. -# Copied from utf8.h -my $UTF8_ALLOW_EMPTY = 0x0001; -my $UTF8_ALLOW_CONTINUATION = 0x0002; -my $UTF8_ALLOW_NON_CONTINUATION = 0x0004; -my $UTF8_ALLOW_SHORT = 0x0008; -my $UTF8_ALLOW_LONG = 0x0010; -my $UTF8_DISALLOW_SURROGATE = 0x0020; -my $UTF8_WARN_SURROGATE = 0x0040; -my $UTF8_DISALLOW_NONCHAR = 0x0080; -my $UTF8_WARN_NONCHAR = 0x0100; -my $UTF8_DISALLOW_SUPER = 0x0200; -my $UTF8_WARN_SUPER = 0x0400; -my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800; -my $UTF8_WARN_ABOVE_31_BIT = 0x1000; -my $UTF8_CHECK_ONLY = 0x2000; - -# Test uvchr_to_utf8(). -my $UNICODE_WARN_SURROGATE = 0x0001; -my $UNICODE_WARN_NONCHAR = 0x0002; -my $UNICODE_WARN_SUPER = 0x0004; -my $UNICODE_WARN_ABOVE_31_BIT = 0x0008; -my $UNICODE_DISALLOW_SURROGATE = 0x0010; -my $UNICODE_DISALLOW_NONCHAR = 0x0020; -my $UNICODE_DISALLOW_SUPER = 0x0040; -my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080; +# strings are hard-coded as I8 strings in this file instead, and we use the +# translation functions to/from I8 from that file instead. my $look_for_everything_utf8n_to - = $UTF8_DISALLOW_SURROGATE - | $UTF8_WARN_SURROGATE - | $UTF8_DISALLOW_NONCHAR - | $UTF8_WARN_NONCHAR - | $UTF8_DISALLOW_SUPER - | $UTF8_WARN_SUPER - | $UTF8_DISALLOW_ABOVE_31_BIT - | $UTF8_WARN_ABOVE_31_BIT; + = $::UTF8_DISALLOW_SURROGATE + | $::UTF8_WARN_SURROGATE + | $::UTF8_DISALLOW_NONCHAR + | $::UTF8_WARN_NONCHAR + | $::UTF8_DISALLOW_SUPER + | $::UTF8_WARN_SUPER + | $::UTF8_DISALLOW_PERL_EXTENDED + | $::UTF8_WARN_PERL_EXTENDED; my $look_for_everything_uvchr_to - = $UNICODE_DISALLOW_SURROGATE - | $UNICODE_WARN_SURROGATE - | $UNICODE_DISALLOW_NONCHAR - | $UNICODE_WARN_NONCHAR - | $UNICODE_DISALLOW_SUPER - | $UNICODE_WARN_SUPER - | $UNICODE_DISALLOW_ABOVE_31_BIT - | $UNICODE_WARN_ABOVE_31_BIT; + = $::UNICODE_DISALLOW_SURROGATE + | $::UNICODE_WARN_SURROGATE + | $::UNICODE_DISALLOW_NONCHAR + | $::UNICODE_WARN_NONCHAR + | $::UNICODE_DISALLOW_SUPER + | $::UNICODE_WARN_SUPER + | $::UNICODE_DISALLOW_PERL_EXTENDED + | $::UNICODE_WARN_PERL_EXTENDED; + +my $highest_non_extended_cp = 2 ** ((isASCII) ? 31 : 30) - 1; foreach ([0, '', '', 'empty'], [0, 'N', 'N', '1 char'], [1, 'NN', 'N', '1 char substring'], [-2, 'Perl', 'Rules', 'different'], [0, $pound_sign, $pound_sign, 'pound sign'], - [1, $pound_sign . 10, $pound_sign . 1, '10 pounds is more than 1 pound'], - [1, $pound_sign . $pound_sign, $pound_sign, '2 pound signs are more than 1'], + [1, $pound_sign . 10, $pound_sign . 1, + '10 pounds is more than 1 pound'], + [1, $pound_sign . $pound_sign, $pound_sign, + '2 pound signs are more than 1'], [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'], [-1, '!', "!\x{1F42A}", 'Initial substrings match'], ) { my ($expect, $left, $right, $desc) = @$_; my $copy = $right; utf8::encode($copy); - is(bytes_cmp_utf8($left, $copy), $expect, $desc); + is(bytes_cmp_utf8($left, $copy), $expect, "bytes_cmp_utf8: $desc"); next if $right =~ tr/\0-\377//c; utf8::encode($left); - is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed"); + is(bytes_cmp_utf8($right, $left), -$expect, "... and $desc reversed"); } # The keys to this hash are Unicode code points, their values are the native @@ -125,9 +180,9 @@ foreach ([0, '', '', 'empty'], # are adjacent to problematic code points, so we want to make sure they aren't # considered problematic. my %code_points = ( - 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"), - 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"), - 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"), + 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"), + 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"), + 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"), 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"), 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"), 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"), @@ -144,81 +199,353 @@ my %code_points = ( # as of this writing, considers potentially problematic on ASCII 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"), - # Bracket the surrogates - 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"), - 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"), - - # Bracket the 32 contiguous non characters - 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"), - 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"), - - # Mostly bracket non-characters, but some are transitions to longer - # strings - 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"), - 0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"), - 0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"), - 0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"), - 0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"), - 0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"), - 0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"), - 0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"), - 0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"), - 0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"), - 0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"), - 0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"), - 0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"), - 0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"), - 0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"), - 0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"), - 0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"), - 0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"), - 0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"), - 0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"), - 0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"), - 0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"), - 0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"), - 0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"), - 0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"), - 0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"), - 0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"), - 0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"), - 0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"), - 0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"), - 0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"), - 0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"), - 0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"), - 0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"), - 0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"), - 0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"), + # Bracket the surrogates, and include several surrogates + 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"), + 0xD800 => (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"), + 0xDC00 => (isASCII) ? "\xed\xb0\x80" : I8_to_native("\xf1\xb7\xa0\xa0"), + 0xDFFF => (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"), + 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"), + + # Include the 32 contiguous non characters, and adjacent code points + 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"), + 0xFDD0 => (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"), + 0xFDD1 => (isASCII) ? "\xef\xb7\x91" : I8_to_native("\xf1\xbf\xae\xb1"), + 0xFDD2 => (isASCII) ? "\xef\xb7\x92" : I8_to_native("\xf1\xbf\xae\xb2"), + 0xFDD3 => (isASCII) ? "\xef\xb7\x93" : I8_to_native("\xf1\xbf\xae\xb3"), + 0xFDD4 => (isASCII) ? "\xef\xb7\x94" : I8_to_native("\xf1\xbf\xae\xb4"), + 0xFDD5 => (isASCII) ? "\xef\xb7\x95" : I8_to_native("\xf1\xbf\xae\xb5"), + 0xFDD6 => (isASCII) ? "\xef\xb7\x96" : I8_to_native("\xf1\xbf\xae\xb6"), + 0xFDD7 => (isASCII) ? "\xef\xb7\x97" : I8_to_native("\xf1\xbf\xae\xb7"), + 0xFDD8 => (isASCII) ? "\xef\xb7\x98" : I8_to_native("\xf1\xbf\xae\xb8"), + 0xFDD9 => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xae\xb9"), + 0xFDDA => (isASCII) ? "\xef\xb7\x9a" : I8_to_native("\xf1\xbf\xae\xba"), + 0xFDDB => (isASCII) ? "\xef\xb7\x9b" : I8_to_native("\xf1\xbf\xae\xbb"), + 0xFDDC => (isASCII) ? "\xef\xb7\x9c" : I8_to_native("\xf1\xbf\xae\xbc"), + 0xFDDD => (isASCII) ? "\xef\xb7\x9d" : I8_to_native("\xf1\xbf\xae\xbd"), + 0xFDDE => (isASCII) ? "\xef\xb7\x9e" : I8_to_native("\xf1\xbf\xae\xbe"), + 0xFDDF => (isASCII) ? "\xef\xb7\x9f" : I8_to_native("\xf1\xbf\xae\xbf"), + 0xFDE0 => (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"), + 0xFDE1 => (isASCII) ? "\xef\xb7\xa1" : I8_to_native("\xf1\xbf\xaf\xa1"), + 0xFDE2 => (isASCII) ? "\xef\xb7\xa2" : I8_to_native("\xf1\xbf\xaf\xa2"), + 0xFDE3 => (isASCII) ? "\xef\xb7\xa3" : I8_to_native("\xf1\xbf\xaf\xa3"), + 0xFDE4 => (isASCII) ? "\xef\xb7\xa4" : I8_to_native("\xf1\xbf\xaf\xa4"), + 0xFDE5 => (isASCII) ? "\xef\xb7\xa5" : I8_to_native("\xf1\xbf\xaf\xa5"), + 0xFDE6 => (isASCII) ? "\xef\xb7\xa6" : I8_to_native("\xf1\xbf\xaf\xa6"), + 0xFDE7 => (isASCII) ? "\xef\xb7\xa7" : I8_to_native("\xf1\xbf\xaf\xa7"), + 0xFDE8 => (isASCII) ? "\xef\xb7\xa8" : I8_to_native("\xf1\xbf\xaf\xa8"), + 0xFDEa => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xaf\xa9"), + 0xFDEA => (isASCII) ? "\xef\xb7\xaa" : I8_to_native("\xf1\xbf\xaf\xaa"), + 0xFDEB => (isASCII) ? "\xef\xb7\xab" : I8_to_native("\xf1\xbf\xaf\xab"), + 0xFDEC => (isASCII) ? "\xef\xb7\xac" : I8_to_native("\xf1\xbf\xaf\xac"), + 0xFDED => (isASCII) ? "\xef\xb7\xad" : I8_to_native("\xf1\xbf\xaf\xad"), + 0xFDEE => (isASCII) ? "\xef\xb7\xae" : I8_to_native("\xf1\xbf\xaf\xae"), + 0xFDEF => (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"), + 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"), + + # Mostly around non-characters, but some are transitions to longer strings + 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"), + 0x10000 - 1 => (isASCII) + ? "\xef\xbf\xbf" + : I8_to_native("\xf1\xbf\xbf\xbf"), + 0x10000 => (isASCII) + ? "\xf0\x90\x80\x80" + : I8_to_native("\xf2\xa0\xa0\xa0"), + 0x1FFFD => (isASCII) + ? "\xf0\x9f\xbf\xbd" + : I8_to_native("\xf3\xbf\xbf\xbd"), + 0x1FFFE => (isASCII) + ? "\xf0\x9f\xbf\xbe" + : I8_to_native("\xf3\xbf\xbf\xbe"), + 0x1FFFF => (isASCII) + ? "\xf0\x9f\xbf\xbf" + : I8_to_native("\xf3\xbf\xbf\xbf"), + 0x20000 => (isASCII) + ? "\xf0\xa0\x80\x80" + : I8_to_native("\xf4\xa0\xa0\xa0"), + 0x2FFFD => (isASCII) + ? "\xf0\xaf\xbf\xbd" + : I8_to_native("\xf5\xbf\xbf\xbd"), + 0x2FFFE => (isASCII) + ? "\xf0\xaf\xbf\xbe" + : I8_to_native("\xf5\xbf\xbf\xbe"), + 0x2FFFF => (isASCII) + ? "\xf0\xaf\xbf\xbf" + : I8_to_native("\xf5\xbf\xbf\xbf"), + 0x30000 => (isASCII) + ? "\xf0\xb0\x80\x80" + : I8_to_native("\xf6\xa0\xa0\xa0"), + 0x3FFFD => (isASCII) + ? "\xf0\xbf\xbf\xbd" + : I8_to_native("\xf7\xbf\xbf\xbd"), + 0x3FFFE => (isASCII) + ? "\xf0\xbf\xbf\xbe" + : I8_to_native("\xf7\xbf\xbf\xbe"), + 0x40000 - 1 => (isASCII) + ? "\xf0\xbf\xbf\xbf" + : I8_to_native("\xf7\xbf\xbf\xbf"), + 0x40000 => (isASCII) + ? "\xf1\x80\x80\x80" + : I8_to_native("\xf8\xa8\xa0\xa0\xa0"), + 0x4FFFD => (isASCII) + ? "\xf1\x8f\xbf\xbd" + : I8_to_native("\xf8\xa9\xbf\xbf\xbd"), + 0x4FFFE => (isASCII) + ? "\xf1\x8f\xbf\xbe" + : I8_to_native("\xf8\xa9\xbf\xbf\xbe"), + 0x4FFFF => (isASCII) + ? "\xf1\x8f\xbf\xbf" + : I8_to_native("\xf8\xa9\xbf\xbf\xbf"), + 0x50000 => (isASCII) + ? "\xf1\x90\x80\x80" + : I8_to_native("\xf8\xaa\xa0\xa0\xa0"), + 0x5FFFD => (isASCII) + ? "\xf1\x9f\xbf\xbd" + : I8_to_native("\xf8\xab\xbf\xbf\xbd"), + 0x5FFFE => (isASCII) + ? "\xf1\x9f\xbf\xbe" + : I8_to_native("\xf8\xab\xbf\xbf\xbe"), + 0x5FFFF => (isASCII) + ? "\xf1\x9f\xbf\xbf" + : I8_to_native("\xf8\xab\xbf\xbf\xbf"), + 0x60000 => (isASCII) + ? "\xf1\xa0\x80\x80" + : I8_to_native("\xf8\xac\xa0\xa0\xa0"), + 0x6FFFD => (isASCII) + ? "\xf1\xaf\xbf\xbd" + : I8_to_native("\xf8\xad\xbf\xbf\xbd"), + 0x6FFFE => (isASCII) + ? "\xf1\xaf\xbf\xbe" + : I8_to_native("\xf8\xad\xbf\xbf\xbe"), + 0x6FFFF => (isASCII) + ? "\xf1\xaf\xbf\xbf" + : I8_to_native("\xf8\xad\xbf\xbf\xbf"), + 0x70000 => (isASCII) + ? "\xf1\xb0\x80\x80" + : I8_to_native("\xf8\xae\xa0\xa0\xa0"), + 0x7FFFD => (isASCII) + ? "\xf1\xbf\xbf\xbd" + : I8_to_native("\xf8\xaf\xbf\xbf\xbd"), + 0x7FFFE => (isASCII) + ? "\xf1\xbf\xbf\xbe" + : I8_to_native("\xf8\xaf\xbf\xbf\xbe"), + 0x7FFFF => (isASCII) + ? "\xf1\xbf\xbf\xbf" + : I8_to_native("\xf8\xaf\xbf\xbf\xbf"), + 0x80000 => (isASCII) + ? "\xf2\x80\x80\x80" + : I8_to_native("\xf8\xb0\xa0\xa0\xa0"), + 0x8FFFD => (isASCII) + ? "\xf2\x8f\xbf\xbd" + : I8_to_native("\xf8\xb1\xbf\xbf\xbd"), + 0x8FFFE => (isASCII) + ? "\xf2\x8f\xbf\xbe" + : I8_to_native("\xf8\xb1\xbf\xbf\xbe"), + 0x8FFFF => (isASCII) + ? "\xf2\x8f\xbf\xbf" + : I8_to_native("\xf8\xb1\xbf\xbf\xbf"), + 0x90000 => (isASCII) + ? "\xf2\x90\x80\x80" + : I8_to_native("\xf8\xb2\xa0\xa0\xa0"), + 0x9FFFD => (isASCII) + ? "\xf2\x9f\xbf\xbd" + : I8_to_native("\xf8\xb3\xbf\xbf\xbd"), + 0x9FFFE => (isASCII) + ? "\xf2\x9f\xbf\xbe" + : I8_to_native("\xf8\xb3\xbf\xbf\xbe"), + 0x9FFFF => (isASCII) + ? "\xf2\x9f\xbf\xbf" + : I8_to_native("\xf8\xb3\xbf\xbf\xbf"), + 0xA0000 => (isASCII) + ? "\xf2\xa0\x80\x80" + : I8_to_native("\xf8\xb4\xa0\xa0\xa0"), + 0xAFFFD => (isASCII) + ? "\xf2\xaf\xbf\xbd" + : I8_to_native("\xf8\xb5\xbf\xbf\xbd"), + 0xAFFFE => (isASCII) + ? "\xf2\xaf\xbf\xbe" + : I8_to_native("\xf8\xb5\xbf\xbf\xbe"), + 0xAFFFF => (isASCII) + ? "\xf2\xaf\xbf\xbf" + : I8_to_native("\xf8\xb5\xbf\xbf\xbf"), + 0xB0000 => (isASCII) + ? "\xf2\xb0\x80\x80" + : I8_to_native("\xf8\xb6\xa0\xa0\xa0"), + 0xBFFFD => (isASCII) + ? "\xf2\xbf\xbf\xbd" + : I8_to_native("\xf8\xb7\xbf\xbf\xbd"), + 0xBFFFE => (isASCII) + ? "\xf2\xbf\xbf\xbe" + : I8_to_native("\xf8\xb7\xbf\xbf\xbe"), + 0xBFFFF => (isASCII) + ? "\xf2\xbf\xbf\xbf" + : I8_to_native("\xf8\xb7\xbf\xbf\xbf"), + 0xC0000 => (isASCII) + ? "\xf3\x80\x80\x80" + : I8_to_native("\xf8\xb8\xa0\xa0\xa0"), + 0xCFFFD => (isASCII) + ? "\xf3\x8f\xbf\xbd" + : I8_to_native("\xf8\xb9\xbf\xbf\xbd"), + 0xCFFFE => (isASCII) + ? "\xf3\x8f\xbf\xbe" + : I8_to_native("\xf8\xb9\xbf\xbf\xbe"), + 0xCFFFF => (isASCII) + ? "\xf3\x8f\xbf\xbf" + : I8_to_native("\xf8\xb9\xbf\xbf\xbf"), + 0xD0000 => (isASCII) + ? "\xf3\x90\x80\x80" + : I8_to_native("\xf8\xba\xa0\xa0\xa0"), + 0xDFFFD => (isASCII) + ? "\xf3\x9f\xbf\xbd" + : I8_to_native("\xf8\xbb\xbf\xbf\xbd"), + 0xDFFFE => (isASCII) + ? "\xf3\x9f\xbf\xbe" + : I8_to_native("\xf8\xbb\xbf\xbf\xbe"), + 0xDFFFF => (isASCII) + ? "\xf3\x9f\xbf\xbf" + : I8_to_native("\xf8\xbb\xbf\xbf\xbf"), + 0xE0000 => (isASCII) + ? "\xf3\xa0\x80\x80" + : I8_to_native("\xf8\xbc\xa0\xa0\xa0"), + 0xEFFFD => (isASCII) + ? "\xf3\xaf\xbf\xbd" + : I8_to_native("\xf8\xbd\xbf\xbf\xbd"), + 0xEFFFE => (isASCII) + ? "\xf3\xaf\xbf\xbe" + : I8_to_native("\xf8\xbd\xbf\xbf\xbe"), + 0xEFFFF => (isASCII) + ? "\xf3\xaf\xbf\xbf" + : I8_to_native("\xf8\xbd\xbf\xbf\xbf"), + 0xF0000 => (isASCII) + ? "\xf3\xb0\x80\x80" + : I8_to_native("\xf8\xbe\xa0\xa0\xa0"), + 0xFFFFD => (isASCII) + ? "\xf3\xbf\xbf\xbd" + : I8_to_native("\xf8\xbf\xbf\xbf\xbd"), + 0xFFFFE => (isASCII) + ? "\xf3\xbf\xbf\xbe" + : I8_to_native("\xf8\xbf\xbf\xbf\xbe"), + 0xFFFFF => (isASCII) + ? "\xf3\xbf\xbf\xbf" + : I8_to_native("\xf8\xbf\xbf\xbf\xbf"), + 0x100000 => (isASCII) + ? "\xf4\x80\x80\x80" + : I8_to_native("\xf9\xa0\xa0\xa0\xa0"), + 0x10FFFD => (isASCII) + ? "\xf4\x8f\xbf\xbd" + : I8_to_native("\xf9\xa1\xbf\xbf\xbd"), + 0x10FFFE => (isASCII) + ? "\xf4\x8f\xbf\xbe" + : I8_to_native("\xf9\xa1\xbf\xbf\xbe"), + 0x10FFFF => (isASCII) + ? "\xf4\x8f\xbf\xbf" + : I8_to_native("\xf9\xa1\xbf\xbf\xbf"), + 0x110000 => (isASCII) + ? "\xf4\x90\x80\x80" + : I8_to_native("\xf9\xa2\xa0\xa0\xa0"), # Things that would be noncharacters if they were in Unicode, and might be # mistaken, if the C code is bad, to be nonchars - 0x11FFFE => (isASCII) ? "\xf4\x9f\xbf\xbe" : I8_to_native("\xf9\xa3\xbf\xbf\xbe"), - 0x11FFFF => (isASCII) ? "\xf4\x9f\xbf\xbf" : I8_to_native("\xf9\xa3\xbf\xbf\xbf"), - 0x20FFFE => (isASCII) ? "\xf8\x88\x8f\xbf\xbe" : I8_to_native("\xfa\xa1\xbf\xbf\xbe"), - 0x20FFFF => (isASCII) ? "\xf8\x88\x8f\xbf\xbf" : I8_to_native("\xfa\xa1\xbf\xbf\xbf"), - - 0x200000 - 1 => (isASCII) ? "\xf7\xbf\xbf\xbf" : I8_to_native("\xf9\xbf\xbf\xbf\xbf"), - 0x200000 => (isASCII) ? "\xf8\x88\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"), - 0x400000 - 1 => (isASCII) ? "\xf8\x8f\xbf\xbf\xbf" : I8_to_native("\xfb\xbf\xbf\xbf\xbf"), - 0x400000 => (isASCII) ? "\xf8\x90\x80\x80\x80" : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"), - 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), - 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), - 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), - 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), - 0x40000000 - 1 => (isASCII) ? "\xfc\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"), - 0x40000000 => (isASCII) ? "\xfd\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"), - 0x80000000 - 1 => (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"), - 0x80000000 => (isASCII) ? "\xfe\x82\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), - 0xFFFFFFFF => (isASCII) ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"), + 0x11FFFE => (isASCII) + ? "\xf4\x9f\xbf\xbe" + : I8_to_native("\xf9\xa3\xbf\xbf\xbe"), + 0x11FFFF => (isASCII) + ? "\xf4\x9f\xbf\xbf" + : I8_to_native("\xf9\xa3\xbf\xbf\xbf"), + 0x20FFFE => (isASCII) + ? "\xf8\x88\x8f\xbf\xbe" + : I8_to_native("\xfa\xa1\xbf\xbf\xbe"), + 0x20FFFF => (isASCII) + ? "\xf8\x88\x8f\xbf\xbf" + : I8_to_native("\xfa\xa1\xbf\xbf\xbf"), + + 0x200000 - 1 => (isASCII) + ? "\xf7\xbf\xbf\xbf" + : I8_to_native("\xf9\xbf\xbf\xbf\xbf"), + 0x200000 => (isASCII) + ? "\xf8\x88\x80\x80\x80" + : I8_to_native("\xfa\xa0\xa0\xa0\xa0"), + 0x400000 - 1 => (isASCII) + ? "\xf8\x8f\xbf\xbf\xbf" + : I8_to_native("\xfb\xbf\xbf\xbf\xbf"), + 0x400000 => (isASCII) + ? "\xf8\x90\x80\x80\x80" + : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"), + 0x4000000 - 1 => (isASCII) + ? "\xfb\xbf\xbf\xbf\xbf" + : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), + 0x4000000 => (isASCII) + ? "\xfc\x84\x80\x80\x80\x80" + : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), + 0x4000000 - 1 => (isASCII) + ? "\xfb\xbf\xbf\xbf\xbf" + : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), + 0x4000000 => (isASCII) + ? "\xfc\x84\x80\x80\x80\x80" + : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), + 0x40000000 - 1 => (isASCII) + ? "\xfc\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"), + 0x40000000 => + (isASCII) ? "\xfd\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"), + 0x80000000 - 1 => + (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"), ); -if ($is64bit) { +if ($::is64bit) { + no warnings qw(overflow portable); + $code_points{0x80000000} + = (isASCII) + ? "\xfe\x82\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"); + $code_points{0xFFFFFFFF} + = (isASCII) + ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"); + $code_points{0x100000000} + = (isASCII) + ? "\xfe\x84\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"); + $code_points{0x1000000000 - 1} + = (isASCII) + ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); + $code_points{0x1000000000} + = (isASCII) + ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"); + $code_points{0x7FFFFFFFFFFFFFFF} + = (isASCII) + ? "\xff\x80\x87\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xff\xa7\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); + + # This is used when UV_MAX is the upper limit of acceptable code points + # $code_points{0xFFFFFFFFFFFFFFFF} + # = (isASCII) + # ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" + # : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); + + if (isASCII) { # These could falsely show as overlongs in a naive + # implementation + $code_points{0x40000000000} + = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80"; + $code_points{0x1000000000000} + = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80"; + $code_points{0x40000000000000} + = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80"; + $code_points{0x1000000000000000} + = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"; + # overflows + #$code_points{0xfoo} + # = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"; + } +} +elsif (! isASCII) { # 32-bit EBCDIC. 64-bit is clearer to handle, so doesn't + # need this test case no warnings qw(overflow portable); - $code_points{0x100000000} = (isASCII) ? "\xfe\x84\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"); - $code_points{0x1000000000 - 1} = (isASCII) ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); - $code_points{0x1000000000} = (isASCII) ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"); - $code_points{0xFFFFFFFFFFFFFFFF} = (isASCII) ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); + $code_points{0x40000000} = I8_to_native( + "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"); } # Now add in entries for each of code points 0-255, which require special @@ -238,18 +565,17 @@ while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of # continuation bytes can be in, and what the lowest start byte can be. So we # cycle through them. -my $first_continuation = (isASCII) ? 0x80 : 0xA0; -my $final_continuation = 0xBF; +my $highest_continuation = 0xBF; my $start = (isASCII) ? 0xC2 : 0xC5; -my $continuation = $first_continuation - 1; +my $continuation = $::lowest_continuation - 1; while ($cp < 255) { - if (++$continuation > $final_continuation) { + if (++$continuation > $highest_continuation) { # Wrap to the next start byte when we reach the final continuation # byte possible - $continuation = $first_continuation; + $continuation = $::lowest_continuation; $start++; } $code_points{$cp} = I8_to_native(chr($start) . chr($continuation)); @@ -262,9 +588,11 @@ my @warnings; use warnings 'utf8'; local $SIG{__WARN__} = sub { push @warnings, @_ }; -# This set of tests looks for basic sanity, and lastly tests the bottom level -# decode routine for the given code point. If the earlier tests for that code -# point fail, that one probably will too. Malformations are tested in later +my %restriction_types; + +# This set of tests looks for basic sanity, and lastly tests various routines +# for the given code point. If the earlier tests for that code point fail, +# the later ones probably will too. Malformations are tested in later # segments of code. for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } keys %code_points) @@ -283,8 +611,8 @@ for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } $u < 0x10000 ? 3 : $u < 0x200000 ? 4 : $u < 0x4000000 ? 5 : - $u < 0x80000000 ? 6 : (($is64bit) - ? ($u < 0x1000000000 ? 7 : 13) + $u < 0x80000000 ? 6 : (($::is64bit) + ? ($u < 0x1000000000 ? 7 : $::max_bytes) : 7) ) : ($u < 0xA0 ? 1 : @@ -293,7 +621,7 @@ for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } $u < 0x40000 ? 4 : $u < 0x400000 ? 5 : $u < 0x4000000 ? 6 : - $u < 0x40000000 ? 7 : 14 ); + $u < 0x40000000 ? 7 : $::max_bytes ); } # If this test fails, subsequent ones are meaningless. @@ -317,7 +645,30 @@ for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be"); use bytes; - for (my $j = 0; $j < length $n_chr; $j++) { + my $byte_length = length $n_chr; + for (my $j = 0; $j < $byte_length; $j++) { + undef @warnings; + + if ($j == $byte_length - 1) { + my $ret + = test_is_utf8_valid_partial_char_flags($n_chr, $byte_length, 0); + is($ret, 0, " Verify is_utf8_valid_partial_char_flags(" + . display_bytes($n_chr) + . ") returns 0 for full character"); + } + else { + my $bytes_so_far = substr($n_chr, 0, $j + 1); + my $ret + = test_is_utf8_valid_partial_char_flags($bytes_so_far, $j + 1, 0); + is($ret, 1, " Verify is_utf8_valid_partial_char_flags(" + . display_bytes($bytes_so_far) + . ") returns 1"); + } + + is(scalar @warnings, 0, " Verify is_utf8_valid_partial_char_flags" + . " generated no warnings") + or output_warnings(@warnings); + my $b = substr($n_chr, $j, 1); my $hex_b = sprintf("\"\\x%02x\"", ord $b); @@ -377,772 +728,451 @@ for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } # later section of the code tests for these kinds of things. my $this_utf8_flags = $look_for_everything_utf8n_to; my $len = length $bytes; - if ($n > 2 ** 31 - 1) { - $this_utf8_flags &= - ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT); - } + + my $valid_under_strict = 1; + my $valid_under_c9strict = 1; + my $valid_for_not_extended_utf8 = 1; if ($n > 0x10FFFF) { - $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER); + $this_utf8_flags &= ~($::UTF8_DISALLOW_SUPER|$::UTF8_WARN_SUPER); + $valid_under_strict = 0; + $valid_under_c9strict = 0; + if ($n > $highest_non_extended_cp) { + $this_utf8_flags &= + ~($::UTF8_DISALLOW_PERL_EXTENDED|$::UTF8_WARN_PERL_EXTENDED); + $valid_for_not_extended_utf8 = 0; + } + } + elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) { + $this_utf8_flags &= ~($::UTF8_DISALLOW_NONCHAR|$::UTF8_WARN_NONCHAR); + $valid_under_strict = 0; } - elsif (($n & 0xFFFE) == 0xFFFE) { - $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR); + elsif ($n >= 0xD800 && $n <= 0xDFFF) { + $this_utf8_flags &= ~($::UTF8_DISALLOW_SURROGATE|$::UTF8_WARN_SURROGATE); + $valid_under_c9strict = 0; + $valid_under_strict = 0; } undef @warnings; my $display_flags = sprintf "0x%x", $this_utf8_flags; - my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags); my $display_bytes = display_bytes($bytes); - is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n"); - is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length"); + my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags); + + # Rest of tests likely meaningless if it gets the wrong code point. + next unless is($ret_ref->[0], $n, + "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)" + . "returns $hex_n"); + is($ret_ref->[1], $len, + "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:" + . " $len"); unless (is(scalar @warnings, 0, - "Verify utf8n_to_uvchr() for $hex_n generated no warnings")) + "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings")) { - diag "The warnings were: " . join(", ", @warnings); + output_warnings(@warnings); } + is($ret_ref->[2], 0, + "Verify utf8n_to_uvchr_error() returned no error bits"); undef @warnings; - $ret_ref = test_valid_utf8_to_uvchr($bytes); - is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n"); - is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length"); + my $ret = test_isUTF8_CHAR($bytes, $len); + is($ret, $len, + "Verify isUTF8_CHAR($display_bytes) returns expected length: $len"); unless (is(scalar @warnings, 0, - "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings")) + "Verify isUTF8_CHAR() for $hex_n generated no warnings")) { - diag "The warnings were: " . join(", ", @warnings); + output_warnings(@warnings); } - # Similarly for uvchr_to_utf8 - my $this_uvchr_flags = $look_for_everything_uvchr_to; - if ($n > 2 ** 31 - 1) { - $this_uvchr_flags &= - ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT); - } - if ($n > 0x10FFFF) { - $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER); - } - elsif (($n & 0xFFFE) == 0xFFFE) { - $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR); - } - $display_flags = sprintf "0x%x", $this_uvchr_flags; + undef @warnings; + + $ret = test_isUTF8_CHAR($bytes, $len - 1); + is($ret, 0, + "Verify isUTF8_CHAR() with too short length parameter returns 0"); + + is(scalar @warnings, 0, "Verify isUTF8_CHAR() generated no warnings") + or output_warnings(@warnings); undef @warnings; - my $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags); - ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success"); - is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes"); + $ret = test_isUTF8_CHAR_flags($bytes, $len, 0); + is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0)" + . " returns expected length: $len"); - unless (is(scalar @warnings, 0, - "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings")) - { - diag "The warnings were: " . join(", ", @warnings); - } -} + is(scalar @warnings, 0, + "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings") + or output_warnings(@warnings); -my $REPLACEMENT = 0xFFFD; - -# Now test the malformations. All these raise category utf8 warnings. -my $c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte -my @malformations = ( - [ "zero length string malformation", "", 0, - $UTF8_ALLOW_EMPTY, 0, 0, - qr/empty string/ - ], - [ "orphan continuation byte malformation", I8_to_native("${c}a"), - 2, - $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1, - qr/unexpected continuation byte/ - ], - [ "premature next character malformation (immediate)", - (isASCII) ? "\xc2a" : I8_to_native("\xc5") ."a", - 2, - $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1, - qr/unexpected non-continuation byte.*immediately after start byte/ - ], - [ "premature next character malformation (non-immediate)", - I8_to_native("\xf0${c}a"), - 3, - $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2, - qr/unexpected non-continuation byte .* 2 bytes after start byte/ - ], - [ "too short malformation", I8_to_native("\xf0${c}a"), 2, - # Having the 'a' after this, but saying there are only 2 bytes also - # tests that we pay attention to the passed in length - $UTF8_ALLOW_SHORT, $REPLACEMENT, 2, - qr/2 bytes, need 4/ - ], - [ "overlong malformation", I8_to_native("\xc0$c"), 2, - $UTF8_ALLOW_LONG, - 0, # NUL - 2, - qr/2 bytes, need 1/ - ], - [ "overflow malformation", - # These are the smallest overflowing on 64 byte machines: - # 2**64 - (isASCII) ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0" - : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"), - (isASCII) ? 13 : 14, - 0, # There is no way to allow this malformation - $REPLACEMENT, - (isASCII) ? 13 : 14, - qr/overflow/ - ], -); + undef @warnings; + + $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0); + is($ret, 0, + "Verify isUTF8_CHAR_flags() with too short length parameter returns 0"); + + is(scalar @warnings, 0, "Verify isUTF8_CHAR_flags() generated no warnings") + or output_warnings(@warnings); + + undef @warnings; + + $ret = test_isSTRICT_UTF8_CHAR($bytes, $len); + my $expected_len = ($valid_under_strict) ? $len : 0; + is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes)" + . " returns expected length: $expected_len"); + + is(scalar @warnings, 0, + "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings") + or output_warnings(@warnings); + + undef @warnings; + + $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1); + is($ret, 0, + "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0"); + + is(scalar @warnings, 0, "Verify isSTRICT_UTF8_CHAR() generated no warnings") + or output_warnings(@warnings); + + undef @warnings; -foreach my $test (@malformations) { - my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test; + $ret = test_isUTF8_CHAR_flags($bytes, $len, + $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE); + is($ret, $expected_len, + "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')" + . " acts like isSTRICT_UTF8_CHAR"); - next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length"); + is(scalar @warnings, 0, + "Verify isUTF8_CHAR() for $hex_n generated no warnings") + or output_warnings(@warnings); - # Test what happens when this malformation is not allowed undef @warnings; - my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0); - is($ret_ref->[0], 0, "$testname: disallowed: Returns 0"); - is($ret_ref->[1], $expected_len, "$testname: disallowed: Returns expected length"); - if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) { - like($warnings[0], $message, "$testname: disallowed: Got expected warning"); + + $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len); + $expected_len = ($valid_under_c9strict) ? $len : 0; + is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes)" + . " returns expected length: $len"); + + is(scalar @warnings, 0, + "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings") + or output_warnings(@warnings); + + undef @warnings; + + $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1); + is($ret, 0, + "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0"); + + is(scalar @warnings, 0, + "Verify isC9_STRICT_UTF8_CHAR() generated no warnings") + or output_warnings(@warnings); + + undef @warnings; + + $ret = test_isUTF8_CHAR_flags($bytes, $len, + $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE); + is($ret, $expected_len, + "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')" + ." acts like isC9_STRICT_UTF8_CHAR"); + + is(scalar @warnings, 0, + "Verify isUTF8_CHAR() for $hex_n generated no warnings") + or output_warnings(@warnings); + + undef @warnings; + + $ret_ref = test_valid_utf8_to_uvchr($bytes); + is($ret_ref->[0], $n, + "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n"); + is($ret_ref->[1], $len, + "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len"); + + is(scalar @warnings, 0, + "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings") + or output_warnings(@warnings); + + # Similarly for uvchr_to_utf8 + my $this_uvchr_flags = $look_for_everything_uvchr_to; + if ($n > $highest_non_extended_cp) { + $this_uvchr_flags &= + ~($::UNICODE_DISALLOW_PERL_EXTENDED|$::UNICODE_WARN_PERL_EXTENDED); } - else { - if (scalar @warnings) { - diag "The warnings were: " . join(", ", @warnings); - } + if ($n > 0x10FFFF) { + $this_uvchr_flags &= ~($::UNICODE_DISALLOW_SUPER|$::UNICODE_WARN_SUPER); } - - { # Next test when disallowed, and warnings are off. - undef @warnings; - no warnings 'utf8'; - my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0); - is($ret_ref->[0], 0, "$testname: disallowed: no warnings 'utf8': Returns 0"); - is($ret_ref->[1], $expected_len, "$testname: disallowed: no warnings 'utf8': Returns expected length"); - if (!is(scalar @warnings, 0, "$testname: disallowed: no warnings 'utf8': no warnings generated")) { - diag "The warnings were: " . join(", ", @warnings); - } + elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) { + $this_uvchr_flags + &= ~($::UNICODE_DISALLOW_NONCHAR|$::UNICODE_WARN_NONCHAR); } + elsif ($n >= 0xD800 && $n <= 0xDFFF) { + $this_uvchr_flags + &= ~($::UNICODE_DISALLOW_SURROGATE|$::UNICODE_WARN_SURROGATE); + } + $display_flags = sprintf "0x%x", $this_uvchr_flags; - # Test with CHECK_ONLY undef @warnings; - $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY); - is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0"); - is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns expected length"); - if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) { - diag "The warnings were: " . join(", ", @warnings); + + $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags); + ok(defined $ret, + "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success"); + is($ret, $bytes, + "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes"); + + is(scalar @warnings, 0, + "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n" + . " generated no warnings") + or output_warnings(@warnings); + + # Now append this code point to a string that we will test various + # versions of is_foo_utf8_string_bar on, and keep a count of how many code + # points are in it. All the code points in this loop are valid in Perl's + # extended UTF-8, but some are not valid under various restrictions. A + # string and count is kept separately that is entirely valid for each + # restriction. And, for each restriction, we note the first occurrence in + # the unrestricted string where we find something not in the restricted + # string. + $restriction_types{""}{'valid_strings'} .= $bytes; + $restriction_types{""}{'valid_counts'}++; + + if ($valid_under_c9strict) { + $restriction_types{"c9strict"}{'valid_strings'} .= $bytes; + $restriction_types{"c9strict"}{'valid_counts'}++; + } + elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) { + $restriction_types{"c9strict"}{'first_invalid_offset'} + = length $restriction_types{"c9strict"}{'valid_strings'}; + $restriction_types{"c9strict"}{'first_invalid_count'} + = $restriction_types{"c9strict"}{'valid_counts'}; } - next if $allow_flags == 0; # Skip if can't allow this malformation + if ($valid_under_strict) { + $restriction_types{"strict"}{'valid_strings'} .= $bytes; + $restriction_types{"strict"}{'valid_counts'}++; + } + elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) { + $restriction_types{"strict"}{'first_invalid_offset'} + = length $restriction_types{"strict"}{'valid_strings'}; + $restriction_types{"strict"}{'first_invalid_count'} + = $restriction_types{"strict"}{'valid_counts'}; + } - # Test when the malformation is allowed - undef @warnings; - $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags); - is($ret_ref->[0], $allowed_uv, "$testname: allowed: Returns expected uv"); - is($ret_ref->[1], $expected_len, "$testname: allowed: Returns expected length"); - if (!is(scalar @warnings, 0, "$testname: allowed: no warnings generated")) + if ($valid_for_not_extended_utf8) { + $restriction_types{"not_extended_utf8"}{'valid_strings'} .= $bytes; + $restriction_types{"not_extended_utf8"}{'valid_counts'}++; + } + elsif (! exists + $restriction_types{"not_extended_utf8"}{'first_invalid_offset'}) { - diag "The warnings were: " . join(", ", @warnings); + $restriction_types{"not_extended_utf8"}{'first_invalid_offset'} + = length $restriction_types{"not_extended_utf8"}{'valid_strings'}; + $restriction_types{"not_extended_utf8"}{'first_invalid_count'} + = $restriction_types{"not_extended_utf8"}{'valid_counts'}; } } -# Now test the cases where a legal code point is generated, but may or may not -# be allowed/warned on. -my @tests = ( - [ "lowest surrogate", - (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"), - $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, - 'surrogate', 0xD800, - (isASCII) ? 3 : 4, - qr/surrogate/ - ], - [ "a middle surrogate", - (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"), - $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, - 'surrogate', 0xD90D, - (isASCII) ? 3 : 4, - qr/surrogate/ - ], - [ "highest surrogate", - (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"), - $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, - 'surrogate', 0xDFFF, - (isASCII) ? 3 : 4, - qr/surrogate/ - ], - [ "first non_unicode", - (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"), - $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, - 'non_unicode', 0x110000, - (isASCII) ? 4 : 5, - qr/not Unicode.* may not be portable/ - ], - [ "first of 32 consecutive non-character code points", - (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFDD0, - (isASCII) ? 3 : 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "a mid non-character code point of the 32 consecutive ones", - (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFDE0, - (isASCII) ? 3 : 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "final of 32 consecutive non-character code points", - (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFDEF, - (isASCII) ? 3 : 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+FFFE", - (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFFFE, - (isASCII) ? 3 : 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+FFFF", - (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFFFF, - (isASCII) ? 3 : 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+1FFFE", - (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x1FFFE, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+1FFFF", - (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x1FFFF, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+2FFFE", - (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x2FFFE, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+2FFFF", - (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x2FFFF, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+3FFFE", - (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x3FFFE, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+3FFFF", - (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x3FFFF, 4, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+4FFFE", - (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x4FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+4FFFF", - (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x4FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+5FFFE", - (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x5FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+5FFFF", - (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x5FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+6FFFE", - (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x6FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+6FFFF", - (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x6FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+7FFFE", - (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x7FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+7FFFF", - (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x7FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+8FFFE", - (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x8FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+8FFFF", - (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x8FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+9FFFE", - (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x9FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+9FFFF", - (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x9FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+AFFFE", - (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xAFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+AFFFF", - (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xAFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+BFFFE", - (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xBFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+BFFFF", - (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xBFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+CFFFE", - (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xCFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+CFFFF", - (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xCFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+DFFFE", - (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xDFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+DFFFF", - (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xDFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+EFFFE", - (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xEFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+EFFFF", - (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xEFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+FFFFE", - (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFFFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+FFFFF", - (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0xFFFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+10FFFE", - (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x10FFFE, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "non-character code point U+10FFFF", - (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"), - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, - 'nonchar', 0x10FFFF, - (isASCII) ? 4 : 5, - qr/Unicode non-character.*is not recommended for open interchange/ - ], - [ "requires at least 32 bits", - (isASCII) - ? "\xfe\x82\x80\x80\x80\x80\x80" - : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), - # This code point is chosen so that it is representable in a UV on - # 32-bit machines - $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT, - 'utf8', 0x80000000, (isASCII) ? 7 :14, - qr/Code point 0x80000000 is not Unicode, and not portable/ - ], - [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT", - (isASCII) - ? "\xfe\x82\x80\x80\x80\x80\x80" - : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), - $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, - 'utf8', 0x80000000, (isASCII) ? 7 :14, - qr/Code point 0x80000000 is not Unicode, and not portable/ - ], - [ "overflow with warnings/disallow for more than 31 bits", - # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT - # with overflow. The overflow malformation is never allowed, so - # preventing it takes precedence if the ABOVE_31_BIT options would - # otherwise allow in an overflowing value. The ASCII code points (1 - # for 32-bits; 1 for 64) were chosen because the old overflow - # detection algorithm did not catch them; this means this test also - # checks for that fix. The EBCDIC are arbitrary overflowing ones - # since we have no reports of failures with it. - (($is64bit) - ? ((isASCII) - ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" - : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0")) - : ((isASCII) - ? "\xfe\x86\x80\x80\x80\x80\x80" - : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))), - - # We include both warning categories to make sure the ABOVE_31_BIT one - # has precedence - "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER", - "$UTF8_DISALLOW_ABOVE_31_BIT", - 'utf8', 0, - (! isASCII) ? 14 : ($is64bit) ? 13 : 7, - qr/overflow at byte .*, after start byte 0xf/ - ], -); +my $I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte +my $cont_byte = I8_to_native($I8c); +my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0"); # partial -if ($is64bit) { - no warnings qw{portable overflow}; - push @tests, - [ "More than 32 bits", - (isASCII) - ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80" - : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"), - $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT, - 'utf8', 0x1000000000, (isASCII) ? 13 : 14, - qr/Code point 0x.* is not Unicode, and not portable/ - ]; -} +# The loop above tested the single or partial character functions/macros, +# while building up strings to test the string functions, which we do now. -foreach my $test (@tests) { - my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test; - - my $length = length $bytes; - my $will_overflow = $testname =~ /overflow/; - - # This is more complicated than the malformations tested earlier, as there - # are several orthogonal variables involved. We test all the subclasses - # of utf8 warnings to verify they work with and without the utf8 class, - # and don't have effects on other sublass warnings - foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') { - foreach my $warn_flag (0, $warn_flags) { - foreach my $disallow_flag (0, $disallow_flags) { - foreach my $do_warning (0, 1) { - - my $eval_warn = $do_warning - ? "use warnings '$warning'" - : $warning eq "utf8" - ? "no warnings 'utf8'" - : "use warnings 'utf8'; no warnings '$warning'"; - - # is effectively disallowed if will overflow, even if the - # flag indicates it is allowed, fix up test name to - # indicate this as well - my $disallowed = $disallow_flag || $will_overflow; - - my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag) - ? 'disallowed' - : ($disallowed) - ? 'ABOVE_31_BIT allowed' - : 'allowed'); - $this_name .= ", $eval_warn"; - $this_name .= ", " . (($warn_flag) - ? 'with warning flag' - : 'no warning flag'); - - undef @warnings; - my $ret_ref; - my $display_bytes = display_bytes($bytes); - my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)"; - my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; - eval "$eval_text"; - if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { - diag "\$!='$!'; eval'd=\"$call\""; - next; - } - if ($disallowed) { - unless (is($ret_ref->[0], 0, "$this_name: Returns 0")) - { - diag $call; - } - } - else { - unless (is($ret_ref->[0], $allowed_uv, - "$this_name: Returns expected uv")) - { - diag $call; - } - } - unless (is($ret_ref->[1], $expected_len, - "$this_name: Returns expected length")) - { - diag $call; - } +for my $restriction (sort keys %restriction_types) { + use bytes; - if (! $do_warning - && ($warning eq 'utf8' || $warning eq $category)) - { - if (!is(scalar @warnings, 0, - "$this_name: No warnings generated")) - { - diag $call; - diag "The warnings were: " . join(", ", @warnings); - } - } - elsif ($will_overflow - && ! $disallow_flag - && $warning eq 'utf8') - { - - # Will get the overflow message instead of the expected - # message under these circumstances, as they would - # otherwise accept an overflowed value, which the code - # should not allow, so falls back to overflow. - if (is(scalar @warnings, 1, - "$this_name: Got a single warning ")) + for my $use_flags ("", "_flags") { + + # For each restriction, we test it in both the is_foo_flags functions + # and the specially named foo function. But not if there isn't such a + # specially named function. Currently, this is the only tested + # restriction that doesn't have a specially named function + next if $use_flags eq "" && $restriction eq "not_extended_utf8"; + + # Start building up the name of the function we will test. + my $base_name = "is_"; + + if (! $use_flags && $restriction ne "") { + $base_name .= $restriction . "_"; + } + + # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions + foreach my $operand ('string', 'fixed_width_buf') { + + # Currently, only fixed_width_buf functions have the '_flags' + # suffix. + next if $operand eq 'fixed_width_buf' && $use_flags eq ""; + + my $name = "${base_name}utf8_$operand"; + + # We test each version of the function + for my $function ("_loclen", "_loc", "") { + + # We test each function against + # a) valid input + # b) invalid input created by appending an out-of-place + # continuation character to the valid string + # c) input created by appending a partial character. This + # is valid in the 'fixed_width' functions, but invalid in + # the 'string' ones + # d) invalid input created by calling a function that is + # expecting a restricted form of the input using the string + # that's valid when unrestricted + for my $error_type (0, $cont_byte, $p, $restriction) { + #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type); + + # If there is no restriction, the error type will be "", + # which is redundant with 0. + next if $error_type eq ""; + + my $this_name = "$name$function$use_flags"; + my $bytes + = $restriction_types{$restriction}{'valid_strings'}; + my $expected_offset = length $bytes; + my $expected_count + = $restriction_types{$restriction}{'valid_counts'}; + my $test_name_suffix = ""; + + my $this_error_type = $error_type; + if ($this_error_type) { + + # Appending a bare continuation byte or a partial + # character doesn't change the character count or + # offset. But in the other cases, we have saved where + # the failures should occur, so use those. Appending + # a continuation byte makes it invalid; appending a + # partial character makes the 'string' form invalid, + # but not the 'fixed_width_buf' form. + if ( $this_error_type eq $cont_byte + || $this_error_type eq $p) { - unless (like($warnings[0], qr/overflow/, - "$this_name: Got overflow warning")) - { - diag $call; + $bytes .= $this_error_type; + if ($this_error_type eq $cont_byte) { + $test_name_suffix + = " for an unexpected continuation"; } - } - else { - diag $call; - if (scalar @warnings) { - diag "The warnings were: " - . join(", ", @warnings); + else { + $test_name_suffix + = " if ends with a partial character"; + $this_error_type + = 0 if $operand eq "fixed_width_buf"; } } - } - elsif ($warn_flag - && ($warning eq 'utf8' || $warning eq $category)) - { - if (is(scalar @warnings, 1, - "$this_name: Got a single warning ")) + elsif (! exists $restriction_types + {$this_error_type}{'first_invalid_count'}) { - unless (like($warnings[0], $message, - "$this_name: Got expected warning")) - { - diag $call; - } + # If no errors were found, this is entirely valid. + $this_error_type = 0; } else { - diag $call; - if (scalar @warnings) { - diag "The warnings were: " - . join(", ", @warnings); + + if (! exists $restriction_types{$this_error_type}) { + fail("Internal test error: Unknown error type " + . "'$this_error_type'"); + next; } + $test_name_suffix + = " if contains forbidden code points"; + + $bytes = $restriction_types{""}{'valid_strings'}; + $expected_offset + = $restriction_types{$this_error_type} + {'first_invalid_offset'}; + $expected_count + = $restriction_types{$this_error_type } + {'first_invalid_count'}; } } - # Check CHECK_ONLY results when the input is disallowed. Do - # this when actually disallowed, not just when the - # $disallow_flag is set - if ($disallowed) { - undef @warnings; - $ret_ref = test_utf8n_to_uvchr($bytes, $length, - $disallow_flag|$UTF8_CHECK_ONLY); - unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) { - diag $call; - } - unless (is($ret_ref->[1], -1, - "$this_name: CHECK_ONLY: returns expected length")) - { - diag $call; - } - if (! is(scalar @warnings, 0, - "$this_name, CHECK_ONLY: no warnings generated")) - { - diag $call; - diag "The warnings were: " . join(", ", @warnings); - } - } + my $length = length $bytes; + my $ret_ref; - # Now repeat some of the above, but for - # uvchr_to_utf8_flags(). Since this comes from an - # existing code point, it hasn't overflowed. - next if $will_overflow; - - # The warning and disallow flags passed in are for - # utf8n_to_uvchr(). Convert them for - # uvchr_to_utf8_flags(). - my $uvchr_warn_flag = 0; - my $uvchr_disallow_flag = 0; - if ($warn_flag) { - if ($warn_flag == $UTF8_WARN_SURROGATE) { - $uvchr_warn_flag = $UNICODE_WARN_SURROGATE - } - elsif ($warn_flag == $UTF8_WARN_NONCHAR) { - $uvchr_warn_flag = $UNICODE_WARN_NONCHAR - } - elsif ($warn_flag == $UTF8_WARN_SUPER) { - $uvchr_warn_flag = $UNICODE_WARN_SUPER - } - elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) { - $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT; - } - else { - fail(sprintf "Unexpected warn flag: %x", - $warn_flag); - next; - } - } - if ($disallow_flag) { - if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) { - $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE - } - elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) { - $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR - } - elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) { - $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER - } - elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) { - $uvchr_disallow_flag = - $UNICODE_DISALLOW_ABOVE_31_BIT; + my $test = "\$ret_ref = test_$this_name(\$bytes, $length"; + + # If using the _flags functions, we have to figure out what + # flags to pass. This is done to match the restriction. + if ($use_flags eq "_flags") { + if (! $restriction) { + $test .= ", 0"; # The flag + + # Indicate the kind of flag in the test name. + $this_name .= "(0)"; } else { - fail(sprintf "Unexpected disallow flag: %x", - $disallow_flag); - next; + $this_name .= "($restriction)"; + if ($restriction eq "c9strict") { + $test + .= ", $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE"; + } + elsif ($restriction eq "strict") { + $test .= ", $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE"; + } + elsif ($restriction eq "not_extended_utf8") { + $test .= ", $::UTF8_DISALLOW_PERL_EXTENDED"; + } + else { + fail("Internal test error: Unknown restriction " + . "'$restriction'"); + next; + } } } + $test .= ")"; - $disallowed = $uvchr_disallow_flag; - - $this_name = "uvchr_to_utf8_flags() $testname: " - . (($uvchr_disallow_flag) - ? 'disallowed' - : ($disallowed) - ? 'ABOVE_31_BIT allowed' - : 'allowed'); - $this_name .= ", $eval_warn"; - $this_name .= ", " . (($uvchr_warn_flag) - ? 'with warning flag' - : 'no warning flag'); + # Actually run the test + eval $test; + if ($@) { + fail($test); + diag $@; + next; + } - undef @warnings; my $ret; - my $warn_flag = sprintf "0x%x", $uvchr_warn_flag; - my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag; - $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv; - $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)"; - eval "$eval_text"; - if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { - diag "\$!='$!'; eval'd=\"$eval_text\""; - next; + my $error_offset; + my $cp_count; + + if ($function eq "") { + $ret = $ret_ref; # For plain function, there's only a + # single return value } - if ($disallowed) { - unless (is($ret, undef, "$this_name: Returns undef")) { - diag $call; - } + else { # Otherwise, the multiple values come in an array. + $ret = shift @$ret_ref ; + $error_offset = shift @$ret_ref; + $cp_count = shift@$ret_ref if $function eq "_loclen"; } - else { - unless (is($ret, $bytes, "$this_name: Returns expected string")) { - diag $call; - } + + if ($this_error_type) { + is($ret, 0, + "Verify $this_name is FALSE$test_name_suffix"); } - if (! $do_warning - && ($warning eq 'utf8' || $warning eq $category)) - { - if (!is(scalar @warnings, 0, - "$this_name: No warnings generated")) + else { + unless(is($ret, 1, + "Verify $this_name is TRUE for valid input" + . "$test_name_suffix")) { - diag $call; - diag "The warnings were: " . join(", ", @warnings); + diag(" The bytes starting at offset" + . " $error_offset are" + . display_bytes(substr( + $restriction_types{$restriction} + {'valid_strings'}, + $error_offset))); + next; } } - elsif ($uvchr_warn_flag - && ($warning eq 'utf8' || $warning eq $category)) - { - if (is(scalar @warnings, 1, - "$this_name: Got a single warning ")) + + if ($function ne "") { + unless (is($error_offset, $expected_offset, + "\tAnd returns the correct offset")) { - unless (like($warnings[0], $message, - "$this_name: Got expected warning")) - { - diag $call; - } + my $min = ($error_offset < $expected_offset) + ? $error_offset + : $expected_offset; + diag(" The bytes starting at offset" . $min + . " are " . display_bytes(substr($bytes, $min))); } - else { - diag $call; - if (scalar @warnings) { - diag "The warnings were: " - . join(", ", @warnings); - } + + if ($function eq '_loclen') { + is($cp_count, $expected_count, + "\tAnd returns the correct character count"); } } } @@ -1151,4 +1181,50 @@ foreach my $test (@tests) { } } +SKIP: +{ + isASCII + or skip "These tests probably break on non-ASCII", 1; + my $simple = join "", "A" .. "J"; + my $utf_ch = "\x{7fffffff}"; + utf8::encode($utf_ch); + my $utf_ch_len = length $utf_ch; + note "utf_ch_len $utf_ch_len"; + my $utf = $utf_ch x 10; + my $bad_start = substr($utf, 1); + # $bad_end ends with a start byte and a single continuation + my $bad_end = substr($utf, 0, length($utf)-$utf_ch_len+2); + + # WARNING: all offsets are *byte* offsets + my @hop_tests = + ( + # string s off expected name + [ $simple, 0, 5, 5, "simple in range, forward" ], + [ $simple, 10, -5, 5, "simple in range, backward" ], + [ $simple, 5, 10, 10, "simple out of range, forward" ], + [ $simple, 5, -10, 0, "simple out of range, backward" ], + [ $utf, $utf_ch_len * 5, 5, length($utf), "utf in range, forward" ], + [ $utf, $utf_ch_len * 5, -5, 0, "utf in range, backward" ], + [ $utf, $utf_ch_len * 5, 4, $utf_ch_len * 9, "utf in range b, forward" ], + [ $utf, $utf_ch_len * 5, -4, $utf_ch_len, "utf in range b, backward" ], + [ $utf, $utf_ch_len * 5, 6, length($utf), "utf out of range, forward" ], + [ $utf, $utf_ch_len * 5, -6, 0, "utf out of range, backward" ], + [ $bad_start, 0, 1, 1, "bad start, forward 1 from 0" ], + [ $bad_start, 0, $utf_ch_len-1, $utf_ch_len-1, "bad start, forward ch_len-1 from 0" ], + [ $bad_start, 0, $utf_ch_len, $utf_ch_len*2-1, "bad start, forward ch_len from 0" ], + [ $bad_start, $utf_ch_len-1, -1, 0, "bad start, back 1 from first start byte" ], + [ $bad_start, $utf_ch_len-2, -1, 0, "bad start, back 1 from before first start byte" ], + [ $bad_start, 0, -1, 0, "bad start, back 1 from 0" ], + [ $bad_start, length $bad_start, -10, 0, "bad start, back 10 from end" ], + [ $bad_end, 0, 10, length $bad_end, "bad end, forward 10 from 0" ], + [ $bad_end, length($bad_end)-1, 10, length $bad_end, "bad end, forward 1 from end-1" ], + ); + + for my $test (@hop_tests) { + my ($str, $s_off, $off, $want, $name) = @$test; + my $result = test_utf8_hop_safe($str, $s_off, $off); + is($result, $want, "utf8_hop_safe: $name"); + } +} + done_testing; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t b/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t index e7631305259..a7e2541e425 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t @@ -5,7 +5,7 @@ use Test::More; BEGIN { use_ok('XS::APItest') }; -use vars qw($XS_VERSION $VERSION); +our ($XS_VERSION, $VERSION); # This is what the code expects my $real_version = $XS::APItest::VERSION; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/typemap b/gnu/usr.bin/perl/ext/XS-APItest/typemap index ed86a374f10..f4c401eba2c 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/typemap +++ b/gnu/usr.bin/perl/ext/XS-APItest/typemap @@ -1,6 +1,7 @@ XS::APItest::PtrTable T_PTROBJ const WCHAR * WPV +U8 * T_PV INPUT diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm index a1ae0211d2a..9871415319b 100644 --- a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm +++ b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm @@ -34,11 +34,9 @@ to the test script. use parent qw/ Exporter /; require XSLoader; -use vars qw/ $VERSION @EXPORT /; +our $VERSION = '0.16'; -$VERSION = '0.14'; - -@EXPORT = (qw/ +our @EXPORT = (qw/ T_SV T_SVREF T_SVREF_REFCOUNT_FIXED diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs index 8314cc2b04b..16731b1a01e 100644 --- a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs +++ b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs @@ -176,7 +176,8 @@ XS_unpack_anotherstructPtrPtr(SV *in) if (SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVHV) inhash = (HV*)SvRV(tmp); else - Perl_croak(aTHX_ "Array element %"UVuf" is not a HASH reference", i); + Perl_croak(aTHX_ "Array element %" UVuf + " is not a HASH reference", i); elem = hv_fetchs(inhash, "a", 0); if (elem == NULL) diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t b/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t index 46ab20fd116..3e56b573d6c 100755 --- a/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t +++ b/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t @@ -381,7 +381,7 @@ if (defined $fh) { ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) ); # open from perl, and check contents - open($fh, "< $testfile"); + open($fh, '<', $testfile); ok($fh); my $line = <$fh>; is($line,$lines[0]); diff --git a/gnu/usr.bin/perl/ext/arybase/arybase.pm b/gnu/usr.bin/perl/ext/arybase/arybase.pm index a519a4b3927..5e34e29e8d8 100644 --- a/gnu/usr.bin/perl/ext/arybase/arybase.pm +++ b/gnu/usr.bin/perl/ext/arybase/arybase.pm @@ -1,6 +1,6 @@ package arybase; -our $VERSION = "0.11"; +our $VERSION = "0.15"; require XSLoader; XSLoader::load(); # This returns true, which makes require happy. diff --git a/gnu/usr.bin/perl/ext/arybase/arybase.xs b/gnu/usr.bin/perl/ext/arybase/arybase.xs index 4ff6cbd68aa..6c12d0515fa 100644 --- a/gnu/usr.bin/perl/ext/arybase/arybase.xs +++ b/gnu/usr.bin/perl/ext/arybase/arybase.xs @@ -26,9 +26,7 @@ STATIC perl_mutex ab_op_map_mutex; STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) { const ab_op_info *val; -#ifdef USE_ITHREADS MUTEX_LOCK(&ab_op_map_mutex); -#endif val = (ab_op_info *)ptable_fetch(ab_op_map, o); if (val) { @@ -36,9 +34,7 @@ STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) { val = oi; } -#ifdef USE_ITHREADS MUTEX_UNLOCK(&ab_op_map_mutex); -#endif return val; } @@ -65,28 +61,20 @@ STATIC void ab_map_store( { #define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B)) -#ifdef USE_ITHREADS MUTEX_LOCK(&ab_op_map_mutex); -#endif ab_map_store_locked(o, old_pp, base); -#ifdef USE_ITHREADS MUTEX_UNLOCK(&ab_op_map_mutex); -#endif } STATIC void ab_map_delete(pTHX_ const OP *o) { #define ab_map_delete(O) ab_map_delete(aTHX_ (O)) -#ifdef USE_ITHREADS MUTEX_LOCK(&ab_op_map_mutex); -#endif ptable_map_store(ab_op_map, o, NULL); -#ifdef USE_ITHREADS MUTEX_UNLOCK(&ab_op_map_mutex); -#endif } /* ... $[ Implementation .............................................. */ @@ -165,11 +153,15 @@ STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) { #define ab_process_assignment(l, r) \ ab_process_assignment(aTHX_ (l), (r)) if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) { - set_arybase_to(SvIV(cSVOPx_sv(right))); + IV base = SvIV(cSVOPx_sv(right)); + set_arybase_to(base); ab_neuter_dollar_bracket(left); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" - ); + if (base) { + Perl_ck_warner_d(aTHX_ + packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" + ", and will be fatal in Perl 5.30" + ); + } } } @@ -410,15 +402,9 @@ PROTOTYPES: DISABLE BOOT: { - GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV); - sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */ - tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv))); - if (!ab_initialized++) { ab_op_map = ptable_new(); -#ifdef USE_ITHREADS MUTEX_INIT(&ab_op_map_mutex); -#endif #define check(uc,lc,ck) \ wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc) check(SASSIGN, sassign, sassign); @@ -438,6 +424,16 @@ BOOT: } void +_tie_it(SV *sv) + INIT: + GV * const gv = (GV *)sv; + CODE: + if (GvSV(gv)) + /* This is *our* scalar now! */ + sv_unmagic(GvSV(gv), PERL_MAGIC_sv); + tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv))); + +void FETCH(...) PREINIT: SV *ret = FEATURE_ARYBASE_IS_ENABLED diff --git a/gnu/usr.bin/perl/ext/attributes/attributes.pm b/gnu/usr.bin/perl/ext/attributes/attributes.pm index f7af31b7b4c..c60f9406b99 100644 --- a/gnu/usr.bin/perl/ext/attributes/attributes.pm +++ b/gnu/usr.bin/perl/ext/attributes/attributes.pm @@ -1,6 +1,6 @@ package attributes; -our $VERSION = 0.27; +our $VERSION = 0.33; @EXPORT_OK = qw(get reftype); @EXPORT = (); @@ -18,10 +18,9 @@ sub carp { goto &Carp::carp; } +# Hash of SV type (CODE, SCALAR, etc.) to regex matching deprecated +# attributes for that type. my %deprecated; -$deprecated{CODE} = qr/\A-?(locked)\z/; -$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} - = qr/\A-?(unique)\z/; my %msg = ( lvalue => 'lvalue attribute applied to already-defined subroutine', @@ -31,14 +30,15 @@ my %msg = ( sub _modify_attrs_and_deprecate { my $svtype = shift; - # Now that we've removed handling of locked from the XS code, we need to + # After we've removed a deprecated attribute from the XS code, we need to # remove it here, else it ends up in @badattrs. (If we do the deprecation in # XS, we can't control the warning based on *our* caller's lexical settings, # and the warned line is in this package) grep { $deprecated{$svtype} && /$deprecated{$svtype}/ ? do { require warnings; - warnings::warnif('deprecated', "Attribute \"$1\" is deprecated"); + warnings::warnif('deprecated', "Attribute \"$1\" is deprecated, " . + "and will disappear in Perl 5.28"); 0; } : $svtype eq 'CODE' && exists $msg{$_} ? do { require warnings; @@ -255,11 +255,6 @@ C<sub foo($$) : prototype(@) {}> is indistinguishable from C<sub foo(@){}>. If illegalproto warnings are enabled, the prototype declared inside this attribute will be sanity checked at compile time. -=item locked - -The "locked" attribute is deprecated, and has no effect in 5.10.0 and later. -It was used as part of the now-removed "Perl 5.005 threads". - =item const This experimental attribute, introduced in Perl 5.22, only applies to @@ -278,13 +273,6 @@ The following are the built-in attributes for variables: Indicates that the referenced variable can be shared across different threads when used in conjunction with the L<threads> and L<threads::shared> modules. -=item unique - -The "unique" attribute is deprecated, and has no effect in 5.10.0 and later. -It used to indicate that a single copy of an C<our> variable was to be used by -all interpreters should the program happen to be running in a -multi-interpreter environment. - =back =head2 Available Subroutines diff --git a/gnu/usr.bin/perl/ext/attributes/attributes.xs b/gnu/usr.bin/perl/ext/attributes/attributes.xs index d98fd9e3ec2..07b7b8dfe82 100644 --- a/gnu/usr.bin/perl/ext/attributes/attributes.xs +++ b/gnu/usr.bin/perl/ext/attributes/attributes.xs @@ -15,6 +15,8 @@ * [p.597 of _The Lord of the Rings_, III/xi: "The PalantÃr"] */ +#define PERL_EXT + #define PERL_NO_GET_CONTEXT #include "EXTERN.h" @@ -44,7 +46,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) case SVt_PVCV: switch ((int)len) { case 5: - if (memEQ(name, "const", 5)) { + if (memEQs(name, 5, "const")) { if (negated) CvANONCONST_off(sv); else { @@ -60,11 +62,11 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) case 6: switch (name[3]) { case 'l': - if (memEQ(name, "lvalue", 6)) { + if (memEQs(name, 6, "lvalue")) { bool warn = !CvISXSUB(MUTABLE_CV(sv)) && CvROOT(MUTABLE_CV(sv)) - && !CvLVALUE(MUTABLE_CV(sv)) != negated; + && cBOOL(CvLVALUE(MUTABLE_CV(sv))) == negated; if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; else @@ -74,7 +76,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) } break; case 'h': - if (memEQ(name, "method", 6)) { + if (memEQs(name, 6, "method")) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; else @@ -85,8 +87,9 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) } break; default: - if (len > 10 && memEQ(name, "prototype(", 10)) { - SV * proto = newSVpvn(name+10,len-11); + if (memBEGINPs(name, len, "prototype(")) { + const STRLEN proto_len = sizeof("prototype(") - 1; + SV * proto = newSVpvn(name + proto_len, len - proto_len - 1); HEK *const hek = CvNAME_HEK((CV *)sv); SV *subname; if (name[len-1] != ')') @@ -96,7 +99,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) else subname=(SV *)CvGV((const CV *)sv); if (ckWARN(WARN_ILLEGALPROTO)) - Perl_validate_proto(aTHX_ subname, proto, TRUE); + Perl_validate_proto(aTHX_ subname, proto, TRUE, 0); Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, (const GV *)subname, name+10, diff --git a/gnu/usr.bin/perl/ext/mro/mro.pm b/gnu/usr.bin/perl/ext/mro/mro.pm index 0946fb67221..4a7685cc042 100644 --- a/gnu/usr.bin/perl/ext/mro/mro.pm +++ b/gnu/usr.bin/perl/ext/mro/mro.pm @@ -12,7 +12,10 @@ use warnings; # mro.pm versions < 1.00 reserved for MRO::Compat # for partial back-compat to 5.[68].x -our $VERSION = '1.18'; +our $VERSION = '1.22'; + +require XSLoader; +XSLoader::load('mro'); sub import { mro::set_mro(scalar(caller), $_[1]) if $_[1]; @@ -37,9 +40,6 @@ sub method { return; } -require XSLoader; -XSLoader::load('mro'); - 1; __END__ @@ -308,7 +308,7 @@ works (like C<goto &maybe::next::method>); =over 4 -=item L<http://haahr.tempdomainname.com/dylan/linearization-oopsla96.html> +=item L<http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.19.3910&rep=rep1&type=pdf> =back diff --git a/gnu/usr.bin/perl/ext/mro/mro.xs b/gnu/usr.bin/perl/ext/mro/mro.xs index 6d891ae7315..80bce9a6ad1 100644 --- a/gnu/usr.bin/perl/ext/mro/mro.xs +++ b/gnu/usr.bin/perl/ext/mro/mro.xs @@ -45,7 +45,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%"HEKf + Perl_croak(aTHX_ "Recursive inheritance detected in package '%" HEKf "'", HEKfARG(stashhek)); @@ -256,21 +256,21 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) I32 i; errmsg = newSVpvf( - "Inconsistent hierarchy during C3 merge of class '%"HEKf"':\n\t" + "Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t" "current merge results [\n", HEKfARG(stashhek)); for (i = 0; i <= av_tindex(retval); i++) { SV **elem = av_fetch(retval, i, 0); - sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem)); + sv_catpvf(errmsg, "\t\t%" SVf ",\n", SVfARG(*elem)); } - sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand)); + sv_catpvf(errmsg, "\t]\n\tmerging failed on '%" SVf "'", SVfARG(cand)); /* we have to do some cleanup before we croak */ SvREFCNT_dec(retval); Safefree(heads); - Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg)); + Perl_croak(aTHX_ "%" SVf, SVfARG(errmsg)); } } } @@ -330,7 +330,7 @@ mro_get_linear_isa(...) else if(items > 1) { const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1)); if (!algo) - Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1)); + Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", ST(1)); RETVAL = algo->resolve(aTHX_ class_stash, 0); } else { @@ -353,7 +353,7 @@ mro_set_mro(...) classname = ST(0); class_stash = gv_stashsv(classname, GV_ADD); - if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname)); + if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%" SVf "'!", SVfARG(classname)); meta = HvMROMETA(class_stash); Perl_mro_set_mro(aTHX_ meta, ST(1)); @@ -431,8 +431,8 @@ mro_is_universal(...) he = hv_fetch_ent(PL_isarev, classname, 0, 0); isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; - if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) - || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) + if((memEQs(classname_pv, classname_len, "UNIVERSAL")) + || (isarev && hv_existss(isarev, "UNIVERSAL"))) XSRETURN_YES; else XSRETURN_NO; @@ -566,7 +566,7 @@ mro__nextcan(...) subname++; subname_len = fq_subname_len - (subname - fq_subname); - if(subname_len == 8 && strEQ(subname, "__ANON__")) { + if(memEQs(subname, subname_len, "__ANON__")) { cxix = __dopoptosub_at(ccstack, cxix - 1); continue; } @@ -590,7 +590,7 @@ mro__nextcan(...) if(val == &PL_sv_undef) { if(throw_nomethod) Perl_croak(aTHX_ - "No next::method '%"SVf"' found for %"HEKf, + "No next::method '%" SVf "' found for %" HEKf, SVfARG(newSVpvn_flags(subname, subname_len, SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), HEKfARG( HvNAME_HEK(selfstash) )); @@ -638,7 +638,7 @@ mro__nextcan(...) if (!curstash) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%"HEKf"::ISA", + "Can't locate package %" SVf " for @%" HEKf "::ISA", (void*)linear_sv, HEKfARG( HvNAME_HEK(selfstash) )); continue; @@ -671,7 +671,7 @@ mro__nextcan(...) (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0); if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%"SVf"' found for %"HEKf, + Perl_croak(aTHX_ "No next::method '%" SVf "' found for %" HEKf, SVfARG(newSVpvn_flags(subname, subname_len, SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), HEKfARG( HvNAME_HEK(selfstash) )); diff --git a/gnu/usr.bin/perl/ext/re/re.pm b/gnu/usr.bin/perl/ext/re/re.pm index 058b8aa961c..0b52e1d7d7e 100644 --- a/gnu/usr.bin/perl/ext/re/re.pm +++ b/gnu/usr.bin/perl/ext/re/re.pm @@ -4,7 +4,7 @@ package re; use strict; use warnings; -our $VERSION = "0.32"; +our $VERSION = "0.36"; our @ISA = qw(Exporter); our @EXPORT_OK = ('regmust', qw(is_regexp regexp_pattern @@ -23,6 +23,7 @@ my %reflags = ( s => 1 << ($PMMOD_SHIFT + 1), i => 1 << ($PMMOD_SHIFT + 2), x => 1 << ($PMMOD_SHIFT + 3), + xx => 1 << ($PMMOD_SHIFT + 4), n => 1 << ($PMMOD_SHIFT + 5), p => 1 << ($PMMOD_SHIFT + 6), strict => 1 << ($PMMOD_SHIFT + 10), @@ -112,7 +113,6 @@ sub bits { my $on = shift; my $bits = 0; my $turning_all_off = ! @_ && ! $on; - my %seen; # Has flag already been seen? if ($turning_all_off) { # Pretend were called with certain parameters, which are best dealt @@ -180,6 +180,7 @@ sub bits { } elsif ($s =~ s/^\///) { my $reflags = $^H{reflags} || 0; my $seen_charset; + my $x_count = 0; while ($s =~ m/( . )/gx) { local $_ = $1; if (/[adul]/) { @@ -225,7 +226,19 @@ sub bits { && $^H{reflags_charset} == $reflags{$_}; } } elsif (exists $reflags{$_}) { - $seen{$_}++; + if ($_ eq 'x') { + $x_count++; + if ($x_count > 2) { + require Carp; + Carp::carp( + qq 'The "x" flag may only appear a maximum of twice' + ); + } + elsif ($x_count == 2) { + $_ = 'xx'; # First time through got the /x + } + } + $on ? $reflags |= $reflags{$_} : ($reflags &= ~$reflags{$_}); @@ -247,18 +260,6 @@ sub bits { ")"); } } - if (exists $seen{'x'} && $seen{'x'} > 1 - && (warnings::enabled("deprecated") - || warnings::enabled("regexp"))) - { - my $message = "Having more than one /x regexp modifier is deprecated"; - if (warnings::enabled("deprecated")) { - warnings::warn("deprecated", $message); - } - else { - warnings::warn("regexp", $message); - } - } if ($turning_all_off) { _load_unload(0); @@ -331,7 +332,7 @@ re - Perl pragma to alter regular expression behaviour use re qw(is_regexp regexp_pattern); # import utility functions my ($pat,$mods)=regexp_pattern(qr/foo/i); - if (is_regexp($obj)) { + if (is_regexp($obj)) { print "Got regexp: ", scalar regexp_pattern($obj); # just as perl would stringify } # it but no hassle with blessed @@ -420,20 +421,34 @@ under non-strict. =head2 '/flags' mode -When C<use re '/flags'> is specified, the given flags are automatically +When C<use re '/I<flags>'> is specified, the given I<flags> are automatically added to every regular expression till the end of the lexical scope. - -C<no re '/flags'> will turn off the effect of C<use re '/flags'> for the +I<flags> can be any combination of +C<'a'>, +C<'aa'>, +C<'d'>, +C<'i'>, +C<'l'>, +C<'m'>, +C<'n'>, +C<'p'>, +C<'s'>, +C<'u'>, +C<'x'>, +and/or +C<'xx'>. + +C<no re '/I<flags>'> will turn off the effect of C<use re '/I<flags>'> for the given flags. -For example, if you want all your regular expressions to have /msx on by +For example, if you want all your regular expressions to have /msxx on by default, simply put - use re '/msx'; + use re '/msxx'; at the top of your code. -The character set /adul flags cancel each other out. So, in this example, +The character set C</adul> flags cancel each other out. So, in this example, use re "/u"; "ss" =~ /\xdf/; @@ -442,6 +457,13 @@ The character set /adul flags cancel each other out. So, in this example, the second C<use re> does an implicit C<no re '/u'>. +Similarly, + + use re "/xx"; # Doubled-x + ... + use re "/x"; # Single x from here on + ... + Turning on one of the character set flags with C<use re> takes precedence over the C<locale> pragma and the 'unicode_strings' C<feature>, for regular expressions. Turning off one of these flags when it is active reverts to @@ -467,7 +489,7 @@ strings on/off, pre-point part on/off. See L<perldebug/"Debugging Regular Expressions"> for additional info. As of 5.9.5 the directive C<use re 'debug'> and its equivalents are -lexically scoped, as the other directives are. However they have both +lexically scoped, as the other directives are. However they have both compile-time and run-time effects. See L<perlmodlib/Pragmatic Modules>. diff --git a/gnu/usr.bin/perl/ext/re/re.xs b/gnu/usr.bin/perl/ext/re/re.xs index 9545d1dba04..497135a5daa 100644 --- a/gnu/usr.bin/perl/ext/re/re.xs +++ b/gnu/usr.bin/perl/ext/re/re.xs @@ -1,5 +1,6 @@ #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING) # define DEBUGGING +# define DEBUGGING_RE_ONLY #endif #define PERL_NO_GET_CONTEXT @@ -17,7 +18,7 @@ START_EXTERN_C extern REGEXP* my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags); extern REGEXP* my_re_op_compile (pTHX_ SV ** const patternp, int pat_count, - OP *expr, const regexp_engine* eng, REGEXP *VOL old_re, + OP *expr, const regexp_engine* eng, REGEXP *volatile old_re, bool *is_bare_re, U32 rx_flags, U32 pm_flags); extern I32 my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend, diff --git a/gnu/usr.bin/perl/ext/re/re_top.h b/gnu/usr.bin/perl/ext/re/re_top.h index ce4c716aa54..543f924908b 100644 --- a/gnu/usr.bin/perl/ext/re/re_top.h +++ b/gnu/usr.bin/perl/ext/re/re_top.h @@ -5,6 +5,7 @@ /* need access to debugger hooks */ #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING) # define DEBUGGING +# define DEBUGGING_RE_ONLY #endif /* We *really* need to overwrite these symbols: */ diff --git a/gnu/usr.bin/perl/ext/re/t/reflags.t b/gnu/usr.bin/perl/ext/re/t/reflags.t index fd1c35a848a..595b4b28b46 100644 --- a/gnu/usr.bin/perl/ext/re/t/reflags.t +++ b/gnu/usr.bin/perl/ext/re/t/reflags.t @@ -11,7 +11,7 @@ BEGIN { use strict; -use Test::More tests => 67; +use Test::More tests => 74; my @flags = qw( a d l u ); @@ -24,10 +24,19 @@ ok "Foo" !~ /(??{'foo'})/, 'no re "/i" (??{})'; use re '/x'; ok "foo" =~ / foo /, 'use re "/x"'; ok "foo" =~ / (??{' foo '}) /, 'use re "/x" (??{})'; +like " ", qr/[a b]/, 'use re "/x" [a b]'; no re '/x'; ok "foo" !~ / foo /, 'no re "/x"'; ok "foo" !~ /(??{' foo '})/, 'no re "/x" (??{})'; ok "foo" !~ / (??{'foo'}) /, 'no re "/x" (??{})'; +use re '/xx'; +ok "foo" =~ / foo /, 'use re "/xx"'; +ok "foo" =~ / (??{' foo '}) /, 'use re "/xx" (??{})'; +unlike " ", qr/[a b]/, 'use re "/xx" [a b] # Space in [] gobbled up'; +no re '/xx'; +ok "foo" !~ / foo /, 'no re "/xx"'; +ok "foo" !~ /(??{' foo '})/, 'no re "/xx" (??{})'; +ok "foo" !~ / (??{'foo'}) /, 'no re "/xx" (??{})'; use re '/s'; ok "\n" =~ /./, 'use re "/s"'; ok "\n" =~ /(??{'.'})/, 'use re "/s" (??{})'; @@ -178,8 +187,8 @@ is qr//, '(?^:)', 'no re "/aai"'; "warning with eval \"use re \"/amaa\""; $w = ""; - eval "use re '/xamax'"; - like $w, qr/Having more than one \/x regexp modifier is deprecated/, - "warning with eval \"use re \"/xamax\""; + eval "use re '/xamaxx'"; + like $w, qr/The "x" flag may only appear a maximum of twice/, + "warning with eval \"use re \"/xamaxx\""; } diff --git a/gnu/usr.bin/perl/ext/re/t/regop.t b/gnu/usr.bin/perl/ext/re/t/regop.t index f75e5413fff..54a197b3a1d 100644 --- a/gnu/usr.bin/perl/ext/re/t/regop.t +++ b/gnu/usr.bin/perl/ext/re/t/regop.t @@ -23,7 +23,7 @@ shift @tests plan( @tests + 2 + ( @strs - grep { !$_ or /^---/ } @strs )); is( scalar @tests, $NUM_SECTS, - "Expecting output for $NUM_SECTS patterns" ); + "Expecting output for $NUM_SECTS patterns, got ". scalar(@tests) ); ok( defined $out, 'regop.pl returned something defined' ); $out ||= ""; |