- HV *hv = (HV *) SvRV(ST(0));
-
- /* I don't care how many parameters were passed in, but I want to avoid
- the unused variable warning. */
-
- items = (I32)HvPLACEHOLDERS(hv);
-
- if (items) {
- HE *entry;
- I32 riter = HvRITER(hv);
- HE *eiter = HvEITER(hv);
- hv_iterinit(hv);
- /* This may look suboptimal with the items *after* the iternext, but
- it's quite deliberate. We only get here with items==0 if we've
- just deleted the last placeholder in the hash. If we've just done
- that then it means that the hash is in lazy delete mode, and the
- HE is now only referenced in our iterator. If we just quit the loop
- and discarded our iterator then the HE leaks. So we do the && the
- other way to ensure iternext is called just one more time, which
- has the side effect of triggering the lazy delete. */
- while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
- && items) {
- SV *val = hv_iterval(hv, entry);
-
- if (val == &PL_sv_undef) {
-
- /* It seems that I have to go back in the front of the hash
- API to delete a hash, even though I have a HE structure
- pointing to the very entry I want to delete, and could hold
- onto the previous HE that points to it. And it's easier to
- go in with SVs as I can then specify the precomputed hash,
- and don't have fun and games with utf8 keys. */
- SV *key = hv_iterkeysv(entry);
-
- hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
- items--;
- }
- }
- HvRITER(hv) = riter;
- HvEITER(hv) = eiter;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
+ else {
+ HV * const hv = (HV *) SvRV(ST(0));
+ hv_clear_placeholders(hv);
+ XSRETURN(0);
+ }
+}
+
+XS(XS_Regexp_DESTROY)
+{
+ PERL_UNUSED_ARG(cv);
+}
+
+XS(XS_PerlIO_get_layers)
+{
+ dXSARGS;
+ if (items < 1 || items % 2 == 0)
+ Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
+#ifdef USE_PERLIO
+ {
+ SV * sv;
+ GV * gv;
+ IO * io;
+ bool input = TRUE;
+ bool details = FALSE;
+
+ if (items > 1) {
+ SV * const *svp;
+ for (svp = MARK + 2; svp <= SP; svp += 2) {
+ SV * const * const varp = svp;
+ SV * const * const valp = svp + 1;
+ STRLEN klen;
+ const char * const key = SvPV_const(*varp, klen);
+
+ switch (*key) {
+ case 'i':
+ if (klen == 5 && memEQ(key, "input", 5)) {
+ input = SvTRUE(*valp);
+ break;
+ }
+ goto fail;
+ case 'o':
+ if (klen == 6 && memEQ(key, "output", 6)) {
+ input = !SvTRUE(*valp);
+ break;
+ }
+ goto fail;
+ case 'd':
+ if (klen == 7 && memEQ(key, "details", 7)) {
+ details = SvTRUE(*valp);
+ break;
+ }
+ goto fail;
+ default:
+ fail:
+ Perl_croak(aTHX_
+ "get_layers: unknown argument '%s'",
+ key);
+ }
+ }
+
+ SP -= (items - 1);
+ }
+
+ sv = POPs;
+ gv = (GV*)sv;
+
+ if (!isGV(sv)) {
+ if (SvROK(sv) && isGV(SvRV(sv)))
+ gv = (GV*)SvRV(sv);
+ else if (SvPOKp(sv))
+ gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
+ }
+
+ if (gv && (io = GvIO(gv))) {
+ dTARGET;
+ AV* const av = PerlIO_get_layers(aTHX_ input ?
+ IoIFP(io) : IoOFP(io));
+ I32 i;
+ const I32 last = av_len(av);
+ I32 nitem = 0;
+
+ for (i = last; i >= 0; i -= 3) {
+ SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
+ SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
+ SV * const * const flgsvp = av_fetch(av, i, FALSE);
+
+ const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
+ const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
+ const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
+
+ if (details) {
+ XPUSHs(namok
+ ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
+ : &PL_sv_undef);
+ XPUSHs(argok
+ ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
+ : &PL_sv_undef);
+ if (flgok)
+ XPUSHi(SvIVX(*flgsvp));
+ else
+ XPUSHs(&PL_sv_undef);
+ nitem += 3;
+ }
+ else {
+ if (namok && argok)
+ XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
+ *namsvp, *argsvp));
+ else if (namok)
+ XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
+ else
+ XPUSHs(&PL_sv_undef);
+ nitem++;
+ if (flgok) {
+ const IV flags = SvIVX(*flgsvp);
+
+ if (flags & PERLIO_F_UTF8) {
+ XPUSHs(newSVpvn("utf8", 4));
+ nitem++;
+ }
+ }
+ }
+ }
+
+ SvREFCNT_dec(av);
+
+ XSRETURN(nitem);
+ }