This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3e8d8b113bb322dd68e3f6ca1f8a5c325ed21b8c
[perl5.git] / universal.c
1 /*    universal.c
2  *
3  *    Copyright (c) 1997-2002, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "The roots of those mountains must be roots indeed; there must be
12  * great secrets buried there which have not been discovered since the
13  * beginning." --Gandalf, relating Gollum's story
14  */
15
16 #include "EXTERN.h"
17 #define PERL_IN_UNIVERSAL_C
18 #include "perl.h"
19
20 /*
21  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
22  * The main guts of traverse_isa was actually copied from gv_fetchmeth
23  */
24
25 STATIC SV *
26 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
27              int len, int level)
28 {
29     AV* av;
30     GV* gv;
31     GV** gvp;
32     HV* hv = Nullhv;
33     SV* subgen = Nullsv;
34
35     /* A stash/class can go by many names (ie. User == main::User), so 
36        we compare the stash itself just in case */
37     if (name_stash && (stash == name_stash))
38         return &PL_sv_yes;
39
40     if (strEQ(HvNAME(stash), name))
41         return &PL_sv_yes;
42
43     if (level > 100)
44         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
45                    HvNAME(stash));
46
47     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
48
49     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
50         && (hv = GvHV(gv)))
51     {
52         if (SvIV(subgen) == (IV)PL_sub_generation) {
53             SV* sv;
54             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
55             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
56                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
57                                   name, HvNAME(stash)) );
58                 return sv;
59             }
60         }
61         else {
62             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
63                               HvNAME(stash)) );
64             hv_clear(hv);
65             sv_setiv(subgen, PL_sub_generation);
66         }
67     }
68
69     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
70
71     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
72         if (!hv || !subgen) {
73             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
74
75             gv = *gvp;
76
77             if (SvTYPE(gv) != SVt_PVGV)
78                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
79
80             if (!hv)
81                 hv = GvHVn(gv);
82             if (!subgen) {
83                 subgen = newSViv(PL_sub_generation);
84                 GvSV(gv) = subgen;
85             }
86         }
87         if (hv) {
88             SV** svp = AvARRAY(av);
89             /* NOTE: No support for tied ISA */
90             I32 items = AvFILLp(av) + 1;
91             while (items--) {
92                 SV* sv = *svp++;
93                 HV* basestash = gv_stashsv(sv, FALSE);
94                 if (!basestash) {
95                     if (ckWARN(WARN_MISC))
96                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
97                              "Can't locate package %"SVf" for @%s::ISA",
98                             sv, HvNAME(stash));
99                     continue;
100                 }
101                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
102                                              len, level + 1)) {
103                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
104                     return &PL_sv_yes;
105                 }
106             }
107             (void)hv_store(hv,name,len,&PL_sv_no,0);
108         }
109     }
110
111     return boolSV(strEQ(name, "UNIVERSAL"));
112 }
113
114 /*
115 =head1 SV Manipulation Functions
116
117 =for apidoc sv_derived_from
118
119 Returns a boolean indicating whether the SV is derived from the specified
120 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
121 for class names as well as for objects.
122
123 =cut
124 */
125
126 bool
127 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
128 {
129     char *type;
130     HV *stash;
131     HV *name_stash;
132
133     stash = Nullhv;
134     type = Nullch;
135
136     if (SvGMAGICAL(sv))
137         mg_get(sv) ;
138
139     if (SvROK(sv)) {
140         sv = SvRV(sv);
141         type = sv_reftype(sv,0);
142         if (SvOBJECT(sv))
143             stash = SvSTASH(sv);
144     }
145     else {
146         stash = gv_stashsv(sv, FALSE);
147     }
148
149     name_stash = gv_stashpv(name, FALSE);
150
151     return (type && strEQ(type,name)) ||
152             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
153              == &PL_sv_yes)
154         ? TRUE
155         : FALSE ;
156 }
157
158 #include "XSUB.h"
159
160 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
161 void XS_UNIVERSAL_can(pTHX_ CV *cv);
162 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
163 XS(XS_version_new);
164 XS(XS_version_stringify);
165 XS(XS_version_numify);
166 XS(XS_version_vcmp);
167 XS(XS_version_boolean);
168 XS(XS_version_noop);
169 XS(XS_utf8_valid);
170 XS(XS_utf8_encode);
171 XS(XS_utf8_decode);
172 XS(XS_utf8_upgrade);
173 XS(XS_utf8_downgrade);
174 XS(XS_utf8_unicode_to_native);
175 XS(XS_utf8_native_to_unicode);
176 XS(XS_Internals_SvREADONLY);
177 XS(XS_Internals_SvREFCNT);
178 XS(XS_Internals_hv_clear_placehold);
179
180 void
181 Perl_boot_core_UNIVERSAL(pTHX)
182 {
183     char *file = __FILE__;
184
185     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
186     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
187     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
188     {
189         /* register the overloading (type 'A') magic */
190         PL_amagic_generation++;
191         /* Make it findable via fetchmethod */
192         newXS("version::()", XS_version_noop, file);
193         newXS("version::new", XS_version_new, file);
194         newXS("version::(\"\"", XS_version_stringify, file);
195         newXS("version::stringify", XS_version_stringify, file);
196         newXS("version::(0+", XS_version_numify, file);
197         newXS("version::numify", XS_version_numify, file);
198         newXS("version::(cmp", XS_version_vcmp, file);
199         newXS("version::(<=>", XS_version_vcmp, file);
200         newXS("version::vcmp", XS_version_vcmp, file);
201         newXS("version::(bool", XS_version_boolean, file);
202         newXS("version::boolean", XS_version_boolean, file);
203         newXS("version::(nomethod", XS_version_noop, file);
204         newXS("version::noop", XS_version_noop, file);
205     }
206     newXS("utf8::valid", XS_utf8_valid, file);
207     newXS("utf8::encode", XS_utf8_encode, file);
208     newXS("utf8::decode", XS_utf8_decode, file);
209     newXS("utf8::upgrade", XS_utf8_upgrade, file);
210     newXS("utf8::downgrade", XS_utf8_downgrade, file);
211     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
212     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
213     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
214     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
215     newXSproto("Internals::hv_clear_placeholders",
216                XS_Internals_hv_clear_placehold, file, "\\%");
217 }
218
219
220 XS(XS_UNIVERSAL_isa)
221 {
222     dXSARGS;
223     SV *sv;
224     char *name;
225     STRLEN n_a;
226
227     if (items != 2)
228         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
229
230     sv = ST(0);
231
232     if (SvGMAGICAL(sv))
233         mg_get(sv);
234
235     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
236                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
237         XSRETURN_UNDEF;
238
239     name = (char *)SvPV(ST(1),n_a);
240
241     ST(0) = boolSV(sv_derived_from(sv, name));
242     XSRETURN(1);
243 }
244
245 XS(XS_UNIVERSAL_can)
246 {
247     dXSARGS;
248     SV   *sv;
249     char *name;
250     SV   *rv;
251     HV   *pkg = NULL;
252     STRLEN n_a;
253
254     if (items != 2)
255         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
256
257     sv = ST(0);
258
259     if (SvGMAGICAL(sv))
260         mg_get(sv);
261
262     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
263                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
264         XSRETURN_UNDEF;
265
266     name = (char *)SvPV(ST(1),n_a);
267     rv = &PL_sv_undef;
268
269     if (SvROK(sv)) {
270         sv = (SV*)SvRV(sv);
271         if (SvOBJECT(sv))
272             pkg = SvSTASH(sv);
273     }
274     else {
275         pkg = gv_stashsv(sv, FALSE);
276     }
277
278     if (pkg) {
279         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
280         if (gv && isGV(gv))
281             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
282     }
283
284     ST(0) = rv;
285     XSRETURN(1);
286 }
287
288 XS(XS_UNIVERSAL_VERSION)
289 {
290     dXSARGS;
291     HV *pkg;
292     GV **gvp;
293     GV *gv;
294     SV *sv;
295     char *undef;
296
297     if (SvROK(ST(0))) {
298         sv = (SV*)SvRV(ST(0));
299         if (!SvOBJECT(sv))
300             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
301         pkg = SvSTASH(sv);
302     }
303     else {
304         pkg = gv_stashsv(ST(0), FALSE);
305     }
306
307     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
308
309     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
310         SV *nsv = sv_newmortal();
311         sv_setsv(nsv, sv);
312         sv = nsv;
313         undef = Nullch;
314     }
315     else {
316         sv = (SV*)&PL_sv_undef;
317         undef = "(undef)";
318     }
319
320     if (items > 1) {
321         STRLEN len;
322         SV *req = ST(1);
323
324         if (undef) {
325              if (pkg)
326                   Perl_croak(aTHX_
327                              "%s does not define $%s::VERSION--version check failed",
328                              HvNAME(pkg), HvNAME(pkg));
329              else {
330                   char *str = SvPVx(ST(0), len);
331
332                   Perl_croak(aTHX_
333                              "%s defines neither package nor VERSION--version check failed", str);
334              }
335         }
336         if ( !sv_derived_from(sv, "version"))
337             sv = new_version(sv);
338
339         if ( !sv_derived_from(req, "version"))
340             req = new_version(req);
341
342         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
343             Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
344                 HvNAME(pkg), req, sv);
345     }
346
347     ST(0) = sv;
348
349     XSRETURN(1);
350 }
351
352 XS(XS_version_new)
353 {
354     dXSARGS;
355     if (items != 2)
356         Perl_croak(aTHX_ "Usage: version::new(class, version)");
357     SP -= items;
358     {
359 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
360         SV *    version = ST(1);
361
362 {
363     PUSHs(new_version(version));
364 }
365
366         PUTBACK;
367         return;
368     }
369 }
370
371 XS(XS_version_stringify)
372 {
373     dXSARGS;
374     if (items < 1)
375         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
376     SP -= items;
377     {
378         SV *    lobj;
379
380         if (sv_derived_from(ST(0), "version")) {
381                 SV *tmp = SvRV(ST(0));
382                 lobj = tmp;
383         }
384         else
385                 Perl_croak(aTHX_ "lobj is not of type version");
386
387 {
388     PUSHs(vstringify(lobj));
389 }
390
391         PUTBACK;
392         return;
393     }
394 }
395
396 XS(XS_version_numify)
397 {
398     dXSARGS;
399     if (items < 1)
400         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
401     SP -= items;
402     {
403         SV *    lobj;
404
405         if (sv_derived_from(ST(0), "version")) {
406                 SV *tmp = SvRV(ST(0));
407                 lobj = tmp;
408         }
409         else
410                 Perl_croak(aTHX_ "lobj is not of type version");
411
412 {
413     PUSHs(vnumify(lobj));
414 }
415
416         PUTBACK;
417         return;
418     }
419 }
420
421 XS(XS_version_vcmp)
422 {
423     dXSARGS;
424     if (items < 1)
425         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
426     SP -= items;
427     {
428         SV *    lobj;
429
430         if (sv_derived_from(ST(0), "version")) {
431                 SV *tmp = SvRV(ST(0));
432                 lobj = tmp;
433         }
434         else
435                 Perl_croak(aTHX_ "lobj is not of type version");
436
437 {
438     SV  *rs;
439     SV  *rvs;
440     SV * robj = ST(1);
441     IV   swap = (IV)SvIV(ST(2));
442
443     if ( ! sv_derived_from(robj, "version") )
444     {
445         robj = new_version(robj);
446     }
447     rvs = SvRV(robj);
448
449     if ( swap )
450     {
451         rs = newSViv(vcmp(rvs,lobj));
452     }
453     else
454     {
455         rs = newSViv(vcmp(lobj,rvs));
456     }
457
458     PUSHs(rs);
459 }
460
461         PUTBACK;
462         return;
463     }
464 }
465
466 XS(XS_version_boolean)
467 {
468     dXSARGS;
469     if (items < 1)
470         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
471     SP -= items;
472     {
473         SV *    lobj;
474
475         if (sv_derived_from(ST(0), "version")) {
476                 SV *tmp = SvRV(ST(0));
477                 lobj = tmp;
478         }
479         else
480                 Perl_croak(aTHX_ "lobj is not of type version");
481
482 {
483     SV  *rs;
484     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
485     PUSHs(rs);
486 }
487
488         PUTBACK;
489         return;
490     }
491 }
492
493 XS(XS_version_noop)
494 {
495     dXSARGS;
496     if (items < 1)
497         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
498     {
499         SV *    lobj;
500
501         if (sv_derived_from(ST(0), "version")) {
502                 SV *tmp = SvRV(ST(0));
503                 lobj = tmp;
504         }
505         else
506                 Perl_croak(aTHX_ "lobj is not of type version");
507
508 {
509     Perl_croak(aTHX_ "operation not supported with version object");
510 }
511
512     }
513     XSRETURN_EMPTY;
514 }
515
516 XS(XS_utf8_valid)
517 {
518     dXSARGS;
519     if (items != 1)
520         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
521     {
522         SV *    sv = ST(0);
523  {
524   STRLEN len;
525   char *s = SvPV(sv,len);
526   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
527    XSRETURN_YES;
528   else
529    XSRETURN_NO;
530  }
531     }
532     XSRETURN_EMPTY;
533 }
534
535 XS(XS_utf8_encode)
536 {
537     dXSARGS;
538     if (items != 1)
539         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
540     {
541         SV *    sv = ST(0);
542
543         sv_utf8_encode(sv);
544     }
545     XSRETURN_EMPTY;
546 }
547
548 XS(XS_utf8_decode)
549 {
550     dXSARGS;
551     if (items != 1)
552         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
553     {
554         SV *    sv = ST(0);
555         bool    RETVAL;
556
557         RETVAL = sv_utf8_decode(sv);
558         ST(0) = boolSV(RETVAL);
559         sv_2mortal(ST(0));
560     }
561     XSRETURN(1);
562 }
563
564 XS(XS_utf8_upgrade)
565 {
566     dXSARGS;
567     if (items != 1)
568         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
569     {
570         SV *    sv = ST(0);
571         STRLEN  RETVAL;
572         dXSTARG;
573
574         RETVAL = sv_utf8_upgrade(sv);
575         XSprePUSH; PUSHi((IV)RETVAL);
576     }
577     XSRETURN(1);
578 }
579
580 XS(XS_utf8_downgrade)
581 {
582     dXSARGS;
583     if (items < 1 || items > 2)
584         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
585     {
586         SV *    sv = ST(0);
587         bool    failok;
588         bool    RETVAL;
589
590         if (items < 2)
591             failok = 0;
592         else {
593             failok = (int)SvIV(ST(1));
594         }
595
596         RETVAL = sv_utf8_downgrade(sv, failok);
597         ST(0) = boolSV(RETVAL);
598         sv_2mortal(ST(0));
599     }
600     XSRETURN(1);
601 }
602
603 XS(XS_utf8_native_to_unicode)
604 {
605  dXSARGS;
606  UV uv = SvUV(ST(0));
607
608  if (items > 1)
609      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
610
611  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
612  XSRETURN(1);
613 }
614
615 XS(XS_utf8_unicode_to_native)
616 {
617  dXSARGS;
618  UV uv = SvUV(ST(0));
619
620  if (items > 1)
621      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
622
623  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
624  XSRETURN(1);
625 }
626
627 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
628 {
629     dXSARGS;
630     SV *sv = SvRV(ST(0));
631     if (items == 1) {
632          if (SvREADONLY(sv))
633              XSRETURN_YES;
634          else
635              XSRETURN_NO;
636     }
637     else if (items == 2) {
638         if (SvTRUE(ST(1))) {
639             SvREADONLY_on(sv);
640             XSRETURN_YES;
641         }
642         else {
643             /* I hope you really know what you are doing. */
644             SvREADONLY_off(sv);
645             XSRETURN_NO;
646         }
647     }
648     XSRETURN_UNDEF; /* Can't happen. */
649 }
650
651 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
652 {
653     dXSARGS;
654     SV *sv = SvRV(ST(0));
655     if (items == 1)
656          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
657     else if (items == 2) {
658          /* I hope you really know what you are doing. */
659          SvREFCNT(sv) = SvIV(ST(1));
660          XSRETURN_IV(SvREFCNT(sv));
661     }
662     XSRETURN_UNDEF; /* Can't happen. */
663 }
664
665 /* Maybe this should return the number of placeholders found in scalar context,
666    and a list of them in list context.  */
667 XS(XS_Internals_hv_clear_placehold)
668 {
669     dXSARGS;
670     HV *hv = (HV *) SvRV(ST(0));
671
672     /* I don't care how many parameters were passed in, but I want to avoid
673        the unused variable warning. */
674
675     items = (I32)HvPLACEHOLDERS(hv);
676
677     if (items) {
678         HE *entry;
679         I32 riter = HvRITER(hv);
680         HE *eiter = HvEITER(hv);
681         hv_iterinit(hv);
682         /* This may look suboptimal with the items *after* the iternext, but
683            it's quite deliberate. We only get here with items==0 if we've
684            just deleted the last placeholder in the hash. If we've just done
685            that then it means that the hash is in lazy delete mode, and the
686            HE is now only referenced in our iterator. If we just quit the loop
687            and discarded our iterator then the HE leaks. So we do the && the
688            other way to ensure iternext is called just one more time, which
689            has the side effect of triggering the lazy delete.  */
690         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
691             && items) {
692             SV *val = hv_iterval(hv, entry);
693
694             if (val == &PL_sv_undef) {
695
696                 /* It seems that I have to go back in the front of the hash
697                    API to delete a hash, even though I have a HE structure
698                    pointing to the very entry I want to delete, and could hold
699                    onto the previous HE that points to it. And it's easier to
700                    go in with SVs as I can then specify the precomputed hash,
701                    and don't have fun and games with utf8 keys.  */
702                 SV *key = hv_iterkeysv(entry);
703
704                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
705                 items--;
706             }
707         }
708         HvRITER(hv) = riter;
709         HvEITER(hv) = eiter;
710     }
711
712     XSRETURN(0);
713 }