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