This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
version objects final(?) patch
[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 > 3)
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         if (items == 3 )
362         {
363             char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
364             version = newSVpvf("v%s",vs);
365         }
366
367         PUSHs(new_version(version));
368         PUTBACK;
369         return;
370     }
371 }
372
373 XS(XS_version_stringify)
374 {
375     dXSARGS;
376     if (items < 1)
377         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
378     SP -= items;
379     {
380         SV *    lobj;
381
382         if (sv_derived_from(ST(0), "version")) {
383                 SV *tmp = SvRV(ST(0));
384                 lobj = tmp;
385         }
386         else
387                 Perl_croak(aTHX_ "lobj is not of type version");
388
389 {
390     PUSHs(vstringify(lobj));
391 }
392
393         PUTBACK;
394         return;
395     }
396 }
397
398 XS(XS_version_numify)
399 {
400     dXSARGS;
401     if (items < 1)
402         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
403     SP -= items;
404     {
405         SV *    lobj;
406
407         if (sv_derived_from(ST(0), "version")) {
408                 SV *tmp = SvRV(ST(0));
409                 lobj = tmp;
410         }
411         else
412                 Perl_croak(aTHX_ "lobj is not of type version");
413
414 {
415     PUSHs(vnumify(lobj));
416 }
417
418         PUTBACK;
419         return;
420     }
421 }
422
423 XS(XS_version_vcmp)
424 {
425     dXSARGS;
426     if (items < 1)
427         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
428     SP -= items;
429     {
430         SV *    lobj;
431
432         if (sv_derived_from(ST(0), "version")) {
433                 SV *tmp = SvRV(ST(0));
434                 lobj = tmp;
435         }
436         else
437                 Perl_croak(aTHX_ "lobj is not of type version");
438
439 {
440     SV  *rs;
441     SV  *rvs;
442     SV * robj = ST(1);
443     IV   swap = (IV)SvIV(ST(2));
444
445     if ( ! sv_derived_from(robj, "version") )
446     {
447         robj = new_version(robj);
448     }
449     rvs = SvRV(robj);
450
451     if ( swap )
452     {
453         rs = newSViv(vcmp(rvs,lobj));
454     }
455     else
456     {
457         rs = newSViv(vcmp(lobj,rvs));
458     }
459
460     PUSHs(rs);
461 }
462
463         PUTBACK;
464         return;
465     }
466 }
467
468 XS(XS_version_boolean)
469 {
470     dXSARGS;
471     if (items < 1)
472         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
473     SP -= items;
474     {
475         SV *    lobj;
476
477         if (sv_derived_from(ST(0), "version")) {
478                 SV *tmp = SvRV(ST(0));
479                 lobj = tmp;
480         }
481         else
482                 Perl_croak(aTHX_ "lobj is not of type version");
483
484 {
485     SV  *rs;
486     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
487     PUSHs(rs);
488 }
489
490         PUTBACK;
491         return;
492     }
493 }
494
495 XS(XS_version_noop)
496 {
497     dXSARGS;
498     if (items < 1)
499         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
500     {
501         SV *    lobj;
502
503         if (sv_derived_from(ST(0), "version")) {
504                 SV *tmp = SvRV(ST(0));
505                 lobj = tmp;
506         }
507         else
508                 Perl_croak(aTHX_ "lobj is not of type version");
509
510 {
511     Perl_croak(aTHX_ "operation not supported with version object");
512 }
513
514     }
515     XSRETURN_EMPTY;
516 }
517
518 XS(XS_utf8_valid)
519 {
520     dXSARGS;
521     if (items != 1)
522         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
523     {
524         SV *    sv = ST(0);
525  {
526   STRLEN len;
527   char *s = SvPV(sv,len);
528   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
529    XSRETURN_YES;
530   else
531    XSRETURN_NO;
532  }
533     }
534     XSRETURN_EMPTY;
535 }
536
537 XS(XS_utf8_encode)
538 {
539     dXSARGS;
540     if (items != 1)
541         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
542     {
543         SV *    sv = ST(0);
544
545         sv_utf8_encode(sv);
546     }
547     XSRETURN_EMPTY;
548 }
549
550 XS(XS_utf8_decode)
551 {
552     dXSARGS;
553     if (items != 1)
554         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
555     {
556         SV *    sv = ST(0);
557         bool    RETVAL;
558
559         RETVAL = sv_utf8_decode(sv);
560         ST(0) = boolSV(RETVAL);
561         sv_2mortal(ST(0));
562     }
563     XSRETURN(1);
564 }
565
566 XS(XS_utf8_upgrade)
567 {
568     dXSARGS;
569     if (items != 1)
570         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
571     {
572         SV *    sv = ST(0);
573         STRLEN  RETVAL;
574         dXSTARG;
575
576         RETVAL = sv_utf8_upgrade(sv);
577         XSprePUSH; PUSHi((IV)RETVAL);
578     }
579     XSRETURN(1);
580 }
581
582 XS(XS_utf8_downgrade)
583 {
584     dXSARGS;
585     if (items < 1 || items > 2)
586         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
587     {
588         SV *    sv = ST(0);
589         bool    failok;
590         bool    RETVAL;
591
592         if (items < 2)
593             failok = 0;
594         else {
595             failok = (int)SvIV(ST(1));
596         }
597
598         RETVAL = sv_utf8_downgrade(sv, failok);
599         ST(0) = boolSV(RETVAL);
600         sv_2mortal(ST(0));
601     }
602     XSRETURN(1);
603 }
604
605 XS(XS_utf8_native_to_unicode)
606 {
607  dXSARGS;
608  UV uv = SvUV(ST(0));
609
610  if (items > 1)
611      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
612
613  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
614  XSRETURN(1);
615 }
616
617 XS(XS_utf8_unicode_to_native)
618 {
619  dXSARGS;
620  UV uv = SvUV(ST(0));
621
622  if (items > 1)
623      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
624
625  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
626  XSRETURN(1);
627 }
628
629 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
630 {
631     dXSARGS;
632     SV *sv = SvRV(ST(0));
633     if (items == 1) {
634          if (SvREADONLY(sv))
635              XSRETURN_YES;
636          else
637              XSRETURN_NO;
638     }
639     else if (items == 2) {
640         if (SvTRUE(ST(1))) {
641             SvREADONLY_on(sv);
642             XSRETURN_YES;
643         }
644         else {
645             /* I hope you really know what you are doing. */
646             SvREADONLY_off(sv);
647             XSRETURN_NO;
648         }
649     }
650     XSRETURN_UNDEF; /* Can't happen. */
651 }
652
653 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
654 {
655     dXSARGS;
656     SV *sv = SvRV(ST(0));
657     if (items == 1)
658          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
659     else if (items == 2) {
660          /* I hope you really know what you are doing. */
661          SvREFCNT(sv) = SvIV(ST(1));
662          XSRETURN_IV(SvREFCNT(sv));
663     }
664     XSRETURN_UNDEF; /* Can't happen. */
665 }
666
667 /* Maybe this should return the number of placeholders found in scalar context,
668    and a list of them in list context.  */
669 XS(XS_Internals_hv_clear_placehold)
670 {
671     dXSARGS;
672     HV *hv = (HV *) SvRV(ST(0));
673
674     /* I don't care how many parameters were passed in, but I want to avoid
675        the unused variable warning. */
676
677     items = (I32)HvPLACEHOLDERS(hv);
678
679     if (items) {
680         HE *entry;
681         I32 riter = HvRITER(hv);
682         HE *eiter = HvEITER(hv);
683         hv_iterinit(hv);
684         /* This may look suboptimal with the items *after* the iternext, but
685            it's quite deliberate. We only get here with items==0 if we've
686            just deleted the last placeholder in the hash. If we've just done
687            that then it means that the hash is in lazy delete mode, and the
688            HE is now only referenced in our iterator. If we just quit the loop
689            and discarded our iterator then the HE leaks. So we do the && the
690            other way to ensure iternext is called just one more time, which
691            has the side effect of triggering the lazy delete.  */
692         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
693             && items) {
694             SV *val = hv_iterval(hv, entry);
695
696             if (val == &PL_sv_undef) {
697
698                 /* It seems that I have to go back in the front of the hash
699                    API to delete a hash, even though I have a HE structure
700                    pointing to the very entry I want to delete, and could hold
701                    onto the previous HE that points to it. And it's easier to
702                    go in with SVs as I can then specify the precomputed hash,
703                    and don't have fun and games with utf8 keys.  */
704                 SV *key = hv_iterkeysv(entry);
705
706                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
707                 items--;
708             }
709         }
710         HvRITER(hv) = riter;
711         HvEITER(hv) = eiter;
712     }
713
714     XSRETURN(0);
715 }