This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS() __attribute__
[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
255     if (items != 2)
256         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
257
258     sv = ST(0);
259
260     if (SvGMAGICAL(sv))
261         mg_get(sv);
262
263     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
264                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
265         XSRETURN_UNDEF;
266
267     name = (const char *)SvPV(ST(1),n_a);
268
269     ST(0) = boolSV(sv_derived_from(sv, name));
270     XSRETURN(1);
271 }
272
273 XS(XS_UNIVERSAL_can)
274 {
275     dXSARGS;
276     SV   *sv;
277     const char *name;
278     SV   *rv;
279     HV   *pkg = NULL;
280     STRLEN n_a;
281
282     if (items != 2)
283         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
284
285     sv = ST(0);
286
287     if (SvGMAGICAL(sv))
288         mg_get(sv);
289
290     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
291                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
292         XSRETURN_UNDEF;
293
294     name = (const char *)SvPV(ST(1),n_a);
295     rv = &PL_sv_undef;
296
297     if (SvROK(sv)) {
298         sv = (SV*)SvRV(sv);
299         if (SvOBJECT(sv))
300             pkg = SvSTASH(sv);
301     }
302     else {
303         pkg = gv_stashsv(sv, FALSE);
304     }
305
306     if (pkg) {
307         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
308         if (gv && isGV(gv))
309             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
310     }
311
312     ST(0) = rv;
313     XSRETURN(1);
314 }
315
316 XS(XS_UNIVERSAL_VERSION)
317 {
318     dXSARGS;
319     HV *pkg;
320     GV **gvp;
321     GV *gv;
322     SV *sv;
323     const char *undef;
324
325     if (SvROK(ST(0))) {
326         sv = (SV*)SvRV(ST(0));
327         if (!SvOBJECT(sv))
328             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
329         pkg = SvSTASH(sv);
330     }
331     else {
332         pkg = gv_stashsv(ST(0), FALSE);
333     }
334
335     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
336
337     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
338         SV *nsv = sv_newmortal();
339         sv_setsv(nsv, sv);
340         sv = nsv;
341         if ( !sv_derived_from(sv, "version"))
342             upg_version(sv);
343         undef = Nullch;
344     }
345     else {
346         sv = (SV*)&PL_sv_undef;
347         undef = "(undef)";
348     }
349
350     if (items > 1) {
351         STRLEN len;
352         SV *req = ST(1);
353
354         if (undef) {
355              if (pkg)
356                   Perl_croak(aTHX_
357                              "%s does not define $%s::VERSION--version check failed",
358                              HvNAME(pkg), HvNAME(pkg));
359              else {
360                   const char *str = SvPVx(ST(0), len);
361
362                   Perl_croak(aTHX_
363                              "%s defines neither package nor VERSION--version check failed", str);
364              }
365         }
366
367         if ( !sv_derived_from(req, "version")) {
368             /* req may very well be R/O, so create a new object */
369             SV *nsv = sv_newmortal();
370             sv_setsv(nsv, req);
371             req = nsv;
372             upg_version(req);
373         }
374
375         if ( vcmp( req, sv ) > 0 )
376             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
377                     "this is only version %"SVf" (%"SVf")", HvNAME(pkg),
378                     vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
379     }
380
381     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
382         ST(0) = vnumify(sv);
383     } else {
384         ST(0) = sv;
385     }
386
387     XSRETURN(1);
388 }
389
390 XS(XS_version_new)
391 {
392     dXSARGS;
393     if (items > 3)
394         Perl_croak(aTHX_ "Usage: version::new(class, version)");
395     SP -= items;
396     {
397         const char *classname = SvPV_nolen(ST(0));
398         SV *vs = ST(1);
399         SV *rv;
400         if (items == 3 )
401         {
402             vs = sv_newmortal(); 
403             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen(ST(2)));
404         }
405
406         rv = new_version(vs);
407         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
408             sv_bless(rv, gv_stashpv(classname,TRUE));
409
410         PUSHs(sv_2mortal(rv));
411         PUTBACK;
412         return;
413     }
414 }
415
416 XS(XS_version_stringify)
417 {
418      dXSARGS;
419      if (items < 1)
420           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
421      SP -= items;
422      {
423           SV *  lobj;
424
425           if (sv_derived_from(ST(0), "version")) {
426                SV *tmp = SvRV(ST(0));
427                lobj = tmp;
428           }
429           else
430                Perl_croak(aTHX_ "lobj is not of type version");
431
432           PUSHs(sv_2mortal(vstringify(lobj)));
433
434           PUTBACK;
435           return;
436      }
437 }
438
439 XS(XS_version_numify)
440 {
441      dXSARGS;
442      if (items < 1)
443           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
444      SP -= items;
445      {
446           SV *  lobj;
447
448           if (sv_derived_from(ST(0), "version")) {
449                SV *tmp = SvRV(ST(0));
450                lobj = tmp;
451           }
452           else
453                Perl_croak(aTHX_ "lobj is not of type version");
454
455           PUSHs(sv_2mortal(vnumify(lobj)));
456
457           PUTBACK;
458           return;
459      }
460 }
461
462 XS(XS_version_vcmp)
463 {
464      dXSARGS;
465      if (items < 1)
466           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
467      SP -= items;
468      {
469           SV *  lobj;
470
471           if (sv_derived_from(ST(0), "version")) {
472                SV *tmp = SvRV(ST(0));
473                lobj = tmp;
474           }
475           else
476                Perl_croak(aTHX_ "lobj is not of type version");
477
478           {
479                SV       *rs;
480                SV       *rvs;
481                SV * robj = ST(1);
482                IV        swap = (IV)SvIV(ST(2));
483
484                if ( ! sv_derived_from(robj, "version") )
485                {
486                     robj = new_version(robj);
487                }
488                rvs = SvRV(robj);
489
490                if ( swap )
491                {
492                     rs = newSViv(vcmp(rvs,lobj));
493                }
494                else
495                {
496                     rs = newSViv(vcmp(lobj,rvs));
497                }
498
499                PUSHs(sv_2mortal(rs));
500           }
501
502           PUTBACK;
503           return;
504      }
505 }
506
507 XS(XS_version_boolean)
508 {
509      dXSARGS;
510      if (items < 1)
511           Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
512      SP -= items;
513      {
514           SV *  lobj;
515
516           if (sv_derived_from(ST(0), "version")) {
517                /* XXX If tmp serves a purpose, explain it. */
518                SV *tmp = SvRV(ST(0));
519                lobj = tmp;
520           }
521           else
522                Perl_croak(aTHX_ "lobj is not of type version");
523
524           {
525                SV       *rs;
526                rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
527                PUSHs(sv_2mortal(rs));
528           }
529
530           PUTBACK;
531           return;
532      }
533 }
534
535 XS(XS_version_noop)
536 {
537      dXSARGS;
538      if (items < 1)
539           Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
540      {
541           SV *  lobj;
542
543           if (sv_derived_from(ST(0), "version")) {
544                SV *tmp = SvRV(ST(0));
545                lobj = tmp;
546           }
547           else
548                Perl_croak(aTHX_ "lobj is not of type version");
549
550           {
551                Perl_croak(aTHX_ "operation not supported with version object");
552           }
553
554      }
555      XSRETURN_EMPTY;
556 }
557
558 XS(XS_version_is_alpha)
559 {
560     dXSARGS;
561     if (items != 1)
562         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
563     SP -= items;
564     {
565         SV *lobj;
566
567         if (sv_derived_from(ST(0), "version")) {
568                 /* XXX If tmp serves a purpose, explain it. */
569                 SV *tmp = SvRV(ST(0));
570                 lobj = tmp;
571         }
572         else
573                 Perl_croak(aTHX_ "lobj is not of type version");
574 {
575     const I32 len = av_len((AV *)lobj);
576     const I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
577     if ( digit < 0 )
578         XSRETURN_YES;
579     else
580         XSRETURN_NO;
581 }
582         PUTBACK;
583         return;
584     }
585 }
586
587 XS(XS_version_qv)
588 {
589     dXSARGS;
590     if (items != 1)
591         Perl_croak(aTHX_ "Usage: version::qv(ver)");
592     SP -= items;
593     {
594         SV *    ver = ST(0);
595         if ( !SvVOK(ver) ) /* only need to do with if not already v-string */
596         {
597             SV *vs = sv_newmortal();
598             char *version;
599             if ( SvNOK(ver) ) /* may get too much accuracy */
600             {
601                 char tbuf[64];
602                 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
603                 version = savepv(tbuf);
604             }
605             else
606             {
607                 version = savesvpv(ver);
608             }
609             (void)scan_version(version,vs,TRUE);
610             Safefree(version);
611
612             PUSHs(vs);
613         }
614         else
615         {
616             PUSHs(sv_2mortal(new_version(ver)));
617         }
618
619         PUTBACK;
620         return;
621     }
622 }
623
624 XS(XS_utf8_is_utf8)
625 {
626      dXSARGS;
627      if (items != 1)
628           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
629      {
630           const SV *sv = ST(0);
631           {
632                if (SvUTF8(sv))
633                     XSRETURN_YES;
634                else
635                     XSRETURN_NO;
636           }
637      }
638      XSRETURN_EMPTY;
639 }
640
641 XS(XS_utf8_valid)
642 {
643      dXSARGS;
644      if (items != 1)
645           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
646      {
647           SV *  sv = ST(0);
648           {
649                STRLEN len;
650                const char *s = SvPV(sv,len);
651                if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
652                     XSRETURN_YES;
653                else
654                     XSRETURN_NO;
655           }
656      }
657      XSRETURN_EMPTY;
658 }
659
660 XS(XS_utf8_encode)
661 {
662     dXSARGS;
663     if (items != 1)
664         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
665     {
666         SV *    sv = ST(0);
667
668         sv_utf8_encode(sv);
669     }
670     XSRETURN_EMPTY;
671 }
672
673 XS(XS_utf8_decode)
674 {
675     dXSARGS;
676     if (items != 1)
677         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
678     {
679         SV *    sv = ST(0);
680         const bool RETVAL = sv_utf8_decode(sv);
681         ST(0) = boolSV(RETVAL);
682         sv_2mortal(ST(0));
683     }
684     XSRETURN(1);
685 }
686
687 XS(XS_utf8_upgrade)
688 {
689     dXSARGS;
690     if (items != 1)
691         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
692     {
693         SV *    sv = ST(0);
694         STRLEN  RETVAL;
695         dXSTARG;
696
697         RETVAL = sv_utf8_upgrade(sv);
698         XSprePUSH; PUSHi((IV)RETVAL);
699     }
700     XSRETURN(1);
701 }
702
703 XS(XS_utf8_downgrade)
704 {
705     dXSARGS;
706     if (items < 1 || items > 2)
707         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
708     {
709         SV *    sv = ST(0);
710         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
711         const bool RETVAL = sv_utf8_downgrade(sv, failok);
712
713         ST(0) = boolSV(RETVAL);
714         sv_2mortal(ST(0));
715     }
716     XSRETURN(1);
717 }
718
719 XS(XS_utf8_native_to_unicode)
720 {
721  dXSARGS;
722  const UV uv = SvUV(ST(0));
723
724  if (items > 1)
725      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
726
727  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
728  XSRETURN(1);
729 }
730
731 XS(XS_utf8_unicode_to_native)
732 {
733  dXSARGS;
734  const UV uv = SvUV(ST(0));
735
736  if (items > 1)
737      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
738
739  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
740  XSRETURN(1);
741 }
742
743 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
744 {
745     dXSARGS;
746     SV *sv = SvRV(ST(0));
747
748     if (items == 1) {
749          if (SvREADONLY(sv))
750              XSRETURN_YES;
751          else
752              XSRETURN_NO;
753     }
754     else if (items == 2) {
755         if (SvTRUE(ST(1))) {
756             SvREADONLY_on(sv);
757             XSRETURN_YES;
758         }
759         else {
760             /* I hope you really know what you are doing. */
761             SvREADONLY_off(sv);
762             XSRETURN_NO;
763         }
764     }
765     XSRETURN_UNDEF; /* Can't happen. */
766 }
767
768 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
769 {
770     dXSARGS;
771     SV *sv = SvRV(ST(0));
772
773     if (items == 1)
774          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
775     else if (items == 2) {
776          /* I hope you really know what you are doing. */
777          SvREFCNT(sv) = SvIV(ST(1));
778          XSRETURN_IV(SvREFCNT(sv));
779     }
780     XSRETURN_UNDEF; /* Can't happen. */
781 }
782
783 XS(XS_Internals_hv_clear_placehold)
784 {
785     dXSARGS;
786     HV *hv = (HV *) SvRV(ST(0));
787
788     if (items != 1)
789         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
790     hv_clear_placeholders(hv);
791     XSRETURN(0);
792 }
793
794 XS(XS_Regexp_DESTROY)
795 {
796 }
797
798 XS(XS_PerlIO_get_layers)
799 {
800     dXSARGS;
801     if (items < 1 || items % 2 == 0)
802         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
803 #ifdef USE_PERLIO
804     {
805         SV *    sv;
806         GV *    gv;
807         IO *    io;
808         bool    input = TRUE;
809         bool    details = FALSE;
810
811         if (items > 1) {
812              SV **svp;
813              
814              for (svp = MARK + 2; svp <= SP; svp += 2) {
815                   SV **varp = svp;
816                   SV **valp = svp + 1;
817                   STRLEN klen;
818                   const char *key = SvPV(*varp, klen);
819
820                   switch (*key) {
821                   case 'i':
822                        if (klen == 5 && memEQ(key, "input", 5)) {
823                             input = SvTRUE(*valp);
824                             break;
825                        }
826                        goto fail;
827                   case 'o': 
828                        if (klen == 6 && memEQ(key, "output", 6)) {
829                             input = !SvTRUE(*valp);
830                             break;
831                        }
832                        goto fail;
833                   case 'd':
834                        if (klen == 7 && memEQ(key, "details", 7)) {
835                             details = SvTRUE(*valp);
836                             break;
837                        }
838                        goto fail;
839                   default:
840                   fail:
841                        Perl_croak(aTHX_
842                                   "get_layers: unknown argument '%s'",
843                                   key);
844                   }
845              }
846
847              SP -= (items - 1);
848         }
849
850         sv = POPs;
851         gv = (GV*)sv;
852
853         if (!isGV(sv)) {
854              if (SvROK(sv) && isGV(SvRV(sv)))
855                   gv = (GV*)SvRV(sv);
856              else
857                   gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
858         }
859
860         if (gv && (io = GvIO(gv))) {
861              dTARGET;
862              AV* av = PerlIO_get_layers(aTHX_ input ?
863                                         IoIFP(io) : IoOFP(io));
864              I32 i;
865              I32 last = av_len(av);
866              I32 nitem = 0;
867              
868              for (i = last; i >= 0; i -= 3) {
869                   SV **namsvp;
870                   SV **argsvp;
871                   SV **flgsvp;
872                   bool namok, argok, flgok;
873
874                   namsvp = av_fetch(av, i - 2, FALSE);
875                   argsvp = av_fetch(av, i - 1, FALSE);
876                   flgsvp = av_fetch(av, i,     FALSE);
877
878                   namok = namsvp && *namsvp && SvPOK(*namsvp);
879                   argok = argsvp && *argsvp && SvPOK(*argsvp);
880                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
881
882                   if (details) {
883                        XPUSHs(namok ?
884                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
885                        XPUSHs(argok ?
886                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
887                        if (flgok)
888                             XPUSHi(SvIVX(*flgsvp));
889                        else
890                             XPUSHs(&PL_sv_undef);
891                        nitem += 3;
892                   }
893                   else {
894                        if (namok && argok)
895                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
896                                                *namsvp, *argsvp));
897                        else if (namok)
898                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
899                        else
900                             XPUSHs(&PL_sv_undef);
901                        nitem++;
902                        if (flgok) {
903                             IV flags = SvIVX(*flgsvp);
904
905                             if (flags & PERLIO_F_UTF8) {
906                                  XPUSHs(newSVpvn("utf8", 4));
907                                  nitem++;
908                             }
909                        }
910                   }
911              }
912
913              SvREFCNT_dec(av);
914
915              XSRETURN(nitem);
916         }
917     }
918 #endif
919
920     XSRETURN(0);
921 }
922
923 XS(XS_Internals_hash_seed)
924 {
925     /* Using dXSARGS would also have dITEM and dSP,
926      * which define 2 unused local variables.  */
927     dMARK; dAX;
928     XSRETURN_UV(PERL_HASH_SEED);
929 }
930
931 XS(XS_Internals_rehash_seed)
932 {
933     /* Using dXSARGS would also have dITEM and dSP,
934      * which define 2 unused local variables.  */
935     dMARK; dAX;
936     XSRETURN_UV(PL_rehash_seed);
937 }
938
939 XS(XS_Internals_HvREHASH)       /* Subject to change  */
940 {
941     dXSARGS;
942     if (SvROK(ST(0))) {
943         const HV *hv = (HV *) SvRV(ST(0));
944         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
945             if (HvREHASH(hv))
946                 XSRETURN_YES;
947             else
948                 XSRETURN_NO;
949         }
950     }
951     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
952 }
953
954 /*
955  * Local variables:
956  * c-indentation-style: bsd
957  * c-basic-offset: 4
958  * indent-tabs-mode: t
959  * End:
960  *
961  * vim: shiftwidth=4:
962 */