This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixup Perl_magic_freemglob()
[perl5.git] / universal.c
... / ...
CommitLineData
1/* universal.c
2 *
3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 2005, 2006, 2007, 2008 by Larry Wall and others
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
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 history
15 *
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
17 */
18
19/* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
21 *
22 * It is also used to store XS functions that need to be present in
23 * miniperl for a lack of a better place to put them. It might be
24 * clever to move them to separate XS files which would then be pulled
25 * in by some to-be-written build process.
26 */
27
28#include "EXTERN.h"
29#define PERL_IN_UNIVERSAL_C
30#include "perl.h"
31
32#if defined(USE_PERLIO)
33#include "perliol.h" /* For the PERLIO_F_XXX */
34#endif
35
36/*
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
39 */
40
41#define PERL_ARGS_ASSERT_ISA_LOOKUP \
42 assert(stash); \
43 assert(namesv || name)
44
45
46STATIC bool
47S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
48{
49 const struct mro_meta *const meta = HvMROMETA(stash);
50 HV *isa = meta->isa;
51 const HV *our_stash;
52
53 PERL_ARGS_ASSERT_ISA_LOOKUP;
54
55 if (!isa) {
56 (void)mro_get_linear_isa(stash);
57 isa = meta->isa;
58 }
59
60 if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
61 HV_FETCH_ISEXISTS, NULL, 0)) {
62 /* Direct name lookup worked. */
63 return TRUE;
64 }
65
66 /* A stash/class can go by many names (ie. User == main::User), so
67 we use the HvENAME in the stash itself, which is canonical, falling
68 back to HvNAME if necessary. */
69 our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
70
71 if (our_stash) {
72 HEK *canon_name = HvENAME_HEK(our_stash);
73 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
74 assert(canon_name);
75 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
76 HEK_FLAGS(canon_name),
77 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
78 return TRUE;
79 }
80 }
81
82 return FALSE;
83}
84
85#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
86 assert(sv); \
87 assert(namesv || name)
88
89STATIC bool
90S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
91{
92 HV* stash;
93
94 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
95 SvGETMAGIC(sv);
96
97 if (SvROK(sv)) {
98 const char *type;
99 sv = SvRV(sv);
100 type = sv_reftype(sv,0);
101 if (type) {
102 if (namesv)
103 name = SvPV_nolen(namesv);
104 if (strEQ(name, type))
105 return TRUE;
106 }
107 if (!SvOBJECT(sv))
108 return FALSE;
109 stash = SvSTASH(sv);
110 }
111 else {
112 stash = gv_stashsv(sv, 0);
113 }
114
115 if (stash && isa_lookup(stash, namesv, name, len, flags))
116 return TRUE;
117
118 stash = gv_stashpvs("UNIVERSAL", 0);
119 return stash && isa_lookup(stash, namesv, name, len, flags);
120}
121
122/*
123=for apidoc_section $SV
124
125=for apidoc sv_derived_from_pvn
126
127Returns a boolean indicating whether the SV is derived from the specified class
128I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
129normal Perl method.
130
131Currently, the only significant value for C<flags> is SVf_UTF8.
132
133=cut
134
135=for apidoc sv_derived_from_sv
136
137Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
138of an SV instead of a string/length pair. This is the advised form.
139
140=cut
141
142*/
143
144bool
145Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
146{
147 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
148 return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
149}
150
151/*
152=for apidoc sv_derived_from
153
154Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
155
156=cut
157*/
158
159bool
160Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
161{
162 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
163 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
164}
165
166/*
167=for apidoc sv_derived_from_pv
168
169Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
170instead of a string/length pair.
171
172=cut
173*/
174
175
176bool
177Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
178{
179 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
180 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
181}
182
183bool
184Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
185{
186 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
187 return sv_derived_from_svpvn(sv, NULL, name, len, flags);
188}
189
190/*
191=for apidoc sv_isa_sv
192
193Returns a boolean indicating whether the SV is an object reference and is
194derived from the specified class, respecting any C<isa()> method overloading
195it may have. Returns false if C<sv> is not a reference to an object, or is
196not derived from the specified class.
197
198This is the function used to implement the behaviour of the C<isa> operator.
199
200Does not invoke magic on C<sv>.
201
202Not to be confused with the older C<sv_isa> function, which does not use an
203overloaded C<isa()> method, nor will check subclassing.
204
205=cut
206
207*/
208
209bool
210Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
211{
212 GV *isagv;
213
214 PERL_ARGS_ASSERT_SV_ISA_SV;
215
216 if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
217 return FALSE;
218
219 /* This abuse of gv_fetchmeth_pv() with level = 1 skips the UNIVERSAL
220 * lookup
221 * TODO: Consider if we want a NOUNIVERSAL flag for requesting this in a
222 * more obvious way
223 */
224 isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, 1, 0);
225 if(isagv) {
226 dSP;
227 CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
228 SV *retsv;
229 bool ret;
230
231 PUTBACK;
232
233 ENTER;
234 SAVETMPS;
235
236 EXTEND(SP, 2);
237 PUSHMARK(SP);
238 PUSHs(sv);
239 PUSHs(namesv);
240 PUTBACK;
241
242 call_sv((SV *)isacv, G_SCALAR);
243
244 SPAGAIN;
245 retsv = POPs;
246 ret = SvTRUE(retsv);
247 PUTBACK;
248
249 FREETMPS;
250 LEAVE;
251
252 return ret;
253 }
254
255 /* TODO: Support namesv being an HV ref to the stash directly? */
256
257 return sv_derived_from_sv(sv, namesv, 0);
258}
259
260/*
261=for apidoc sv_does_sv
262
263Returns a boolean indicating whether the SV performs a specific, named role.
264The SV can be a Perl object or the name of a Perl class.
265
266=cut
267*/
268
269#include "XSUB.h"
270
271bool
272Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
273{
274 SV *classname;
275 bool does_it;
276 SV *methodname;
277 dSP;
278
279 PERL_ARGS_ASSERT_SV_DOES_SV;
280 PERL_UNUSED_ARG(flags);
281
282 ENTER;
283 SAVETMPS;
284
285 SvGETMAGIC(sv);
286
287 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
288 LEAVE;
289 return FALSE;
290 }
291
292 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
293 classname = sv_ref(NULL,SvRV(sv),TRUE);
294 } else {
295 classname = sv;
296 }
297
298 if (sv_eq(classname, namesv)) {
299 LEAVE;
300 return TRUE;
301 }
302
303 PUSHMARK(SP);
304 EXTEND(SP, 2);
305 PUSHs(sv);
306 PUSHs(namesv);
307 PUTBACK;
308
309 /* create a PV with value "isa", but with a special address
310 * so that perl knows we're really doing "DOES" instead */
311 methodname = newSV_type(SVt_PV);
312 SvLEN_set(methodname, 0);
313 SvCUR_set(methodname, strlen(PL_isa_DOES));
314 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
315 SvPOK_on(methodname);
316 sv_2mortal(methodname);
317 call_sv(methodname, G_SCALAR | G_METHOD);
318 SPAGAIN;
319
320 does_it = SvTRUE_NN( TOPs );
321 FREETMPS;
322 LEAVE;
323
324 return does_it;
325}
326
327/*
328=for apidoc sv_does
329
330Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
331
332=cut
333*/
334
335bool
336Perl_sv_does(pTHX_ SV *sv, const char *const name)
337{
338 PERL_ARGS_ASSERT_SV_DOES;
339 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
340}
341
342/*
343=for apidoc sv_does_pv
344
345Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
346
347=cut
348*/
349
350
351bool
352Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
353{
354 PERL_ARGS_ASSERT_SV_DOES_PV;
355 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
356}
357
358/*
359=for apidoc sv_does_pvn
360
361Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
362
363=cut
364*/
365
366bool
367Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
368{
369 PERL_ARGS_ASSERT_SV_DOES_PVN;
370
371 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
372}
373
374/*
375=for apidoc croak_xs_usage
376
377A specialised variant of C<croak()> for emitting the usage message for xsubs
378
379 croak_xs_usage(cv, "eee_yow");
380
381works out the package name and subroutine name from C<cv>, and then calls
382C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
383
384 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
385 "eee_yow");
386
387=cut
388*/
389
390void
391Perl_croak_xs_usage(const CV *const cv, const char *const params)
392{
393 /* Avoid CvGV as it requires aTHX. */
394 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
395
396 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
397
398 if (gv) got_gv: {
399 const HV *const stash = GvSTASH(gv);
400
401 if (HvNAME_get(stash))
402 /* diag_listed_as: SKIPME */
403 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
404 HEKfARG(HvNAME_HEK(stash)),
405 HEKfARG(GvNAME_HEK(gv)),
406 params);
407 else
408 /* diag_listed_as: SKIPME */
409 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
410 HEKfARG(GvNAME_HEK(gv)), params);
411 } else {
412 dTHX;
413 if ((gv = CvGV(cv))) goto got_gv;
414
415 /* Pants. I don't think that it should be possible to get here. */
416 /* diag_listed_as: SKIPME */
417 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
418 }
419}
420
421XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
422XS(XS_UNIVERSAL_isa)
423{
424 dXSARGS;
425
426 if (items != 2)
427 croak_xs_usage(cv, "reference, kind");
428 else {
429 SV * const sv = ST(0);
430
431 SvGETMAGIC(sv);
432
433 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
434 XSRETURN_UNDEF;
435
436 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
437 XSRETURN(1);
438 }
439}
440
441XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
442XS(XS_UNIVERSAL_can)
443{
444 dXSARGS;
445 SV *sv;
446 SV *rv;
447 HV *pkg = NULL;
448 GV *iogv;
449
450 if (items != 2)
451 croak_xs_usage(cv, "object-ref, method");
452
453 sv = ST(0);
454
455 SvGETMAGIC(sv);
456
457 /* Reject undef and empty string. Note that the string form takes
458 precedence here over the numeric form, as (!1)->foo treats the
459 invocant as the empty string, though it is a dualvar. */
460 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
461 XSRETURN_UNDEF;
462
463 rv = &PL_sv_undef;
464
465 if (SvROK(sv)) {
466 sv = MUTABLE_SV(SvRV(sv));
467 if (SvOBJECT(sv))
468 pkg = SvSTASH(sv);
469 else if (isGV_with_GP(sv) && GvIO(sv))
470 pkg = SvSTASH(GvIO(sv));
471 }
472 else if (isGV_with_GP(sv) && GvIO(sv))
473 pkg = SvSTASH(GvIO(sv));
474 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
475 pkg = SvSTASH(GvIO(iogv));
476 else {
477 pkg = gv_stashsv(sv, 0);
478 if (!pkg)
479 pkg = gv_stashpvs("UNIVERSAL", 0);
480 }
481
482 if (pkg) {
483 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
484 if (gv && isGV(gv))
485 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
486 }
487
488 ST(0) = rv;
489 XSRETURN(1);
490}
491
492XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
493XS(XS_UNIVERSAL_DOES)
494{
495 dXSARGS;
496 PERL_UNUSED_ARG(cv);
497
498 if (items != 2)
499 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
500 else {
501 SV * const sv = ST(0);
502 if (sv_does_sv( sv, ST(1), 0 ))
503 XSRETURN_YES;
504
505 XSRETURN_NO;
506 }
507}
508
509XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
510XS(XS_utf8_is_utf8)
511{
512 dXSARGS;
513 if (items != 1)
514 croak_xs_usage(cv, "sv");
515 else {
516 SV * const sv = ST(0);
517 SvGETMAGIC(sv);
518 if (SvUTF8(sv))
519 XSRETURN_YES;
520 else
521 XSRETURN_NO;
522 }
523 XSRETURN_EMPTY;
524}
525
526XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
527XS(XS_utf8_valid)
528{
529 dXSARGS;
530 if (items != 1)
531 croak_xs_usage(cv, "sv");
532 else {
533 SV * const sv = ST(0);
534 STRLEN len;
535 const char * const s = SvPV_const(sv,len);
536 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
537 XSRETURN_YES;
538 else
539 XSRETURN_NO;
540 }
541 XSRETURN_EMPTY;
542}
543
544XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
545XS(XS_utf8_encode)
546{
547 dXSARGS;
548 if (items != 1)
549 croak_xs_usage(cv, "sv");
550 sv_utf8_encode(ST(0));
551 SvSETMAGIC(ST(0));
552 XSRETURN_EMPTY;
553}
554
555XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
556XS(XS_utf8_decode)
557{
558 dXSARGS;
559 if (items != 1)
560 croak_xs_usage(cv, "sv");
561 else {
562 SV * const sv = ST(0);
563 bool RETVAL;
564 SvPV_force_nolen(sv);
565 RETVAL = sv_utf8_decode(sv);
566 SvSETMAGIC(sv);
567 ST(0) = boolSV(RETVAL);
568 }
569 XSRETURN(1);
570}
571
572XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
573XS(XS_utf8_upgrade)
574{
575 dXSARGS;
576 if (items != 1)
577 croak_xs_usage(cv, "sv");
578 else {
579 SV * const sv = ST(0);
580 STRLEN RETVAL;
581 dXSTARG;
582
583 RETVAL = sv_utf8_upgrade(sv);
584 XSprePUSH; PUSHi((IV)RETVAL);
585 }
586 XSRETURN(1);
587}
588
589XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
590XS(XS_utf8_downgrade)
591{
592 dXSARGS;
593 if (items < 1 || items > 2)
594 croak_xs_usage(cv, "sv, failok=0");
595 else {
596 SV * const sv0 = ST(0);
597 SV * const sv1 = ST(1);
598 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
599 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
600
601 ST(0) = boolSV(RETVAL);
602 }
603 XSRETURN(1);
604}
605
606XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
607XS(XS_utf8_native_to_unicode)
608{
609 dXSARGS;
610 const UV uv = SvUV(ST(0));
611
612 if (items > 1)
613 croak_xs_usage(cv, "sv");
614
615 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
616 XSRETURN(1);
617}
618
619XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
620XS(XS_utf8_unicode_to_native)
621{
622 dXSARGS;
623 const UV uv = SvUV(ST(0));
624
625 if (items > 1)
626 croak_xs_usage(cv, "sv");
627
628 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
629 XSRETURN(1);
630}
631
632XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
633XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
634{
635 dXSARGS;
636 SV * const svz = ST(0);
637 SV * sv;
638
639 /* [perl #77776] - called as &foo() not foo() */
640 if (!SvROK(svz))
641 croak_xs_usage(cv, "SCALAR[, ON]");
642
643 sv = SvRV(svz);
644
645 if (items == 1) {
646 if (SvREADONLY(sv))
647 XSRETURN_YES;
648 else
649 XSRETURN_NO;
650 }
651 else if (items == 2) {
652 SV *sv1 = ST(1);
653 if (SvTRUE_NN(sv1)) {
654 SvFLAGS(sv) |= SVf_READONLY;
655 XSRETURN_YES;
656 }
657 else {
658 /* I hope you really know what you are doing. */
659 SvFLAGS(sv) &=~ SVf_READONLY;
660 XSRETURN_NO;
661 }
662 }
663 XSRETURN_UNDEF; /* Can't happen. */
664}
665
666XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
667XS(XS_constant__make_const) /* This is dangerous stuff. */
668{
669 dXSARGS;
670 SV * const svz = ST(0);
671 SV * sv;
672
673 /* [perl #77776] - called as &foo() not foo() */
674 if (!SvROK(svz) || items != 1)
675 croak_xs_usage(cv, "SCALAR");
676
677 sv = SvRV(svz);
678
679 SvREADONLY_on(sv);
680 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
681 /* for constant.pm; nobody else should be calling this
682 on arrays anyway. */
683 SV **svp;
684 for (svp = AvARRAY(sv) + AvFILLp(sv)
685 ; svp >= AvARRAY(sv)
686 ; --svp)
687 if (*svp) SvPADTMP_on(*svp);
688 }
689 XSRETURN(0);
690}
691
692XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
693XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
694{
695 dXSARGS;
696 SV * const svz = ST(0);
697 SV * sv;
698 U32 refcnt;
699
700 /* [perl #77776] - called as &foo() not foo() */
701 if ((items != 1 && items != 2) || !SvROK(svz))
702 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
703
704 sv = SvRV(svz);
705
706 /* I hope you really know what you are doing. */
707 /* idea is for SvREFCNT(sv) to be accessed only once */
708 refcnt = items == 2 ?
709 /* we free one ref on exit */
710 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
711 : SvREFCNT(sv);
712 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
713
714}
715
716XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
717XS(XS_Internals_hv_clear_placehold)
718{
719 dXSARGS;
720
721 if (items != 1 || !SvROK(ST(0)))
722 croak_xs_usage(cv, "hv");
723 else {
724 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
725 hv_clear_placeholders(hv);
726 XSRETURN(0);
727 }
728}
729
730XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
731XS(XS_PerlIO_get_layers)
732{
733 dXSARGS;
734 if (items < 1 || items % 2 == 0)
735 croak_xs_usage(cv, "filehandle[,args]");
736#if defined(USE_PERLIO)
737 {
738 SV * sv;
739 GV * gv;
740 IO * io;
741 bool input = TRUE;
742 bool details = FALSE;
743
744 if (items > 1) {
745 SV * const *svp;
746 for (svp = MARK + 2; svp <= SP; svp += 2) {
747 SV * const * const varp = svp;
748 SV * const * const valp = svp + 1;
749 STRLEN klen;
750 const char * const key = SvPV_const(*varp, klen);
751
752 switch (*key) {
753 case 'i':
754 if (memEQs(key, klen, "input")) {
755 input = SvTRUE(*valp);
756 break;
757 }
758 goto fail;
759 case 'o':
760 if (memEQs(key, klen, "output")) {
761 input = !SvTRUE(*valp);
762 break;
763 }
764 goto fail;
765 case 'd':
766 if (memEQs(key, klen, "details")) {
767 details = SvTRUE(*valp);
768 break;
769 }
770 goto fail;
771 default:
772 fail:
773 Perl_croak(aTHX_
774 "get_layers: unknown argument '%s'",
775 key);
776 }
777 }
778
779 SP -= (items - 1);
780 }
781
782 sv = POPs;
783 gv = MAYBE_DEREF_GV(sv);
784
785 if (!gv && !SvROK(sv))
786 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
787
788 if (gv && (io = GvIO(gv))) {
789 AV* const av = PerlIO_get_layers(aTHX_ input ?
790 IoIFP(io) : IoOFP(io));
791 SSize_t i;
792 const SSize_t last = av_top_index(av);
793 SSize_t nitem = 0;
794
795 for (i = last; i >= 0; i -= 3) {
796 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
797 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
798 SV * const * const flgsvp = av_fetch(av, i, FALSE);
799
800 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
801 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
802 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
803
804 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
805 if (details) {
806 /* Indents of 5? Yuck. */
807 /* We know that PerlIO_get_layers creates a new SV for
808 the name and flags, so we can just take a reference
809 and "steal" it when we free the AV below. */
810 PUSHs(namok
811 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
812 : &PL_sv_undef);
813 PUSHs(argok
814 ? newSVpvn_flags(SvPVX_const(*argsvp),
815 SvCUR(*argsvp),
816 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
817 | SVs_TEMP)
818 : &PL_sv_undef);
819 PUSHs(flgok
820 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
821 : &PL_sv_undef);
822 nitem += 3;
823 }
824 else {
825 if (namok && argok)
826 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
827 SVfARG(*namsvp),
828 SVfARG(*argsvp))));
829 else if (namok)
830 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
831 else
832 PUSHs(&PL_sv_undef);
833 nitem++;
834 if (flgok) {
835 const IV flags = SvIVX(*flgsvp);
836
837 if (flags & PERLIO_F_UTF8) {
838 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
839 nitem++;
840 }
841 }
842 }
843 }
844
845 SvREFCNT_dec(av);
846
847 XSRETURN(nitem);
848 }
849 }
850#endif
851
852 XSRETURN(0);
853}
854
855XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
856XS(XS_re_is_regexp)
857{
858 dXSARGS;
859
860 if (items != 1)
861 croak_xs_usage(cv, "sv");
862
863 if (SvRXOK(ST(0))) {
864 XSRETURN_YES;
865 } else {
866 XSRETURN_NO;
867 }
868}
869
870XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
871XS(XS_re_regnames_count)
872{
873 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
874 SV * ret;
875 dXSARGS;
876
877 if (items != 0)
878 croak_xs_usage(cv, "");
879
880 if (!rx)
881 XSRETURN_UNDEF;
882
883 ret = CALLREG_NAMED_BUFF_COUNT(rx);
884
885 SPAGAIN;
886 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
887 XSRETURN(1);
888}
889
890XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
891XS(XS_re_regname)
892{
893 dXSARGS;
894 REGEXP * rx;
895 U32 flags;
896 SV * ret;
897
898 if (items < 1 || items > 2)
899 croak_xs_usage(cv, "name[, all ]");
900
901 SP -= items;
902 PUTBACK;
903
904 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
905
906 if (!rx)
907 XSRETURN_UNDEF;
908
909 if (items == 2 && SvTRUE_NN(ST(1))) {
910 flags = RXapif_ALL;
911 } else {
912 flags = RXapif_ONE;
913 }
914 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
915
916 SPAGAIN;
917 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
918 XSRETURN(1);
919}
920
921
922XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
923XS(XS_re_regnames)
924{
925 dXSARGS;
926 REGEXP * rx;
927 U32 flags;
928 SV *ret;
929 AV *av;
930 SSize_t length;
931 SSize_t i;
932 SV **entry;
933
934 if (items > 1)
935 croak_xs_usage(cv, "[all]");
936
937 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
938
939 if (!rx)
940 XSRETURN_UNDEF;
941
942 if (items == 1 && SvTRUE_NN(ST(0))) {
943 flags = RXapif_ALL;
944 } else {
945 flags = RXapif_ONE;
946 }
947
948 SP -= items;
949 PUTBACK;
950
951 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
952
953 SPAGAIN;
954
955 if (!ret)
956 XSRETURN_UNDEF;
957
958 av = MUTABLE_AV(SvRV(ret));
959 length = av_count(av);
960
961 EXTEND(SP, length); /* better extend stack just once */
962 for (i = 0; i < length; i++) {
963 entry = av_fetch(av, i, FALSE);
964
965 if (!entry)
966 Perl_croak(aTHX_ "NULL array element in re::regnames()");
967
968 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
969 }
970
971 SvREFCNT_dec(ret);
972
973 PUTBACK;
974 return;
975}
976
977XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
978XS(XS_re_regexp_pattern)
979{
980 dXSARGS;
981 REGEXP *re;
982 U8 const gimme = GIMME_V;
983
984 EXTEND(SP, 2);
985 SP -= items;
986 if (items != 1)
987 croak_xs_usage(cv, "sv");
988
989 /*
990 Checks if a reference is a regex or not. If the parameter is
991 not a ref, or is not the result of a qr// then returns false
992 in scalar context and an empty list in list context.
993 Otherwise in list context it returns the pattern and the
994 modifiers, in scalar context it returns the pattern just as it
995 would if the qr// was stringified normally, regardless as
996 to the class of the variable and any stringification overloads
997 on the object.
998 */
999
1000 if ((re = SvRX(ST(0)))) /* assign deliberate */
1001 {
1002 /* Houston, we have a regex! */
1003 SV *pattern;
1004
1005 if ( gimme == G_ARRAY ) {
1006 STRLEN left = 0;
1007 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1008 const char *fptr;
1009 char ch;
1010 U16 match_flags;
1011
1012 /*
1013 we are in list context so stringify
1014 the modifiers that apply. We ignore "negative
1015 modifiers" in this scenario, and the default character set
1016 */
1017
1018 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1019 STRLEN len;
1020 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1021 &len);
1022 Copy(name, reflags + left, len, char);
1023 left += len;
1024 }
1025 fptr = INT_PAT_MODS;
1026 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1027 >> RXf_PMf_STD_PMMOD_SHIFT);
1028
1029 while((ch = *fptr++)) {
1030 if(match_flags & 1) {
1031 reflags[left++] = ch;
1032 }
1033 match_flags >>= 1;
1034 }
1035
1036 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1037 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1038
1039 /* return the pattern and the modifiers */
1040 PUSHs(pattern);
1041 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1042 XSRETURN(2);
1043 } else {
1044 /* Scalar, so use the string that Perl would return */
1045 /* return the pattern in (?msixn:..) format */
1046 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1047 PUSHs(pattern);
1048 XSRETURN(1);
1049 }
1050 } else {
1051 /* It ain't a regexp folks */
1052 if ( gimme == G_ARRAY ) {
1053 /* return the empty list */
1054 XSRETURN_EMPTY;
1055 } else {
1056 /* Because of the (?:..) wrapping involved in a
1057 stringified pattern it is impossible to get a
1058 result for a real regexp that would evaluate to
1059 false. Therefore we can return PL_sv_no to signify
1060 that the object is not a regex, this means that one
1061 can say
1062
1063 if (regex($might_be_a_regex) eq '(?:foo)') { }
1064
1065 and not worry about undefined values.
1066 */
1067 XSRETURN_NO;
1068 }
1069 }
1070 NOT_REACHED; /* NOTREACHED */
1071}
1072
1073#ifdef HAS_GETCWD
1074
1075XS(XS_Internals_getcwd)
1076{
1077 dXSARGS;
1078 SV *sv = sv_newmortal();
1079
1080 if (items != 0)
1081 croak_xs_usage(cv, "");
1082
1083 (void)getcwd_sv(sv);
1084
1085 SvTAINTED_on(sv);
1086 PUSHs(sv);
1087 XSRETURN(1);
1088}
1089
1090#endif
1091
1092XS(XS_NamedCapture_tie_it)
1093{
1094 dXSARGS;
1095
1096 if (items != 1)
1097 croak_xs_usage(cv, "sv");
1098 {
1099 SV *sv = ST(0);
1100 GV * const gv = (GV *)sv;
1101 HV * const hv = GvHVn(gv);
1102 SV *rv = newSV_type(SVt_IV);
1103 const char *gv_name = GvNAME(gv);
1104
1105 SvRV_set(rv, newSVuv(
1106 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1107 ? RXapif_ALL : RXapif_ONE));
1108 SvROK_on(rv);
1109 sv_bless(rv, GvSTASH(CvGV(cv)));
1110
1111 sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1112 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1113 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
1114 }
1115 XSRETURN_EMPTY;
1116}
1117
1118XS(XS_NamedCapture_TIEHASH)
1119{
1120 dXSARGS;
1121 if (items < 1)
1122 croak_xs_usage(cv, "package, ...");
1123 {
1124 const char * package = (const char *)SvPV_nolen(ST(0));
1125 UV flag = RXapif_ONE;
1126 mark += 2;
1127 while(mark < sp) {
1128 STRLEN len;
1129 const char *p = SvPV_const(*mark, len);
1130 if(memEQs(p, len, "all"))
1131 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1132 mark += 2;
1133 }
1134 ST(0) = sv_2mortal(newSV_type(SVt_IV));
1135 sv_setuv(newSVrv(ST(0), package), flag);
1136 }
1137 XSRETURN(1);
1138}
1139
1140/* These are tightly coupled to the RXapif_* flags defined in regexp.h */
1141#define UNDEF_FATAL 0x80000
1142#define DISCARD 0x40000
1143#define EXPECT_SHIFT 24
1144#define ACTION_MASK 0x000FF
1145
1146#define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
1147#define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1148#define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1149#define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1150#define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1151#define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1152
1153XS(XS_NamedCapture_FETCH)
1154{
1155 dXSARGS;
1156 dXSI32;
1157 PERL_UNUSED_VAR(cv); /* -W */
1158 PERL_UNUSED_VAR(ax); /* -Wall */
1159 SP -= items;
1160 {
1161 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1162 U32 flags;
1163 SV *ret;
1164 const U32 action = ix & ACTION_MASK;
1165 const int expect = ix >> EXPECT_SHIFT;
1166 if (items != expect)
1167 croak_xs_usage(cv, expect == 2 ? "$key"
1168 : (expect == 3 ? "$key, $value"
1169 : ""));
1170
1171 if (!rx || !SvROK(ST(0))) {
1172 if (ix & UNDEF_FATAL)
1173 Perl_croak_no_modify();
1174 else
1175 XSRETURN_UNDEF;
1176 }
1177
1178 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1179
1180 PUTBACK;
1181 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1182 expect >= 3 ? ST(2) : NULL, flags | action);
1183 SPAGAIN;
1184
1185 if (ix & DISCARD) {
1186 /* Called with G_DISCARD, so our return stack state is thrown away.
1187 Hence if we were returned anything, free it immediately. */
1188 SvREFCNT_dec(ret);
1189 } else {
1190 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1191 }
1192 PUTBACK;
1193 return;
1194 }
1195}
1196
1197
1198XS(XS_NamedCapture_FIRSTKEY)
1199{
1200 dXSARGS;
1201 dXSI32;
1202 PERL_UNUSED_VAR(cv); /* -W */
1203 PERL_UNUSED_VAR(ax); /* -Wall */
1204 SP -= items;
1205 {
1206 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1207 U32 flags;
1208 SV *ret;
1209 const int expect = ix ? 2 : 1;
1210 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1211 if (items != expect)
1212 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1213
1214 if (!rx || !SvROK(ST(0)))
1215 XSRETURN_UNDEF;
1216
1217 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1218
1219 PUTBACK;
1220 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1221 expect >= 2 ? ST(1) : NULL,
1222 flags | action);
1223 SPAGAIN;
1224
1225 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1226 PUTBACK;
1227 return;
1228 }
1229}
1230
1231/* is this still needed? */
1232XS(XS_NamedCapture_flags)
1233{
1234 dXSARGS;
1235 PERL_UNUSED_VAR(cv); /* -W */
1236 PERL_UNUSED_VAR(ax); /* -Wall */
1237 SP -= items;
1238 {
1239 EXTEND(SP, 2);
1240 mPUSHu(RXapif_ONE);
1241 mPUSHu(RXapif_ALL);
1242 PUTBACK;
1243 return;
1244 }
1245}
1246
1247#include "vutil.h"
1248#include "vxs.inc"
1249
1250struct xsub_details {
1251 const char *name;
1252 XSUBADDR_t xsub;
1253 const char *proto;
1254 int ix;
1255};
1256
1257static const struct xsub_details these_details[] = {
1258 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1259 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1260 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1261#define VXS_XSUB_DETAILS
1262#include "vxs.inc"
1263#undef VXS_XSUB_DETAILS
1264 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1265 {"utf8::valid", XS_utf8_valid, NULL, 0 },
1266 {"utf8::encode", XS_utf8_encode, NULL, 0 },
1267 {"utf8::decode", XS_utf8_decode, NULL, 0 },
1268 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1269 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1270 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1271 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1272 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1273 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1274 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1275 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1276 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1277 {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1278 {"re::regname", XS_re_regname, ";$$", 0 },
1279 {"re::regnames", XS_re_regnames, ";$", 0 },
1280 {"re::regnames_count", XS_re_regnames_count, "", 0 },
1281 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1282#ifdef HAS_GETCWD
1283 {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1284#endif
1285 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1286 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1287 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1288 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1289 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1290 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1291 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1292 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1293 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1294 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1295 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1296};
1297
1298STATIC OP*
1299optimize_out_native_convert_function(pTHX_ OP* entersubop,
1300 GV* namegv,
1301 SV* protosv)
1302{
1303 /* Optimizes out an identity function, i.e., one that just returns its
1304 * argument. The passed in function is assumed to be an identity function,
1305 * with no checking. This is designed to be called for utf8_to_native()
1306 * and native_to_utf8() on ASCII platforms, as they just return their
1307 * arguments, but it could work on any such function.
1308 *
1309 * The code is mostly just cargo-culted from Memoize::Lift */
1310
1311 OP *pushop, *argop;
1312 OP *parent;
1313 SV* prototype = newSVpvs("$");
1314
1315 PERL_UNUSED_ARG(protosv);
1316
1317 assert(entersubop->op_type == OP_ENTERSUB);
1318
1319 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1320 parent = entersubop;
1321
1322 SvREFCNT_dec(prototype);
1323
1324 pushop = cUNOPx(entersubop)->op_first;
1325 if (! OpHAS_SIBLING(pushop)) {
1326 parent = pushop;
1327 pushop = cUNOPx(pushop)->op_first;
1328 }
1329 argop = OpSIBLING(pushop);
1330
1331 /* Carry on without doing the optimization if it is not something we're
1332 * expecting, so continues to work */
1333 if ( ! argop
1334 || ! OpHAS_SIBLING(argop)
1335 || OpHAS_SIBLING(OpSIBLING(argop))
1336 ) {
1337 return entersubop;
1338 }
1339
1340 /* cut argop from the subtree */
1341 (void)op_sibling_splice(parent, pushop, 1, NULL);
1342
1343 op_free(entersubop);
1344 return argop;
1345}
1346
1347void
1348Perl_boot_core_UNIVERSAL(pTHX)
1349{
1350 static const char file[] = __FILE__;
1351 const struct xsub_details *xsub = these_details;
1352 const struct xsub_details *end = C_ARRAY_END(these_details);
1353
1354 do {
1355 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1356 XSANY.any_i32 = xsub->ix;
1357 } while (++xsub < end);
1358
1359#ifndef EBCDIC
1360 { /* On ASCII platforms these functions just return their argument, so can
1361 be optimized away */
1362
1363 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1364 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1365
1366 cv_set_call_checker_flags(to_native_cv,
1367 optimize_out_native_convert_function,
1368 (SV*) to_native_cv, 0);
1369 cv_set_call_checker_flags(to_unicode_cv,
1370 optimize_out_native_convert_function,
1371 (SV*) to_unicode_cv, 0);
1372 }
1373#endif
1374
1375 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1376 {
1377 CV * const cv =
1378 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1379 char ** cvfile = &CvFILE(cv);
1380 char * oldfile = *cvfile;
1381 CvDYNFILE_off(cv);
1382 *cvfile = (char *)file;
1383 Safefree(oldfile);
1384 }
1385}
1386
1387/*
1388 * ex: set ts=8 sts=4 sw=4 et:
1389 */