projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
configure.gnu --prefix
[p5sagit/p5-mst-13.2.git] / universal.c
CommitLineData
d6376244 1/* universal.c
2 *
4bb101f2 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * by Larry Wall and others
d6376244 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
d31a8517 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
6d4a7be2 17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_UNIVERSAL_C
6d4a7be2 19#include "perl.h"
6d4a7be2 20
39f7a870 21#ifdef USE_PERLIO
22#include "perliol.h" /* For the PERLIO_F_XXX */
23#endif
24
6d4a7be2 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
76e3520e 30STATIC SV *
301daebc 31S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
32 int len, int level)
6d4a7be2 33{
34 AV* av;
35 GV* gv;
36 GV** gvp;
37 HV* hv = Nullhv;
46e4b22b 38 SV* subgen = Nullsv;
6d4a7be2 39
301daebc 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;
6d4a7be2 44
46e4b22b 45 if (strEQ(HvNAME(stash), name))
3280af22 46 return &PL_sv_yes;
6d4a7be2 47
a1d407e8 48 if (strEQ(name, "UNIVERSAL"))
49 return &PL_sv_yes;
50
6d4a7be2 51 if (level > 100)
46e4b22b 52 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
53 HvNAME(stash));
6d4a7be2 54
55 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
56
46e4b22b 57 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
58 && (hv = GvHV(gv)))
59 {
eb160463 60 if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b 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 }
6d4a7be2 75 }
76
77 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 78
3280af22 79 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 80 if (!hv || !subgen) {
6d4a7be2 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
46e4b22b 88 if (!hv)
89 hv = GvHVn(gv);
90 if (!subgen) {
91 subgen = newSViv(PL_sub_generation);
92 GvSV(gv) = subgen;
93 }
6d4a7be2 94 }
46e4b22b 95 if (hv) {
6d4a7be2 96 SV** svp = AvARRAY(av);
93965878 97 /* NOTE: No support for tied ISA */
98 I32 items = AvFILLp(av) + 1;
6d4a7be2 99 while (items--) {
100 SV* sv = *svp++;
101 HV* basestash = gv_stashsv(sv, FALSE);
102 if (!basestash) {
599cee73 103 if (ckWARN(WARN_MISC))
9014280d 104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
35c1215d 105 "Can't locate package %"SVf" for @%s::ISA",
106 sv, HvNAME(stash));
6d4a7be2 107 continue;
108 }
301daebc 109 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
110 len, level + 1)) {
3280af22 111 (void)hv_store(hv,name,len,&PL_sv_yes,0);
112 return &PL_sv_yes;
6d4a7be2 113 }
114 }
3280af22 115 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2 116 }
117 }
a1d407e8 118 return &PL_sv_no;
6d4a7be2 119}
120
954c1994 121/*
ccfc67b7 122=head1 SV Manipulation Functions
123
954c1994 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
55497cff 133bool
864dbfa3 134Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 135{
55497cff 136 char *type;
137 HV *stash;
301daebc 138 HV *name_stash;
46e4b22b 139
55497cff 140 stash = Nullhv;
141 type = Nullch;
46e4b22b 142
55497cff 143 if (SvGMAGICAL(sv))
144 mg_get(sv) ;
145
146 if (SvROK(sv)) {
147 sv = SvRV(sv);
148 type = sv_reftype(sv,0);
46e4b22b 149 if (SvOBJECT(sv))
55497cff 150 stash = SvSTASH(sv);
151 }
152 else {
153 stash = gv_stashsv(sv, FALSE);
154 }
46e4b22b 155
301daebc 156 name_stash = gv_stashpv(name, FALSE);
157
55497cff 158 return (type && strEQ(type,name)) ||
301daebc 159 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
160 == &PL_sv_yes)
55497cff 161 ? TRUE
162 : FALSE ;
55497cff 163}
164
1b026014 165#include "XSUB.h"
166
acfe0abc 167void XS_UNIVERSAL_isa(pTHX_ CV *cv);
168void XS_UNIVERSAL_can(pTHX_ CV *cv);
169void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4 170XS(XS_version_new);
171XS(XS_version_stringify);
172XS(XS_version_numify);
173XS(XS_version_vcmp);
174XS(XS_version_boolean);
175XS(XS_version_noop);
c8d69e4a 176XS(XS_version_is_alpha);
8800c35a 177XS(XS_utf8_is_utf8);
1b026014 178XS(XS_utf8_valid);
179XS(XS_utf8_encode);
180XS(XS_utf8_decode);
181XS(XS_utf8_upgrade);
182XS(XS_utf8_downgrade);
183XS(XS_utf8_unicode_to_native);
184XS(XS_utf8_native_to_unicode);
29569577 185XS(XS_Internals_SvREADONLY);
186XS(XS_Internals_SvREFCNT);
f044d0d1 187XS(XS_Internals_hv_clear_placehold);
39f7a870 188XS(XS_PerlIO_get_layers);
39cff0d9 189XS(XS_Regexp_DESTROY);
0cb96387 190
191void
192Perl_boot_core_UNIVERSAL(pTHX)
193{
194 char *file = __FILE__;
195
196 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
197 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
198 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 199 {
ad63d80f 200 /* register the overloading (type 'A') magic */
201 PL_amagic_generation++;
439cb1c4 202 /* Make it findable via fetchmethod */
be2ebcad 203 newXS("version::()", XS_version_noop, file);
439cb1c4 204 newXS("version::new", XS_version_new, file);
205 newXS("version::(\"\"", XS_version_stringify, file);
206 newXS("version::stringify", XS_version_stringify, file);
207 newXS("version::(0+", XS_version_numify, file);
208 newXS("version::numify", XS_version_numify, file);
209 newXS("version::(cmp", XS_version_vcmp, file);
210 newXS("version::(<=>", XS_version_vcmp, file);
211 newXS("version::vcmp", XS_version_vcmp, file);
212 newXS("version::(bool", XS_version_boolean, file);
213 newXS("version::boolean", XS_version_boolean, file);
214 newXS("version::(nomethod", XS_version_noop, file);
215 newXS("version::noop", XS_version_noop, file);
c8d69e4a 216 newXS("version::is_alpha", XS_version_is_alpha, file);
439cb1c4 217 }
8800c35a 218 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014 219 newXS("utf8::valid", XS_utf8_valid, file);
220 newXS("utf8::encode", XS_utf8_encode, file);
221 newXS("utf8::decode", XS_utf8_decode, file);
222 newXS("utf8::upgrade", XS_utf8_upgrade, file);
223 newXS("utf8::downgrade", XS_utf8_downgrade, file);
224 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
225 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577 226 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
227 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 228 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 229 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce 230 newXSproto("PerlIO::get_layers",
231 XS_PerlIO_get_layers, file, "*;@");
39cff0d9 232 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
0cb96387 233}
234
55497cff 235
6d4a7be2 236XS(XS_UNIVERSAL_isa)
237{
238 dXSARGS;
55497cff 239 SV *sv;
240 char *name;
2d8e6c8d 241 STRLEN n_a;
6d4a7be2 242
243 if (items != 2)
cea2e8a9 244 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2 245
246 sv = ST(0);
f8f70380 247
d3f7f2b2 248 if (SvGMAGICAL(sv))
249 mg_get(sv);
250
253ecd6d 251 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
252 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380 253 XSRETURN_UNDEF;
254
2d8e6c8d 255 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 256
54310121 257 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2 258 XSRETURN(1);
259}
260
6d4a7be2 261XS(XS_UNIVERSAL_can)
262{
263 dXSARGS;
264 SV *sv;
265 char *name;
266 SV *rv;
6f08146e 267 HV *pkg = NULL;
2d8e6c8d 268 STRLEN n_a;
6d4a7be2 269
270 if (items != 2)
cea2e8a9 271 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2 272
273 sv = ST(0);
f8f70380 274
d3f7f2b2 275 if (SvGMAGICAL(sv))
276 mg_get(sv);
277
253ecd6d 278 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
279 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380 280 XSRETURN_UNDEF;
281
2d8e6c8d 282 name = (char *)SvPV(ST(1),n_a);
3280af22 283 rv = &PL_sv_undef;
6d4a7be2 284
46e4b22b 285 if (SvROK(sv)) {
6f08146e 286 sv = (SV*)SvRV(sv);
46e4b22b 287 if (SvOBJECT(sv))
6f08146e 288 pkg = SvSTASH(sv);
289 }
290 else {
291 pkg = gv_stashsv(sv, FALSE);
292 }
293
294 if (pkg) {
dc848c6f 295 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
296 if (gv && isGV(gv))
297 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2 298 }
299
300 ST(0) = rv;
301 XSRETURN(1);
302}
303
6d4a7be2 304XS(XS_UNIVERSAL_VERSION)
305{
306 dXSARGS;
307 HV *pkg;
308 GV **gvp;
309 GV *gv;
310 SV *sv;
311 char *undef;
312
1571675a 313 if (SvROK(ST(0))) {
6d4a7be2 314 sv = (SV*)SvRV(ST(0));
1571675a 315 if (!SvOBJECT(sv))
cea2e8a9 316 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2 317 pkg = SvSTASH(sv);
318 }
319 else {
320 pkg = gv_stashsv(ST(0), FALSE);
321 }
322
323 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
324
d4bea2fb 325 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2 326 SV *nsv = sv_newmortal();
327 sv_setsv(nsv, sv);
328 sv = nsv;
329 undef = Nullch;
330 }
331 else {
3280af22 332 sv = (SV*)&PL_sv_undef;
6d4a7be2 333 undef = "(undef)";
334 }
335
1571675a 336 if (items > 1) {
337 STRLEN len;
338 SV *req = ST(1);
339
62658f4d 340 if (undef) {
341 if (pkg)
342 Perl_croak(aTHX_
343 "%s does not define $%s::VERSION--version check failed",
344 HvNAME(pkg), HvNAME(pkg));
345 else {
346 char *str = SvPVx(ST(0), len);
347
348 Perl_croak(aTHX_
349 "%s defines neither package nor VERSION--version check failed", str);
350 }
351 }
ad63d80f 352 if ( !sv_derived_from(sv, "version"))
353 sv = new_version(sv);
354
355 if ( !sv_derived_from(req, "version"))
356 req = new_version(req);
1571675a 357
ad63d80f 358 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
e3feee4e 359 Perl_croak(aTHX_
360 "%s version %"SVf" required--this is only version %"SVf,
0773b1f0 361 HvNAME(pkg), req, sv);
2d8e6c8d 362 }
6d4a7be2 363
364 ST(0) = sv;
365
366 XSRETURN(1);
367}
368
439cb1c4 369XS(XS_version_new)
370{
371 dXSARGS;
129318bd 372 if (items > 3)
439cb1c4 373 Perl_croak(aTHX_ "Usage: version::new(class, version)");
374 SP -= items;
375 {
376/* char * class = (char *)SvPV_nolen(ST(0)); */
129318bd 377 SV *version = ST(1);
378 if (items == 3 )
379 {
380 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc 381 version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd 382 }
439cb1c4 383
129318bd 384 PUSHs(new_version(version));
439cb1c4 385 PUTBACK;
386 return;
387 }
388}
389
390XS(XS_version_stringify)
391{
41be1fbd 392 dXSARGS;
393 if (items < 1)
394 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
395 SP -= items;
396 {
397 SV * lobj;
398
399 if (sv_derived_from(ST(0), "version")) {
400 SV *tmp = SvRV(ST(0));
401 lobj = tmp;
402 }
403 else
404 Perl_croak(aTHX_ "lobj is not of type version");
405
406 {
407 PUSHs(vstringify(lobj));
408 }
409
410 PUTBACK;
411 return;
412 }
439cb1c4 413}
414
415XS(XS_version_numify)
416{
41be1fbd 417 dXSARGS;
418 if (items < 1)
419 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
420 SP -= items;
421 {
422 SV * lobj;
423
424 if (sv_derived_from(ST(0), "version")) {
425 SV *tmp = SvRV(ST(0));
426 lobj = tmp;
427 }
428 else
429 Perl_croak(aTHX_ "lobj is not of type version");
430
431 {
432 PUSHs(vnumify(lobj));
433 }
434
435 PUTBACK;
436 return;
437 }
439cb1c4 438}
439
440XS(XS_version_vcmp)
441{
41be1fbd 442 dXSARGS;
443 if (items < 1)
444 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
445 SP -= items;
446 {
447 SV * lobj;
448
449 if (sv_derived_from(ST(0), "version")) {
450 SV *tmp = SvRV(ST(0));
451 lobj = tmp;
452 }
453 else
454 Perl_croak(aTHX_ "lobj is not of type version");
455
456 {
457 SV *rs;
458 SV *rvs;
459 SV * robj = ST(1);
460 IV swap = (IV)SvIV(ST(2));
461
462 if ( ! sv_derived_from(robj, "version") )
463 {
464 robj = new_version(robj);
465 }
466 rvs = SvRV(robj);
467
468 if ( swap )
469 {
470 rs = newSViv(vcmp(rvs,lobj));
471 }
472 else
473 {
474 rs = newSViv(vcmp(lobj,rvs));
475 }
476
477 PUSHs(rs);
478 }
479
480 PUTBACK;
481 return;
482 }
439cb1c4 483}
484
485XS(XS_version_boolean)
486{
41be1fbd 487 dXSARGS;
488 if (items < 1)
489 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
490 SP -= items;
491 {
492 SV * lobj;
493
494 if (sv_derived_from(ST(0), "version")) {
495 SV *tmp = SvRV(ST(0));
496 lobj = tmp;
497 }
498 else
499 Perl_croak(aTHX_ "lobj is not of type version");
500
501 {
502 SV *rs;
503 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
504 PUSHs(rs);
505 }
506
507 PUTBACK;
508 return;
509 }
439cb1c4 510}
511
512XS(XS_version_noop)
513{
41be1fbd 514 dXSARGS;
515 if (items < 1)
516 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
517 {
518 SV * lobj;
519
520 if (sv_derived_from(ST(0), "version")) {
521 SV *tmp = SvRV(ST(0));
522 lobj = tmp;
523 }
524 else
525 Perl_croak(aTHX_ "lobj is not of type version");
526
527 {
528 Perl_croak(aTHX_ "operation not supported with version object");
529 }
530
531 }
532 XSRETURN_EMPTY;
439cb1c4 533}
534
c8d69e4a 535XS(XS_version_is_alpha)
536{
537 dXSARGS;
538 if (items != 1)
539 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
540 SP -= items;
541 {
542 SV *lobj;
543
544 if (sv_derived_from(ST(0), "version")) {
545 SV *tmp = SvRV(ST(0));
546 lobj = tmp;
547 }
548 else
549 Perl_croak(aTHX_ "lobj is not of type version");
550{
551 I32 len = av_len((AV *)lobj);
552 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
553 if ( digit < 0 )
554 XSRETURN_YES;
555 else
556 XSRETURN_NO;
557}
558 PUTBACK;
559 return;
560 }
561}
562
8800c35a 563XS(XS_utf8_is_utf8)
564{
41be1fbd 565 dXSARGS;
566 if (items != 1)
567 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
568 {
569 SV * sv = ST(0);
570 {
571 if (SvUTF8(sv))
572 XSRETURN_YES;
573 else
574 XSRETURN_NO;
575 }
576 }
577 XSRETURN_EMPTY;
8800c35a 578}
579
1b026014 580XS(XS_utf8_valid)
581{
41be1fbd 582 dXSARGS;
583 if (items != 1)
584 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
585 {
586 SV * sv = ST(0);
587 {
588 STRLEN len;
589 char *s = SvPV(sv,len);
590 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
591 XSRETURN_YES;
592 else
593 XSRETURN_NO;
594 }
595 }
596 XSRETURN_EMPTY;
1b026014 597}
598
599XS(XS_utf8_encode)
600{
601 dXSARGS;
602 if (items != 1)
603 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
604 {
605 SV * sv = ST(0);
606
607 sv_utf8_encode(sv);
608 }
609 XSRETURN_EMPTY;
610}
611
612XS(XS_utf8_decode)
613{
614 dXSARGS;
615 if (items != 1)
616 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
617 {
618 SV * sv = ST(0);
619 bool RETVAL;
620
621 RETVAL = sv_utf8_decode(sv);
622 ST(0) = boolSV(RETVAL);
623 sv_2mortal(ST(0));
624 }
625 XSRETURN(1);
626}
627
628XS(XS_utf8_upgrade)
629{
630 dXSARGS;
631 if (items != 1)
632 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
633 {
634 SV * sv = ST(0);
635 STRLEN RETVAL;
636 dXSTARG;
637
638 RETVAL = sv_utf8_upgrade(sv);
639 XSprePUSH; PUSHi((IV)RETVAL);
640 }
641 XSRETURN(1);
642}
643
644XS(XS_utf8_downgrade)
645{
646 dXSARGS;
647 if (items < 1 || items > 2)
648 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
649 {
650 SV * sv = ST(0);
651 bool failok;
652 bool RETVAL;
653
654 if (items < 2)
655 failok = 0;
656 else {
657 failok = (int)SvIV(ST(1));
658 }
659
660 RETVAL = sv_utf8_downgrade(sv, failok);
661 ST(0) = boolSV(RETVAL);
662 sv_2mortal(ST(0));
663 }
664 XSRETURN(1);
665}
666
667XS(XS_utf8_native_to_unicode)
668{
669 dXSARGS;
670 UV uv = SvUV(ST(0));
b7953727 671
672 if (items > 1)
673 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
674
1b026014 675 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
676 XSRETURN(1);
677}
678
679XS(XS_utf8_unicode_to_native)
680{
681 dXSARGS;
682 UV uv = SvUV(ST(0));
b7953727 683
684 if (items > 1)
685 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
686
1b026014 687 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
688 XSRETURN(1);
689}
690
14a976d6 691XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 692{
693 dXSARGS;
694 SV *sv = SvRV(ST(0));
695 if (items == 1) {
696 if (SvREADONLY(sv))
697 XSRETURN_YES;
698 else
699 XSRETURN_NO;
700 }
701 else if (items == 2) {
702 if (SvTRUE(ST(1))) {
703 SvREADONLY_on(sv);
704 XSRETURN_YES;
705 }
706 else {
14a976d6 707 /* I hope you really know what you are doing. */
29569577 708 SvREADONLY_off(sv);
709 XSRETURN_NO;
710 }
711 }
14a976d6 712 XSRETURN_UNDEF; /* Can't happen. */
29569577 713}
714
14a976d6 715XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 716{
717 dXSARGS;
718 SV *sv = SvRV(ST(0));
719 if (items == 1)
14a976d6 720 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 721 else if (items == 2) {
14a976d6 722 /* I hope you really know what you are doing. */
29569577 723 SvREFCNT(sv) = SvIV(ST(1));
724 XSRETURN_IV(SvREFCNT(sv));
725 }
14a976d6 726 XSRETURN_UNDEF; /* Can't happen. */
29569577 727}
728
dfd4ef2f 729/* Maybe this should return the number of placeholders found in scalar context,
730 and a list of them in list context. */
f044d0d1 731XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 732{
733 dXSARGS;
734 HV *hv = (HV *) SvRV(ST(0));
735
736 /* I don't care how many parameters were passed in, but I want to avoid
737 the unused variable warning. */
738
eb160463 739 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f 740
741 if (items) {
742 HE *entry;
743 I32 riter = HvRITER(hv);
744 HE *eiter = HvEITER(hv);
745 hv_iterinit(hv);
fe7bca90 746 /* This may look suboptimal with the items *after* the iternext, but
747 it's quite deliberate. We only get here with items==0 if we've
748 just deleted the last placeholder in the hash. If we've just done
749 that then it means that the hash is in lazy delete mode, and the
750 HE is now only referenced in our iterator. If we just quit the loop
751 and discarded our iterator then the HE leaks. So we do the && the
752 other way to ensure iternext is called just one more time, which
753 has the side effect of triggering the lazy delete. */
754 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
755 && items) {
dfd4ef2f 756 SV *val = hv_iterval(hv, entry);
757
758 if (val == &PL_sv_undef) {
759
760 /* It seems that I have to go back in the front of the hash
761 API to delete a hash, even though I have a HE structure
762 pointing to the very entry I want to delete, and could hold
763 onto the previous HE that points to it. And it's easier to
764 go in with SVs as I can then specify the precomputed hash,
765 and don't have fun and games with utf8 keys. */
766 SV *key = hv_iterkeysv(entry);
767
768 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
769 items--;
770 }
771 }
772 HvRITER(hv) = riter;
773 HvEITER(hv) = eiter;
774 }
775
776 XSRETURN(0);
777}
39f7a870 778
39cff0d9 779XS(XS_Regexp_DESTROY)
780{
781
782}
783
39f7a870 784XS(XS_PerlIO_get_layers)
785{
786 dXSARGS;
787 if (items < 1 || items % 2 == 0)
788 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 789#ifdef USE_PERLIO
39f7a870 790 {
791 SV * sv;
792 GV * gv;
793 IO * io;
794 bool input = TRUE;
795 bool details = FALSE;
796
797 if (items > 1) {
39f7a870 798 SV **svp;
799
800 for (svp = MARK + 2; svp <= SP; svp += 2) {
801 SV **varp = svp;
802 SV **valp = svp + 1;
803 STRLEN klen;
804 char *key = SvPV(*varp, klen);
805
806 switch (*key) {
807 case 'i':
808 if (klen == 5 && memEQ(key, "input", 5)) {
809 input = SvTRUE(*valp);
810 break;
811 }
812 goto fail;
813 case 'o':
814 if (klen == 6 && memEQ(key, "output", 6)) {
815 input = !SvTRUE(*valp);
816 break;
817 }
818 goto fail;
819 case 'd':
820 if (klen == 7 && memEQ(key, "details", 7)) {
821 details = SvTRUE(*valp);
822 break;
823 }
824 goto fail;
825 default:
826 fail:
827 Perl_croak(aTHX_
828 "get_layers: unknown argument '%s'",
829 key);
830 }
831 }
832
833 SP -= (items - 1);
834 }
835
836 sv = POPs;
837 gv = (GV*)sv;
838
839 if (!isGV(sv)) {
840 if (SvROK(sv) && isGV(SvRV(sv)))
841 gv = (GV*)SvRV(sv);
842 else
843 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
844 }
845
846 if (gv && (io = GvIO(gv))) {
847 dTARGET;
848 AV* av = PerlIO_get_layers(aTHX_ input ?
849 IoIFP(io) : IoOFP(io));
850 I32 i;
851 I32 last = av_len(av);
852 I32 nitem = 0;
853
854 for (i = last; i >= 0; i -= 3) {
855 SV **namsvp;
856 SV **argsvp;
857 SV **flgsvp;
858 bool namok, argok, flgok;
859
860 namsvp = av_fetch(av, i - 2, FALSE);
861 argsvp = av_fetch(av, i - 1, FALSE);
862 flgsvp = av_fetch(av, i, FALSE);
863
864 namok = namsvp && *namsvp && SvPOK(*namsvp);
865 argok = argsvp && *argsvp && SvPOK(*argsvp);
866 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
867
868 if (details) {
869 XPUSHs(namok ?
870 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
871 XPUSHs(argok ?
872 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
873 if (flgok)
874 XPUSHi(SvIVX(*flgsvp));
875 else
876 XPUSHs(&PL_sv_undef);
877 nitem += 3;
878 }
879 else {
880 if (namok && argok)
881 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
882 *namsvp, *argsvp));
883 else if (namok)
884 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
885 else
886 XPUSHs(&PL_sv_undef);
887 nitem++;
888 if (flgok) {
889 IV flags = SvIVX(*flgsvp);
890
891 if (flags & PERLIO_F_UTF8) {
892 XPUSHs(newSVpvn("utf8", 4));
893 nitem++;
894 }
895 }
896 }
897 }
898
899 SvREFCNT_dec(av);
900
901 XSRETURN(nitem);
902 }
903 }
5fef3b4a 904#endif
39f7a870 905
906 XSRETURN(0);
907}
908
Unnamed repository; edit this file to name it for gitweb.