source: trunk/third/perl/universal.c @ 18450

Revision 18450, 12.8 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r18449, which included commits to RCS files with non-trunk default branches.
Line 
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
25STATIC SV *
26S_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 %s for @%s::ISA",
98                            SvPVX(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
119Returns a boolean indicating whether the SV is derived from the specified
120class.  This is the function that implements C<UNIVERSAL::isa>.  It works
121for class names as well as for objects.
122
123=cut
124*/
125
126bool
127Perl_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
160void XS_UNIVERSAL_isa(pTHX_ CV *cv);
161void XS_UNIVERSAL_can(pTHX_ CV *cv);
162void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
163XS(XS_utf8_valid);
164XS(XS_utf8_encode);
165XS(XS_utf8_decode);
166XS(XS_utf8_upgrade);
167XS(XS_utf8_downgrade);
168XS(XS_utf8_unicode_to_native);
169XS(XS_utf8_native_to_unicode);
170XS(XS_Internals_SvREADONLY);
171XS(XS_Internals_SvREFCNT);
172XS(XS_Internals_hv_clear_placehold);
173
174void
175Perl_boot_core_UNIVERSAL(pTHX)
176{
177    char *file = __FILE__;
178
179    newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
180    newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
181    newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
182    newXS("utf8::valid", XS_utf8_valid, file);
183    newXS("utf8::encode", XS_utf8_encode, file);
184    newXS("utf8::decode", XS_utf8_decode, file);
185    newXS("utf8::upgrade", XS_utf8_upgrade, file);
186    newXS("utf8::downgrade", XS_utf8_downgrade, file);
187    newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
188    newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
189    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
190    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
191    newXSproto("Internals::hv_clear_placeholders",
192               XS_Internals_hv_clear_placehold, file, "\\%");
193}
194
195
196XS(XS_UNIVERSAL_isa)
197{
198    dXSARGS;
199    SV *sv;
200    char *name;
201    STRLEN n_a;
202
203    if (items != 2)
204        Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
205
206    sv = ST(0);
207
208    if (SvGMAGICAL(sv))
209        mg_get(sv);
210
211    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
212        XSRETURN_UNDEF;
213
214    name = (char *)SvPV(ST(1),n_a);
215
216    ST(0) = boolSV(sv_derived_from(sv, name));
217    XSRETURN(1);
218}
219
220XS(XS_UNIVERSAL_can)
221{
222    dXSARGS;
223    SV   *sv;
224    char *name;
225    SV   *rv;
226    HV   *pkg = NULL;
227    STRLEN n_a;
228
229    if (items != 2)
230        Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
231
232    sv = ST(0);
233
234    if (SvGMAGICAL(sv))
235        mg_get(sv);
236
237    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
238        XSRETURN_UNDEF;
239
240    name = (char *)SvPV(ST(1),n_a);
241    rv = &PL_sv_undef;
242
243    if (SvROK(sv)) {
244        sv = (SV*)SvRV(sv);
245        if (SvOBJECT(sv))
246            pkg = SvSTASH(sv);
247    }
248    else {
249        pkg = gv_stashsv(sv, FALSE);
250    }
251
252    if (pkg) {
253        GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
254        if (gv && isGV(gv))
255            rv = sv_2mortal(newRV((SV*)GvCV(gv)));
256    }
257
258    ST(0) = rv;
259    XSRETURN(1);
260}
261
262XS(XS_UNIVERSAL_VERSION)
263{
264    dXSARGS;
265    HV *pkg;
266    GV **gvp;
267    GV *gv;
268    SV *sv;
269    char *undef;
270
271    if (SvROK(ST(0))) {
272        sv = (SV*)SvRV(ST(0));
273        if (!SvOBJECT(sv))
274            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
275        pkg = SvSTASH(sv);
276    }
277    else {
278        pkg = gv_stashsv(ST(0), FALSE);
279    }
280
281    gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
282
283    if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
284        SV *nsv = sv_newmortal();
285        sv_setsv(nsv, sv);
286        sv = nsv;
287        undef = Nullch;
288    }
289    else {
290        sv = (SV*)&PL_sv_undef;
291        undef = "(undef)";
292    }
293
294    if (items > 1) {
295        STRLEN len;
296        SV *req = ST(1);
297
298        if (undef) {
299             if (pkg)
300                  Perl_croak(aTHX_
301                             "%s does not define $%s::VERSION--version check failed",
302                             HvNAME(pkg), HvNAME(pkg));
303             else {
304                  char *str = SvPVx(ST(0), len);
305
306                  Perl_croak(aTHX_
307                             "%s defines neither package nor VERSION--version check failed", str);
308             }
309        }
310        if (!SvNIOK(sv) && SvPOK(sv)) {
311            char *str = SvPVx(sv,len);
312            while (len) {
313                --len;
314                /* XXX could DWIM "1.2.3" here */
315                if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
316                    break;
317            }
318            if (len) {
319                if (SvNOK(req) && SvPOK(req)) {
320                    /* they said C<use Foo v1.2.3> and $Foo::VERSION
321                     * doesn't look like a float: do string compare */
322                    if (sv_cmp(req,sv) == 1) {
323                        Perl_croak(aTHX_ "%s v%"VDf" required--"
324                                   "this is only v%"VDf,
325                                   HvNAME(pkg), req, sv);
326                    }
327                    goto finish;
328                }
329                /* they said C<use Foo 1.002_003> and $Foo::VERSION
330                 * doesn't look like a float: force numeric compare */
331                (void)SvUPGRADE(sv, SVt_PVNV);
332                SvNVX(sv) = str_to_version(sv);
333                SvPOK_off(sv);
334                SvNOK_on(sv);
335            }
336        }
337        /* if we get here, we're looking for a numeric comparison,
338         * so force the required version into a float, even if they
339         * said C<use Foo v1.2.3> */
340        if (SvNOK(req) && SvPOK(req)) {
341            NV n = SvNV(req);
342            req = sv_newmortal();
343            sv_setnv(req, n);
344        }
345
346        if (SvNV(req) > SvNV(sv))
347            Perl_croak(aTHX_ "%s version %s required--this is only version %s",
348                       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
349    }
350
351finish:
352    ST(0) = sv;
353
354    XSRETURN(1);
355}
356
357XS(XS_utf8_valid)
358{
359    dXSARGS;
360    if (items != 1)
361        Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
362    {
363        SV *    sv = ST(0);
364 {
365  STRLEN len;
366  char *s = SvPV(sv,len);
367  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
368   XSRETURN_YES;
369  else
370   XSRETURN_NO;
371 }
372    }
373    XSRETURN_EMPTY;
374}
375
376XS(XS_utf8_encode)
377{
378    dXSARGS;
379    if (items != 1)
380        Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
381    {
382        SV *    sv = ST(0);
383
384        sv_utf8_encode(sv);
385    }
386    XSRETURN_EMPTY;
387}
388
389XS(XS_utf8_decode)
390{
391    dXSARGS;
392    if (items != 1)
393        Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
394    {
395        SV *    sv = ST(0);
396        bool    RETVAL;
397
398        RETVAL = sv_utf8_decode(sv);
399        ST(0) = boolSV(RETVAL);
400        sv_2mortal(ST(0));
401    }
402    XSRETURN(1);
403}
404
405XS(XS_utf8_upgrade)
406{
407    dXSARGS;
408    if (items != 1)
409        Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
410    {
411        SV *    sv = ST(0);
412        STRLEN  RETVAL;
413        dXSTARG;
414
415        RETVAL = sv_utf8_upgrade(sv);
416        XSprePUSH; PUSHi((IV)RETVAL);
417    }
418    XSRETURN(1);
419}
420
421XS(XS_utf8_downgrade)
422{
423    dXSARGS;
424    if (items < 1 || items > 2)
425        Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
426    {
427        SV *    sv = ST(0);
428        bool    failok;
429        bool    RETVAL;
430
431        if (items < 2)
432            failok = 0;
433        else {
434            failok = (int)SvIV(ST(1));
435        }
436
437        RETVAL = sv_utf8_downgrade(sv, failok);
438        ST(0) = boolSV(RETVAL);
439        sv_2mortal(ST(0));
440    }
441    XSRETURN(1);
442}
443
444XS(XS_utf8_native_to_unicode)
445{
446 dXSARGS;
447 UV uv = SvUV(ST(0));
448
449 if (items > 1)
450     Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
451
452 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
453 XSRETURN(1);
454}
455
456XS(XS_utf8_unicode_to_native)
457{
458 dXSARGS;
459 UV uv = SvUV(ST(0));
460
461 if (items > 1)
462     Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
463
464 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
465 XSRETURN(1);
466}
467
468XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
469{
470    dXSARGS;
471    SV *sv = SvRV(ST(0));
472    if (items == 1) {
473         if (SvREADONLY(sv))
474             XSRETURN_YES;
475         else
476             XSRETURN_NO;
477    }
478    else if (items == 2) {
479        if (SvTRUE(ST(1))) {
480            SvREADONLY_on(sv);
481            XSRETURN_YES;
482        }
483        else {
484            /* I hope you really know what you are doing. */
485            SvREADONLY_off(sv);
486            XSRETURN_NO;
487        }
488    }
489    XSRETURN_UNDEF; /* Can't happen. */
490}
491
492XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
493{
494    dXSARGS;
495    SV *sv = SvRV(ST(0));
496    if (items == 1)
497         XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
498    else if (items == 2) {
499         /* I hope you really know what you are doing. */
500         SvREFCNT(sv) = SvIV(ST(1));
501         XSRETURN_IV(SvREFCNT(sv));
502    }
503    XSRETURN_UNDEF; /* Can't happen. */
504}
505
506/* Maybe this should return the number of placeholders found in scalar context,
507   and a list of them in list context.  */
508XS(XS_Internals_hv_clear_placehold)
509{
510    dXSARGS;
511    HV *hv = (HV *) SvRV(ST(0));
512
513    /* I don't care how many parameters were passed in, but I want to avoid
514       the unused variable warning. */
515
516    items = (I32)HvPLACEHOLDERS(hv);
517
518    if (items) {
519        HE *entry;
520        I32 riter = HvRITER(hv);
521        HE *eiter = HvEITER(hv);
522        hv_iterinit(hv);
523        /* This may look suboptimal with the items *after* the iternext, but
524           it's quite deliberate. We only get here with items==0 if we've
525           just deleted the last placeholder in the hash. If we've just done
526           that then it means that the hash is in lazy delete mode, and the
527           HE is now only referenced in our iterator. If we just quit the loop
528           and discarded our iterator then the HE leaks. So we do the && the
529           other way to ensure iternext is called just one more time, which
530           has the side effect of triggering the lazy delete.  */
531        while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
532            && items) {
533            SV *val = hv_iterval(hv, entry);
534
535            if (val == &PL_sv_undef) {
536
537                /* It seems that I have to go back in the front of the hash
538                   API to delete a hash, even though I have a HE structure
539                   pointing to the very entry I want to delete, and could hold
540                   onto the previous HE that points to it. And it's easier to
541                   go in with SVs as I can then specify the precomputed hash,
542                   and don't have fun and games with utf8 keys.  */
543                SV *key = hv_iterkeysv(entry);
544
545                hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
546                items--;
547            }
548        }
549        HvRITER(hv) = riter;
550        HvEITER(hv) = eiter;
551    }
552
553    XSRETURN(0);
554}
Note: See TracBrowser for help on using the repository browser.