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