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