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

Revision 20075, 15.4 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1/*    universal.c
2 *
3 *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
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
30STATIC SV *
31S_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
126Returns a boolean indicating whether the SV is derived from the specified
127class.  This is the function that implements C<UNIVERSAL::isa>.  It works
128for class names as well as for objects.
129
130=cut
131*/
132
133bool
134Perl_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
167void XS_UNIVERSAL_isa(pTHX_ CV *cv);
168void XS_UNIVERSAL_can(pTHX_ CV *cv);
169void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
170XS(XS_utf8_is_utf8);
171XS(XS_utf8_valid);
172XS(XS_utf8_encode);
173XS(XS_utf8_decode);
174XS(XS_utf8_upgrade);
175XS(XS_utf8_downgrade);
176XS(XS_utf8_unicode_to_native);
177XS(XS_utf8_native_to_unicode);
178XS(XS_Internals_SvREADONLY);
179XS(XS_Internals_SvREFCNT);
180XS(XS_Internals_hv_clear_placehold);
181XS(XS_PerlIO_get_layers);
182XS(XS_Regexp_DESTROY);
183XS(XS_Internals_hash_seed);
184XS(XS_Internals_rehash_seed);
185XS(XS_Internals_HvREHASH);
186
187void
188Perl_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
216XS(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
241XS(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
284XS(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
373finish:
374    ST(0) = sv;
375
376    XSRETURN(1);
377}
378
379XS(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
396XS(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
415XS(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
428XS(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
444XS(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
460XS(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
483XS(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
495XS(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
507XS(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
531XS(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
545XS(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
555XS(XS_Regexp_DESTROY)
556{
557
558}
559
560XS(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
685XS(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
693XS(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
701XS(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}
Note: See TracBrowser for help on using the repository browser.