This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Tweaks so that miniperl.exe doesnt croak while building perl.exe
[perl5.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);
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             SV * const nsv = sv_newmortal();
487             sv_setsv(nsv, req);
488             req = nsv;
489             upg_version(req);
490         }
491
492         if ( vcmp( req, sv ) > 0 )
493             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
494                        "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
495                        SVfARG(vnumify(req)),
496                        SVfARG(vnormal(req)),
497                        SVfARG(vnumify(sv)),
498                        SVfARG(vnormal(sv)));
499     }
500
501     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
502         ST(0) = vnumify(sv);
503     } else {
504         ST(0) = sv;
505     }
506
507     XSRETURN(1);
508 }
509
510 XS(XS_version_new)
511 {
512     dVAR;
513     dXSARGS;
514     PERL_UNUSED_ARG(cv);
515     if (items > 3)
516         Perl_croak(aTHX_ "Usage: version::new(class, version)");
517     SP -= items;
518     {
519         SV *vs = ST(1);
520         SV *rv;
521         const char * const classname =
522             sv_isobject(ST(0)) /* get the class if called as an object method */
523                 ? HvNAME(SvSTASH(SvRV(ST(0))))
524                 : (char *)SvPV_nolen(ST(0));
525
526         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
527             /* create empty object */
528             vs = sv_newmortal();
529             sv_setpvn(vs,"",0);
530         }
531         else if ( items == 3 ) {
532             vs = sv_newmortal();
533             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
534         }
535
536         rv = new_version(vs);
537         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
538             sv_bless(rv, gv_stashpv(classname, GV_ADD));
539
540         PUSHs(sv_2mortal(rv));
541         PUTBACK;
542         return;
543     }
544 }
545
546 XS(XS_version_stringify)
547 {
548      dVAR;
549      dXSARGS;
550      PERL_UNUSED_ARG(cv);
551      if (items < 1)
552           Perl_croak(aTHX_ "Usage: version::stringify(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           PUSHs(sv_2mortal(vstringify(lobj)));
564
565           PUTBACK;
566           return;
567      }
568 }
569
570 XS(XS_version_numify)
571 {
572      dVAR;
573      dXSARGS;
574      PERL_UNUSED_ARG(cv);
575      if (items < 1)
576           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
577      SP -= items;
578      {
579           SV *  lobj;
580
581           if (sv_derived_from(ST(0), "version")) {
582                lobj = SvRV(ST(0));
583           }
584           else
585                Perl_croak(aTHX_ "lobj is not of type version");
586
587           PUSHs(sv_2mortal(vnumify(lobj)));
588
589           PUTBACK;
590           return;
591      }
592 }
593
594 XS(XS_version_normal)
595 {
596      dVAR;
597      dXSARGS;
598      PERL_UNUSED_ARG(cv);
599      if (items < 1)
600           Perl_croak(aTHX_ "Usage: version::normal(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           PUSHs(sv_2mortal(vnormal(lobj)));
612
613           PUTBACK;
614           return;
615      }
616 }
617
618 XS(XS_version_vcmp)
619 {
620      dVAR;
621      dXSARGS;
622      PERL_UNUSED_ARG(cv);
623      if (items < 1)
624           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
625      SP -= items;
626      {
627           SV *  lobj;
628
629           if (sv_derived_from(ST(0), "version")) {
630                lobj = SvRV(ST(0));
631           }
632           else
633                Perl_croak(aTHX_ "lobj is not of type version");
634
635           {
636                SV       *rs;
637                SV       *rvs;
638                SV * robj = ST(1);
639                const IV  swap = (IV)SvIV(ST(2));
640
641                if ( ! sv_derived_from(robj, "version") )
642                {
643                     robj = new_version(robj);
644                }
645                rvs = SvRV(robj);
646
647                if ( swap )
648                {
649                     rs = newSViv(vcmp(rvs,lobj));
650                }
651                else
652                {
653                     rs = newSViv(vcmp(lobj,rvs));
654                }
655
656                PUSHs(sv_2mortal(rs));
657           }
658
659           PUTBACK;
660           return;
661      }
662 }
663
664 XS(XS_version_boolean)
665 {
666     dVAR;
667     dXSARGS;
668     PERL_UNUSED_ARG(cv);
669     if (items < 1)
670         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
671     SP -= items;
672     if (sv_derived_from(ST(0), "version")) {
673         SV * const lobj = SvRV(ST(0));
674         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
675         PUSHs(sv_2mortal(rs));
676         PUTBACK;
677         return;
678     }
679     else
680         Perl_croak(aTHX_ "lobj is not of type version");
681 }
682
683 XS(XS_version_noop)
684 {
685     dVAR;
686     dXSARGS;
687     PERL_UNUSED_ARG(cv);
688     if (items < 1)
689         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
690     if (sv_derived_from(ST(0), "version"))
691         Perl_croak(aTHX_ "operation not supported with version object");
692     else
693         Perl_croak(aTHX_ "lobj is not of type version");
694 #ifndef HASATTRIBUTE_NORETURN
695     XSRETURN_EMPTY;
696 #endif
697 }
698
699 XS(XS_version_is_alpha)
700 {
701     dVAR;
702     dXSARGS;
703     PERL_UNUSED_ARG(cv);
704     if (items != 1)
705         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
706     SP -= items;
707     if (sv_derived_from(ST(0), "version")) {
708         SV * const lobj = ST(0);
709         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
710             XSRETURN_YES;
711         else
712             XSRETURN_NO;
713         PUTBACK;
714         return;
715     }
716     else
717         Perl_croak(aTHX_ "lobj is not of type version");
718 }
719
720 XS(XS_version_qv)
721 {
722     dVAR;
723     dXSARGS;
724     PERL_UNUSED_ARG(cv);
725     if (items != 1)
726         Perl_croak(aTHX_ "Usage: version::qv(ver)");
727     SP -= items;
728     {
729         SV *    ver = ST(0);
730         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
731             SV * const vs = sv_newmortal();
732             char *version;
733             if ( SvNOK(ver) ) /* may get too much accuracy */
734             {
735                 char tbuf[64];
736 #ifdef USE_LOCALE_NUMERIC
737                 char *loc = setlocale(LC_NUMERIC, "C");
738 #endif
739                 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
740 #ifdef USE_LOCALE_NUMERIC
741                 setlocale(LC_NUMERIC, loc);
742 #endif
743                 while (tbuf[len-1] == '0' && len > 0) len--;
744                 version = savepvn(tbuf, len);
745             }
746             else
747             {
748                 version = savesvpv(ver);
749             }
750             (void)scan_version(version,vs,TRUE);
751             Safefree(version);
752
753             PUSHs(vs);
754         }
755         else
756         {
757             PUSHs(sv_2mortal(new_version(ver)));
758         }
759
760         PUTBACK;
761         return;
762     }
763 }
764
765 XS(XS_utf8_is_utf8)
766 {
767      dVAR;
768      dXSARGS;
769      PERL_UNUSED_ARG(cv);
770      if (items != 1)
771           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
772      else {
773         const SV * const sv = ST(0);
774             if (SvUTF8(sv))
775                 XSRETURN_YES;
776             else
777                 XSRETURN_NO;
778      }
779      XSRETURN_EMPTY;
780 }
781
782 XS(XS_utf8_valid)
783 {
784      dVAR;
785      dXSARGS;
786      PERL_UNUSED_ARG(cv);
787      if (items != 1)
788           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
789     else {
790         SV * const sv = ST(0);
791         STRLEN len;
792         const char * const s = SvPV_const(sv,len);
793         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
794             XSRETURN_YES;
795         else
796             XSRETURN_NO;
797     }
798      XSRETURN_EMPTY;
799 }
800
801 XS(XS_utf8_encode)
802 {
803     dVAR;
804     dXSARGS;
805     PERL_UNUSED_ARG(cv);
806     if (items != 1)
807         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
808     sv_utf8_encode(ST(0));
809     XSRETURN_EMPTY;
810 }
811
812 XS(XS_utf8_decode)
813 {
814     dVAR;
815     dXSARGS;
816     PERL_UNUSED_ARG(cv);
817     if (items != 1)
818         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
819     else {
820         SV * const sv = ST(0);
821         const bool RETVAL = sv_utf8_decode(sv);
822         ST(0) = boolSV(RETVAL);
823         sv_2mortal(ST(0));
824     }
825     XSRETURN(1);
826 }
827
828 XS(XS_utf8_upgrade)
829 {
830     dVAR;
831     dXSARGS;
832     PERL_UNUSED_ARG(cv);
833     if (items != 1)
834         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
835     else {
836         SV * const sv = ST(0);
837         STRLEN  RETVAL;
838         dXSTARG;
839
840         RETVAL = sv_utf8_upgrade(sv);
841         XSprePUSH; PUSHi((IV)RETVAL);
842     }
843     XSRETURN(1);
844 }
845
846 XS(XS_utf8_downgrade)
847 {
848     dVAR;
849     dXSARGS;
850     PERL_UNUSED_ARG(cv);
851     if (items < 1 || items > 2)
852         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
853     else {
854         SV * const sv = ST(0);
855         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
856         const bool RETVAL = sv_utf8_downgrade(sv, failok);
857
858         ST(0) = boolSV(RETVAL);
859         sv_2mortal(ST(0));
860     }
861     XSRETURN(1);
862 }
863
864 XS(XS_utf8_native_to_unicode)
865 {
866  dVAR;
867  dXSARGS;
868  const UV uv = SvUV(ST(0));
869  PERL_UNUSED_ARG(cv);
870
871  if (items > 1)
872      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
873
874  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
875  XSRETURN(1);
876 }
877
878 XS(XS_utf8_unicode_to_native)
879 {
880  dVAR;
881  dXSARGS;
882  const UV uv = SvUV(ST(0));
883  PERL_UNUSED_ARG(cv);
884
885  if (items > 1)
886      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
887
888  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
889  XSRETURN(1);
890 }
891
892 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
893 {
894     dVAR;
895     dXSARGS;
896     SV * const sv = SvRV(ST(0));
897     PERL_UNUSED_ARG(cv);
898
899     if (items == 1) {
900          if (SvREADONLY(sv))
901              XSRETURN_YES;
902          else
903              XSRETURN_NO;
904     }
905     else if (items == 2) {
906         if (SvTRUE(ST(1))) {
907             SvREADONLY_on(sv);
908             XSRETURN_YES;
909         }
910         else {
911             /* I hope you really know what you are doing. */
912             SvREADONLY_off(sv);
913             XSRETURN_NO;
914         }
915     }
916     XSRETURN_UNDEF; /* Can't happen. */
917 }
918
919 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
920 {
921     dVAR;
922     dXSARGS;
923     SV * const sv = SvRV(ST(0));
924     PERL_UNUSED_ARG(cv);
925
926     if (items == 1)
927          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
928     else if (items == 2) {
929          /* I hope you really know what you are doing. */
930          SvREFCNT(sv) = SvIV(ST(1));
931          XSRETURN_IV(SvREFCNT(sv));
932     }
933     XSRETURN_UNDEF; /* Can't happen. */
934 }
935
936 XS(XS_Internals_hv_clear_placehold)
937 {
938     dVAR;
939     dXSARGS;
940     PERL_UNUSED_ARG(cv);
941
942     if (items != 1)
943         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
944     else {
945         HV * const hv = (HV *) SvRV(ST(0));
946         hv_clear_placeholders(hv);
947         XSRETURN(0);
948     }
949 }
950
951 XS(XS_Regexp_DESTROY)
952 {
953     PERL_UNUSED_CONTEXT;
954     PERL_UNUSED_ARG(cv);
955 }
956
957 XS(XS_PerlIO_get_layers)
958 {
959     dVAR;
960     dXSARGS;
961     PERL_UNUSED_ARG(cv);
962     if (items < 1 || items % 2 == 0)
963         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
964 #ifdef USE_PERLIO
965     {
966         SV *    sv;
967         GV *    gv;
968         IO *    io;
969         bool    input = TRUE;
970         bool    details = FALSE;
971
972         if (items > 1) {
973              SV * const *svp;
974              for (svp = MARK + 2; svp <= SP; svp += 2) {
975                   SV * const * const varp = svp;
976                   SV * const * const valp = svp + 1;
977                   STRLEN klen;
978                   const char * const key = SvPV_const(*varp, klen);
979
980                   switch (*key) {
981                   case 'i':
982                        if (klen == 5 && memEQ(key, "input", 5)) {
983                             input = SvTRUE(*valp);
984                             break;
985                        }
986                        goto fail;
987                   case 'o': 
988                        if (klen == 6 && memEQ(key, "output", 6)) {
989                             input = !SvTRUE(*valp);
990                             break;
991                        }
992                        goto fail;
993                   case 'd':
994                        if (klen == 7 && memEQ(key, "details", 7)) {
995                             details = SvTRUE(*valp);
996                             break;
997                        }
998                        goto fail;
999                   default:
1000                   fail:
1001                        Perl_croak(aTHX_
1002                                   "get_layers: unknown argument '%s'",
1003                                   key);
1004                   }
1005              }
1006
1007              SP -= (items - 1);
1008         }
1009
1010         sv = POPs;
1011         gv = (GV*)sv;
1012
1013         if (!isGV(sv)) {
1014              if (SvROK(sv) && isGV(SvRV(sv)))
1015                   gv = (GV*)SvRV(sv);
1016              else if (SvPOKp(sv))
1017                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1018         }
1019
1020         if (gv && (io = GvIO(gv))) {
1021              dTARGET;
1022              AV* const av = PerlIO_get_layers(aTHX_ input ?
1023                                         IoIFP(io) : IoOFP(io));
1024              I32 i;
1025              const I32 last = av_len(av);
1026              I32 nitem = 0;
1027              
1028              for (i = last; i >= 0; i -= 3) {
1029                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1030                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1031                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1032
1033                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1034                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1035                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1036
1037                   if (details) {
1038                        XPUSHs(namok
1039                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
1040                               : &PL_sv_undef);
1041                        XPUSHs(argok
1042                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
1043                               : &PL_sv_undef);
1044                        if (flgok)
1045                             XPUSHi(SvIVX(*flgsvp));
1046                        else
1047                             XPUSHs(&PL_sv_undef);
1048                        nitem += 3;
1049                   }
1050                   else {
1051                        if (namok && argok)
1052                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1053                                                  SVfARG(*namsvp),
1054                                                  SVfARG(*argsvp)));
1055                        else if (namok)
1056                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
1057                                                  SVfARG(*namsvp)));
1058                        else
1059                             XPUSHs(&PL_sv_undef);
1060                        nitem++;
1061                        if (flgok) {
1062                             const IV flags = SvIVX(*flgsvp);
1063
1064                             if (flags & PERLIO_F_UTF8) {
1065                                  XPUSHs(newSVpvs("utf8"));
1066                                  nitem++;
1067                             }
1068                        }
1069                   }
1070              }
1071
1072              SvREFCNT_dec(av);
1073
1074              XSRETURN(nitem);
1075         }
1076     }
1077 #endif
1078
1079     XSRETURN(0);
1080 }
1081
1082 XS(XS_Internals_hash_seed)
1083 {
1084     dVAR;
1085     /* Using dXSARGS would also have dITEM and dSP,
1086      * which define 2 unused local variables.  */
1087     dAXMARK;
1088     PERL_UNUSED_ARG(cv);
1089     PERL_UNUSED_VAR(mark);
1090     XSRETURN_UV(PERL_HASH_SEED);
1091 }
1092
1093 XS(XS_Internals_rehash_seed)
1094 {
1095     dVAR;
1096     /* Using dXSARGS would also have dITEM and dSP,
1097      * which define 2 unused local variables.  */
1098     dAXMARK;
1099     PERL_UNUSED_ARG(cv);
1100     PERL_UNUSED_VAR(mark);
1101     XSRETURN_UV(PL_rehash_seed);
1102 }
1103
1104 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1105 {
1106     dVAR;
1107     dXSARGS;
1108     PERL_UNUSED_ARG(cv);
1109     if (SvROK(ST(0))) {
1110         const HV * const hv = (HV *) SvRV(ST(0));
1111         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1112             if (HvREHASH(hv))
1113                 XSRETURN_YES;
1114             else
1115                 XSRETURN_NO;
1116         }
1117     }
1118     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1119 }
1120
1121 XS(XS_Internals_inc_sub_generation)
1122 {
1123     dVAR;
1124     /* Using dXSARGS would also have dITEM and dSP,
1125      * which define 2 unused local variables.  */
1126     dAXMARK;
1127     PERL_UNUSED_ARG(cv);
1128     PERL_UNUSED_VAR(mark);
1129     ++PL_sub_generation;
1130     XSRETURN_EMPTY;
1131 }
1132
1133 XS(XS_re_is_regexp)
1134 {
1135     dVAR; 
1136     dXSARGS;
1137     if (items != 1)
1138        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1139     PERL_UNUSED_VAR(cv); /* -W */
1140     PERL_UNUSED_VAR(ax); /* -Wall */
1141     SP -= items;
1142     {
1143         SV *    sv = ST(0);
1144         if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) ) 
1145         {
1146             XSRETURN_YES;
1147         } else {
1148             XSRETURN_NO;
1149         }
1150         /* NOTREACHED */        
1151         PUTBACK;
1152         return;
1153     }
1154 }
1155
1156 XS(XS_re_regname)
1157 {
1158
1159     dVAR; 
1160     dXSARGS;
1161     if (items < 1 || items > 3)
1162        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL");
1163     PERL_UNUSED_VAR(cv); /* -W */
1164     PERL_UNUSED_VAR(ax); /* -Wall */
1165     SP -= items;
1166     {
1167         SV *    sv = ST(0);
1168         SV *    qr;
1169         SV *    all;
1170         regexp *re = NULL;
1171         SV *bufs = NULL;
1172
1173         if (items < 2)
1174             qr = NULL;
1175         else {
1176             qr = ST(1);
1177         }
1178
1179         if (items < 3)
1180             all = NULL;
1181         else {
1182             all = ST(2);
1183         }
1184         {
1185             re = Perl_get_re_arg( aTHX_ qr, 1, NULL);
1186             if (SvPOK(sv) && re && re->paren_names) {
1187                 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1188                 if (bufs) {
1189                     if (all && SvTRUE(all))
1190                         XPUSHs(newRV(bufs));
1191                     else
1192                         XPUSHs(SvREFCNT_inc(bufs));
1193                     XSRETURN(1);
1194                 }
1195             }
1196             XSRETURN_UNDEF;
1197         }
1198         PUTBACK;
1199         return;
1200     }
1201 }
1202
1203 XS(XS_re_regnames)
1204 {
1205     dVAR; 
1206     dXSARGS;
1207     if (items < 0 || items > 2)
1208        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL");
1209     PERL_UNUSED_VAR(cv); /* -W */
1210     PERL_UNUSED_VAR(ax); /* -Wall */
1211     SP -= items;
1212     {
1213         SV *    sv;
1214         SV *    all;
1215         regexp *re = NULL;
1216         IV count = 0;
1217
1218         if (items < 1)
1219             sv = NULL;
1220         else {
1221             sv = ST(0);
1222         }
1223
1224         if (items < 2)
1225             all = NULL;
1226         else {
1227             all = ST(1);
1228         }
1229         {
1230             re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1231             if (re && re->paren_names) {
1232                 HV *hv= re->paren_names;
1233                 (void)hv_iterinit(hv);
1234                 while (1) {
1235                     HE *temphe = hv_iternext_flags(hv,0);
1236                     if (temphe) {
1237                         IV i;
1238                         IV parno = 0;
1239                         SV* sv_dat = HeVAL(temphe);
1240                         I32 *nums = (I32*)SvPVX(sv_dat);
1241                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1242                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1243                                 re->startp[nums[i]] != -1 &&
1244                                 re->endp[nums[i]] != -1)
1245                             {
1246                                 parno = nums[i];
1247                                 break;
1248                             }
1249                         }
1250                         if (parno || (all && SvTRUE(all))) {
1251                             STRLEN len;
1252                             char *pv = HePV(temphe, len);
1253                             if ( GIMME_V == G_ARRAY ) 
1254                                 XPUSHs(newSVpvn(pv,len));
1255                             count++;
1256                         }
1257                     } else {
1258                         break;
1259                     }
1260                 }
1261             }
1262             if ( GIMME_V == G_ARRAY ) 
1263                 XSRETURN(count);
1264             else 
1265                 XSRETURN_UNDEF;
1266         }    
1267         PUTBACK;
1268         return;
1269     }
1270 }
1271
1272
1273 XS(XS_re_regnames_iterinit)
1274 {
1275     dVAR; 
1276     dXSARGS;
1277     if (items < 0 || items > 1)
1278        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL");
1279     PERL_UNUSED_VAR(cv); /* -W */
1280     PERL_UNUSED_VAR(ax); /* -Wall */
1281     SP -= items;
1282     {
1283         SV *    sv;
1284         regexp *re = NULL;
1285
1286         if (items < 1)
1287             sv = NULL;
1288         else {
1289             sv = ST(0);
1290         }
1291         {
1292             re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1293             if (re && re->paren_names) {
1294                 (void)hv_iterinit(re->paren_names);
1295                 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1296             } else {
1297                 XSRETURN_UNDEF;
1298             }  
1299         }
1300         PUTBACK;
1301         return;
1302     }
1303 }
1304
1305
1306 XS(XS_re_regnames_iternext)
1307 {
1308     dVAR; 
1309     dXSARGS;
1310     if (items < 0 || items > 2)
1311        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL");
1312     PERL_UNUSED_VAR(cv); /* -W */
1313     PERL_UNUSED_VAR(ax); /* -Wall */
1314     SP -= items;
1315     {
1316         SV *    sv;
1317         SV *    all;
1318         regexp *re;
1319
1320         if (items < 1)
1321             sv = NULL;
1322         else {
1323             sv = ST(0);
1324         }
1325
1326         if (items < 2)
1327             all = NULL;
1328         else {
1329             all = ST(1);
1330         }
1331         {
1332             re = Perl_get_re_arg( aTHX_  sv, 1, NULL ); 
1333             if (re && re->paren_names) {
1334                 HV *hv= re->paren_names;
1335                 while (1) {
1336                     HE *temphe = hv_iternext_flags(hv,0);
1337                     if (temphe) {
1338                         IV i;
1339                         IV parno = 0;
1340                         SV* sv_dat = HeVAL(temphe);
1341                         I32 *nums = (I32*)SvPVX(sv_dat);
1342                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1343                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1344                                 re->startp[nums[i]] != -1 &&
1345                                 re->endp[nums[i]] != -1)
1346                             {
1347                                 parno = nums[i];
1348                                 break;
1349                             }
1350                         }
1351                         if (parno || (all && SvTRUE(all))) {
1352                             STRLEN len;
1353                             char *pv = HePV(temphe, len);
1354                             XPUSHs(newSVpvn(pv,len));
1355                             XSRETURN(1);    
1356                         }
1357                     } else {
1358                         break;
1359                     }
1360                 }
1361             }
1362             XSRETURN_UNDEF;
1363         }    
1364         PUTBACK;
1365         return;
1366     }
1367 }
1368
1369
1370 XS(XS_re_regnames_count)
1371 {
1372     SV *        sv;
1373     regexp *re = NULL;
1374     dVAR; 
1375     dXSARGS;
1376
1377     if (items < 0 || items > 1)
1378        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL");
1379     PERL_UNUSED_VAR(cv); /* -W */
1380     PERL_UNUSED_VAR(ax); /* -Wall */
1381     SP -= items;
1382     if (items < 1)
1383         sv = NULL;
1384     else {
1385         sv = ST(0);
1386     }
1387     re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1388     if (re && re->paren_names) {
1389         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1390     } else {
1391         XSRETURN_UNDEF;
1392     }  
1393     PUTBACK;
1394     return;
1395 }
1396
1397
1398 /*
1399  * Local variables:
1400  * c-indentation-style: bsd
1401  * c-basic-offset: 4
1402  * indent-tabs-mode: t
1403  * End:
1404  *
1405  * ex: set ts=8 sts=4 sw=4 noet:
1406  */