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