This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e93a7c19ad8478eb962ce9dc1dc3d975029457c0
[perl5.git] / universal.c
1 /*    universal.c
2  *
3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4  *    2005, 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 SV *
35 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
36              int len, int level)
37 {
38     AV* av;
39     GV* gv;
40     GV** gvp;
41     HV* hv = Nullhv;
42     SV* subgen = Nullsv;
43
44     /* A stash/class can go by many names (ie. User == main::User), so 
45        we compare the stash itself just in case */
46     if (name_stash && (stash == name_stash))
47         return &PL_sv_yes;
48
49     if (strEQ(HvNAME(stash), name))
50         return &PL_sv_yes;
51
52     if (strEQ(name, "UNIVERSAL"))
53         return &PL_sv_yes;
54
55     if (level > 100)
56         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
57                    HvNAME(stash));
58
59     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
60
61     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
62         && (hv = GvHV(gv)))
63     {
64         if (SvIV(subgen) == (IV)PL_sub_generation) {
65             SV* sv;
66             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
67             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
68                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
69                                   name, HvNAME(stash)) );
70                 return sv;
71             }
72         }
73         else {
74             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
75                               HvNAME(stash)) );
76             hv_clear(hv);
77             sv_setiv(subgen, PL_sub_generation);
78         }
79     }
80
81     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
82
83     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
84         if (!hv || !subgen) {
85             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
86
87             gv = *gvp;
88
89             if (SvTYPE(gv) != SVt_PVGV)
90                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
91
92             if (!hv)
93                 hv = GvHVn(gv);
94             if (!subgen) {
95                 subgen = newSViv(PL_sub_generation);
96                 GvSV(gv) = subgen;
97             }
98         }
99         if (hv) {
100             SV** svp = AvARRAY(av);
101             /* NOTE: No support for tied ISA */
102             I32 items = AvFILLp(av) + 1;
103             while (items--) {
104                 SV* sv = *svp++;
105                 HV* basestash = gv_stashsv(sv, FALSE);
106                 if (!basestash) {
107                     if (ckWARN(WARN_MISC))
108                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
109                              "Can't locate package %"SVf" for @%s::ISA",
110                             sv, HvNAME(stash));
111                     continue;
112                 }
113                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
114                                              len, level + 1)) {
115                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
116                     return &PL_sv_yes;
117                 }
118             }
119             (void)hv_store(hv,name,len,&PL_sv_no,0);
120         }
121     }
122     return &PL_sv_no;
123 }
124
125 /*
126 =head1 SV Manipulation Functions
127
128 =for apidoc sv_derived_from
129
130 Returns a boolean indicating whether the SV is derived from the specified
131 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
132 for class names as well as for objects.
133
134 =cut
135 */
136
137 bool
138 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
139 {
140     const char *type;
141     HV *stash;
142     HV *name_stash;
143
144     stash = Nullhv;
145     type = Nullch;
146
147     if (SvGMAGICAL(sv))
148         mg_get(sv) ;
149
150     if (SvROK(sv)) {
151         sv = SvRV(sv);
152         type = sv_reftype(sv,0);
153         if (SvOBJECT(sv))
154             stash = SvSTASH(sv);
155     }
156     else {
157         stash = gv_stashsv(sv, FALSE);
158     }
159
160     name_stash = gv_stashpv(name, FALSE);
161
162     return (type && strEQ(type,name)) ||
163             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
164              == &PL_sv_yes)
165         ? TRUE
166         : FALSE ;
167 }
168
169 #include "XSUB.h"
170
171 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
172 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
173 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
174 XS(XS_version_new);
175 XS(XS_version_stringify);
176 XS(XS_version_numify);
177 XS(XS_version_vcmp);
178 XS(XS_version_boolean);
179 XS(XS_version_noop);
180 XS(XS_version_is_alpha);
181 XS(XS_version_qv);
182 XS(XS_utf8_is_utf8);
183 XS(XS_utf8_valid);
184 XS(XS_utf8_encode);
185 XS(XS_utf8_decode);
186 XS(XS_utf8_upgrade);
187 XS(XS_utf8_downgrade);
188 XS(XS_utf8_unicode_to_native);
189 XS(XS_utf8_native_to_unicode);
190 XS(XS_Internals_SvREADONLY);
191 XS(XS_Internals_SvREFCNT);
192 XS(XS_Internals_hv_clear_placehold);
193 XS(XS_PerlIO_get_layers);
194 XS(XS_Regexp_DESTROY);
195 XS(XS_Internals_hash_seed);
196 XS(XS_Internals_rehash_seed);
197 XS(XS_Internals_HvREHASH);
198
199 void
200 Perl_boot_core_UNIVERSAL(pTHX)
201 {
202     const char file[] = __FILE__;
203
204     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
205     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
206     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
207     {
208         /* register the overloading (type 'A') magic */
209         PL_amagic_generation++;
210         /* Make it findable via fetchmethod */
211         newXS("version::()", XS_version_noop, file);
212         newXS("version::new", XS_version_new, file);
213         newXS("version::(\"\"", XS_version_stringify, file);
214         newXS("version::stringify", XS_version_stringify, file);
215         newXS("version::(0+", XS_version_numify, file);
216         newXS("version::numify", XS_version_numify, file);
217         newXS("version::(cmp", XS_version_vcmp, file);
218         newXS("version::(<=>", XS_version_vcmp, file);
219         newXS("version::vcmp", XS_version_vcmp, file);
220         newXS("version::(bool", XS_version_boolean, file);
221         newXS("version::boolean", XS_version_boolean, file);
222         newXS("version::(nomethod", XS_version_noop, file);
223         newXS("version::noop", XS_version_noop, file);
224         newXS("version::is_alpha", XS_version_is_alpha, file);
225         newXS("version::qv", XS_version_qv, file);
226     }
227     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
228     newXS("utf8::valid", XS_utf8_valid, file);
229     newXS("utf8::encode", XS_utf8_encode, file);
230     newXS("utf8::decode", XS_utf8_decode, file);
231     newXS("utf8::upgrade", XS_utf8_upgrade, file);
232     newXS("utf8::downgrade", XS_utf8_downgrade, file);
233     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
234     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
235     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
236     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
237     newXSproto("Internals::hv_clear_placeholders",
238                XS_Internals_hv_clear_placehold, file, "\\%");
239     newXSproto("PerlIO::get_layers",
240                XS_PerlIO_get_layers, file, "*;@");
241     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
242     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
243     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
244     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
245 }
246
247
248 XS(XS_UNIVERSAL_isa)
249 {
250     dXSARGS;
251     SV *sv;
252     const char *name;
253     STRLEN n_a;
254     (void)cv;
255
256     if (items != 2)
257         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
258
259     sv = ST(0);
260
261     if (SvGMAGICAL(sv))
262         mg_get(sv);
263
264     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
265                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
266         XSRETURN_UNDEF;
267
268     name = (const char *)SvPV(ST(1),n_a);
269
270     ST(0) = boolSV(sv_derived_from(sv, name));
271     XSRETURN(1);
272 }
273
274 XS(XS_UNIVERSAL_can)
275 {
276     dXSARGS;
277     SV   *sv;
278     const char *name;
279     SV   *rv;
280     HV   *pkg = NULL;
281     STRLEN n_a;
282     (void)cv;
283
284     if (items != 2)
285         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
286
287     sv = ST(0);
288
289     if (SvGMAGICAL(sv))
290         mg_get(sv);
291
292     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
293                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
294         XSRETURN_UNDEF;
295
296     name = (const char *)SvPV(ST(1),n_a);
297     rv = &PL_sv_undef;
298
299     if (SvROK(sv)) {
300         sv = (SV*)SvRV(sv);
301         if (SvOBJECT(sv))
302             pkg = SvSTASH(sv);
303     }
304     else {
305         pkg = gv_stashsv(sv, FALSE);
306     }
307
308     if (pkg) {
309         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
310         if (gv && isGV(gv))
311             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
312     }
313
314     ST(0) = rv;
315     XSRETURN(1);
316 }
317
318 XS(XS_UNIVERSAL_VERSION)
319 {
320     dXSARGS;
321     HV *pkg;
322     GV **gvp;
323     GV *gv;
324     SV *sv;
325     const char *undef;
326     (void)cv;
327
328     if (SvROK(ST(0))) {
329         sv = (SV*)SvRV(ST(0));
330         if (!SvOBJECT(sv))
331             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
332         pkg = SvSTASH(sv);
333     }
334     else {
335         pkg = gv_stashsv(ST(0), FALSE);
336     }
337
338     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
339
340     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
341         SV *nsv = sv_newmortal();
342         sv_setsv(nsv, sv);
343         sv = nsv;
344         if ( !sv_derived_from(sv, "version"))
345             upg_version(sv);
346         undef = Nullch;
347     }
348     else {
349         sv = (SV*)&PL_sv_undef;
350         undef = "(undef)";
351     }
352
353     if (items > 1) {
354         STRLEN len;
355         SV *req = ST(1);
356
357         if (undef) {
358              if (pkg)
359                   Perl_croak(aTHX_
360                              "%s does not define $%s::VERSION--version check failed",
361                              HvNAME(pkg), HvNAME(pkg));
362              else {
363                   const char *str = SvPVx(ST(0), len);
364
365                   Perl_croak(aTHX_
366                              "%s defines neither package nor VERSION--version check failed", str);
367              }
368         }
369
370         if ( !sv_derived_from(req, "version")) {
371             /* req may very well be R/O, so create a new object */
372             SV *nsv = sv_newmortal();
373             sv_setsv(nsv, req);
374             req = nsv;
375             upg_version(req);
376         }
377
378         if ( vcmp( req, sv ) > 0 )
379             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
380                     "this is only version %"SVf" (%"SVf")", HvNAME(pkg),
381                     vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
382     }
383
384     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
385         ST(0) = vnumify(sv);
386     } else {
387         ST(0) = sv;
388     }
389
390     XSRETURN(1);
391 }
392
393 XS(XS_version_new)
394 {
395     dXSARGS;
396     (void)cv;
397     if (items > 3)
398         Perl_croak(aTHX_ "Usage: version::new(class, version)");
399     SP -= items;
400     {
401         const char *classname = SvPV_nolen(ST(0));
402         SV *vs = ST(1);
403         SV *rv;
404         if (items == 3 )
405         {
406             vs = sv_newmortal(); 
407             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen(ST(2)));
408         }
409
410         rv = new_version(vs);
411         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
412             sv_bless(rv, gv_stashpv(classname,TRUE));
413
414         PUSHs(sv_2mortal(rv));
415         PUTBACK;
416         return;
417     }
418 }
419
420 XS(XS_version_stringify)
421 {
422      dXSARGS;
423      (void)cv;
424      if (items < 1)
425           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
426      SP -= items;
427      {
428           SV *  lobj;
429
430           if (sv_derived_from(ST(0), "version")) {
431                SV *tmp = SvRV(ST(0));
432                lobj = tmp;
433           }
434           else
435                Perl_croak(aTHX_ "lobj is not of type version");
436
437           PUSHs(sv_2mortal(vstringify(lobj)));
438
439           PUTBACK;
440           return;
441      }
442 }
443
444 XS(XS_version_numify)
445 {
446      dXSARGS;
447      (void)cv;
448      if (items < 1)
449           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
450      SP -= items;
451      {
452           SV *  lobj;
453
454           if (sv_derived_from(ST(0), "version")) {
455                SV *tmp = SvRV(ST(0));
456                lobj = tmp;
457           }
458           else
459                Perl_croak(aTHX_ "lobj is not of type version");
460
461           PUSHs(sv_2mortal(vnumify(lobj)));
462
463           PUTBACK;
464           return;
465      }
466 }
467
468 XS(XS_version_vcmp)
469 {
470      dXSARGS;
471      (void)cv;
472      if (items < 1)
473           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
474      SP -= items;
475      {
476           SV *  lobj;
477
478           if (sv_derived_from(ST(0), "version")) {
479                SV *tmp = SvRV(ST(0));
480                lobj = tmp;
481           }
482           else
483                Perl_croak(aTHX_ "lobj is not of type version");
484
485           {
486                SV       *rs;
487                SV       *rvs;
488                SV * robj = ST(1);
489                IV        swap = (IV)SvIV(ST(2));
490
491                if ( ! sv_derived_from(robj, "version") )
492                {
493                     robj = new_version(robj);
494                }
495                rvs = SvRV(robj);
496
497                if ( swap )
498                {
499                     rs = newSViv(vcmp(rvs,lobj));
500                }
501                else
502                {
503                     rs = newSViv(vcmp(lobj,rvs));
504                }
505
506                PUSHs(sv_2mortal(rs));
507           }
508
509           PUTBACK;
510           return;
511      }
512 }
513
514 XS(XS_version_boolean)
515 {
516      dXSARGS;
517      (void)cv;
518      if (items < 1)
519           Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
520      SP -= items;
521      {
522           SV *  lobj;
523
524           if (sv_derived_from(ST(0), "version")) {
525                /* XXX If tmp serves a purpose, explain it. */
526                SV *tmp = SvRV(ST(0));
527                lobj = tmp;
528           }
529           else
530                Perl_croak(aTHX_ "lobj is not of type version");
531
532           {
533                SV       *rs;
534                rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
535                PUSHs(sv_2mortal(rs));
536           }
537
538           PUTBACK;
539           return;
540      }
541 }
542
543 XS(XS_version_noop)
544 {
545      dXSARGS;
546      (void)cv;
547      if (items < 1)
548           Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
549      {
550           SV *  lobj;
551
552           if (sv_derived_from(ST(0), "version")) {
553                SV *tmp = SvRV(ST(0));
554                lobj = tmp;
555           }
556           else
557                Perl_croak(aTHX_ "lobj is not of type version");
558
559           {
560                Perl_croak(aTHX_ "operation not supported with version object");
561           }
562
563      }
564      XSRETURN_EMPTY;
565 }
566
567 XS(XS_version_is_alpha)
568 {
569     dXSARGS;
570     (void)cv;
571     if (items != 1)
572         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
573     SP -= items;
574     {
575         SV *lobj;
576
577         if (sv_derived_from(ST(0), "version")) {
578                 /* XXX If tmp serves a purpose, explain it. */
579                 SV *tmp = SvRV(ST(0));
580                 lobj = tmp;
581         }
582         else
583                 Perl_croak(aTHX_ "lobj is not of type version");
584 {
585     const I32 len = av_len((AV *)lobj);
586     const I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
587     if ( digit < 0 )
588         XSRETURN_YES;
589     else
590         XSRETURN_NO;
591 }
592         PUTBACK;
593         return;
594     }
595 }
596
597 XS(XS_version_qv)
598 {
599     dXSARGS;
600     (void)cv;
601     if (items != 1)
602         Perl_croak(aTHX_ "Usage: version::qv(ver)");
603     SP -= items;
604     {
605         SV *    ver = ST(0);
606         if ( !SvVOK(ver) ) /* only need to do with if not already v-string */
607         {
608             SV *vs = sv_newmortal();
609             char *version;
610             if ( SvNOK(ver) ) /* may get too much accuracy */
611             {
612                 char tbuf[64];
613                 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
614                 version = savepv(tbuf);
615             }
616             else
617             {
618                 version = savesvpv(ver);
619             }
620             (void)scan_version(version,vs,TRUE);
621             Safefree(version);
622
623             PUSHs(vs);
624         }
625         else
626         {
627             PUSHs(sv_2mortal(new_version(ver)));
628         }
629
630         PUTBACK;
631         return;
632     }
633 }
634
635 XS(XS_utf8_is_utf8)
636 {
637      dXSARGS;
638      (void)cv;
639      if (items != 1)
640           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
641      {
642           const SV *sv = ST(0);
643           {
644                if (SvUTF8(sv))
645                     XSRETURN_YES;
646                else
647                     XSRETURN_NO;
648           }
649      }
650      XSRETURN_EMPTY;
651 }
652
653 XS(XS_utf8_valid)
654 {
655      dXSARGS;
656      (void)cv;
657      if (items != 1)
658           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
659      {
660           SV *  sv = ST(0);
661           {
662                STRLEN len;
663                const char *s = SvPV(sv,len);
664                if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
665                     XSRETURN_YES;
666                else
667                     XSRETURN_NO;
668           }
669      }
670      XSRETURN_EMPTY;
671 }
672
673 XS(XS_utf8_encode)
674 {
675     dXSARGS;
676     (void)cv;
677     if (items != 1)
678         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
679     {
680         SV *    sv = ST(0);
681
682         sv_utf8_encode(sv);
683     }
684     XSRETURN_EMPTY;
685 }
686
687 XS(XS_utf8_decode)
688 {
689     dXSARGS;
690     (void)cv;
691     if (items != 1)
692         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
693     {
694         SV *    sv = ST(0);
695         const bool RETVAL = sv_utf8_decode(sv);
696         ST(0) = boolSV(RETVAL);
697         sv_2mortal(ST(0));
698     }
699     XSRETURN(1);
700 }
701
702 XS(XS_utf8_upgrade)
703 {
704     dXSARGS;
705     (void)cv;
706     if (items != 1)
707         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
708     {
709         SV *    sv = ST(0);
710         STRLEN  RETVAL;
711         dXSTARG;
712
713         RETVAL = sv_utf8_upgrade(sv);
714         XSprePUSH; PUSHi((IV)RETVAL);
715     }
716     XSRETURN(1);
717 }
718
719 XS(XS_utf8_downgrade)
720 {
721     dXSARGS;
722     (void)cv;
723     if (items < 1 || items > 2)
724         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
725     {
726         SV *    sv = ST(0);
727         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
728         const bool RETVAL = sv_utf8_downgrade(sv, failok);
729
730         ST(0) = boolSV(RETVAL);
731         sv_2mortal(ST(0));
732     }
733     XSRETURN(1);
734 }
735
736 XS(XS_utf8_native_to_unicode)
737 {
738  dXSARGS;
739  const UV uv = SvUV(ST(0));
740  (void)cv;
741
742  if (items > 1)
743      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
744
745  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
746  XSRETURN(1);
747 }
748
749 XS(XS_utf8_unicode_to_native)
750 {
751  dXSARGS;
752  const UV uv = SvUV(ST(0));
753  (void)cv;
754
755  if (items > 1)
756      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
757
758  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
759  XSRETURN(1);
760 }
761
762 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
763 {
764     dXSARGS;
765     SV *sv = SvRV(ST(0));
766     (void)cv;
767
768     if (items == 1) {
769          if (SvREADONLY(sv))
770              XSRETURN_YES;
771          else
772              XSRETURN_NO;
773     }
774     else if (items == 2) {
775         if (SvTRUE(ST(1))) {
776             SvREADONLY_on(sv);
777             XSRETURN_YES;
778         }
779         else {
780             /* I hope you really know what you are doing. */
781             SvREADONLY_off(sv);
782             XSRETURN_NO;
783         }
784     }
785     XSRETURN_UNDEF; /* Can't happen. */
786 }
787
788 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
789 {
790     dXSARGS;
791     SV *sv = SvRV(ST(0));
792     (void)cv;
793
794     if (items == 1)
795          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
796     else if (items == 2) {
797          /* I hope you really know what you are doing. */
798          SvREFCNT(sv) = SvIV(ST(1));
799          XSRETURN_IV(SvREFCNT(sv));
800     }
801     XSRETURN_UNDEF; /* Can't happen. */
802 }
803
804 XS(XS_Internals_hv_clear_placehold)
805 {
806     dXSARGS;
807     HV *hv = (HV *) SvRV(ST(0));
808     (void)cv;
809
810     if (items != 1)
811         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
812     hv_clear_placeholders(hv);
813     XSRETURN(0);
814 }
815
816 XS(XS_Regexp_DESTROY)
817 {
818     (void)cv;
819 }
820
821 XS(XS_PerlIO_get_layers)
822 {
823     dXSARGS;
824     (void)cv;
825     if (items < 1 || items % 2 == 0)
826         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
827 #ifdef USE_PERLIO
828     {
829         SV *    sv;
830         GV *    gv;
831         IO *    io;
832         bool    input = TRUE;
833         bool    details = FALSE;
834
835         if (items > 1) {
836              SV **svp;
837              
838              for (svp = MARK + 2; svp <= SP; svp += 2) {
839                   SV **varp = svp;
840                   SV **valp = svp + 1;
841                   STRLEN klen;
842                   const char *key = SvPV(*varp, klen);
843
844                   switch (*key) {
845                   case 'i':
846                        if (klen == 5 && memEQ(key, "input", 5)) {
847                             input = SvTRUE(*valp);
848                             break;
849                        }
850                        goto fail;
851                   case 'o': 
852                        if (klen == 6 && memEQ(key, "output", 6)) {
853                             input = !SvTRUE(*valp);
854                             break;
855                        }
856                        goto fail;
857                   case 'd':
858                        if (klen == 7 && memEQ(key, "details", 7)) {
859                             details = SvTRUE(*valp);
860                             break;
861                        }
862                        goto fail;
863                   default:
864                   fail:
865                        Perl_croak(aTHX_
866                                   "get_layers: unknown argument '%s'",
867                                   key);
868                   }
869              }
870
871              SP -= (items - 1);
872         }
873
874         sv = POPs;
875         gv = (GV*)sv;
876
877         if (!isGV(sv)) {
878              if (SvROK(sv) && isGV(SvRV(sv)))
879                   gv = (GV*)SvRV(sv);
880              else
881                   gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
882         }
883
884         if (gv && (io = GvIO(gv))) {
885              dTARGET;
886              AV* av = PerlIO_get_layers(aTHX_ input ?
887                                         IoIFP(io) : IoOFP(io));
888              I32 i;
889              I32 last = av_len(av);
890              I32 nitem = 0;
891              
892              for (i = last; i >= 0; i -= 3) {
893                   SV **namsvp;
894                   SV **argsvp;
895                   SV **flgsvp;
896                   bool namok, argok, flgok;
897
898                   namsvp = av_fetch(av, i - 2, FALSE);
899                   argsvp = av_fetch(av, i - 1, FALSE);
900                   flgsvp = av_fetch(av, i,     FALSE);
901
902                   namok = namsvp && *namsvp && SvPOK(*namsvp);
903                   argok = argsvp && *argsvp && SvPOK(*argsvp);
904                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
905
906                   if (details) {
907                        XPUSHs(namok ?
908                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
909                        XPUSHs(argok ?
910                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
911                        if (flgok)
912                             XPUSHi(SvIVX(*flgsvp));
913                        else
914                             XPUSHs(&PL_sv_undef);
915                        nitem += 3;
916                   }
917                   else {
918                        if (namok && argok)
919                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
920                                                *namsvp, *argsvp));
921                        else if (namok)
922                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
923                        else
924                             XPUSHs(&PL_sv_undef);
925                        nitem++;
926                        if (flgok) {
927                             IV flags = SvIVX(*flgsvp);
928
929                             if (flags & PERLIO_F_UTF8) {
930                                  XPUSHs(newSVpvn("utf8", 4));
931                                  nitem++;
932                             }
933                        }
934                   }
935              }
936
937              SvREFCNT_dec(av);
938
939              XSRETURN(nitem);
940         }
941     }
942 #endif
943
944     XSRETURN(0);
945 }
946
947 XS(XS_Internals_hash_seed)
948 {
949     /* Using dXSARGS would also have dITEM and dSP,
950      * which define 2 unused local variables.  */
951     dMARK; dAX;
952     (void)cv;
953     XSRETURN_UV(PERL_HASH_SEED);
954 }
955
956 XS(XS_Internals_rehash_seed)
957 {
958     /* Using dXSARGS would also have dITEM and dSP,
959      * which define 2 unused local variables.  */
960     dMARK; dAX;
961     (void)cv;
962     XSRETURN_UV(PL_rehash_seed);
963 }
964
965 XS(XS_Internals_HvREHASH)       /* Subject to change  */
966 {
967     dXSARGS;
968     (void)cv;
969     if (SvROK(ST(0))) {
970         const HV *hv = (HV *) SvRV(ST(0));
971         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
972             if (HvREHASH(hv))
973                 XSRETURN_YES;
974             else
975                 XSRETURN_NO;
976         }
977     }
978     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
979 }
980
981 /*
982  * Local variables:
983  * c-indentation-style: bsd
984  * c-basic-offset: 4
985  * indent-tabs-mode: t
986  * End:
987  *
988  * vim: shiftwidth=4:
989 */