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