home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / universal.c < prev    next >
C/C++ Source or Header  |  2000-03-21  |  6KB  |  283 lines
  1. #include "EXTERN.h"
  2. #define PERL_IN_UNIVERSAL_C
  3. #include "perl.h"
  4.  
  5. /*
  6.  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  7.  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  8.  */
  9.  
  10. STATIC SV *
  11. S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
  12. {
  13.     AV* av;
  14.     GV* gv;
  15.     GV** gvp;
  16.     HV* hv = Nullhv;
  17.  
  18.     if (!stash)
  19.     return &PL_sv_undef;
  20.  
  21.     if(strEQ(HvNAME(stash), name))
  22.     return &PL_sv_yes;
  23.  
  24.     if (level > 100)
  25.     Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash));
  26.  
  27.     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  28.  
  29.     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) {
  30.     SV* sv;
  31.     SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
  32.     if (svp && (sv = *svp) != (SV*)&PL_sv_undef)
  33.         return sv;
  34.     }
  35.  
  36.     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  37.     
  38.     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  39.     if(!hv) {
  40.         gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  41.  
  42.         gv = *gvp;
  43.  
  44.         if (SvTYPE(gv) != SVt_PVGV)
  45.         gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  46.  
  47.         hv = GvHVn(gv);
  48.     }
  49.     if(hv) {
  50.         SV** svp = AvARRAY(av);
  51.         /* NOTE: No support for tied ISA */
  52.         I32 items = AvFILLp(av) + 1;
  53.         while (items--) {
  54.         SV* sv = *svp++;
  55.         HV* basestash = gv_stashsv(sv, FALSE);
  56.         if (!basestash) {
  57.             dTHR;
  58.             if (ckWARN(WARN_MISC))
  59.             Perl_warner(aTHX_ WARN_SYNTAX,
  60.                      "Can't locate package %s for @%s::ISA",
  61.                 SvPVX(sv), HvNAME(stash));
  62.             continue;
  63.         }
  64.         if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
  65.             (void)hv_store(hv,name,len,&PL_sv_yes,0);
  66.             return &PL_sv_yes;
  67.         }
  68.         }
  69.         (void)hv_store(hv,name,len,&PL_sv_no,0);
  70.     }
  71.     }
  72.  
  73.     return boolSV(strEQ(name, "UNIVERSAL"));
  74. }
  75.  
  76. /*
  77. =for apidoc sv_derived_from
  78.  
  79. Returns a boolean indicating whether the SV is derived from the specified
  80. class.  This is the function that implements C<UNIVERSAL::isa>.  It works
  81. for class names as well as for objects.
  82.  
  83. =cut
  84. */
  85.  
  86. bool
  87. Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
  88. {
  89.     char *type;
  90.     HV *stash;
  91.   
  92.     stash = Nullhv;
  93.     type = Nullch;
  94.  
  95.     if (SvGMAGICAL(sv))
  96.         mg_get(sv) ;
  97.  
  98.     if (SvROK(sv)) {
  99.         sv = SvRV(sv);
  100.         type = sv_reftype(sv,0);
  101.         if(SvOBJECT(sv))
  102.             stash = SvSTASH(sv);
  103.     }
  104.     else {
  105.         stash = gv_stashsv(sv, FALSE);
  106.     }
  107.  
  108.     return (type && strEQ(type,name)) ||
  109.             (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
  110.         ? TRUE
  111.         : FALSE ;
  112. }
  113.  
  114. void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
  115. void XS_UNIVERSAL_can(pTHXo_ CV *cv);
  116. void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv);
  117.  
  118. void
  119. Perl_boot_core_UNIVERSAL(pTHX)
  120. {
  121.     char *file = __FILE__;
  122.  
  123.     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
  124.     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
  125.     newXS("UNIVERSAL::VERSION",     XS_UNIVERSAL_VERSION,       file);
  126. }
  127.  
  128. #include "XSUB.h"
  129.  
  130. XS(XS_UNIVERSAL_isa)
  131. {
  132.     dXSARGS;
  133.     SV *sv;
  134.     char *name;
  135.     STRLEN n_a;
  136.  
  137.     if (items != 2)
  138.     Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
  139.  
  140.     sv = ST(0);
  141.  
  142.     if (SvGMAGICAL(sv))
  143.     mg_get(sv);
  144.  
  145.     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
  146.     XSRETURN_UNDEF;
  147.  
  148.     name = (char *)SvPV(ST(1),n_a);
  149.  
  150.     ST(0) = boolSV(sv_derived_from(sv, name));
  151.     XSRETURN(1);
  152. }
  153.  
  154. XS(XS_UNIVERSAL_can)
  155. {
  156.     dXSARGS;
  157.     SV   *sv;
  158.     char *name;
  159.     SV   *rv;
  160.     HV   *pkg = NULL;
  161.     STRLEN n_a;
  162.  
  163.     if (items != 2)
  164.     Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
  165.  
  166.     sv = ST(0);
  167.  
  168.     if (SvGMAGICAL(sv))
  169.     mg_get(sv);
  170.  
  171.     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
  172.     XSRETURN_UNDEF;
  173.  
  174.     name = (char *)SvPV(ST(1),n_a);
  175.     rv = &PL_sv_undef;
  176.  
  177.     if(SvROK(sv)) {
  178.         sv = (SV*)SvRV(sv);
  179.         if(SvOBJECT(sv))
  180.             pkg = SvSTASH(sv);
  181.     }
  182.     else {
  183.         pkg = gv_stashsv(sv, FALSE);
  184.     }
  185.  
  186.     if (pkg) {
  187.         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
  188.         if (gv && isGV(gv))
  189.         rv = sv_2mortal(newRV((SV*)GvCV(gv)));
  190.     }
  191.  
  192.     ST(0) = rv;
  193.     XSRETURN(1);
  194. }
  195.  
  196. XS(XS_UNIVERSAL_VERSION)
  197. {
  198.     dXSARGS;
  199.     HV *pkg;
  200.     GV **gvp;
  201.     GV *gv;
  202.     SV *sv;
  203.     char *undef;
  204.  
  205.     if (SvROK(ST(0))) {
  206.         sv = (SV*)SvRV(ST(0));
  207.         if (!SvOBJECT(sv))
  208.             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
  209.         pkg = SvSTASH(sv);
  210.     }
  211.     else {
  212.         pkg = gv_stashsv(ST(0), FALSE);
  213.     }
  214.  
  215.     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
  216.  
  217.     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
  218.         SV *nsv = sv_newmortal();
  219.         sv_setsv(nsv, sv);
  220.         sv = nsv;
  221.         undef = Nullch;
  222.     }
  223.     else {
  224.         sv = (SV*)&PL_sv_undef;
  225.         undef = "(undef)";
  226.     }
  227.  
  228.     if (items > 1) {
  229.     STRLEN len;
  230.     SV *req = ST(1);
  231.  
  232.     if (undef)
  233.         Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
  234.                HvNAME(pkg), HvNAME(pkg));
  235.  
  236.     if (!SvNIOK(sv) && SvPOK(sv)) {
  237.         char *str = SvPVx(sv,len);
  238.         while (len) {
  239.         --len;
  240.         /* XXX could DWIM "1.2.3" here */
  241.         if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
  242.             break;
  243.         }
  244.         if (len) {
  245.         if (SvNIOKp(req) && SvPOK(req)) {
  246.             /* they said C<use Foo v1.2.3> and $Foo::VERSION
  247.              * doesn't look like a float: do string compare */
  248.             if (sv_cmp(req,sv) == 1) {
  249.             Perl_croak(aTHX_ "%s v%vd required--"
  250.                    "this is only v%vd",
  251.                    HvNAME(pkg), req, sv);
  252.             }
  253.             goto finish;
  254.         }
  255.         /* they said C<use Foo 1.002_003> and $Foo::VERSION
  256.          * doesn't look like a float: force numeric compare */
  257.         (void)SvUPGRADE(sv, SVt_PVNV);
  258.         SvNVX(sv) = str_to_version(sv);
  259.         SvPOK_off(sv);
  260.         SvNOK_on(sv);
  261.         }
  262.     }
  263.     /* if we get here, we're looking for a numeric comparison,
  264.      * so force the required version into a float, even if they
  265.      * said C<use Foo v1.2.3> */
  266.     if (SvNIOKp(req) && SvPOK(req)) {
  267.         NV n = SvNV(req);
  268.         req = sv_newmortal();
  269.         sv_setnv(req, n);
  270.     }
  271.  
  272.     if (SvNV(req) > SvNV(sv))
  273.         Perl_croak(aTHX_ "%s version %s required--this is only version %s",
  274.           HvNAME(pkg), SvPV(req,len), SvPV(sv,len));
  275.     }
  276.  
  277. finish:
  278.     ST(0) = sv;
  279.  
  280.     XSRETURN(1);
  281. }
  282.  
  283.