binmode(FH); to act like binmode(FH,":bytes") as well as
[p5sagit/p5-mst-13.2.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 %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
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_utf8_valid);
164 XS(XS_utf8_encode);
165 XS(XS_utf8_decode);
166 XS(XS_utf8_upgrade);
167 XS(XS_utf8_downgrade);
168 XS(XS_utf8_unicode_to_native);
169 XS(XS_utf8_native_to_unicode);
170 XS(XS_Internals_SvREADONLY);
171 XS(XS_Internals_SvREFCNT);
172 XS(XS_Internals_hv_clear_placehold);
173
174 void
175 Perl_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
196 XS(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
220 XS(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
262 XS(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
351 finish:
352     ST(0) = sv;
353
354     XSRETURN(1);
355 }
356
357 XS(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
376 XS(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
389 XS(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
405 XS(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
421 XS(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
444 XS(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
456 XS(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
468 XS(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
492 XS(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.  */
508 XS(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 }