This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS-assisted SWASHGET (esp. for t/uni/class.t speedup)
[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     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 XS(XS_utf8_SWASHGET_heavy);
203
204 void
205 Perl_boot_core_UNIVERSAL(pTHX)
206 {
207     const char file[] = __FILE__;
208
209     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
210     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
211     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
212     {
213         /* register the overloading (type 'A') magic */
214         PL_amagic_generation++;
215         /* Make it findable via fetchmethod */
216         newXS("version::()", XS_version_noop, file);
217         newXS("version::new", XS_version_new, file);
218         newXS("version::(\"\"", XS_version_stringify, file);
219         newXS("version::stringify", XS_version_stringify, file);
220         newXS("version::(0+", XS_version_numify, file);
221         newXS("version::numify", XS_version_numify, file);
222         newXS("version::normal", XS_version_normal, file);
223         newXS("version::(cmp", XS_version_vcmp, file);
224         newXS("version::(<=>", XS_version_vcmp, file);
225         newXS("version::vcmp", XS_version_vcmp, file);
226         newXS("version::(bool", XS_version_boolean, file);
227         newXS("version::boolean", XS_version_boolean, file);
228         newXS("version::(nomethod", XS_version_noop, file);
229         newXS("version::noop", XS_version_noop, file);
230         newXS("version::is_alpha", XS_version_is_alpha, file);
231         newXS("version::qv", XS_version_qv, file);
232     }
233     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
234     newXS("utf8::valid", XS_utf8_valid, file);
235     newXS("utf8::encode", XS_utf8_encode, file);
236     newXS("utf8::decode", XS_utf8_decode, file);
237     newXS("utf8::upgrade", XS_utf8_upgrade, file);
238     newXS("utf8::downgrade", XS_utf8_downgrade, file);
239     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
240     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
241     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
242     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
243     newXSproto("Internals::hv_clear_placeholders",
244                XS_Internals_hv_clear_placehold, file, "\\%");
245     newXSproto("PerlIO::get_layers",
246                XS_PerlIO_get_layers, file, "*;@");
247     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
248     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
249     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
250     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
251     newXS("utf8::SWASHGET_heavy", XS_utf8_SWASHGET_heavy, file);
252 }
253
254
255 XS(XS_UNIVERSAL_isa)
256 {
257     dXSARGS;
258
259     if (items != 2)
260         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
261     else {
262         SV * const sv = ST(0);
263         const char *name;
264
265         SvGETMAGIC(sv);
266
267         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
268                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
269             XSRETURN_UNDEF;
270
271         name = SvPV_nolen_const(ST(1));
272
273         ST(0) = boolSV(sv_derived_from(sv, name));
274         XSRETURN(1);
275     }
276 }
277
278 XS(XS_UNIVERSAL_can)
279 {
280     dXSARGS;
281     SV   *sv;
282     const char *name;
283     SV   *rv;
284     HV   *pkg = NULL;
285
286     if (items != 2)
287         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
288
289     sv = ST(0);
290
291     SvGETMAGIC(sv);
292
293     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
294                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
295         XSRETURN_UNDEF;
296
297     name = SvPV_nolen_const(ST(1));
298     rv = &PL_sv_undef;
299
300     if (SvROK(sv)) {
301         sv = (SV*)SvRV(sv);
302         if (SvOBJECT(sv))
303             pkg = SvSTASH(sv);
304     }
305     else {
306         pkg = gv_stashsv(sv, FALSE);
307     }
308
309     if (pkg) {
310         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
311         if (gv && isGV(gv))
312             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
313     }
314
315     ST(0) = rv;
316     XSRETURN(1);
317 }
318
319 XS(XS_UNIVERSAL_VERSION)
320 {
321     dXSARGS;
322     HV *pkg;
323     GV **gvp;
324     GV *gv;
325     SV *sv;
326     const char *undef;
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) && (sv = GvSV(gv)) && SvOK(sv)) {
341         SV * const 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         SV *req = ST(1);
355
356         if (undef) {
357             if (pkg) {
358                 const char * const name = HvNAME_get(pkg);
359                 Perl_croak(aTHX_
360                            "%s does not define $%s::VERSION--version check failed",
361                            name, name);
362             } else {
363                 Perl_croak(aTHX_
364                              "%s defines neither package nor VERSION--version check failed",
365                              SvPVx_nolen_const(ST(0)) );
366              }
367         }
368
369         if ( !sv_derived_from(req, "version")) {
370             /* req may very well be R/O, so create a new object */
371             SV * const nsv = sv_newmortal();
372             sv_setsv(nsv, req);
373             req = nsv;
374             upg_version(req);
375         }
376
377         if ( vcmp( req, sv ) > 0 )
378             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
379                     "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
380                     vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
381     }
382
383     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
384         ST(0) = vnumify(sv);
385     } else {
386         ST(0) = sv;
387     }
388
389     XSRETURN(1);
390 }
391
392 XS(XS_version_new)
393 {
394     dXSARGS;
395     if (items > 3)
396         Perl_croak(aTHX_ "Usage: version::new(class, version)");
397     SP -= items;
398     {
399         SV *vs = ST(1);
400         SV *rv;
401         const char * const classname =
402             sv_isobject(ST(0)) /* get the class if called as an object method */
403                 ? HvNAME(SvSTASH(SvRV(ST(0))))
404                 : (char *)SvPV_nolen(ST(0));
405
406         if ( items == 1 ) {
407             /* no parameter provided */
408             if ( sv_isobject(ST(0)) ) {
409                 /* copy existing object */
410                 vs = ST(0);
411             }
412             else {
413                 /* create empty object */
414                 vs = sv_newmortal();
415                 sv_setpvn(vs,"",0);
416             }
417         }
418         else if ( items == 3 ) {
419             vs = sv_newmortal();
420             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
421         }
422
423         rv = new_version(vs);
424         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
425             sv_bless(rv, gv_stashpv(classname,TRUE));
426
427         PUSHs(sv_2mortal(rv));
428         PUTBACK;
429         return;
430     }
431 }
432
433 XS(XS_version_stringify)
434 {
435      dXSARGS;
436      if (items < 1)
437           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
438      SP -= items;
439      {
440           SV *  lobj;
441
442           if (sv_derived_from(ST(0), "version")) {
443                lobj = SvRV(ST(0));
444           }
445           else
446                Perl_croak(aTHX_ "lobj is not of type version");
447
448           PUSHs(sv_2mortal(vstringify(lobj)));
449
450           PUTBACK;
451           return;
452      }
453 }
454
455 XS(XS_version_numify)
456 {
457      dXSARGS;
458      if (items < 1)
459           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
460      SP -= items;
461      {
462           SV *  lobj;
463
464           if (sv_derived_from(ST(0), "version")) {
465                lobj = SvRV(ST(0));
466           }
467           else
468                Perl_croak(aTHX_ "lobj is not of type version");
469
470           PUSHs(sv_2mortal(vnumify(lobj)));
471
472           PUTBACK;
473           return;
474      }
475 }
476
477 XS(XS_version_normal)
478 {
479      dXSARGS;
480      if (items < 1)
481           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
482      SP -= items;
483      {
484           SV *  lobj;
485
486           if (sv_derived_from(ST(0), "version")) {
487                lobj = SvRV(ST(0));
488           }
489           else
490                Perl_croak(aTHX_ "lobj is not of type version");
491
492           PUSHs(sv_2mortal(vnormal(lobj)));
493
494           PUTBACK;
495           return;
496      }
497 }
498
499 XS(XS_version_vcmp)
500 {
501      dXSARGS;
502      if (items < 1)
503           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
504      SP -= items;
505      {
506           SV *  lobj;
507
508           if (sv_derived_from(ST(0), "version")) {
509                lobj = SvRV(ST(0));
510           }
511           else
512                Perl_croak(aTHX_ "lobj is not of type version");
513
514           {
515                SV       *rs;
516                SV       *rvs;
517                SV * robj = ST(1);
518                const IV  swap = (IV)SvIV(ST(2));
519
520                if ( ! sv_derived_from(robj, "version") )
521                {
522                     robj = new_version(robj);
523                }
524                rvs = SvRV(robj);
525
526                if ( swap )
527                {
528                     rs = newSViv(vcmp(rvs,lobj));
529                }
530                else
531                {
532                     rs = newSViv(vcmp(lobj,rvs));
533                }
534
535                PUSHs(sv_2mortal(rs));
536           }
537
538           PUTBACK;
539           return;
540      }
541 }
542
543 XS(XS_version_boolean)
544 {
545      dXSARGS;
546      if (items < 1)
547           Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
548      SP -= items;
549     if (sv_derived_from(ST(0), "version")) {
550         SV * const lobj = SvRV(ST(0));
551         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
552         PUSHs(sv_2mortal(rs));
553         PUTBACK;
554         return;
555     }
556     else
557         Perl_croak(aTHX_ "lobj is not of type version");
558 }
559
560 XS(XS_version_noop)
561 {
562     dXSARGS;
563     if (items < 1)
564         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
565     if (sv_derived_from(ST(0), "version"))
566         Perl_croak(aTHX_ "operation not supported with version object");
567     else
568         Perl_croak(aTHX_ "lobj is not of type version");
569 #ifndef HASATTRIBUTE_NORETURN
570     XSRETURN_EMPTY;
571 #endif
572 }
573
574 XS(XS_version_is_alpha)
575 {
576     dXSARGS;
577     if (items != 1)
578         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
579     SP -= items;
580     if (sv_derived_from(ST(0), "version")) {
581         SV * const lobj = ST(0);
582         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
583             XSRETURN_YES;
584         else
585             XSRETURN_NO;
586         PUTBACK;
587         return;
588     }
589     else
590         Perl_croak(aTHX_ "lobj is not of type version");
591 }
592
593 XS(XS_version_qv)
594 {
595     dXSARGS;
596     if (items != 1)
597         Perl_croak(aTHX_ "Usage: version::qv(ver)");
598     SP -= items;
599     {
600         SV *    ver = ST(0);
601         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
602             SV * const vs = sv_newmortal();
603             char *version;
604             if ( SvNOK(ver) ) /* may get too much accuracy */
605             {
606                 char tbuf[64];
607                 const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
608                 version = savepvn(tbuf, len);
609             }
610             else
611             {
612                 version = savesvpv(ver);
613             }
614             (void)scan_version(version,vs,TRUE);
615             Safefree(version);
616
617             PUSHs(vs);
618         }
619         else
620         {
621             PUSHs(sv_2mortal(new_version(ver)));
622         }
623
624         PUTBACK;
625         return;
626     }
627 }
628
629 XS(XS_utf8_is_utf8)
630 {
631      dXSARGS;
632      if (items != 1)
633           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
634      else {
635         const SV * const sv = ST(0);
636             if (SvUTF8(sv))
637                 XSRETURN_YES;
638             else
639                 XSRETURN_NO;
640      }
641      XSRETURN_EMPTY;
642 }
643
644 XS(XS_utf8_valid)
645 {
646      dXSARGS;
647      if (items != 1)
648           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
649     else {
650         SV * const sv = ST(0);
651         STRLEN len;
652         const char * const s = SvPV_const(sv,len);
653         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
654             XSRETURN_YES;
655         else
656             XSRETURN_NO;
657     }
658      XSRETURN_EMPTY;
659 }
660
661 XS(XS_utf8_encode)
662 {
663     dXSARGS;
664     if (items != 1)
665         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
666     sv_utf8_encode(ST(0));
667     XSRETURN_EMPTY;
668 }
669
670 XS(XS_utf8_decode)
671 {
672     dXSARGS;
673     if (items != 1)
674         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
675     else {
676         SV * const sv = ST(0);
677         const bool RETVAL = sv_utf8_decode(sv);
678         ST(0) = boolSV(RETVAL);
679         sv_2mortal(ST(0));
680     }
681     XSRETURN(1);
682 }
683
684 XS(XS_utf8_upgrade)
685 {
686     dXSARGS;
687     if (items != 1)
688         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
689     else {
690         SV * const sv = ST(0);
691         STRLEN  RETVAL;
692         dXSTARG;
693
694         RETVAL = sv_utf8_upgrade(sv);
695         XSprePUSH; PUSHi((IV)RETVAL);
696     }
697     XSRETURN(1);
698 }
699
700 XS(XS_utf8_downgrade)
701 {
702     dXSARGS;
703     if (items < 1 || items > 2)
704         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
705     else {
706         SV * const sv = ST(0);
707         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
708         const bool RETVAL = sv_utf8_downgrade(sv, failok);
709
710         ST(0) = boolSV(RETVAL);
711         sv_2mortal(ST(0));
712     }
713     XSRETURN(1);
714 }
715
716 XS(XS_utf8_native_to_unicode)
717 {
718  dXSARGS;
719  const UV uv = SvUV(ST(0));
720
721  if (items > 1)
722      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
723
724  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
725  XSRETURN(1);
726 }
727
728 XS(XS_utf8_unicode_to_native)
729 {
730  dXSARGS;
731  const UV uv = SvUV(ST(0));
732
733  if (items > 1)
734      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
735
736  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
737  XSRETURN(1);
738 }
739
740 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
741 {
742     dXSARGS;
743     SV * const sv = SvRV(ST(0));
744
745     if (items == 1) {
746          if (SvREADONLY(sv))
747              XSRETURN_YES;
748          else
749              XSRETURN_NO;
750     }
751     else if (items == 2) {
752         if (SvTRUE(ST(1))) {
753             SvREADONLY_on(sv);
754             XSRETURN_YES;
755         }
756         else {
757             /* I hope you really know what you are doing. */
758             SvREADONLY_off(sv);
759             XSRETURN_NO;
760         }
761     }
762     XSRETURN_UNDEF; /* Can't happen. */
763 }
764
765 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
766 {
767     dXSARGS;
768     SV * const sv = SvRV(ST(0));
769
770     if (items == 1)
771          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
772     else if (items == 2) {
773          /* I hope you really know what you are doing. */
774          SvREFCNT(sv) = SvIV(ST(1));
775          XSRETURN_IV(SvREFCNT(sv));
776     }
777     XSRETURN_UNDEF; /* Can't happen. */
778 }
779
780 XS(XS_Internals_hv_clear_placehold)
781 {
782     dXSARGS;
783
784     if (items != 1)
785         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
786     else {
787         HV * const hv = (HV *) SvRV(ST(0));
788         hv_clear_placeholders(hv);
789         XSRETURN(0);
790     }
791 }
792
793 XS(XS_Regexp_DESTROY)
794 {
795     PERL_UNUSED_ARG(cv);
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 * const *svp;
813              for (svp = MARK + 2; svp <= SP; svp += 2) {
814                   SV * const * const varp = svp;
815                   SV * const * const valp = svp + 1;
816                   STRLEN klen;
817                   const char * const key = SvPV_const(*varp, klen);
818
819                   switch (*key) {
820                   case 'i':
821                        if (klen == 5 && memEQ(key, "input", 5)) {
822                             input = SvTRUE(*valp);
823                             break;
824                        }
825                        goto fail;
826                   case 'o': 
827                        if (klen == 6 && memEQ(key, "output", 6)) {
828                             input = !SvTRUE(*valp);
829                             break;
830                        }
831                        goto fail;
832                   case 'd':
833                        if (klen == 7 && memEQ(key, "details", 7)) {
834                             details = SvTRUE(*valp);
835                             break;
836                        }
837                        goto fail;
838                   default:
839                   fail:
840                        Perl_croak(aTHX_
841                                   "get_layers: unknown argument '%s'",
842                                   key);
843                   }
844              }
845
846              SP -= (items - 1);
847         }
848
849         sv = POPs;
850         gv = (GV*)sv;
851
852         if (!isGV(sv)) {
853              if (SvROK(sv) && isGV(SvRV(sv)))
854                   gv = (GV*)SvRV(sv);
855              else if (SvPOKp(sv))
856                   gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
857         }
858
859         if (gv && (io = GvIO(gv))) {
860              dTARGET;
861              AV* const av = PerlIO_get_layers(aTHX_ input ?
862                                         IoIFP(io) : IoOFP(io));
863              I32 i;
864              const I32 last = av_len(av);
865              I32 nitem = 0;
866              
867              for (i = last; i >= 0; i -= 3) {
868                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
869                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
870                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
871
872                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
873                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
874                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
875
876                   if (details) {
877                        XPUSHs(namok
878                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
879                               : &PL_sv_undef);
880                        XPUSHs(argok
881                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
882                               : &PL_sv_undef);
883                        if (flgok)
884                             XPUSHi(SvIVX(*flgsvp));
885                        else
886                             XPUSHs(&PL_sv_undef);
887                        nitem += 3;
888                   }
889                   else {
890                        if (namok && argok)
891                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
892                                                *namsvp, *argsvp));
893                        else if (namok)
894                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
895                        else
896                             XPUSHs(&PL_sv_undef);
897                        nitem++;
898                        if (flgok) {
899                             const IV flags = SvIVX(*flgsvp);
900
901                             if (flags & PERLIO_F_UTF8) {
902                                  XPUSHs(newSVpvn("utf8", 4));
903                                  nitem++;
904                             }
905                        }
906                   }
907              }
908
909              SvREFCNT_dec(av);
910
911              XSRETURN(nitem);
912         }
913     }
914 #endif
915
916     XSRETURN(0);
917 }
918
919 XS(XS_Internals_hash_seed)
920 {
921     /* Using dXSARGS would also have dITEM and dSP,
922      * which define 2 unused local variables.  */
923     dAXMARK;
924     PERL_UNUSED_ARG(cv);
925     PERL_UNUSED_VAR(mark);
926     XSRETURN_UV(PERL_HASH_SEED);
927 }
928
929 XS(XS_Internals_rehash_seed)
930 {
931     /* Using dXSARGS would also have dITEM and dSP,
932      * which define 2 unused local variables.  */
933     dAXMARK;
934     PERL_UNUSED_ARG(cv);
935     PERL_UNUSED_VAR(mark);
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 * const 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 XS(XS_utf8_SWASHGET_heavy)
955 {
956     dXSARGS;
957     if (items != 4) {
958         Perl_croak(aTHX_
959             "Usage: utf8::SWASHGET_heavy($self, $start, $len, DEBUG)");
960     }
961     {
962         SV* self    = ST(0);
963         const I32 i_start = (I32)SvIV(ST(1));
964         const I32 i_len   = (I32)SvIV(ST(2));
965         const I32 debug   = (I32)SvIV(ST(3));
966         U32 start = (U32)i_start;
967         U32 len   = (U32)i_len;
968
969         HV *hv;
970         SV **listsvp, **typesvp, **bitssvp, **nonesvp, **extssvp, *swatch;
971         U8 *l, *lend, *x, *xend, *s, *nextline;
972         STRLEN lcur, xcur, scur;
973         U8* typestr;
974         int typeto;
975         U32 bits, none, end, octets;
976
977         if (SvROK(self) && SvTYPE(SvRV(self))==SVt_PVHV)
978             hv = (HV*)SvRV(self);
979         else
980             Perl_croak(aTHX_ "hv is not a hash reference");
981
982         if (i_start < 0)
983             Perl_croak(aTHX_ "SWASHGET negative start");
984         if (i_len < 0)
985             Perl_croak(aTHX_ "SWASHGET negative len");
986
987         listsvp = hv_fetch(hv, "LIST", 4, FALSE);
988         typesvp = hv_fetch(hv, "TYPE", 4, FALSE);
989         bitssvp = hv_fetch(hv, "BITS", 4, FALSE);
990         nonesvp = hv_fetch(hv, "NONE", 4, FALSE);
991         extssvp = hv_fetch(hv, "EXTRAS", 6, FALSE);
992         typestr = SvPV_nolen(*typesvp);
993         typeto  = typestr[0] == 'T' && typestr[1] == 'o';
994         bits    = (U32)SvUV(*bitssvp);
995         none    = (U32)SvUV(*nonesvp);
996         end     = start + len;
997         octets  = bits >> 3; /* if bits == 1, then octets == 0 */
998
999         if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1000             Perl_croak(aTHX_ "SWASHGET unknown bits %"UVuf, (UV)bits);
1001         }
1002         if (debug) {
1003             char* selfstr = SvPV_nolen(self);
1004             PerlIO_printf(Perl_error_log, "SWASHGET ");
1005             PerlIO_printf(Perl_error_log, "%s %"UVuf" %"UVuf" ",
1006                                           selfstr, (UV)start, (UV)len);
1007             PerlIO_printf(Perl_error_log, "[%s/%"UVuf"/%"UVuf"]\n",
1008                                           typestr, (UV)bits, (UV)none);
1009         }
1010
1011         /* initialize $swatch */
1012         swatch = newSVpvn("",0);
1013         scur   = octets ? (len * octets) : (len + 7) / 8;
1014         SvGROW(swatch, scur + 1);
1015         s = (U8*)SvPVX(swatch);
1016         if (octets && none) {
1017             const U8* e = s + scur;
1018             while (s < e) {
1019                 if (bits == 8)
1020                     *s++ = (U8)(none & 0xff);
1021                 else if (bits == 16) {
1022                     *s++ = (U8)((none >>  8) & 0xff);
1023                     *s++ = (U8)( none        & 0xff);
1024                 }
1025                 else if (bits == 32) {
1026                     *s++ = (U8)((none >> 24) & 0xff);
1027                     *s++ = (U8)((none >> 16) & 0xff);
1028                     *s++ = (U8)((none >>  8) & 0xff);
1029                     *s++ = (U8)( none        & 0xff);
1030                 }
1031             }
1032             *s = '\0';
1033         }
1034         else {
1035             (void)memzero((U8*)s, scur + 1);
1036         }
1037         SvCUR_set(swatch, scur);
1038         s = (U8*)SvPVX(swatch);
1039
1040         /* read $self->{LIST} */
1041         l = (U8*)SvPV(*listsvp, lcur);
1042         lend = l + lcur;
1043         while (l < lend) {
1044             U32 min, max, val, key;
1045             STRLEN numlen;
1046             I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1047
1048             nextline = (U8*)memchr(l, '\n', lend - l);
1049
1050             numlen = lend - l;
1051             min = (U32)grok_hex(l, &numlen, &flags, NULL);
1052             if (numlen)
1053                 l += numlen;
1054             else if (nextline) {
1055                 l = nextline + 1; /* 1 is length of "\n" */
1056                 continue;
1057             }
1058             else {
1059                 l = lend; /* to the end of LIST, at which no \n */
1060                 break;
1061             }
1062
1063             if (isBLANK(*l)) {
1064                 ++l;
1065                 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1066                 numlen = lend - l;
1067                 max = (U32)grok_hex(l, &numlen, &flags, NULL);
1068                 if (numlen)
1069                     l += numlen;
1070                 else
1071                     max = min;
1072
1073                 if (octets) {
1074                     if (isBLANK(*l)) {
1075                         ++l;
1076                         flags = PERL_SCAN_SILENT_ILLDIGIT |
1077                                 PERL_SCAN_DISALLOW_PREFIX;
1078                         numlen = lend - l;
1079                         val = (U32)grok_hex(l, &numlen, &flags, NULL);
1080                         if (numlen)
1081                             l += numlen;
1082                         else
1083                             val = 0;
1084                     }
1085                     else {
1086                         val = 0;
1087                         if (typeto) {
1088                             Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1089                                              typestr, l);
1090                         }
1091                     }
1092                 }
1093             }
1094             else {
1095                 max = min;
1096                 if (octets) {
1097                     val = 0;
1098                     if (typeto) {
1099                         Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1100                                          typestr, l);
1101                     }
1102                 }
1103             }
1104
1105             if (nextline)
1106                 l = nextline + 1;
1107             else
1108                 l = lend;
1109
1110             if (max < start)
1111                 continue;
1112
1113             if (octets) {
1114                 if (debug) {
1115                     PerlIO_printf(Perl_error_log,
1116                         "%"UVuf" %"UVuf" %"UVuf"\n",
1117                         (UV)min, (UV)max, (UV)val);
1118                 }
1119                 if (min < start) {
1120                     if (!none || val < none) {
1121                         val += start - min;
1122                     }
1123                     min = start;
1124                 }
1125                 for (key = min; key <= max; key++) {
1126                     U32 offset;
1127                     if (key >= end)
1128                         goto go_out_list;
1129                     if (debug) {
1130                         PerlIO_printf(Perl_error_log,
1131                                 "%"UVuf" => %"UVuf"\n",
1132                                 (UV)key, (UV)val);
1133                     }
1134
1135                 /* offset must be non-negative (start <= min <= key < end) */
1136                     offset = (key - start) * octets;
1137                     if (bits == 8)
1138                         s[offset] = (U8)(val & 0xff);
1139                     else if (bits == 16) {
1140                         s[offset    ] = (U8)((val >>  8) & 0xff);
1141                         s[offset + 1] = (U8)( val        & 0xff);
1142                     }
1143                     else if (bits == 32) {
1144                         s[offset    ] = (U8)((val >> 24) & 0xff);
1145                         s[offset + 1] = (U8)((val >> 16) & 0xff);
1146                         s[offset + 2] = (U8)((val >>  8) & 0xff);
1147                         s[offset + 3] = (U8)( val        & 0xff);
1148                     }
1149
1150                     if (!none || val < none)
1151                         ++val;
1152                 }
1153             }
1154             else {
1155                 if (min < start)
1156                     min = start;
1157                 for (key = min; key <= max; key++) {
1158                     U32 offset = key - start;
1159                     if (key >= end)
1160                         goto go_out_list;
1161                     if (debug) {
1162                         PerlIO_printf(Perl_error_log,
1163                                 "%"UVuf" => 1\n", (UV)key);
1164                     }
1165                     s[offset >> 3] |= 1 << (offset & 7);
1166                 }
1167             }
1168         }
1169     go_out_list:
1170
1171         /* read $self->{EXTRAS} */
1172         x = (U8*)SvPV(*extssvp, xcur);
1173         xend = x + xcur;
1174         while (x < xend) {
1175             STRLEN namelen;
1176             U8 *namestr;
1177             SV** othersvp;
1178             U32 otherbits;
1179
1180             U8 opc = *x++;
1181             if (opc == '\n')
1182                 continue;
1183
1184             nextline = (U8*)memchr(x, '\n', xend - x);
1185
1186             if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
1187                 if (nextline) {
1188                     x = nextline + 1;
1189                     continue;
1190                 }
1191                 else {
1192                     x = xend;
1193                     break;
1194                 }
1195             }
1196
1197             namestr = x;
1198
1199             if (nextline) {
1200                 namelen = nextline - namestr;
1201                 x = nextline + 1;
1202             }
1203             else {
1204                 namelen = xend - namestr;
1205                 x = xend;
1206             }
1207
1208             if (debug) {
1209                 U8* tmpstr;
1210                 Newx(tmpstr, namelen + 1, U8);
1211                 Move(namestr, tmpstr, namelen, U8);
1212                 tmpstr[namelen] = '\0';
1213                 PerlIO_printf(Perl_error_log,
1214                         "INDIRECT %c %s\n", opc, tmpstr);
1215                 Safefree(tmpstr);
1216             }
1217
1218             {
1219                 HV* otherhv;
1220                 SV **otherbitssvp;
1221
1222                 othersvp = hv_fetch(hv, namestr, namelen, FALSE);
1223                 if (*othersvp && SvROK(*othersvp) &&
1224                                  SvTYPE(SvRV(*othersvp))==SVt_PVHV)
1225                     otherhv = (HV*)SvRV(*othersvp);
1226                 else
1227                     Perl_croak(aTHX_ "otherhv is not a hash reference");
1228
1229                 otherbitssvp = hv_fetch(otherhv, "BITS", 4, FALSE);
1230                 otherbits = (U32)SvUV(*otherbitssvp);
1231                 if (bits < otherbits)
1232                     Perl_croak(aTHX_ "SWASHGET size mismatch");
1233             }
1234
1235             {
1236                 dSP;
1237                 ENTER;
1238                 SAVETMPS;
1239                 PUSHMARK(SP);
1240                 EXTEND(SP,3);
1241                 PUSHs(*othersvp);
1242                 PUSHs(sv_2mortal(newSViv(start)));
1243                 PUSHs(sv_2mortal(newSViv(len)));
1244                 PUTBACK;
1245                 if (call_method("SWASHGET", G_SCALAR)) {
1246                     U8 *s, *o;
1247                     STRLEN slen, olen;
1248                     SV* tmpsv = *PL_stack_sp--;
1249                     o = (U8*)SvPV(tmpsv, olen);
1250
1251                     if (!olen)
1252                         Perl_croak(aTHX_ "SWASHGET didn't return valid swatch");
1253                     s = SvPV(swatch, slen);
1254                     if (bits == 1 && otherbits == 1) {
1255                         if (slen != olen)
1256                             Perl_croak(aTHX_ "SWASHGET length mismatch");
1257
1258                         switch (opc) {
1259                         case '+':
1260                             while (slen--)
1261                                 *s++ |= *o++;
1262                             break;
1263                         case '!':
1264                             while (slen--)
1265                                 *s++ |= ~*o++;
1266                             break;
1267                         case '-':
1268                             while (slen--)
1269                                 *s++ &= ~*o++;
1270                             break;
1271                         case '&':
1272                             while (slen--)
1273                                 *s++ &= *o++;
1274                             break;
1275                         default:
1276                             break;
1277                         }
1278                     }
1279                     else {
1280                         U32 otheroctets = otherbits / 8;
1281                         U32 offset = 0;
1282                         U8* send = s + slen;
1283
1284                         while (s < send) {
1285                             U32 val = 0;
1286
1287                             if (otherbits == 1) {
1288                                 val = (o[offset >> 3] >> (offset & 7)) & 1;
1289                                 ++offset;
1290                             }
1291                             else {
1292                                 U32 vlen = otheroctets;
1293                                 val = *o++;
1294                                 while (--vlen) {
1295                                     val <<= 8;
1296                                     val |= *o++;
1297                                 }
1298                             }
1299
1300                             if      (opc == '+' && val)
1301                                 val = 1;
1302                             else if (opc == '!' && !val)
1303                                 val = 1;
1304                             else if (opc == '-' && val)
1305                                 val = 0;
1306                             else if (opc == '&' && !val)
1307                                 val = 0;
1308                             else {
1309                                 s += octets;
1310                                 continue;
1311                             }
1312
1313                             if (bits == 8)
1314                                 *s++ = (U8)( val & 0xff);
1315                             else if (bits == 16) {
1316                                 *s++ = (U8)((val >>  8) & 0xff);
1317                                 *s++ = (U8)( val        & 0xff);
1318                             }
1319                             else if (bits == 32) {
1320                                 *s++ = (U8)((val >> 24) & 0xff);
1321                                 *s++ = (U8)((val >> 16) & 0xff);
1322                                 *s++ = (U8)((val >>  8) & 0xff);
1323                                 *s++ = (U8)( val        & 0xff);
1324                             }
1325                         }
1326                     }
1327                 }
1328                 FREETMPS;
1329                 LEAVE;
1330             }
1331         }
1332
1333         if (debug) {
1334             U8* s = (U8*)SvPVX(swatch);
1335             PerlIO_printf(Perl_error_log, "CELLS ");
1336             if (bits == 1) {
1337                 U32 key;
1338                 for (key = 0; key < len; key++) {
1339                     int val = (s[key >> 3] >> (key & 7)) & 1;
1340                     PerlIO_printf(Perl_error_log, val ? "1 " : "0 ");
1341                 }
1342             }
1343             else {
1344                 U8* send = s + len * octets;
1345                 while (s < send) {
1346                     U32 vlen = octets;
1347                     U32 val = *s++;
1348                     while (--vlen) {
1349                         val <<= 8;
1350                         val |= *s++;
1351                     }
1352                     PerlIO_printf(Perl_error_log, "%"UVuf" ", (UV)val);
1353                 }
1354             }
1355             PerlIO_printf(Perl_error_log, "\n");
1356         }
1357
1358         ST(0) = swatch;
1359         sv_2mortal(ST(0));
1360     }
1361     XSRETURN(1);
1362 }
1363
1364
1365 /*
1366  * Local variables:
1367  * c-indentation-style: bsd
1368  * c-basic-offset: 4
1369  * indent-tabs-mode: t
1370  * End:
1371  *
1372  * ex: set ts=8 sts=4 sw=4 noet:
1373  */