1 /* universal.c
2 *
3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 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 #include "EXTERN.h"
18 #define PERL_IN_UNIVERSAL_C
19 #include "perl.h"
20
21 #ifdef USE_PERLIO
22 #include "perliol.h" /* For the PERLIO_F_XXX */
23 #endif
24
25 /*
26 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
27 * The main guts of traverse_isa was actually copied from gv_fetchmeth
28 */
29
30 STATIC SV *
S_isa_lookup(pTHX_ HV * stash,const char * name,HV * name_stash,int len,int level)31 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
32 int len, int level)
33 {
34 AV* av;
35 GV* gv;
36 GV** gvp;
37 HV* hv = Nullhv;
38 SV* subgen = Nullsv;
39
40 /* A stash/class can go by many names (ie. User == main::User), so
41 we compare the stash itself just in case */
42 if (name_stash && (stash == name_stash))
43 return &PL_sv_yes;
44
45 if (strEQ(HvNAME(stash), name))
46 return &PL_sv_yes;
47
48 if (strEQ(name, "UNIVERSAL"))
49 return &PL_sv_yes;
50
51 if (level > 100)
52 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
53 HvNAME(stash));
54
55 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
56
57 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
58 && (hv = GvHV(gv)))
59 {
60 if (SvIV(subgen) == (IV)PL_sub_generation) {
61 SV* sv;
62 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
63 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
64 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
65 name, HvNAME(stash)) );
66 return sv;
67 }
68 }
69 else {
70 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
71 HvNAME(stash)) );
72 hv_clear(hv);
73 sv_setiv(subgen, PL_sub_generation);
74 }
75 }
76
77 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
78
79 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
80 if (!hv || !subgen) {
81 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
82
83 gv = *gvp;
84
85 if (SvTYPE(gv) != SVt_PVGV)
86 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
87
88 if (!hv)
89 hv = GvHVn(gv);
90 if (!subgen) {
91 subgen = newSViv(PL_sub_generation);
92 GvSV(gv) = subgen;
93 }
94 }
95 if (hv) {
96 SV** svp = AvARRAY(av);
97 /* NOTE: No support for tied ISA */
98 I32 items = AvFILLp(av) + 1;
99 while (items--) {
100 SV* sv = *svp++;
101 HV* basestash = gv_stashsv(sv, FALSE);
102 if (!basestash) {
103 if (ckWARN(WARN_MISC))
104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
105 "Can't locate package %"SVf" for @%s::ISA",
106 sv, HvNAME(stash));
107 continue;
108 }
109 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
110 len, level + 1)) {
111 (void)hv_store(hv,name,len,&PL_sv_yes,0);
112 return &PL_sv_yes;
113 }
114 }
115 (void)hv_store(hv,name,len,&PL_sv_no,0);
116 }
117 }
118 return &PL_sv_no;
119 }
120
121 /*
122 =head1 SV Manipulation Functions
123
124 =for apidoc sv_derived_from
125
126 Returns a boolean indicating whether the SV is derived from the specified
127 class. This is the function that implements C<UNIVERSAL::isa>. It works
128 for class names as well as for objects.
129
130 =cut
131 */
132
133 bool
Perl_sv_derived_from(pTHX_ SV * sv,const char * name)134 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
135 {
136 char *type;
137 HV *stash;
138 HV *name_stash;
139
140 stash = Nullhv;
141 type = Nullch;
142
143 if (SvGMAGICAL(sv))
144 mg_get(sv) ;
145
146 if (SvROK(sv)) {
147 sv = SvRV(sv);
148 type = sv_reftype(sv,0);
149 if (SvOBJECT(sv))
150 stash = SvSTASH(sv);
151 }
152 else {
153 stash = gv_stashsv(sv, FALSE);
154 }
155
156 name_stash = gv_stashpv(name, FALSE);
157
158 return (type && strEQ(type,name)) ||
159 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
160 == &PL_sv_yes)
161 ? TRUE
162 : FALSE ;
163 }
164
165 #include "XSUB.h"
166
167 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
168 void XS_UNIVERSAL_can(pTHX_ CV *cv);
169 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
170 XS(XS_utf8_is_utf8);
171 XS(XS_utf8_valid);
172 XS(XS_utf8_encode);
173 XS(XS_utf8_decode);
174 XS(XS_utf8_upgrade);
175 XS(XS_utf8_downgrade);
176 XS(XS_utf8_unicode_to_native);
177 XS(XS_utf8_native_to_unicode);
178 XS(XS_Internals_SvREADONLY);
179 XS(XS_Internals_SvREFCNT);
180 XS(XS_Internals_hv_clear_placehold);
181 XS(XS_PerlIO_get_layers);
182 XS(XS_Regexp_DESTROY);
183 XS(XS_Internals_hash_seed);
184 XS(XS_Internals_rehash_seed);
185 XS(XS_Internals_HvREHASH);
186
187 void
Perl_boot_core_UNIVERSAL(pTHX)188 Perl_boot_core_UNIVERSAL(pTHX)
189 {
190 char *file = __FILE__;
191
192 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
193 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
194 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
195 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
196 newXS("utf8::valid", XS_utf8_valid, file);
197 newXS("utf8::encode", XS_utf8_encode, file);
198 newXS("utf8::decode", XS_utf8_decode, file);
199 newXS("utf8::upgrade", XS_utf8_upgrade, file);
200 newXS("utf8::downgrade", XS_utf8_downgrade, file);
201 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
202 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
203 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
204 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
205 newXSproto("Internals::hv_clear_placeholders",
206 XS_Internals_hv_clear_placehold, file, "\\%");
207 newXSproto("PerlIO::get_layers",
208 XS_PerlIO_get_layers, file, "*;@");
209 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
210 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
211 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
212 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
213 }
214
215
XS(XS_UNIVERSAL_isa)216 XS(XS_UNIVERSAL_isa)
217 {
218 dXSARGS;
219 SV *sv;
220 char *name;
221 STRLEN n_a;
222
223 if (items != 2)
224 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
225
226 sv = ST(0);
227
228 if (SvGMAGICAL(sv))
229 mg_get(sv);
230
231 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
232 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
233 XSRETURN_UNDEF;
234
235 name = (char *)SvPV(ST(1),n_a);
236
237 ST(0) = boolSV(sv_derived_from(sv, name));
238 XSRETURN(1);
239 }
240
XS(XS_UNIVERSAL_can)241 XS(XS_UNIVERSAL_can)
242 {
243 dXSARGS;
244 SV *sv;
245 char *name;
246 SV *rv;
247 HV *pkg = NULL;
248 STRLEN n_a;
249
250 if (items != 2)
251 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
252
253 sv = ST(0);
254
255 if (SvGMAGICAL(sv))
256 mg_get(sv);
257
258 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
259 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
260 XSRETURN_UNDEF;
261
262 name = (char *)SvPV(ST(1),n_a);
263 rv = &PL_sv_undef;
264
265 if (SvROK(sv)) {
266 sv = (SV*)SvRV(sv);
267 if (SvOBJECT(sv))
268 pkg = SvSTASH(sv);
269 }
270 else {
271 pkg = gv_stashsv(sv, FALSE);
272 }
273
274 if (pkg) {
275 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
276 if (gv && isGV(gv))
277 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
278 }
279
280 ST(0) = rv;
281 XSRETURN(1);
282 }
283
XS(XS_UNIVERSAL_VERSION)284 XS(XS_UNIVERSAL_VERSION)
285 {
286 dXSARGS;
287 HV *pkg;
288 GV **gvp;
289 GV *gv;
290 SV *sv;
291 char *undef;
292
293 if (SvROK(ST(0))) {
294 sv = (SV*)SvRV(ST(0));
295 if (!SvOBJECT(sv))
296 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
297 pkg = SvSTASH(sv);
298 }
299 else {
300 pkg = gv_stashsv(ST(0), FALSE);
301 }
302
303 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
304
305 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
306 SV *nsv = sv_newmortal();
307 sv_setsv(nsv, sv);
308 sv = nsv;
309 undef = Nullch;
310 }
311 else {
312 sv = (SV*)&PL_sv_undef;
313 undef = "(undef)";
314 }
315
316 if (items > 1) {
317 STRLEN len;
318 SV *req = ST(1);
319
320 if (undef) {
321 if (pkg)
322 Perl_croak(aTHX_
323 "%s does not define $%s::VERSION--version check failed",
324 HvNAME(pkg), HvNAME(pkg));
325 else {
326 char *str = SvPVx(ST(0), len);
327
328 Perl_croak(aTHX_
329 "%s defines neither package nor VERSION--version check failed", str);
330 }
331 }
332 if (!SvNIOK(sv) && SvPOK(sv)) {
333 char *str = SvPVx(sv,len);
334 while (len) {
335 --len;
336 /* XXX could DWIM "1.2.3" here */
337 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
338 break;
339 }
340 if (len) {
341 if (SvNOK(req) && SvPOK(req)) {
342 /* they said C<use Foo v1.2.3> and $Foo::VERSION
343 * doesn't look like a float: do string compare */
344 if (sv_cmp(req,sv) == 1) {
345 Perl_croak(aTHX_ "%s v%"VDf" required--"
346 "this is only v%"VDf,
347 HvNAME(pkg), req, sv);
348 }
349 goto finish;
350 }
351 /* they said C<use Foo 1.002_003> and $Foo::VERSION
352 * doesn't look like a float: force numeric compare */
353 (void)SvUPGRADE(sv, SVt_PVNV);
354 SvNVX(sv) = str_to_version(sv);
355 SvPOK_off(sv);
356 SvNOK_on(sv);
357 }
358 }
359 /* if we get here, we're looking for a numeric comparison,
360 * so force the required version into a float, even if they
361 * said C<use Foo v1.2.3> */
362 if (SvNOK(req) && SvPOK(req)) {
363 NV n = SvNV(req);
364 req = sv_newmortal();
365 sv_setnv(req, n);
366 }
367
368 if (SvNV(req) > SvNV(sv))
369 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
370 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
371 }
372
373 finish:
374 ST(0) = sv;
375
376 XSRETURN(1);
377 }
378
XS(XS_utf8_is_utf8)379 XS(XS_utf8_is_utf8)
380 {
381 dXSARGS;
382 if (items != 1)
383 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
384 {
385 SV * sv = ST(0);
386 {
387 if (SvUTF8(sv))
388 XSRETURN_YES;
389 else
390 XSRETURN_NO;
391 }
392 }
393 XSRETURN_EMPTY;
394 }
395
XS(XS_utf8_valid)396 XS(XS_utf8_valid)
397 {
398 dXSARGS;
399 if (items != 1)
400 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
401 {
402 SV * sv = ST(0);
403 {
404 STRLEN len;
405 char *s = SvPV(sv,len);
406 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
407 XSRETURN_YES;
408 else
409 XSRETURN_NO;
410 }
411 }
412 XSRETURN_EMPTY;
413 }
414
XS(XS_utf8_encode)415 XS(XS_utf8_encode)
416 {
417 dXSARGS;
418 if (items != 1)
419 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
420 {
421 SV * sv = ST(0);
422
423 sv_utf8_encode(sv);
424 }
425 XSRETURN_EMPTY;
426 }
427
XS(XS_utf8_decode)428 XS(XS_utf8_decode)
429 {
430 dXSARGS;
431 if (items != 1)
432 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
433 {
434 SV * sv = ST(0);
435 bool RETVAL;
436
437 RETVAL = sv_utf8_decode(sv);
438 ST(0) = boolSV(RETVAL);
439 sv_2mortal(ST(0));
440 }
441 XSRETURN(1);
442 }
443
XS(XS_utf8_upgrade)444 XS(XS_utf8_upgrade)
445 {
446 dXSARGS;
447 if (items != 1)
448 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
449 {
450 SV * sv = ST(0);
451 STRLEN RETVAL;
452 dXSTARG;
453
454 RETVAL = sv_utf8_upgrade(sv);
455 XSprePUSH; PUSHi((IV)RETVAL);
456 }
457 XSRETURN(1);
458 }
459
XS(XS_utf8_downgrade)460 XS(XS_utf8_downgrade)
461 {
462 dXSARGS;
463 if (items < 1 || items > 2)
464 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
465 {
466 SV * sv = ST(0);
467 bool failok;
468 bool RETVAL;
469
470 if (items < 2)
471 failok = 0;
472 else {
473 failok = (int)SvIV(ST(1));
474 }
475
476 RETVAL = sv_utf8_downgrade(sv, failok);
477 ST(0) = boolSV(RETVAL);
478 sv_2mortal(ST(0));
479 }
480 XSRETURN(1);
481 }
482
XS(XS_utf8_native_to_unicode)483 XS(XS_utf8_native_to_unicode)
484 {
485 dXSARGS;
486 UV uv = SvUV(ST(0));
487
488 if (items > 1)
489 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
490
491 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
492 XSRETURN(1);
493 }
494
XS(XS_utf8_unicode_to_native)495 XS(XS_utf8_unicode_to_native)
496 {
497 dXSARGS;
498 UV uv = SvUV(ST(0));
499
500 if (items > 1)
501 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
502
503 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
504 XSRETURN(1);
505 }
506
XS(XS_Internals_SvREADONLY)507 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
508 {
509 dXSARGS;
510 SV *sv = SvRV(ST(0));
511 if (items == 1) {
512 if (SvREADONLY(sv))
513 XSRETURN_YES;
514 else
515 XSRETURN_NO;
516 }
517 else if (items == 2) {
518 if (SvTRUE(ST(1))) {
519 SvREADONLY_on(sv);
520 XSRETURN_YES;
521 }
522 else {
523 /* I hope you really know what you are doing. */
524 SvREADONLY_off(sv);
525 XSRETURN_NO;
526 }
527 }
528 XSRETURN_UNDEF; /* Can't happen. */
529 }
530
XS(XS_Internals_SvREFCNT)531 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
532 {
533 dXSARGS;
534 SV *sv = SvRV(ST(0));
535 if (items == 1)
536 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
537 else if (items == 2) {
538 /* I hope you really know what you are doing. */
539 SvREFCNT(sv) = SvIV(ST(1));
540 XSRETURN_IV(SvREFCNT(sv));
541 }
542 XSRETURN_UNDEF; /* Can't happen. */
543 }
544
XS(XS_Internals_hv_clear_placehold)545 XS(XS_Internals_hv_clear_placehold)
546 {
547 dXSARGS;
548 HV *hv = (HV *) SvRV(ST(0));
549 if (items != 1)
550 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
551 hv_clear_placeholders(hv);
552 XSRETURN(0);
553 }
554
XS(XS_Regexp_DESTROY)555 XS(XS_Regexp_DESTROY)
556 {
557
558 }
559
XS(XS_PerlIO_get_layers)560 XS(XS_PerlIO_get_layers)
561 {
562 dXSARGS;
563 if (items < 1 || items % 2 == 0)
564 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
565 #ifdef USE_PERLIO
566 {
567 SV * sv;
568 GV * gv;
569 IO * io;
570 bool input = TRUE;
571 bool details = FALSE;
572
573 if (items > 1) {
574 SV **svp;
575
576 for (svp = MARK + 2; svp <= SP; svp += 2) {
577 SV **varp = svp;
578 SV **valp = svp + 1;
579 STRLEN klen;
580 char *key = SvPV(*varp, klen);
581
582 switch (*key) {
583 case 'i':
584 if (klen == 5 && memEQ(key, "input", 5)) {
585 input = SvTRUE(*valp);
586 break;
587 }
588 goto fail;
589 case 'o':
590 if (klen == 6 && memEQ(key, "output", 6)) {
591 input = !SvTRUE(*valp);
592 break;
593 }
594 goto fail;
595 case 'd':
596 if (klen == 7 && memEQ(key, "details", 7)) {
597 details = SvTRUE(*valp);
598 break;
599 }
600 goto fail;
601 default:
602 fail:
603 Perl_croak(aTHX_
604 "get_layers: unknown argument '%s'",
605 key);
606 }
607 }
608
609 SP -= (items - 1);
610 }
611
612 sv = POPs;
613 gv = (GV*)sv;
614
615 if (!isGV(sv)) {
616 if (SvROK(sv) && isGV(SvRV(sv)))
617 gv = (GV*)SvRV(sv);
618 else
619 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
620 }
621
622 if (gv && (io = GvIO(gv))) {
623 dTARGET;
624 AV* av = PerlIO_get_layers(aTHX_ input ?
625 IoIFP(io) : IoOFP(io));
626 I32 i;
627 I32 last = av_len(av);
628 I32 nitem = 0;
629
630 for (i = last; i >= 0; i -= 3) {
631 SV **namsvp;
632 SV **argsvp;
633 SV **flgsvp;
634 bool namok, argok, flgok;
635
636 namsvp = av_fetch(av, i - 2, FALSE);
637 argsvp = av_fetch(av, i - 1, FALSE);
638 flgsvp = av_fetch(av, i, FALSE);
639
640 namok = namsvp && *namsvp && SvPOK(*namsvp);
641 argok = argsvp && *argsvp && SvPOK(*argsvp);
642 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
643
644 if (details) {
645 XPUSHs(namok ?
646 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
647 XPUSHs(argok ?
648 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
649 if (flgok)
650 XPUSHi(SvIVX(*flgsvp));
651 else
652 XPUSHs(&PL_sv_undef);
653 nitem += 3;
654 }
655 else {
656 if (namok && argok)
657 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
658 *namsvp, *argsvp));
659 else if (namok)
660 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
661 else
662 XPUSHs(&PL_sv_undef);
663 nitem++;
664 if (flgok) {
665 IV flags = SvIVX(*flgsvp);
666
667 if (flags & PERLIO_F_UTF8) {
668 XPUSHs(newSVpvn("utf8", 4));
669 nitem++;
670 }
671 }
672 }
673 }
674
675 SvREFCNT_dec(av);
676
677 XSRETURN(nitem);
678 }
679 }
680 #endif
681
682 XSRETURN(0);
683 }
684
XS(XS_Internals_hash_seed)685 XS(XS_Internals_hash_seed)
686 {
687 /* Using dXSARGS would also have dITEM and dSP,
688 * which define 2 unused local variables. */
689 dMARK; dAX;
690 XSRETURN_UV(PERL_HASH_SEED);
691 }
692
XS(XS_Internals_rehash_seed)693 XS(XS_Internals_rehash_seed)
694 {
695 /* Using dXSARGS would also have dITEM and dSP,
696 * which define 2 unused local variables. */
697 dMARK; dAX;
698 XSRETURN_UV(PL_rehash_seed);
699 }
700
XS(XS_Internals_HvREHASH)701 XS(XS_Internals_HvREHASH) /* Subject to change */
702 {
703 dXSARGS;
704 if (SvROK(ST(0))) {
705 HV *hv = (HV *) SvRV(ST(0));
706 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
707 if (HvREHASH(hv))
708 XSRETURN_YES;
709 else
710 XSRETURN_NO;
711 }
712 }
713 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
714 }
715