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