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