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