limit what add-package.pl might try to delete
[perl.git] / universal.c
1 /*    universal.c
2  *
3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4  *    2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * '"The roots of those mountains must be roots indeed; there must be
13  *   great secrets buried there which have not been discovered since the
14  *   beginning."'                   --Gandalf, relating Gollum's history
15  *
16  *     [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
17  */
18
19 /* This file contains the code that implements the functions in Perl's
20  * UNIVERSAL package, such as UNIVERSAL->can().
21  *
22  * It is also used to store XS functions that need to be present in
23  * miniperl for a lack of a better place to put them. It might be
24  * clever to move them to seperate XS files which would then be pulled
25  * in by some to-be-written build process.
26  */
27
28 #include "EXTERN.h"
29 #define PERL_IN_UNIVERSAL_C
30 #include "perl.h"
31
32 #ifdef USE_PERLIO
33 #include "perliol.h" /* For the PERLIO_F_XXX */
34 #endif
35
36 static HV *
37 S_get_isa_hash(pTHX_ HV *const stash)
38 {
39     dVAR;
40     struct mro_meta *const meta = HvMROMETA(stash);
41
42     PERL_ARGS_ASSERT_GET_ISA_HASH;
43
44     if (!meta->isa) {
45         AV *const isa = mro_get_linear_isa(stash);
46         if (!meta->isa) {
47             HV *const isa_hash = newHV();
48             /* Linearisation didn't build it for us, so do it here.  */
49             SV *const *svp = AvARRAY(isa);
50             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
51             const HEK *const canon_name = HvNAME_HEK(stash);
52
53             while (svp < svp_end) {
54                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
55             }
56
57             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
58                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
59                              HV_FETCH_ISSTORE, &PL_sv_undef,
60                              HEK_HASH(canon_name));
61             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
62
63             SvREADONLY_on(isa_hash);
64
65             meta->isa = isa_hash;
66         }
67     }
68     return meta->isa;
69 }
70
71 /*
72  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
73  * The main guts of traverse_isa was actually copied from gv_fetchmeth
74  */
75
76 STATIC bool
77 S_isa_lookup(pTHX_ HV *stash, const char * const name)
78 {
79     dVAR;
80     const struct mro_meta *const meta = HvMROMETA(stash);
81     HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
82     STRLEN len = strlen(name);
83     const HV *our_stash;
84
85     PERL_ARGS_ASSERT_ISA_LOOKUP;
86
87     if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
88                                              a char * argument*/,
89                   HV_FETCH_ISEXISTS, NULL, 0)) {
90         /* Direct name lookup worked.  */
91         return TRUE;
92     }
93
94     /* A stash/class can go by many names (ie. User == main::User), so 
95        we use the name in the stash itself, which is canonical.  */
96     our_stash = gv_stashpvn(name, len, 0);
97
98     if (our_stash) {
99         HEK *const canon_name = HvNAME_HEK(our_stash);
100
101         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
102                       HEK_FLAGS(canon_name),
103                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
104             return TRUE;
105         }
106     }
107
108     return FALSE;
109 }
110
111 /*
112 =head1 SV Manipulation Functions
113
114 =for apidoc sv_derived_from
115
116 Returns a boolean indicating whether the SV is derived from the specified class
117 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
118 normal Perl method.
119
120 =cut
121 */
122
123 bool
124 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
125 {
126     dVAR;
127     HV *stash;
128
129     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
130
131     SvGETMAGIC(sv);
132
133     if (SvROK(sv)) {
134         const char *type;
135         sv = SvRV(sv);
136         type = sv_reftype(sv,0);
137         if (type && strEQ(type,name))
138             return TRUE;
139         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
140     }
141     else {
142         stash = gv_stashsv(sv, 0);
143     }
144
145     return stash ? isa_lookup(stash, name) : FALSE;
146 }
147
148 /*
149 =for apidoc sv_does
150
151 Returns a boolean indicating whether the SV performs a specific, named role.
152 The SV can be a Perl object or the name of a Perl class.
153
154 =cut
155 */
156
157 #include "XSUB.h"
158
159 bool
160 Perl_sv_does(pTHX_ SV *sv, const char *name)
161 {
162     const char *classname;
163     bool does_it;
164     SV *methodname;
165     dSP;
166
167     PERL_ARGS_ASSERT_SV_DOES;
168
169     ENTER;
170     SAVETMPS;
171
172     SvGETMAGIC(sv);
173
174     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
175                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
176         return FALSE;
177
178     if (sv_isobject(sv)) {
179         classname = sv_reftype(SvRV(sv),TRUE);
180     } else {
181         classname = SvPV_nolen(sv);
182     }
183
184     if (strEQ(name,classname))
185         return TRUE;
186
187     PUSHMARK(SP);
188     XPUSHs(sv);
189     mXPUSHs(newSVpv(name, 0));
190     PUTBACK;
191
192     methodname = newSVpvs_flags("isa", SVs_TEMP);
193     /* ugly hack: use the SvSCREAM flag so S_method_common
194      * can figure out we're calling DOES() and not isa(),
195      * and report eventual errors correctly. --rgs */
196     SvSCREAM_on(methodname);
197     call_sv(methodname, G_SCALAR | G_METHOD);
198     SPAGAIN;
199
200     does_it = SvTRUE( TOPs );
201     FREETMPS;
202     LEAVE;
203
204     return does_it;
205 }
206
207 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
208 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
209 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
210 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
211 XS(XS_version_new);
212 XS(XS_version_stringify);
213 XS(XS_version_numify);
214 XS(XS_version_normal);
215 XS(XS_version_vcmp);
216 XS(XS_version_boolean);
217 #ifdef HASATTRIBUTE_NORETURN
218 XS(XS_version_noop) __attribute__noreturn__;
219 #else
220 XS(XS_version_noop);
221 #endif
222 XS(XS_version_is_alpha);
223 XS(XS_version_qv);
224 XS(XS_version_is_qv);
225 XS(XS_utf8_is_utf8);
226 XS(XS_utf8_valid);
227 XS(XS_utf8_encode);
228 XS(XS_utf8_decode);
229 XS(XS_utf8_upgrade);
230 XS(XS_utf8_downgrade);
231 XS(XS_utf8_unicode_to_native);
232 XS(XS_utf8_native_to_unicode);
233 XS(XS_Internals_SvREADONLY);
234 XS(XS_Internals_SvREFCNT);
235 XS(XS_Internals_hv_clear_placehold);
236 XS(XS_PerlIO_get_layers);
237 XS(XS_Regexp_DESTROY);
238 XS(XS_Internals_hash_seed);
239 XS(XS_Internals_rehash_seed);
240 XS(XS_Internals_HvREHASH);
241 XS(XS_re_is_regexp); 
242 XS(XS_re_regname);
243 XS(XS_re_regnames);
244 XS(XS_re_regnames_count);
245 XS(XS_re_regexp_pattern);
246 XS(XS_Tie_Hash_NamedCapture_FETCH);
247 XS(XS_Tie_Hash_NamedCapture_STORE);
248 XS(XS_Tie_Hash_NamedCapture_DELETE);
249 XS(XS_Tie_Hash_NamedCapture_CLEAR);
250 XS(XS_Tie_Hash_NamedCapture_EXISTS);
251 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
252 XS(XS_Tie_Hash_NamedCapture_NEXTK);
253 XS(XS_Tie_Hash_NamedCapture_SCALAR);
254 XS(XS_Tie_Hash_NamedCapture_flags);
255
256 void
257 Perl_boot_core_UNIVERSAL(pTHX)
258 {
259     dVAR;
260     static const char file[] = __FILE__;
261
262     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
263     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
264     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
265     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
266     {
267         /* register the overloading (type 'A') magic */
268         PL_amagic_generation++;
269         /* Make it findable via fetchmethod */
270         newXS("version::()", XS_version_noop, file);
271         newXS("version::new", XS_version_new, file);
272         newXS("version::parse", XS_version_new, file);
273         newXS("version::(\"\"", XS_version_stringify, file);
274         newXS("version::stringify", XS_version_stringify, file);
275         newXS("version::(0+", XS_version_numify, file);
276         newXS("version::numify", XS_version_numify, file);
277         newXS("version::normal", XS_version_normal, file);
278         newXS("version::(cmp", XS_version_vcmp, file);
279         newXS("version::(<=>", XS_version_vcmp, file);
280         newXS("version::vcmp", XS_version_vcmp, file);
281         newXS("version::(bool", XS_version_boolean, file);
282         newXS("version::boolean", XS_version_boolean, file);
283         newXS("version::(nomethod", XS_version_noop, file);
284         newXS("version::noop", XS_version_noop, file);
285         newXS("version::is_alpha", XS_version_is_alpha, file);
286         newXS("version::qv", XS_version_qv, file);
287         newXS("version::declare", XS_version_qv, file);
288         newXS("version::is_qv", XS_version_is_qv, file);
289     }
290     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
291     newXS("utf8::valid", XS_utf8_valid, file);
292     newXS("utf8::encode", XS_utf8_encode, file);
293     newXS("utf8::decode", XS_utf8_decode, file);
294     newXS("utf8::upgrade", XS_utf8_upgrade, file);
295     newXS("utf8::downgrade", XS_utf8_downgrade, file);
296     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
297     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
298     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
299     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
300     newXSproto("Internals::hv_clear_placeholders",
301                XS_Internals_hv_clear_placehold, file, "\\%");
302     newXSproto("PerlIO::get_layers",
303                XS_PerlIO_get_layers, file, "*;@");
304     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
305     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
306     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
307     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
308     newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
309     newXSproto("re::regname", XS_re_regname, file, ";$$");
310     newXSproto("re::regnames", XS_re_regnames, file, ";$");
311     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
312     newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
313     newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
314     newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
315     newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
316     newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
317     newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
318     newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
319     newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
320     newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
321     newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
322 }
323
324 /*
325 =for apidoc croak_xs_usage
326
327 A specialised variant of C<croak()> for emitting the usage message for xsubs
328
329     croak_xs_usage(cv, "eee_yow");
330
331 works out the package name and subroutine name from C<cv>, and then calls
332 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
333
334     Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
335
336 =cut
337 */
338
339 void
340 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
341 {
342     const GV *const gv = CvGV(cv);
343
344     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
345
346     if (gv) {
347         const char *const gvname = GvNAME(gv);
348         const HV *const stash = GvSTASH(gv);
349         const char *const hvname = stash ? HvNAME_get(stash) : NULL;
350
351         if (hvname)
352             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
353         else
354             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
355     } else {
356         /* Pants. I don't think that it should be possible to get here. */
357         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
358     }
359 }
360
361 XS(XS_UNIVERSAL_isa)
362 {
363     dVAR;
364     dXSARGS;
365
366     if (items != 2)
367         croak_xs_usage(cv, "reference, kind");
368     else {
369         SV * const sv = ST(0);
370         const char *name;
371
372         SvGETMAGIC(sv);
373
374         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
375                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
376             XSRETURN_UNDEF;
377
378         name = SvPV_nolen_const(ST(1));
379
380         ST(0) = boolSV(sv_derived_from(sv, name));
381         XSRETURN(1);
382     }
383 }
384
385 XS(XS_UNIVERSAL_can)
386 {
387     dVAR;
388     dXSARGS;
389     SV   *sv;
390     const char *name;
391     SV   *rv;
392     HV   *pkg = NULL;
393
394     if (items != 2)
395         croak_xs_usage(cv, "object-ref, method");
396
397     sv = ST(0);
398
399     SvGETMAGIC(sv);
400
401     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
402                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
403         XSRETURN_UNDEF;
404
405     name = SvPV_nolen_const(ST(1));
406     rv = &PL_sv_undef;
407
408     if (SvROK(sv)) {
409         sv = MUTABLE_SV(SvRV(sv));
410         if (SvOBJECT(sv))
411             pkg = SvSTASH(sv);
412     }
413     else {
414         pkg = gv_stashsv(sv, 0);
415     }
416
417     if (pkg) {
418         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
419         if (gv && isGV(gv))
420             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
421     }
422
423     ST(0) = rv;
424     XSRETURN(1);
425 }
426
427 XS(XS_UNIVERSAL_DOES)
428 {
429     dVAR;
430     dXSARGS;
431     PERL_UNUSED_ARG(cv);
432
433     if (items != 2)
434         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
435     else {
436         SV * const sv = ST(0);
437         const char *name;
438
439         name = SvPV_nolen_const(ST(1));
440         if (sv_does( sv, name ))
441             XSRETURN_YES;
442
443         XSRETURN_NO;
444     }
445 }
446
447 XS(XS_UNIVERSAL_VERSION)
448 {
449     dVAR;
450     dXSARGS;
451     HV *pkg;
452     GV **gvp;
453     GV *gv;
454     SV *sv;
455     const char *undef;
456     PERL_UNUSED_ARG(cv);
457
458     if (SvROK(ST(0))) {
459         sv = MUTABLE_SV(SvRV(ST(0)));
460         if (!SvOBJECT(sv))
461             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
462         pkg = SvSTASH(sv);
463     }
464     else {
465         pkg = gv_stashsv(ST(0), 0);
466     }
467
468     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
469
470     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
471         SV * const nsv = sv_newmortal();
472         sv_setsv(nsv, sv);
473         sv = nsv;
474         if ( !sv_derived_from(sv, "version"))
475             upg_version(sv, FALSE);
476         undef = NULL;
477     }
478     else {
479         sv = &PL_sv_undef;
480         undef = "(undef)";
481     }
482
483     if (items > 1) {
484         SV *req = ST(1);
485
486         if (undef) {
487             if (pkg) {
488                 const char * const name = HvNAME_get(pkg);
489                 Perl_croak(aTHX_
490                            "%s does not define $%s::VERSION--version check failed",
491                            name, name);
492             } else {
493                 Perl_croak(aTHX_
494                              "%s defines neither package nor VERSION--version check failed",
495                              SvPVx_nolen_const(ST(0)) );
496              }
497         }
498
499         if ( !sv_derived_from(req, "version")) {
500             /* req may very well be R/O, so create a new object */
501             req = sv_2mortal( new_version(req) );
502         }
503
504         if ( vcmp( req, sv ) > 0 ) {
505             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
506                 Perl_croak(aTHX_ "%s version %"SVf" required--"
507                        "this is only version %"SVf"", HvNAME_get(pkg),
508                        SVfARG(vnormal(req)),
509                        SVfARG(vnormal(sv)));
510             } else {
511                 Perl_croak(aTHX_ "%s version %"SVf" required--"
512                        "this is only version %"SVf"", HvNAME_get(pkg),
513                        SVfARG(vstringify(req)),
514                        SVfARG(vstringify(sv)));
515             }
516         }
517
518     }
519
520     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
521         ST(0) = vstringify(sv);
522     } else {
523         ST(0) = sv;
524     }
525
526     XSRETURN(1);
527 }
528
529 XS(XS_version_new)
530 {
531     dVAR;
532     dXSARGS;
533     if (items > 3)
534         croak_xs_usage(cv, "class, version");
535     SP -= items;
536     {
537         SV *vs = ST(1);
538         SV *rv;
539         const char * const classname =
540             sv_isobject(ST(0)) /* get the class if called as an object method */
541                 ? HvNAME(SvSTASH(SvRV(ST(0))))
542                 : (char *)SvPV_nolen(ST(0));
543
544         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
545             /* create empty object */
546             vs = sv_newmortal();
547             sv_setpvs(vs,"");
548         }
549         else if ( items == 3 ) {
550             vs = sv_newmortal();
551             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
552         }
553
554         rv = new_version(vs);
555         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
556             sv_bless(rv, gv_stashpv(classname, GV_ADD));
557
558         mPUSHs(rv);
559         PUTBACK;
560         return;
561     }
562 }
563
564 XS(XS_version_stringify)
565 {
566      dVAR;
567      dXSARGS;
568      if (items < 1)
569          croak_xs_usage(cv, "lobj, ...");
570      SP -= items;
571      {
572           SV *  lobj;
573
574           if (sv_derived_from(ST(0), "version")) {
575                lobj = SvRV(ST(0));
576           }
577           else
578                Perl_croak(aTHX_ "lobj is not of type version");
579
580           mPUSHs(vstringify(lobj));
581
582           PUTBACK;
583           return;
584      }
585 }
586
587 XS(XS_version_numify)
588 {
589      dVAR;
590      dXSARGS;
591      if (items < 1)
592          croak_xs_usage(cv, "lobj, ...");
593      SP -= items;
594      {
595           SV *  lobj;
596
597           if (sv_derived_from(ST(0), "version")) {
598                lobj = SvRV(ST(0));
599           }
600           else
601                Perl_croak(aTHX_ "lobj is not of type version");
602
603           mPUSHs(vnumify(lobj));
604
605           PUTBACK;
606           return;
607      }
608 }
609
610 XS(XS_version_normal)
611 {
612      dVAR;
613      dXSARGS;
614      if (items < 1)
615          croak_xs_usage(cv, "lobj, ...");
616      SP -= items;
617      {
618           SV *  lobj;
619
620           if (sv_derived_from(ST(0), "version")) {
621                lobj = SvRV(ST(0));
622           }
623           else
624                Perl_croak(aTHX_ "lobj is not of type version");
625
626           mPUSHs(vnormal(lobj));
627
628           PUTBACK;
629           return;
630      }
631 }
632
633 XS(XS_version_vcmp)
634 {
635      dVAR;
636      dXSARGS;
637      if (items < 1)
638          croak_xs_usage(cv, "lobj, ...");
639      SP -= items;
640      {
641           SV *  lobj;
642
643           if (sv_derived_from(ST(0), "version")) {
644                lobj = SvRV(ST(0));
645           }
646           else
647                Perl_croak(aTHX_ "lobj is not of type version");
648
649           {
650                SV       *rs;
651                SV       *rvs;
652                SV * robj = ST(1);
653                const IV  swap = (IV)SvIV(ST(2));
654
655                if ( ! sv_derived_from(robj, "version") )
656                {
657                     robj = new_version(robj);
658                }
659                rvs = SvRV(robj);
660
661                if ( swap )
662                {
663                     rs = newSViv(vcmp(rvs,lobj));
664                }
665                else
666                {
667                     rs = newSViv(vcmp(lobj,rvs));
668                }
669
670                mPUSHs(rs);
671           }
672
673           PUTBACK;
674           return;
675      }
676 }
677
678 XS(XS_version_boolean)
679 {
680     dVAR;
681     dXSARGS;
682     if (items < 1)
683         croak_xs_usage(cv, "lobj, ...");
684     SP -= items;
685     if (sv_derived_from(ST(0), "version")) {
686         SV * const lobj = SvRV(ST(0));
687         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
688         mPUSHs(rs);
689         PUTBACK;
690         return;
691     }
692     else
693         Perl_croak(aTHX_ "lobj is not of type version");
694 }
695
696 XS(XS_version_noop)
697 {
698     dVAR;
699     dXSARGS;
700     if (items < 1)
701         croak_xs_usage(cv, "lobj, ...");
702     if (sv_derived_from(ST(0), "version"))
703         Perl_croak(aTHX_ "operation not supported with version object");
704     else
705         Perl_croak(aTHX_ "lobj is not of type version");
706 #ifndef HASATTRIBUTE_NORETURN
707     XSRETURN_EMPTY;
708 #endif
709 }
710
711 XS(XS_version_is_alpha)
712 {
713     dVAR;
714     dXSARGS;
715     if (items != 1)
716         croak_xs_usage(cv, "lobj");
717     SP -= items;
718     if (sv_derived_from(ST(0), "version")) {
719         SV * const lobj = ST(0);
720         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
721             XSRETURN_YES;
722         else
723             XSRETURN_NO;
724         PUTBACK;
725         return;
726     }
727     else
728         Perl_croak(aTHX_ "lobj is not of type version");
729 }
730
731 XS(XS_version_qv)
732 {
733     dVAR;
734     dXSARGS;
735     PERL_UNUSED_ARG(cv);
736     SP -= items;
737     {
738         SV * ver = ST(0);
739         SV * rv;
740         const char * classname = "";
741         if ( items == 2 && (ST(1)) != &PL_sv_undef ) {
742             /* getting called as object or class method */
743             ver = ST(1);
744             classname = 
745                 sv_isobject(ST(0)) /* class called as an object method */
746                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
747                     : (char *)SvPV_nolen(ST(0));
748         }
749         if ( !SvVOK(ver) ) { /* not already a v-string */
750             rv = sv_newmortal();
751             sv_setsv(rv,ver); /* make a duplicate */
752             upg_version(rv, TRUE);
753         } else {
754             rv = sv_2mortal(new_version(ver));
755         }
756         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
757             sv_bless(rv, gv_stashpv(classname, GV_ADD));
758         }
759         PUSHs(rv);
760     }
761     PUTBACK;
762     return;
763 }
764
765 XS(XS_version_is_qv)
766 {
767     dVAR;
768     dXSARGS;
769     if (items != 1)
770         croak_xs_usage(cv, "lobj");
771     SP -= items;
772     if (sv_derived_from(ST(0), "version")) {
773         SV * const lobj = ST(0);
774         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
775             XSRETURN_YES;
776         else
777             XSRETURN_NO;
778         PUTBACK;
779         return;
780     }
781     else
782         Perl_croak(aTHX_ "lobj is not of type version");
783 }
784
785 XS(XS_utf8_is_utf8)
786 {
787      dVAR;
788      dXSARGS;
789      if (items != 1)
790          croak_xs_usage(cv, "sv");
791      else {
792         const SV * const sv = ST(0);
793             if (SvUTF8(sv))
794                 XSRETURN_YES;
795             else
796                 XSRETURN_NO;
797      }
798      XSRETURN_EMPTY;
799 }
800
801 XS(XS_utf8_valid)
802 {
803      dVAR;
804      dXSARGS;
805      if (items != 1)
806          croak_xs_usage(cv, "sv");
807     else {
808         SV * const sv = ST(0);
809         STRLEN len;
810         const char * const s = SvPV_const(sv,len);
811         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
812             XSRETURN_YES;
813         else
814             XSRETURN_NO;
815     }
816      XSRETURN_EMPTY;
817 }
818
819 XS(XS_utf8_encode)
820 {
821     dVAR;
822     dXSARGS;
823     if (items != 1)
824         croak_xs_usage(cv, "sv");
825     sv_utf8_encode(ST(0));
826     XSRETURN_EMPTY;
827 }
828
829 XS(XS_utf8_decode)
830 {
831     dVAR;
832     dXSARGS;
833     if (items != 1)
834         croak_xs_usage(cv, "sv");
835     else {
836         SV * const sv = ST(0);
837         const bool RETVAL = sv_utf8_decode(sv);
838         ST(0) = boolSV(RETVAL);
839         sv_2mortal(ST(0));
840     }
841     XSRETURN(1);
842 }
843
844 XS(XS_utf8_upgrade)
845 {
846     dVAR;
847     dXSARGS;
848     if (items != 1)
849         croak_xs_usage(cv, "sv");
850     else {
851         SV * const sv = ST(0);
852         STRLEN  RETVAL;
853         dXSTARG;
854
855         RETVAL = sv_utf8_upgrade(sv);
856         XSprePUSH; PUSHi((IV)RETVAL);
857     }
858     XSRETURN(1);
859 }
860
861 XS(XS_utf8_downgrade)
862 {
863     dVAR;
864     dXSARGS;
865     if (items < 1 || items > 2)
866         croak_xs_usage(cv, "sv, failok=0");
867     else {
868         SV * const sv = ST(0);
869         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
870         const bool RETVAL = sv_utf8_downgrade(sv, failok);
871
872         ST(0) = boolSV(RETVAL);
873         sv_2mortal(ST(0));
874     }
875     XSRETURN(1);
876 }
877
878 XS(XS_utf8_native_to_unicode)
879 {
880  dVAR;
881  dXSARGS;
882  const UV uv = SvUV(ST(0));
883
884  if (items > 1)
885      croak_xs_usage(cv, "sv");
886
887  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
888  XSRETURN(1);
889 }
890
891 XS(XS_utf8_unicode_to_native)
892 {
893  dVAR;
894  dXSARGS;
895  const UV uv = SvUV(ST(0));
896
897  if (items > 1)
898      croak_xs_usage(cv, "sv");
899
900  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
901  XSRETURN(1);
902 }
903
904 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
905 {
906     dVAR;
907     dXSARGS;
908     SV * const sv = SvRV(ST(0));
909     PERL_UNUSED_ARG(cv);
910
911     if (items == 1) {
912          if (SvREADONLY(sv))
913              XSRETURN_YES;
914          else
915              XSRETURN_NO;
916     }
917     else if (items == 2) {
918         if (SvTRUE(ST(1))) {
919             SvREADONLY_on(sv);
920             XSRETURN_YES;
921         }
922         else {
923             /* I hope you really know what you are doing. */
924             SvREADONLY_off(sv);
925             XSRETURN_NO;
926         }
927     }
928     XSRETURN_UNDEF; /* Can't happen. */
929 }
930
931 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
932 {
933     dVAR;
934     dXSARGS;
935     SV * const sv = SvRV(ST(0));
936     PERL_UNUSED_ARG(cv);
937
938     if (items == 1)
939          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
940     else if (items == 2) {
941          /* I hope you really know what you are doing. */
942          SvREFCNT(sv) = SvIV(ST(1));
943          XSRETURN_IV(SvREFCNT(sv));
944     }
945     XSRETURN_UNDEF; /* Can't happen. */
946 }
947
948 XS(XS_Internals_hv_clear_placehold)
949 {
950     dVAR;
951     dXSARGS;
952
953     if (items != 1)
954         croak_xs_usage(cv, "hv");
955     else {
956         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
957         hv_clear_placeholders(hv);
958         XSRETURN(0);
959     }
960 }
961
962 XS(XS_Regexp_DESTROY)
963 {
964     PERL_UNUSED_CONTEXT;
965     PERL_UNUSED_ARG(cv);
966 }
967
968 XS(XS_PerlIO_get_layers)
969 {
970     dVAR;
971     dXSARGS;
972     if (items < 1 || items % 2 == 0)
973         croak_xs_usage(cv, "filehandle[,args]");
974 #ifdef USE_PERLIO
975     {
976         SV *    sv;
977         GV *    gv;
978         IO *    io;
979         bool    input = TRUE;
980         bool    details = FALSE;
981
982         if (items > 1) {
983              SV * const *svp;
984              for (svp = MARK + 2; svp <= SP; svp += 2) {
985                   SV * const * const varp = svp;
986                   SV * const * const valp = svp + 1;
987                   STRLEN klen;
988                   const char * const key = SvPV_const(*varp, klen);
989
990                   switch (*key) {
991                   case 'i':
992                        if (klen == 5 && memEQ(key, "input", 5)) {
993                             input = SvTRUE(*valp);
994                             break;
995                        }
996                        goto fail;
997                   case 'o': 
998                        if (klen == 6 && memEQ(key, "output", 6)) {
999                             input = !SvTRUE(*valp);
1000                             break;
1001                        }
1002                        goto fail;
1003                   case 'd':
1004                        if (klen == 7 && memEQ(key, "details", 7)) {
1005                             details = SvTRUE(*valp);
1006                             break;
1007                        }
1008                        goto fail;
1009                   default:
1010                   fail:
1011                        Perl_croak(aTHX_
1012                                   "get_layers: unknown argument '%s'",
1013                                   key);
1014                   }
1015              }
1016
1017              SP -= (items - 1);
1018         }
1019
1020         sv = POPs;
1021         gv = MUTABLE_GV(sv);
1022
1023         if (!isGV(sv)) {
1024              if (SvROK(sv) && isGV(SvRV(sv)))
1025                   gv = MUTABLE_GV(SvRV(sv));
1026              else if (SvPOKp(sv))
1027                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1028         }
1029
1030         if (gv && (io = GvIO(gv))) {
1031              AV* const av = PerlIO_get_layers(aTHX_ input ?
1032                                         IoIFP(io) : IoOFP(io));
1033              I32 i;
1034              const I32 last = av_len(av);
1035              I32 nitem = 0;
1036              
1037              for (i = last; i >= 0; i -= 3) {
1038                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1039                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1040                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1041
1042                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1043                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1044                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1045
1046                   if (details) {
1047                        XPUSHs(namok
1048                               ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
1049                               : &PL_sv_undef);
1050                        XPUSHs(argok
1051                               ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
1052                               : &PL_sv_undef);
1053                        if (flgok)
1054                             mXPUSHi(SvIVX(*flgsvp));
1055                        else
1056                             XPUSHs(&PL_sv_undef);
1057                        nitem += 3;
1058                   }
1059                   else {
1060                        if (namok && argok)
1061                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1062                                                  SVfARG(*namsvp),
1063                                                  SVfARG(*argsvp))));
1064                        else if (namok)
1065                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
1066                                                  SVfARG(*namsvp))));
1067                        else
1068                             XPUSHs(&PL_sv_undef);
1069                        nitem++;
1070                        if (flgok) {
1071                             const IV flags = SvIVX(*flgsvp);
1072
1073                             if (flags & PERLIO_F_UTF8) {
1074                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1075                                  nitem++;
1076                             }
1077                        }
1078                   }
1079              }
1080
1081              SvREFCNT_dec(av);
1082
1083              XSRETURN(nitem);
1084         }
1085     }
1086 #endif
1087
1088     XSRETURN(0);
1089 }
1090
1091 XS(XS_Internals_hash_seed)
1092 {
1093     dVAR;
1094     /* Using dXSARGS would also have dITEM and dSP,
1095      * which define 2 unused local variables.  */
1096     dAXMARK;
1097     PERL_UNUSED_ARG(cv);
1098     PERL_UNUSED_VAR(mark);
1099     XSRETURN_UV(PERL_HASH_SEED);
1100 }
1101
1102 XS(XS_Internals_rehash_seed)
1103 {
1104     dVAR;
1105     /* Using dXSARGS would also have dITEM and dSP,
1106      * which define 2 unused local variables.  */
1107     dAXMARK;
1108     PERL_UNUSED_ARG(cv);
1109     PERL_UNUSED_VAR(mark);
1110     XSRETURN_UV(PL_rehash_seed);
1111 }
1112
1113 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1114 {
1115     dVAR;
1116     dXSARGS;
1117     PERL_UNUSED_ARG(cv);
1118     if (SvROK(ST(0))) {
1119         const HV * const hv = (const HV *) SvRV(ST(0));
1120         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1121             if (HvREHASH(hv))
1122                 XSRETURN_YES;
1123             else
1124                 XSRETURN_NO;
1125         }
1126     }
1127     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1128 }
1129
1130 XS(XS_re_is_regexp)
1131 {
1132     dVAR; 
1133     dXSARGS;
1134     PERL_UNUSED_VAR(cv);
1135
1136     if (items != 1)
1137         croak_xs_usage(cv, "sv");
1138
1139     SP -= items;
1140
1141     if (SvRXOK(ST(0))) {
1142         XSRETURN_YES;
1143     } else {
1144         XSRETURN_NO;
1145     }
1146 }
1147
1148 XS(XS_re_regnames_count)
1149 {
1150     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1151     SV * ret;
1152     dVAR; 
1153     dXSARGS;
1154
1155     if (items != 0)
1156         croak_xs_usage(cv, "");
1157
1158     SP -= items;
1159
1160     if (!rx)
1161         XSRETURN_UNDEF;
1162
1163     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1164
1165     SPAGAIN;
1166
1167     if (ret) {
1168         mXPUSHs(ret);
1169         PUTBACK;
1170         return;
1171     } else {
1172         XSRETURN_UNDEF;
1173     }
1174 }
1175
1176 XS(XS_re_regname)
1177 {
1178     dVAR;
1179     dXSARGS;
1180     REGEXP * rx;
1181     U32 flags;
1182     SV * ret;
1183
1184     if (items < 1 || items > 2)
1185         croak_xs_usage(cv, "name[, all ]");
1186
1187     SP -= items;
1188
1189     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1190
1191     if (!rx)
1192         XSRETURN_UNDEF;
1193
1194     if (items == 2 && SvTRUE(ST(1))) {
1195         flags = RXapif_ALL;
1196     } else {
1197         flags = RXapif_ONE;
1198     }
1199     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1200
1201     if (ret) {
1202         mXPUSHs(ret);
1203         XSRETURN(1);
1204     }
1205     XSRETURN_UNDEF;    
1206 }
1207
1208
1209 XS(XS_re_regnames)
1210 {
1211     dVAR;
1212     dXSARGS;
1213     REGEXP * rx;
1214     U32 flags;
1215     SV *ret;
1216     AV *av;
1217     I32 length;
1218     I32 i;
1219     SV **entry;
1220
1221     if (items > 1)
1222         croak_xs_usage(cv, "[all]");
1223
1224     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1225
1226     if (!rx)
1227         XSRETURN_UNDEF;
1228
1229     if (items == 1 && SvTRUE(ST(0))) {
1230         flags = RXapif_ALL;
1231     } else {
1232         flags = RXapif_ONE;
1233     }
1234
1235     SP -= items;
1236
1237     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1238
1239     SPAGAIN;
1240
1241     SP -= items;
1242
1243     if (!ret)
1244         XSRETURN_UNDEF;
1245
1246     av = MUTABLE_AV(SvRV(ret));
1247     length = av_len(av);
1248
1249     for (i = 0; i <= length; i++) {
1250         entry = av_fetch(av, i, FALSE);
1251         
1252         if (!entry)
1253             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1254
1255         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1256     }
1257
1258     SvREFCNT_dec(ret);
1259
1260     PUTBACK;
1261     return;
1262 }
1263
1264 XS(XS_re_regexp_pattern)
1265 {
1266     dVAR;
1267     dXSARGS;
1268     REGEXP *re;
1269
1270     if (items != 1)
1271         croak_xs_usage(cv, "sv");
1272
1273     SP -= items;
1274
1275     /*
1276        Checks if a reference is a regex or not. If the parameter is
1277        not a ref, or is not the result of a qr// then returns false
1278        in scalar context and an empty list in list context.
1279        Otherwise in list context it returns the pattern and the
1280        modifiers, in scalar context it returns the pattern just as it
1281        would if the qr// was stringified normally, regardless as
1282        to the class of the variable and any strigification overloads
1283        on the object.
1284     */
1285
1286     if ((re = SvRX(ST(0)))) /* assign deliberate */
1287     {
1288         /* Housten, we have a regex! */
1289         SV *pattern;
1290         STRLEN left = 0;
1291         char reflags[6];
1292
1293         if ( GIMME_V == G_ARRAY ) {
1294             /*
1295                we are in list context so stringify
1296                the modifiers that apply. We ignore "negative
1297                modifiers" in this scenario.
1298             */
1299
1300             const char *fptr = INT_PAT_MODS;
1301             char ch;
1302             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1303                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1304
1305             while((ch = *fptr++)) {
1306                 if(match_flags & 1) {
1307                     reflags[left++] = ch;
1308                 }
1309                 match_flags >>= 1;
1310             }
1311
1312             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1313                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1314
1315             /* return the pattern and the modifiers */
1316             XPUSHs(pattern);
1317             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1318             XSRETURN(2);
1319         } else {
1320             /* Scalar, so use the string that Perl would return */
1321             /* return the pattern in (?msix:..) format */
1322 #if PERL_VERSION >= 11
1323             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1324 #else
1325             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1326                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1327 #endif
1328             XPUSHs(pattern);
1329             XSRETURN(1);
1330         }
1331     } else {
1332         /* It ain't a regexp folks */
1333         if ( GIMME_V == G_ARRAY ) {
1334             /* return the empty list */
1335             XSRETURN_UNDEF;
1336         } else {
1337             /* Because of the (?:..) wrapping involved in a
1338                stringified pattern it is impossible to get a
1339                result for a real regexp that would evaluate to
1340                false. Therefore we can return PL_sv_no to signify
1341                that the object is not a regex, this means that one
1342                can say
1343
1344                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1345
1346                and not worry about undefined values.
1347             */
1348             XSRETURN_NO;
1349         }
1350     }
1351     /* NOT-REACHED */
1352 }
1353
1354 XS(XS_Tie_Hash_NamedCapture_FETCH)
1355 {
1356     dVAR;
1357     dXSARGS;
1358     REGEXP * rx;
1359     U32 flags;
1360     SV * ret;
1361
1362     if (items != 2)
1363         croak_xs_usage(cv, "$key, $flags");
1364
1365     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1366
1367     if (!rx)
1368         XSRETURN_UNDEF;
1369
1370     SP -= items;
1371
1372     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1373     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1374
1375     SPAGAIN;
1376
1377     if (ret) {
1378         mXPUSHs(ret);
1379         PUTBACK;
1380         return;
1381     }
1382     XSRETURN_UNDEF;
1383 }
1384
1385 XS(XS_Tie_Hash_NamedCapture_STORE)
1386 {
1387     dVAR;
1388     dXSARGS;
1389     REGEXP * rx;
1390     U32 flags;
1391
1392     if (items != 3)
1393         croak_xs_usage(cv, "$key, $value, $flags");
1394
1395     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1396
1397     if (!rx) {
1398         if (!PL_localizing)
1399             Perl_croak(aTHX_ "%s", PL_no_modify);
1400         else
1401             XSRETURN_UNDEF;
1402     }
1403
1404     SP -= items;
1405
1406     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1407     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1408 }
1409
1410 XS(XS_Tie_Hash_NamedCapture_DELETE)
1411 {
1412     dVAR;
1413     dXSARGS;
1414     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1415     U32 flags;
1416
1417     if (items != 2)
1418         croak_xs_usage(cv, "$key, $flags");
1419
1420     if (!rx)
1421         Perl_croak(aTHX_ "%s", PL_no_modify);
1422
1423     SP -= items;
1424
1425     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1426     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1427 }
1428
1429 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1430 {
1431     dVAR;
1432     dXSARGS;
1433     REGEXP * rx;
1434     U32 flags;
1435
1436     if (items != 1)
1437         croak_xs_usage(cv, "$flags");
1438
1439     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1440
1441     if (!rx)
1442         Perl_croak(aTHX_ "%s", PL_no_modify);
1443
1444     SP -= items;
1445
1446     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1447     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1448 }
1449
1450 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1451 {
1452     dVAR;
1453     dXSARGS;
1454     REGEXP * rx;
1455     U32 flags;
1456     SV * ret;
1457
1458     if (items != 2)
1459         croak_xs_usage(cv, "$key, $flags");
1460
1461     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1462
1463     if (!rx)
1464         XSRETURN_UNDEF;
1465
1466     SP -= items;
1467
1468     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1469     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1470
1471     SPAGAIN;
1472
1473         XPUSHs(ret);
1474         PUTBACK;
1475         return;
1476 }
1477
1478 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1479 {
1480     dVAR;
1481     dXSARGS;
1482     REGEXP * rx;
1483     U32 flags;
1484     SV * ret;
1485
1486     if (items != 1)
1487         croak_xs_usage(cv, "");
1488
1489     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1490
1491     if (!rx)
1492         XSRETURN_UNDEF;
1493
1494     SP -= items;
1495
1496     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1497     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1498
1499     SPAGAIN;
1500
1501     if (ret) {
1502         mXPUSHs(ret);
1503         PUTBACK;
1504     } else {
1505         XSRETURN_UNDEF;
1506     }
1507
1508 }
1509
1510 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1511 {
1512     dVAR;
1513     dXSARGS;
1514     REGEXP * rx;
1515     U32 flags;
1516     SV * ret;
1517
1518     if (items != 2)
1519         croak_xs_usage(cv, "$lastkey");
1520
1521     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1522
1523     if (!rx)
1524         XSRETURN_UNDEF;
1525
1526     SP -= items;
1527
1528     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1529     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1530
1531     SPAGAIN;
1532
1533     if (ret) {
1534         mXPUSHs(ret);
1535     } else {
1536         XSRETURN_UNDEF;
1537     }  
1538     PUTBACK;
1539 }
1540
1541 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1542 {
1543     dVAR;
1544     dXSARGS;
1545     REGEXP * rx;
1546     U32 flags;
1547     SV * ret;
1548
1549     if (items != 1)
1550         croak_xs_usage(cv, "");
1551
1552     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1553
1554     if (!rx)
1555         XSRETURN_UNDEF;
1556
1557     SP -= items;
1558
1559     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1560     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1561
1562     SPAGAIN;
1563
1564     if (ret) {
1565         mXPUSHs(ret);
1566         PUTBACK;
1567         return;
1568     } else {
1569         XSRETURN_UNDEF;
1570     }
1571 }
1572
1573 XS(XS_Tie_Hash_NamedCapture_flags)
1574 {
1575     dVAR;
1576     dXSARGS;
1577
1578     if (items != 0)
1579         croak_xs_usage(cv, "");
1580
1581         mXPUSHu(RXapif_ONE);
1582         mXPUSHu(RXapif_ALL);
1583         PUTBACK;
1584         return;
1585 }
1586
1587
1588 /*
1589  * Local variables:
1590  * c-indentation-style: bsd
1591  * c-basic-offset: 4
1592  * indent-tabs-mode: t
1593  * End:
1594  *
1595  * ex: set ts=8 sts=4 sw=4 noet:
1596  */