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