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 STATIC bool
S_isa_lookup(pTHX_ HV * stash,const char * const name,STRLEN len,U32 flags)42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
43 {
44 const struct mro_meta *const meta = HvMROMETA(stash);
45 HV *isa = meta->isa;
46 const HV *our_stash;
47
48 PERL_ARGS_ASSERT_ISA_LOOKUP;
49
50 if (!isa) {
51 (void)mro_get_linear_isa(stash);
52 isa = meta->isa;
53 }
54
55 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
56 HV_FETCH_ISEXISTS, NULL, 0)) {
57 /* Direct name lookup worked. */
58 return TRUE;
59 }
60
61 /* A stash/class can go by many names (ie. User == main::User), so
62 we use the HvENAME in the stash itself, which is canonical, falling
63 back to HvNAME if necessary. */
64 our_stash = gv_stashpvn(name, len, flags);
65
66 if (our_stash) {
67 HEK *canon_name = HvENAME_HEK(our_stash);
68 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
69 assert(canon_name);
70 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
71 HEK_FLAGS(canon_name),
72 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
73 return TRUE;
74 }
75 }
76
77 return FALSE;
78 }
79
80 /*
81 =head1 SV Manipulation Functions
82
83 =for apidoc sv_derived_from_pvn
84
85 Returns a boolean indicating whether the SV is derived from the specified class
86 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
87 normal Perl method.
88
89 Currently, the only significant value for C<flags> is SVf_UTF8.
90
91 =cut
92
93 =for apidoc sv_derived_from_sv
94
95 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
96 of an SV instead of a string/length pair.
97
98 =cut
99
100 */
101
102 bool
Perl_sv_derived_from_sv(pTHX_ SV * sv,SV * namesv,U32 flags)103 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
104 {
105 char *namepv;
106 STRLEN namelen;
107 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
108 namepv = SvPV(namesv, namelen);
109 if (SvUTF8(namesv))
110 flags |= SVf_UTF8;
111 return sv_derived_from_pvn(sv, namepv, namelen, flags);
112 }
113
114 /*
115 =for apidoc sv_derived_from
116
117 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
118
119 =cut
120 */
121
122 bool
Perl_sv_derived_from(pTHX_ SV * sv,const char * const name)123 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
124 {
125 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
126 return sv_derived_from_pvn(sv, name, strlen(name), 0);
127 }
128
129 /*
130 =for apidoc sv_derived_from_pv
131
132 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
133 instead of a string/length pair.
134
135 =cut
136 */
137
138
139 bool
Perl_sv_derived_from_pv(pTHX_ SV * sv,const char * const name,U32 flags)140 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
141 {
142 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
143 return sv_derived_from_pvn(sv, name, strlen(name), flags);
144 }
145
146 bool
Perl_sv_derived_from_pvn(pTHX_ SV * sv,const char * const name,const STRLEN len,U32 flags)147 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
148 {
149 HV *stash;
150
151 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
152
153 SvGETMAGIC(sv);
154
155 if (SvROK(sv)) {
156 const char *type;
157 sv = SvRV(sv);
158 type = sv_reftype(sv,0);
159 if (type && strEQ(type,name))
160 return TRUE;
161 if (!SvOBJECT(sv))
162 return FALSE;
163 stash = SvSTASH(sv);
164 }
165 else {
166 stash = gv_stashsv(sv, 0);
167 }
168
169 if (stash && isa_lookup(stash, name, len, flags))
170 return TRUE;
171
172 stash = gv_stashpvs("UNIVERSAL", 0);
173 return stash && isa_lookup(stash, name, len, flags);
174 }
175
176 /*
177 =for apidoc sv_does_sv
178
179 Returns a boolean indicating whether the SV performs a specific, named role.
180 The SV can be a Perl object or the name of a Perl class.
181
182 =cut
183 */
184
185 #include "XSUB.h"
186
187 bool
Perl_sv_does_sv(pTHX_ SV * sv,SV * namesv,U32 flags)188 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
189 {
190 SV *classname;
191 bool does_it;
192 SV *methodname;
193 dSP;
194
195 PERL_ARGS_ASSERT_SV_DOES_SV;
196 PERL_UNUSED_ARG(flags);
197
198 ENTER;
199 SAVETMPS;
200
201 SvGETMAGIC(sv);
202
203 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
204 LEAVE;
205 return FALSE;
206 }
207
208 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
209 classname = sv_ref(NULL,SvRV(sv),TRUE);
210 } else {
211 classname = sv;
212 }
213
214 if (sv_eq(classname, namesv)) {
215 LEAVE;
216 return TRUE;
217 }
218
219 PUSHMARK(SP);
220 EXTEND(SP, 2);
221 PUSHs(sv);
222 PUSHs(namesv);
223 PUTBACK;
224
225 /* create a PV with value "isa", but with a special address
226 * so that perl knows we're really doing "DOES" instead */
227 methodname = newSV_type(SVt_PV);
228 SvLEN_set(methodname, 0);
229 SvCUR_set(methodname, strlen(PL_isa_DOES));
230 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
231 SvPOK_on(methodname);
232 sv_2mortal(methodname);
233 call_sv(methodname, G_SCALAR | G_METHOD);
234 SPAGAIN;
235
236 does_it = SvTRUE_NN( TOPs );
237 FREETMPS;
238 LEAVE;
239
240 return does_it;
241 }
242
243 /*
244 =for apidoc sv_does
245
246 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
247
248 =cut
249 */
250
251 bool
Perl_sv_does(pTHX_ SV * sv,const char * const name)252 Perl_sv_does(pTHX_ SV *sv, const char *const name)
253 {
254 PERL_ARGS_ASSERT_SV_DOES;
255 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
256 }
257
258 /*
259 =for apidoc sv_does_pv
260
261 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
262
263 =cut
264 */
265
266
267 bool
Perl_sv_does_pv(pTHX_ SV * sv,const char * const name,U32 flags)268 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
269 {
270 PERL_ARGS_ASSERT_SV_DOES_PV;
271 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
272 }
273
274 /*
275 =for apidoc sv_does_pvn
276
277 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
278
279 =cut
280 */
281
282 bool
Perl_sv_does_pvn(pTHX_ SV * sv,const char * const name,const STRLEN len,U32 flags)283 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
284 {
285 PERL_ARGS_ASSERT_SV_DOES_PVN;
286
287 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
288 }
289
290 /*
291 =for apidoc croak_xs_usage
292
293 A specialised variant of C<croak()> for emitting the usage message for xsubs
294
295 croak_xs_usage(cv, "eee_yow");
296
297 works out the package name and subroutine name from C<cv>, and then calls
298 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
299
300 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
301 "eee_yow");
302
303 =cut
304 */
305
306 void
Perl_croak_xs_usage(const CV * const cv,const char * const params)307 Perl_croak_xs_usage(const CV *const cv, const char *const params)
308 {
309 /* Avoid CvGV as it requires aTHX. */
310 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
311
312 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
313
314 if (gv) got_gv: {
315 const HV *const stash = GvSTASH(gv);
316
317 if (HvNAME_get(stash))
318 /* diag_listed_as: SKIPME */
319 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
320 HEKfARG(HvNAME_HEK(stash)),
321 HEKfARG(GvNAME_HEK(gv)),
322 params);
323 else
324 /* diag_listed_as: SKIPME */
325 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
326 HEKfARG(GvNAME_HEK(gv)), params);
327 } else {
328 dTHX;
329 if ((gv = CvGV(cv))) goto got_gv;
330
331 /* Pants. I don't think that it should be possible to get here. */
332 /* diag_listed_as: SKIPME */
333 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
334 }
335 }
336
337 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_isa)338 XS(XS_UNIVERSAL_isa)
339 {
340 dXSARGS;
341
342 if (items != 2)
343 croak_xs_usage(cv, "reference, kind");
344 else {
345 SV * const sv = ST(0);
346
347 SvGETMAGIC(sv);
348
349 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
350 XSRETURN_UNDEF;
351
352 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
353 XSRETURN(1);
354 }
355 }
356
357 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_can)358 XS(XS_UNIVERSAL_can)
359 {
360 dXSARGS;
361 SV *sv;
362 SV *rv;
363 HV *pkg = NULL;
364 GV *iogv;
365
366 if (items != 2)
367 croak_xs_usage(cv, "object-ref, method");
368
369 sv = ST(0);
370
371 SvGETMAGIC(sv);
372
373 /* Reject undef and empty string. Note that the string form takes
374 precedence here over the numeric form, as (!1)->foo treats the
375 invocant as the empty string, though it is a dualvar. */
376 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
377 XSRETURN_UNDEF;
378
379 rv = &PL_sv_undef;
380
381 if (SvROK(sv)) {
382 sv = MUTABLE_SV(SvRV(sv));
383 if (SvOBJECT(sv))
384 pkg = SvSTASH(sv);
385 else if (isGV_with_GP(sv) && GvIO(sv))
386 pkg = SvSTASH(GvIO(sv));
387 }
388 else if (isGV_with_GP(sv) && GvIO(sv))
389 pkg = SvSTASH(GvIO(sv));
390 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
391 pkg = SvSTASH(GvIO(iogv));
392 else {
393 pkg = gv_stashsv(sv, 0);
394 if (!pkg)
395 pkg = gv_stashpvs("UNIVERSAL", 0);
396 }
397
398 if (pkg) {
399 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
400 if (gv && isGV(gv))
401 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
402 }
403
404 ST(0) = rv;
405 XSRETURN(1);
406 }
407
408 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_DOES)409 XS(XS_UNIVERSAL_DOES)
410 {
411 dXSARGS;
412 PERL_UNUSED_ARG(cv);
413
414 if (items != 2)
415 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
416 else {
417 SV * const sv = ST(0);
418 if (sv_does_sv( sv, ST(1), 0 ))
419 XSRETURN_YES;
420
421 XSRETURN_NO;
422 }
423 }
424
425 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_is_utf8)426 XS(XS_utf8_is_utf8)
427 {
428 dXSARGS;
429 if (items != 1)
430 croak_xs_usage(cv, "sv");
431 else {
432 SV * const sv = ST(0);
433 SvGETMAGIC(sv);
434 if (SvUTF8(sv))
435 XSRETURN_YES;
436 else
437 XSRETURN_NO;
438 }
439 XSRETURN_EMPTY;
440 }
441
442 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_valid)443 XS(XS_utf8_valid)
444 {
445 dXSARGS;
446 if (items != 1)
447 croak_xs_usage(cv, "sv");
448 else {
449 SV * const sv = ST(0);
450 STRLEN len;
451 const char * const s = SvPV_const(sv,len);
452 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
453 XSRETURN_YES;
454 else
455 XSRETURN_NO;
456 }
457 XSRETURN_EMPTY;
458 }
459
460 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_encode)461 XS(XS_utf8_encode)
462 {
463 dXSARGS;
464 if (items != 1)
465 croak_xs_usage(cv, "sv");
466 sv_utf8_encode(ST(0));
467 SvSETMAGIC(ST(0));
468 XSRETURN_EMPTY;
469 }
470
471 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_decode)472 XS(XS_utf8_decode)
473 {
474 dXSARGS;
475 if (items != 1)
476 croak_xs_usage(cv, "sv");
477 else {
478 SV * const sv = ST(0);
479 bool RETVAL;
480 SvPV_force_nolen(sv);
481 RETVAL = sv_utf8_decode(sv);
482 SvSETMAGIC(sv);
483 ST(0) = boolSV(RETVAL);
484 }
485 XSRETURN(1);
486 }
487
488 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_upgrade)489 XS(XS_utf8_upgrade)
490 {
491 dXSARGS;
492 if (items != 1)
493 croak_xs_usage(cv, "sv");
494 else {
495 SV * const sv = ST(0);
496 STRLEN RETVAL;
497 dXSTARG;
498
499 RETVAL = sv_utf8_upgrade(sv);
500 XSprePUSH; PUSHi((IV)RETVAL);
501 }
502 XSRETURN(1);
503 }
504
505 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_downgrade)506 XS(XS_utf8_downgrade)
507 {
508 dXSARGS;
509 if (items < 1 || items > 2)
510 croak_xs_usage(cv, "sv, failok=0");
511 else {
512 SV * const sv0 = ST(0);
513 SV * const sv1 = ST(1);
514 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
515 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
516
517 ST(0) = boolSV(RETVAL);
518 }
519 XSRETURN(1);
520 }
521
522 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_native_to_unicode)523 XS(XS_utf8_native_to_unicode)
524 {
525 dXSARGS;
526 const UV uv = SvUV(ST(0));
527
528 if (items > 1)
529 croak_xs_usage(cv, "sv");
530
531 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
532 XSRETURN(1);
533 }
534
535 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_unicode_to_native)536 XS(XS_utf8_unicode_to_native)
537 {
538 dXSARGS;
539 const UV uv = SvUV(ST(0));
540
541 if (items > 1)
542 croak_xs_usage(cv, "sv");
543
544 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
545 XSRETURN(1);
546 }
547
548 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREADONLY)549 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
550 {
551 dXSARGS;
552 SV * const svz = ST(0);
553 SV * sv;
554
555 /* [perl #77776] - called as &foo() not foo() */
556 if (!SvROK(svz))
557 croak_xs_usage(cv, "SCALAR[, ON]");
558
559 sv = SvRV(svz);
560
561 if (items == 1) {
562 if (SvREADONLY(sv))
563 XSRETURN_YES;
564 else
565 XSRETURN_NO;
566 }
567 else if (items == 2) {
568 SV *sv1 = ST(1);
569 if (SvTRUE_NN(sv1)) {
570 SvFLAGS(sv) |= SVf_READONLY;
571 XSRETURN_YES;
572 }
573 else {
574 /* I hope you really know what you are doing. */
575 SvFLAGS(sv) &=~ SVf_READONLY;
576 XSRETURN_NO;
577 }
578 }
579 XSRETURN_UNDEF; /* Can't happen. */
580 }
581
582 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
XS(XS_constant__make_const)583 XS(XS_constant__make_const) /* This is dangerous stuff. */
584 {
585 dXSARGS;
586 SV * const svz = ST(0);
587 SV * sv;
588
589 /* [perl #77776] - called as &foo() not foo() */
590 if (!SvROK(svz) || items != 1)
591 croak_xs_usage(cv, "SCALAR");
592
593 sv = SvRV(svz);
594
595 SvREADONLY_on(sv);
596 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
597 /* for constant.pm; nobody else should be calling this
598 on arrays anyway. */
599 SV **svp;
600 for (svp = AvARRAY(sv) + AvFILLp(sv)
601 ; svp >= AvARRAY(sv)
602 ; --svp)
603 if (*svp) SvPADTMP_on(*svp);
604 }
605 XSRETURN(0);
606 }
607
608 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREFCNT)609 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
610 {
611 dXSARGS;
612 SV * const svz = ST(0);
613 SV * sv;
614 U32 refcnt;
615
616 /* [perl #77776] - called as &foo() not foo() */
617 if ((items != 1 && items != 2) || !SvROK(svz))
618 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
619
620 sv = SvRV(svz);
621
622 /* I hope you really know what you are doing. */
623 /* idea is for SvREFCNT(sv) to be accessed only once */
624 refcnt = items == 2 ?
625 /* we free one ref on exit */
626 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
627 : SvREFCNT(sv);
628 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
629
630 }
631
632 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_hv_clear_placehold)633 XS(XS_Internals_hv_clear_placehold)
634 {
635 dXSARGS;
636
637 if (items != 1 || !SvROK(ST(0)))
638 croak_xs_usage(cv, "hv");
639 else {
640 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
641 hv_clear_placeholders(hv);
642 XSRETURN(0);
643 }
644 }
645
646 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO_get_layers)647 XS(XS_PerlIO_get_layers)
648 {
649 dXSARGS;
650 if (items < 1 || items % 2 == 0)
651 croak_xs_usage(cv, "filehandle[,args]");
652 #if defined(USE_PERLIO)
653 {
654 SV * sv;
655 GV * gv;
656 IO * io;
657 bool input = TRUE;
658 bool details = FALSE;
659
660 if (items > 1) {
661 SV * const *svp;
662 for (svp = MARK + 2; svp <= SP; svp += 2) {
663 SV * const * const varp = svp;
664 SV * const * const valp = svp + 1;
665 STRLEN klen;
666 const char * const key = SvPV_const(*varp, klen);
667
668 switch (*key) {
669 case 'i':
670 if (memEQs(key, klen, "input")) {
671 input = SvTRUE(*valp);
672 break;
673 }
674 goto fail;
675 case 'o':
676 if (memEQs(key, klen, "output")) {
677 input = !SvTRUE(*valp);
678 break;
679 }
680 goto fail;
681 case 'd':
682 if (memEQs(key, klen, "details")) {
683 details = SvTRUE(*valp);
684 break;
685 }
686 goto fail;
687 default:
688 fail:
689 Perl_croak(aTHX_
690 "get_layers: unknown argument '%s'",
691 key);
692 }
693 }
694
695 SP -= (items - 1);
696 }
697
698 sv = POPs;
699 gv = MAYBE_DEREF_GV(sv);
700
701 if (!gv && !SvROK(sv))
702 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
703
704 if (gv && (io = GvIO(gv))) {
705 AV* const av = PerlIO_get_layers(aTHX_ input ?
706 IoIFP(io) : IoOFP(io));
707 SSize_t i;
708 const SSize_t last = av_tindex(av);
709 SSize_t nitem = 0;
710
711 for (i = last; i >= 0; i -= 3) {
712 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
713 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
714 SV * const * const flgsvp = av_fetch(av, i, FALSE);
715
716 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
717 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
718 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
719
720 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
721 if (details) {
722 /* Indents of 5? Yuck. */
723 /* We know that PerlIO_get_layers creates a new SV for
724 the name and flags, so we can just take a reference
725 and "steal" it when we free the AV below. */
726 PUSHs(namok
727 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
728 : &PL_sv_undef);
729 PUSHs(argok
730 ? newSVpvn_flags(SvPVX_const(*argsvp),
731 SvCUR(*argsvp),
732 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
733 | SVs_TEMP)
734 : &PL_sv_undef);
735 PUSHs(flgok
736 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
737 : &PL_sv_undef);
738 nitem += 3;
739 }
740 else {
741 if (namok && argok)
742 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
743 SVfARG(*namsvp),
744 SVfARG(*argsvp))));
745 else if (namok)
746 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
747 else
748 PUSHs(&PL_sv_undef);
749 nitem++;
750 if (flgok) {
751 const IV flags = SvIVX(*flgsvp);
752
753 if (flags & PERLIO_F_UTF8) {
754 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
755 nitem++;
756 }
757 }
758 }
759 }
760
761 SvREFCNT_dec(av);
762
763 XSRETURN(nitem);
764 }
765 }
766 #endif
767
768 XSRETURN(0);
769 }
770
771 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_is_regexp)772 XS(XS_re_is_regexp)
773 {
774 dXSARGS;
775
776 if (items != 1)
777 croak_xs_usage(cv, "sv");
778
779 if (SvRXOK(ST(0))) {
780 XSRETURN_YES;
781 } else {
782 XSRETURN_NO;
783 }
784 }
785
786 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames_count)787 XS(XS_re_regnames_count)
788 {
789 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
790 SV * ret;
791 dXSARGS;
792
793 if (items != 0)
794 croak_xs_usage(cv, "");
795
796 if (!rx)
797 XSRETURN_UNDEF;
798
799 ret = CALLREG_NAMED_BUFF_COUNT(rx);
800
801 SPAGAIN;
802 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
803 XSRETURN(1);
804 }
805
806 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regname)807 XS(XS_re_regname)
808 {
809 dXSARGS;
810 REGEXP * rx;
811 U32 flags;
812 SV * ret;
813
814 if (items < 1 || items > 2)
815 croak_xs_usage(cv, "name[, all ]");
816
817 SP -= items;
818 PUTBACK;
819
820 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
821
822 if (!rx)
823 XSRETURN_UNDEF;
824
825 if (items == 2 && SvTRUE_NN(ST(1))) {
826 flags = RXapif_ALL;
827 } else {
828 flags = RXapif_ONE;
829 }
830 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
831
832 SPAGAIN;
833 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
834 XSRETURN(1);
835 }
836
837
838 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames)839 XS(XS_re_regnames)
840 {
841 dXSARGS;
842 REGEXP * rx;
843 U32 flags;
844 SV *ret;
845 AV *av;
846 SSize_t length;
847 SSize_t i;
848 SV **entry;
849
850 if (items > 1)
851 croak_xs_usage(cv, "[all]");
852
853 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
854
855 if (!rx)
856 XSRETURN_UNDEF;
857
858 if (items == 1 && SvTRUE_NN(ST(0))) {
859 flags = RXapif_ALL;
860 } else {
861 flags = RXapif_ONE;
862 }
863
864 SP -= items;
865 PUTBACK;
866
867 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
868
869 SPAGAIN;
870
871 if (!ret)
872 XSRETURN_UNDEF;
873
874 av = MUTABLE_AV(SvRV(ret));
875 length = av_tindex(av);
876
877 EXTEND(SP, length+1); /* better extend stack just once */
878 for (i = 0; i <= length; i++) {
879 entry = av_fetch(av, i, FALSE);
880
881 if (!entry)
882 Perl_croak(aTHX_ "NULL array element in re::regnames()");
883
884 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
885 }
886
887 SvREFCNT_dec(ret);
888
889 PUTBACK;
890 return;
891 }
892
893 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regexp_pattern)894 XS(XS_re_regexp_pattern)
895 {
896 dXSARGS;
897 REGEXP *re;
898 U8 const gimme = GIMME_V;
899
900 EXTEND(SP, 2);
901 SP -= items;
902 if (items != 1)
903 croak_xs_usage(cv, "sv");
904
905 /*
906 Checks if a reference is a regex or not. If the parameter is
907 not a ref, or is not the result of a qr// then returns false
908 in scalar context and an empty list in list context.
909 Otherwise in list context it returns the pattern and the
910 modifiers, in scalar context it returns the pattern just as it
911 would if the qr// was stringified normally, regardless as
912 to the class of the variable and any stringification overloads
913 on the object.
914 */
915
916 if ((re = SvRX(ST(0)))) /* assign deliberate */
917 {
918 /* Houston, we have a regex! */
919 SV *pattern;
920
921 if ( gimme == G_ARRAY ) {
922 STRLEN left = 0;
923 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
924 const char *fptr;
925 char ch;
926 U16 match_flags;
927
928 /*
929 we are in list context so stringify
930 the modifiers that apply. We ignore "negative
931 modifiers" in this scenario, and the default character set
932 */
933
934 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
935 STRLEN len;
936 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
937 &len);
938 Copy(name, reflags + left, len, char);
939 left += len;
940 }
941 fptr = INT_PAT_MODS;
942 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
943 >> RXf_PMf_STD_PMMOD_SHIFT);
944
945 while((ch = *fptr++)) {
946 if(match_flags & 1) {
947 reflags[left++] = ch;
948 }
949 match_flags >>= 1;
950 }
951
952 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
953 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
954
955 /* return the pattern and the modifiers */
956 PUSHs(pattern);
957 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
958 XSRETURN(2);
959 } else {
960 /* Scalar, so use the string that Perl would return */
961 /* return the pattern in (?msixn:..) format */
962 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
963 PUSHs(pattern);
964 XSRETURN(1);
965 }
966 } else {
967 /* It ain't a regexp folks */
968 if ( gimme == G_ARRAY ) {
969 /* return the empty list */
970 XSRETURN_EMPTY;
971 } else {
972 /* Because of the (?:..) wrapping involved in a
973 stringified pattern it is impossible to get a
974 result for a real regexp that would evaluate to
975 false. Therefore we can return PL_sv_no to signify
976 that the object is not a regex, this means that one
977 can say
978
979 if (regex($might_be_a_regex) eq '(?:foo)') { }
980
981 and not worry about undefined values.
982 */
983 XSRETURN_NO;
984 }
985 }
986 NOT_REACHED; /* NOTREACHED */
987 }
988
989 #ifdef HAS_GETCWD
990
XS(XS_Internals_getcwd)991 XS(XS_Internals_getcwd)
992 {
993 dXSARGS;
994 SV *sv = sv_newmortal();
995
996 if (items != 0)
997 croak_xs_usage(cv, "");
998
999 (void)getcwd_sv(sv);
1000
1001 SvTAINTED_on(sv);
1002 PUSHs(sv);
1003 XSRETURN(1);
1004 }
1005
1006 #endif
1007
1008 #include "vutil.h"
1009 #include "vxs.inc"
1010
1011 struct xsub_details {
1012 const char *name;
1013 XSUBADDR_t xsub;
1014 const char *proto;
1015 };
1016
1017 static const struct xsub_details these_details[] = {
1018 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1019 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1020 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1021 #define VXS_XSUB_DETAILS
1022 #include "vxs.inc"
1023 #undef VXS_XSUB_DETAILS
1024 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1025 {"utf8::valid", XS_utf8_valid, NULL},
1026 {"utf8::encode", XS_utf8_encode, NULL},
1027 {"utf8::decode", XS_utf8_decode, NULL},
1028 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1029 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1030 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1031 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1032 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1033 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1034 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1035 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1036 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1037 {"re::is_regexp", XS_re_is_regexp, "$"},
1038 {"re::regname", XS_re_regname, ";$$"},
1039 {"re::regnames", XS_re_regnames, ";$"},
1040 {"re::regnames_count", XS_re_regnames_count, ""},
1041 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1042 #ifdef HAS_GETCWD
1043 {"Internals::getcwd", XS_Internals_getcwd, ""},
1044 #endif
1045 };
1046
1047 STATIC OP*
optimize_out_native_convert_function(pTHX_ OP * entersubop,GV * namegv,SV * protosv)1048 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1049 GV* namegv,
1050 SV* protosv)
1051 {
1052 /* Optimizes out an identity function, i.e., one that just returns its
1053 * argument. The passed in function is assumed to be an identity function,
1054 * with no checking. This is designed to be called for utf8_to_native()
1055 * and native_to_utf8() on ASCII platforms, as they just return their
1056 * arguments, but it could work on any such function.
1057 *
1058 * The code is mostly just cargo-culted from Memoize::Lift */
1059
1060 OP *pushop, *argop;
1061 OP *parent;
1062 SV* prototype = newSVpvs("$");
1063
1064 PERL_UNUSED_ARG(protosv);
1065
1066 assert(entersubop->op_type == OP_ENTERSUB);
1067
1068 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1069 parent = entersubop;
1070
1071 SvREFCNT_dec(prototype);
1072
1073 pushop = cUNOPx(entersubop)->op_first;
1074 if (! OpHAS_SIBLING(pushop)) {
1075 parent = pushop;
1076 pushop = cUNOPx(pushop)->op_first;
1077 }
1078 argop = OpSIBLING(pushop);
1079
1080 /* Carry on without doing the optimization if it is not something we're
1081 * expecting, so continues to work */
1082 if ( ! argop
1083 || ! OpHAS_SIBLING(argop)
1084 || OpHAS_SIBLING(OpSIBLING(argop))
1085 ) {
1086 return entersubop;
1087 }
1088
1089 /* cut argop from the subtree */
1090 (void)op_sibling_splice(parent, pushop, 1, NULL);
1091
1092 op_free(entersubop);
1093 return argop;
1094 }
1095
1096 void
Perl_boot_core_UNIVERSAL(pTHX)1097 Perl_boot_core_UNIVERSAL(pTHX)
1098 {
1099 static const char file[] = __FILE__;
1100 const struct xsub_details *xsub = these_details;
1101 const struct xsub_details *end = C_ARRAY_END(these_details);
1102
1103 do {
1104 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1105 } while (++xsub < end);
1106
1107 #ifndef EBCDIC
1108 { /* On ASCII platforms these functions just return their argument, so can
1109 be optimized away */
1110
1111 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1112 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1113
1114 cv_set_call_checker_flags(to_native_cv,
1115 optimize_out_native_convert_function,
1116 (SV*) to_native_cv, 0);
1117 cv_set_call_checker_flags(to_unicode_cv,
1118 optimize_out_native_convert_function,
1119 (SV*) to_unicode_cv, 0);
1120 }
1121 #endif
1122
1123 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1124 {
1125 CV * const cv =
1126 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1127 char ** cvfile = &CvFILE(cv);
1128 char * oldfile = *cvfile;
1129 CvDYNFILE_off(cv);
1130 *cvfile = (char *)file;
1131 Safefree(oldfile);
1132 }
1133 }
1134
1135 /*
1136 * ex: set ts=8 sts=4 sw=4 et:
1137 */
1138