File Coverage

universal.c
Criterion Covered Total %
statement 506 565 89.6
branch 474 948 50.0
condition n/a
subroutine n/a
total 980 1513 64.8


line stmt bran cond sub time code
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           #ifdef USE_PERLIO
33           #include "perliol.h" /* For the PERLIO_F_XXX */
34           #endif
35            
36           /*
37           * Contributed by Graham Barr
38           * The main guts of traverse_isa was actually copied from gv_fetchmeth
39           */
40            
41           STATIC bool
42 10626665         S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
43           {
44           dVAR;
45 10626665 100       const struct mro_meta *const meta = HvMROMETA(stash);
46 10626665         HV *isa = meta->isa;
47           const HV *our_stash;
48            
49           PERL_ARGS_ASSERT_ISA_LOOKUP;
50            
51 10626665 100       if (!isa) {
52 17632         (void)mro_get_linear_isa(stash);
53 17632         isa = meta->isa;
54           }
55            
56 10626665 100       if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
57           HV_FETCH_ISEXISTS, NULL, 0)) {
58           /* Direct name lookup worked. */
59           return TRUE;
60           }
61            
62           /* A stash/class can go by many names (ie. User == main::User), so
63           we use the HvENAME in the stash itself, which is canonical, falling
64           back to HvNAME if necessary. */
65 3800032         our_stash = gv_stashpvn(name, len, flags);
66            
67 3800032 100       if (our_stash) {
68 3753020 50       HEK *canon_name = HvENAME_HEK(our_stash);
    50        
    100        
    50        
    50        
69 3753020 50       if (!canon_name) canon_name = HvNAME_HEK(our_stash);
    0        
    0        
    0        
70            
71 3753020 100       if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
72           HEK_FLAGS(canon_name),
73           HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
74           return TRUE;
75           }
76           }
77            
78 7217206         return FALSE;
79           }
80            
81           /*
82           =head1 SV Manipulation Functions
83            
84           =for apidoc sv_derived_from_pvn
85            
86           Returns a boolean indicating whether the SV is derived from the specified class
87           I. To check derivation at the Perl level, call C as a
88           normal Perl method.
89            
90           Currently, the only significant value for C is SVf_UTF8.
91            
92           =cut
93            
94           =for apidoc sv_derived_from_sv
95            
96           Exactly like L, but takes the name string in the form
97           of an SV instead of a string/length pair.
98            
99           =cut
100            
101           */
102            
103           bool
104 7497394         Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
105           {
106           char *namepv;
107           STRLEN namelen;
108           PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
109 7497394 50       namepv = SvPV(namesv, namelen);
110 7497394 100       if (SvUTF8(namesv))
111 674         flags |= SVf_UTF8;
112 7497394         return sv_derived_from_pvn(sv, namepv, namelen, flags);
113           }
114            
115           /*
116           =for apidoc sv_derived_from
117            
118           Exactly like L, but doesn't take a C parameter.
119            
120           =cut
121           */
122            
123           bool
124 3391935         Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
125           {
126           PERL_ARGS_ASSERT_SV_DERIVED_FROM;
127 3391935         return sv_derived_from_pvn(sv, name, strlen(name), 0);
128           }
129            
130           /*
131           =for apidoc sv_derived_from_pv
132            
133           Exactly like L, but takes a nul-terminated string
134           instead of a string/length pair.
135            
136           =cut
137           */
138            
139            
140           bool
141 0         Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
142           {
143           PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
144 0         return sv_derived_from_pvn(sv, name, strlen(name), flags);
145           }
146            
147           bool
148 11048015         Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
149 11048015 100       {
150           dVAR;
151           HV *stash;
152            
153           PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
154            
155 5517175         SvGETMAGIC(sv);
156            
157 11048015 100       if (SvROK(sv)) {
158           const char *type;
159 10789833         sv = SvRV(sv);
160 10789833         type = sv_reftype(sv,0);
161 10789833 50       if (type && strEQ(type,name))
    100        
162           return TRUE;
163 10627467 100       stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
164           }
165           else {
166 258182         stash = gv_stashsv(sv, 0);
167 258182 100       if (!stash)
168 116184         stash = gv_stashpvs("UNIVERSAL", 0);
169           }
170            
171 10967012 100       return stash ? isa_lookup(stash, name, len, flags) : FALSE;
    100        
172           }
173            
174           /*
175           =for apidoc sv_does_sv
176            
177           Returns a boolean indicating whether the SV performs a specific, named role.
178           The SV can be a Perl object or the name of a Perl class.
179            
180           =cut
181           */
182            
183           #include "XSUB.h"
184            
185           bool
186 172         Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
187 340 50       {
    50        
188           SV *classname;
189           bool does_it;
190           SV *methodname;
191 172         dSP;
192            
193           PERL_ARGS_ASSERT_SV_DOES_SV;
194           PERL_UNUSED_ARG(flags);
195            
196 172         ENTER;
197 172         SAVETMPS;
198            
199 86         SvGETMAGIC(sv);
200            
201 172 50       if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
    0        
    0        
    100        
    50        
    50        
202 0         LEAVE;
203 0         return FALSE;
204           }
205            
206 172 50       if (sv_isobject(sv)) {
207 0         classname = sv_ref(NULL,SvRV(sv),TRUE);
208           } else {
209           classname = sv;
210           }
211            
212 172 100       if (sv_eq(classname, namesv)) {
213 4         LEAVE;
214 4         return TRUE;
215           }
216            
217 168 50       PUSHMARK(SP);
218 84         EXTEND(SP, 2);
219 168         PUSHs(sv);
220 168         PUSHs(namesv);
221 168         PUTBACK;
222            
223 168         methodname = newSVpvs_flags("isa", SVs_TEMP);
224           /* ugly hack: use the SvSCREAM flag so S_method_common
225           * can figure out we're calling DOES() and not isa(),
226           * and report eventual errors correctly. --rgs */
227 168         SvSCREAM_on(methodname);
228 168         call_sv(methodname, G_SCALAR | G_METHOD);
229 164         SPAGAIN;
230            
231 164 50       does_it = SvTRUE( TOPs );
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    50        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
232 164 50       FREETMPS;
233 164         LEAVE;
234            
235 166         return does_it;
236           }
237            
238           /*
239           =for apidoc sv_does
240            
241           Like L, but doesn't take a C parameter.
242            
243           =cut
244           */
245            
246           bool
247 0         Perl_sv_does(pTHX_ SV *sv, const char *const name)
248           {
249           PERL_ARGS_ASSERT_SV_DOES;
250 0         return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
251           }
252            
253           /*
254           =for apidoc sv_does_pv
255            
256           Like L, but takes a nul-terminated string instead of an SV.
257            
258           =cut
259           */
260            
261            
262           bool
263 0         Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
264           {
265           PERL_ARGS_ASSERT_SV_DOES_PV;
266 0         return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
267           }
268            
269           /*
270           =for apidoc sv_does_pvn
271            
272           Like L, but takes a string/length pair instead of an SV.
273            
274           =cut
275           */
276            
277           bool
278 0         Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
279           {
280           PERL_ARGS_ASSERT_SV_DOES_PVN;
281            
282 0         return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
283           }
284            
285           /*
286           =for apidoc croak_xs_usage
287            
288           A specialised variant of C for emitting the usage message for xsubs
289            
290           croak_xs_usage(cv, "eee_yow");
291            
292           works out the package name and subroutine name from C, and then calls
293           C. Hence if C is C<&ouch::awk>, it would call C as:
294            
295           Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
296            
297           =cut
298           */
299            
300           void
301 68         Perl_croak_xs_usage(const CV *const cv, const char *const params)
302           {
303           const GV *const gv = CvGV(cv);
304            
305           PERL_ARGS_ASSERT_CROAK_XS_USAGE;
306            
307 68 50       if (gv) {
308 68         const HV *const stash = GvSTASH(gv);
309            
310 68 50       if (HvNAME_get(stash))
    50        
    50        
    0        
    50        
    50        
    50        
311 170 50       Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
    50        
312 136 50       HEKfARG(HvNAME_HEK(stash)),
313 68         HEKfARG(GvNAME_HEK(gv)),
314           params);
315           else
316 0         Perl_croak_nocontext("Usage: %"HEKf"(%s)",
317 0         HEKfARG(GvNAME_HEK(gv)), params);
318           } else {
319           /* Pants. I don't think that it should be possible to get here. */
320 0         Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
321           }
322           }
323            
324 7510358         XS(XS_UNIVERSAL_isa)
325           {
326           dVAR;
327 7510358         dXSARGS;
328            
329 7510358 50       if (items != 2)
330 0         croak_xs_usage(cv, "reference, kind");
331 7510358 100       else {
332 7510358         SV * const sv = ST(0);
333            
334 3752485         SvGETMAGIC(sv);
335            
336 7510358 100       if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
    50        
    50        
    100        
    100        
    100        
337 12964         XSRETURN_UNDEF;
338            
339 7497394 100       ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
340 7503876         XSRETURN(1);
341           }
342           }
343            
344 75499808         XS(XS_UNIVERSAL_can)
345 75499808 100       {
346           dVAR;
347 75499808         dXSARGS;
348           SV *sv;
349           SV *rv;
350           HV *pkg = NULL;
351           GV *iogv;
352            
353 75499808 50       if (items != 2)
354 0         croak_xs_usage(cv, "object-ref, method");
355            
356 75499808         sv = ST(0);
357            
358 37749908         SvGETMAGIC(sv);
359            
360           /* Reject undef and empty string. Note that the string form takes
361           precedence here over the numeric form, as (!1)->foo treats the
362           invocant as the empty string, though it is a dualvar. */
363 75499808 50       if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
    0        
    0        
    100        
    50        
364 0         XSRETURN_UNDEF;
365            
366           rv = &PL_sv_undef;
367            
368 75499808 100       if (SvROK(sv)) {
369 75373974         sv = MUTABLE_SV(SvRV(sv));
370 75373974 100       if (SvOBJECT(sv))
371 75373702         pkg = SvSTASH(sv);
372 272 100       else if (isGV_with_GP(sv) && GvIO(sv))
    50        
    50        
    50        
    50        
    50        
373 270 50       pkg = SvSTASH(GvIO(sv));
    50        
    50        
374           }
375 125834 100       else if (isGV_with_GP(sv) && GvIO(sv))
    50        
    50        
    50        
    50        
    50        
376 2 50       pkg = SvSTASH(GvIO(sv));
    50        
    50        
377 125832 100       else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
    50        
    50        
    50        
    100        
378 2 50       pkg = SvSTASH(GvIO(iogv));
    50        
    50        
379           else {
380 125830         pkg = gv_stashsv(sv, 0);
381 125830 100       if (!pkg)
382 242         pkg = gv_stashpv("UNIVERSAL", 0);
383           }
384            
385 75499808 100       if (pkg) {
386 75499806         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
387 75499806 100       if (gv && isGV(gv))
    50        
388 64051058         rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
389           }
390            
391 75499808         ST(0) = rv;
392 75499808         XSRETURN(1);
393           }
394            
395 172         XS(XS_UNIVERSAL_DOES)
396           {
397           dVAR;
398 172         dXSARGS;
399           PERL_UNUSED_ARG(cv);
400            
401 172 50       if (items != 2)
402 0         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
403           else {
404 172         SV * const sv = ST(0);
405 172 100       if (sv_does_sv( sv, ST(1), 0 ))
406 10         XSRETURN_YES;
407            
408 163         XSRETURN_NO;
409           }
410           }
411            
412 25620         XS(XS_UNIVERSAL_VERSION)
413           {
414           dVAR;
415 25620         dXSARGS;
416           HV *pkg;
417           GV **gvp;
418           GV *gv;
419           SV *sv;
420           const char *undef;
421           PERL_UNUSED_ARG(cv);
422            
423 25620 100       if (SvROK(ST(0))) {
424 130         sv = MUTABLE_SV(SvRV(ST(0)));
425 130 50       if (!SvOBJECT(sv))
426 0         Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
427 130         pkg = SvSTASH(sv);
428           }
429           else {
430 25490         pkg = gv_stashsv(ST(0), 0);
431           }
432            
433 25620 100       gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
434            
435 25620 100       if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
    50        
    100        
    50        
    0        
    0        
436 25476         SV * const nsv = sv_newmortal();
437 25476         sv_setsv(nsv, sv);
438           sv = nsv;
439 25476 100       if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
    50        
440 25356         upg_version(sv, FALSE);
441            
442           undef = NULL;
443           }
444           else {
445           sv = &PL_sv_undef;
446           undef = "(undef)";
447           }
448            
449 25586 100       if (items > 1) {
450 20824         SV *req = ST(1);
451            
452 20824 100       if (undef) {
453 62 100       if (pkg) {
454 40 50       const HEK * const name = HvNAME_HEK(pkg);
    50        
    50        
455 40         Perl_croak(aTHX_
456           "%"HEKf" does not define $%"HEKf
457           "::VERSION--version check failed",
458           HEKfARG(name), HEKfARG(name));
459           } else {
460 22         Perl_croak(aTHX_
461           "%"SVf" defines neither package nor VERSION--version check failed",
462 22         SVfARG(ST(0)) );
463           }
464           }
465            
466 20762 50       if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
    0        
467           /* req may very well be R/O, so create a new object */
468 20762         req = sv_2mortal( new_version(req) );
469           }
470            
471 20760 100       if ( vcmp( req, sv ) > 0 ) {
472 204 100       if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
473 115 50       Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
    50        
474           "this is only version %"SVf"",
475 92 50       HEKfARG(HvNAME_HEK(pkg)),
476 46         SVfARG(sv_2mortal(vnormal(req))),
477 46         SVfARG(sv_2mortal(vnormal(sv))));
478           } else {
479 395 50       Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
    50        
480           "this is only version %"SVf,
481 316 50       HEKfARG(HvNAME_HEK(pkg)),
482 158         SVfARG(sv_2mortal(vstringify(req))),
483 158         SVfARG(sv_2mortal(vstringify(sv))));
484           }
485           }
486            
487           }
488            
489 25318 100       if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
    50        
    50        
    50        
490 25236         ST(0) = sv_2mortal(vstringify(sv));
491           } else {
492 82         ST(0) = sv;
493           }
494            
495 25318         XSRETURN(1);
496           }
497            
498 23266         XS(XS_version_new)
499           {
500           dVAR;
501 23266         dXSARGS;
502 23266 100       if (items > 3 || items < 1)
503 6         croak_xs_usage(cv, "class, version");
504 23260         SP -= items;
505           {
506 23260         SV *vs = ST(1);
507           SV *rv;
508           STRLEN len;
509           const char *classname;
510           U32 flags;
511 23260 100       if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
512 40         const HV * stash = SvSTASH(SvRV(ST(0)));
513 40 50       classname = HvNAME(stash);
    50        
    50        
    0        
    50        
    50        
514 40 50       len = HvNAMELEN(stash);
    50        
    50        
    0        
    50        
    50        
515 40 50       flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
    50        
    50        
    0        
    50        
    50        
    50        
    50        
516           }
517           else {
518 23220 50       classname = SvPV(ST(0), len);
519 23220         flags = SvUTF8(ST(0));
520           }
521            
522 23260 100       if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
    100        
    50        
    50        
523           /* create empty object */
524 48         vs = sv_newmortal();
525 48         sv_setpvs(vs, "0");
526           }
527 23212 100       else if ( items == 3 ) {
528 40         vs = sv_newmortal();
529 40 50       Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
530           }
531            
532 23260         rv = new_version(vs);
533 22826 50       if ( strnNE(classname,"version", len) ) /* inherited new() */
    0        
    100        
534 1762         sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
535            
536 22826         mPUSHs(rv);
537 22826         PUTBACK;
538 22826         return;
539           }
540           }
541            
542 37722         XS(XS_version_stringify)
543           {
544           dVAR;
545 37722         dXSARGS;
546 37722 50       if (items < 1)
547 0         croak_xs_usage(cv, "lobj, ...");
548 37722         SP -= items;
549           {
550 37722         SV * lobj = ST(0);
551            
552 37722 50       if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
    50        
553 37722         lobj = SvRV(lobj);
554           }
555           else
556 0         Perl_croak(aTHX_ "lobj is not of type version");
557            
558 37722         mPUSHs(vstringify(lobj));
559            
560 37720         PUTBACK;
561 37720         return;
562           }
563           }
564            
565 252         XS(XS_version_numify)
566           {
567           dVAR;
568 252         dXSARGS;
569 252 50       if (items < 1)
570 0         croak_xs_usage(cv, "lobj, ...");
571 252         SP -= items;
572           {
573 252         SV * lobj = ST(0);
574            
575 252 50       if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
    50        
576 252         lobj = SvRV(lobj);
577           }
578           else
579 0         Perl_croak(aTHX_ "lobj is not of type version");
580            
581 252         mPUSHs(vnumify(lobj));
582            
583 250         PUTBACK;
584 250         return;
585           }
586           }
587            
588 304         XS(XS_version_normal)
589           {
590           dVAR;
591 304         dXSARGS;
592 304 50       if (items < 1)
593 0         croak_xs_usage(cv, "lobj, ...");
594 304         SP -= items;
595           {
596 304         SV * lobj = ST(0);
597            
598 304 50       if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
    50        
599 304         lobj = SvRV(lobj);
600           }
601           else
602 0         Perl_croak(aTHX_ "lobj is not of type version");
603            
604 304         mPUSHs(vnormal(lobj));
605            
606 302         PUTBACK;
607 302         return;
608           }
609           }
610            
611 90648         XS(XS_version_vcmp)
612           {
613           dVAR;
614 90648         dXSARGS;
615 90648 50       if (items < 1)
616 0         croak_xs_usage(cv, "lobj, ...");
617 90648         SP -= items;
618           {
619 90648         SV * lobj = ST(0);
620            
621 90648 50       if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
    50        
622 90648         lobj = SvRV(lobj);
623           }
624           else
625 0         Perl_croak(aTHX_ "lobj is not of type version");
626            
627           {
628           SV *rs;
629           SV *rvs;
630 90648         SV * robj = ST(1);
631 135792 50       const IV swap = (IV)SvIV(ST(2));
632            
633 90648 100       if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
    50        
634           {
635 89002 100       robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
    50        
    50        
636 88982         sv_2mortal(robj);
637           }
638 90628         rvs = SvRV(robj);
639            
640 90628 100       if ( swap )
641           {
642 104         rs = newSViv(vcmp(rvs,lobj));
643           }
644           else
645           {
646 90524         rs = newSViv(vcmp(lobj,rvs));
647           }
648            
649 90626         mPUSHs(rs);
650           }
651            
652 90626         PUTBACK;
653 90626         return;
654           }
655           }
656            
657 11850         XS(XS_version_boolean)
658           {
659           dVAR;
660 11850         dXSARGS;
661 11850 50       if (items < 1)
662 0         croak_xs_usage(cv, "lobj, ...");
663 11850         SP -= items;
664 11850 50       if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
    50        
665 11850         SV * const lobj = SvRV(ST(0));
666 11850         SV * const rs =
667 11850         newSViv( vcmp(lobj,
668           sv_2mortal(new_version(
669           sv_2mortal(newSVpvs("0"))
670           ))
671           )
672           );
673 11850         mPUSHs(rs);
674 11850         PUTBACK;
675 11850         return;
676           }
677           else
678 0         Perl_croak(aTHX_ "lobj is not of type version");
679           }
680            
681 158         XS(XS_version_noop)
682           {
683           dVAR;
684 158         dXSARGS;
685 158 50       if (items < 1)
686 0         croak_xs_usage(cv, "lobj, ...");
687 158 50       if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
    50        
688 158         Perl_croak(aTHX_ "operation not supported with version object");
689           else
690 0         Perl_croak(aTHX_ "lobj is not of type version");
691           #ifndef HASATTRIBUTE_NORETURN
692           XSRETURN_EMPTY;
693           #endif
694           }
695            
696 668         XS(XS_version_is_alpha)
697           {
698           dVAR;
699 668         dXSARGS;
700 668 50       if (items != 1)
701 0         croak_xs_usage(cv, "lobj");
702           SP -= items;
703 668 50       if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
    50        
704 668         SV * const lobj = ST(0);
705 668 100       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
706 46         XSRETURN_YES;
707           else
708 622         XSRETURN_NO;
709           PUTBACK;
710           return;
711           }
712           else
713 334         Perl_croak(aTHX_ "lobj is not of type version");
714           }
715            
716 114         XS(XS_version_qv)
717           {
718           dVAR;
719 114         dXSARGS;
720           PERL_UNUSED_ARG(cv);
721 114         SP -= items;
722           {
723 114         SV * ver = ST(0);
724           SV * rv;
725 114         STRLEN len = 0;
726           const char * classname = "";
727           U32 flags = 0;
728 114 100       if ( items == 2 && SvOK(ST(1)) ) {
    50        
    0        
    0        
729 102         ver = ST(1);
730 102 50       if ( sv_isobject(ST(0)) ) { /* class called as an object method */
731 0         const HV * stash = SvSTASH(SvRV(ST(0)));
732 0 0       classname = HvNAME(stash);
    0        
    0        
    0        
    0        
    0        
733 0 0       len = HvNAMELEN(stash);
    0        
    0        
    0        
    0        
    0        
734 0 0       flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
    0        
    0        
    0        
    0        
    0        
    0        
    0        
735           }
736           else {
737 102 50       classname = SvPV(ST(0), len);
738 102         flags = SvUTF8(ST(0));
739           }
740           }
741 114 100       if ( !SvVOK(ver) ) { /* not already a v-string */
    50        
742 98         rv = sv_newmortal();
743 98         sv_setsv(rv,ver); /* make a duplicate */
744 98         upg_version(rv, TRUE);
745           } else {
746 16         rv = sv_2mortal(new_version(ver));
747           }
748 114 100       if ( items == 2
749 102 50       && strnNE(classname,"version", len) ) { /* inherited new() */
    0        
    100        
750 54         sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
751           }
752 114         PUSHs(rv);
753           }
754 114         PUTBACK;
755 114         return;
756           }
757            
758 19608         XS(XS_version_is_qv)
759           {
760           dVAR;
761 19608         dXSARGS;
762 19608 50       if (items != 1)
763 0         croak_xs_usage(cv, "lobj");
764           SP -= items;
765 19608 50       if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
    50        
766 19608         SV * const lobj = ST(0);
767 19608 100       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
768 302         XSRETURN_YES;
769           else
770 19306         XSRETURN_NO;
771           PUTBACK;
772           return;
773           }
774           else
775 9804         Perl_croak(aTHX_ "lobj is not of type version");
776           }
777            
778 3346         XS(XS_utf8_is_utf8)
779           {
780           dVAR;
781 3346         dXSARGS;
782 3346 50       if (items != 1)
783 0         croak_xs_usage(cv, "sv");
784 3346 100       else {
785 3346         SV * const sv = ST(0);
786 1681         SvGETMAGIC(sv);
787 3346 100       if (SvUTF8(sv))
788 884         XSRETURN_YES;
789           else
790 2904         XSRETURN_NO;
791           }
792           XSRETURN_EMPTY;
793           }
794            
795 292         XS(XS_utf8_valid)
796           {
797           dVAR;
798 292         dXSARGS;
799 292 50       if (items != 1)
800 0         croak_xs_usage(cv, "sv");
801           else {
802 292         SV * const sv = ST(0);
803           STRLEN len;
804 292 50       const char * const s = SvPV_const(sv,len);
805 292 100       if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
    50        
806 292         XSRETURN_YES;
807           else
808 146         XSRETURN_NO;
809           }
810           XSRETURN_EMPTY;
811           }
812            
813 931500         XS(XS_utf8_encode)
814           {
815           dVAR;
816 931500         dXSARGS;
817 931500 50       if (items != 1)
818 0         croak_xs_usage(cv, "sv");
819 931500         sv_utf8_encode(ST(0));
820 931498 100       SvSETMAGIC(ST(0));
821 931498         XSRETURN_EMPTY;
822           }
823            
824 4932         XS(XS_utf8_decode)
825           {
826           dVAR;
827 4932         dXSARGS;
828 4932 50       if (items != 1)
829 0         croak_xs_usage(cv, "sv");
830           else {
831 4932         SV * const sv = ST(0);
832           bool RETVAL;
833 4932 100       SvPV_force_nolen(sv);
834 4930         RETVAL = sv_utf8_decode(sv);
835 4930 100       SvSETMAGIC(sv);
836 4930 100       ST(0) = boolSV(RETVAL);
837           }
838 4930         XSRETURN(1);
839           }
840            
841 892150         XS(XS_utf8_upgrade)
842           {
843           dVAR;
844 892150         dXSARGS;
845 892150 50       if (items != 1)
846 0         croak_xs_usage(cv, "sv");
847           else {
848 892150         SV * const sv = ST(0);
849           STRLEN RETVAL;
850 892150 50       dXSTARG;
851            
852 892150         RETVAL = sv_utf8_upgrade(sv);
853 892150 50       XSprePUSH; PUSHi((IV)RETVAL);
854           }
855 892150         XSRETURN(1);
856           }
857            
858 336842         XS(XS_utf8_downgrade)
859           {
860           dVAR;
861 336842         dXSARGS;
862 336842 50       if (items < 1 || items > 2)
863 0         croak_xs_usage(cv, "sv, failok=0");
864           else {
865 336842         SV * const sv = ST(0);
866 336842 100       const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
    50        
867 336842         const bool RETVAL = sv_utf8_downgrade(sv, failok);
868            
869 336838 100       ST(0) = boolSV(RETVAL);
870           }
871 336838         XSRETURN(1);
872           }
873            
874 12922         XS(XS_utf8_native_to_unicode)
875           {
876           dVAR;
877 12922         dXSARGS;
878 12922 50       const UV uv = SvUV(ST(0));
879            
880 12922 50       if (items > 1)
881 0         croak_xs_usage(cv, "sv");
882            
883 12922         ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
884 12922         XSRETURN(1);
885           }
886            
887 581416         XS(XS_utf8_unicode_to_native)
888           {
889           dVAR;
890 581416         dXSARGS;
891 581416 50       const UV uv = SvUV(ST(0));
892            
893 581416 50       if (items > 1)
894 0         croak_xs_usage(cv, "sv");
895            
896 581416         ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
897 581416         XSRETURN(1);
898           }
899            
900 300294         XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
901           {
902           dVAR;
903 300294         dXSARGS;
904 300294         SV * const svz = ST(0);
905           SV * sv;
906           PERL_UNUSED_ARG(cv);
907            
908           /* [perl #77776] - called as &foo() not foo() */
909 300294 100       if (!SvROK(svz))
910 8         croak_xs_usage(cv, "SCALAR[, ON]");
911            
912 300286         sv = SvRV(svz);
913            
914 300286 100       if (items == 1) {
915 34 100       if (SvREADONLY(sv))
916 22         XSRETURN_YES;
917           else
918 12         XSRETURN_NO;
919           }
920 300252 50       else if (items == 2) {
921 300252 50       if (SvTRUE(ST(1))) {
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
922           #ifdef PERL_OLD_COPY_ON_WRITE
923           if (SvIsCOW(sv)) sv_force_normal(sv);
924           #endif
925 300106         SvREADONLY_on(sv);
926 300106 100       if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
    50        
927           /* for constant.pm; nobody else should be calling this
928           on arrays anyway. */
929           SV **svp;
930 2880 100       for (svp = AvARRAY(sv) + AvFILLp(sv)
931 2624         ; svp >= AvARRAY(sv)
932 2112         ; --svp)
933 2112 50       if (*svp) SvPADTMP_on(*svp);
934           }
935 300106         XSRETURN_YES;
936           }
937           else {
938           /* I hope you really know what you are doing. */
939 146         SvREADONLY_off(sv);
940 146         XSRETURN_NO;
941           }
942           }
943 158963         XSRETURN_UNDEF; /* Can't happen. */
944           }
945 80         XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
946           {
947           dVAR;
948 80         dXSARGS;
949 80         SV * const svz = ST(0);
950           SV * sv;
951           U32 refcnt;
952           PERL_UNUSED_ARG(cv);
953            
954           /* [perl #77776] - called as &foo() not foo() */
955 80 100       if ((items != 1 && items != 2) || !SvROK(svz))
    100        
956 8         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
957            
958 72         sv = SvRV(svz);
959            
960           /* I hope you really know what you are doing. */
961           /* idea is for SvREFCNT(sv) to be accessed only once */
962           refcnt = items == 2 ?
963           /* we free one ref on exit */
964 8 50       (SvREFCNT(sv) = SvUV(ST(1)) + 1)
965 80 100       : SvREFCNT(sv);
966 72         XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
967            
968           }
969            
970 238         XS(XS_Internals_hv_clear_placehold)
971           {
972           dVAR;
973 238         dXSARGS;
974            
975 238 100       if (items != 1 || !SvROK(ST(0)))
    100        
976 8         croak_xs_usage(cv, "hv");
977           else {
978 230         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
979 230         hv_clear_placeholders(hv);
980 230         XSRETURN(0);
981           }
982           }
983            
984 6108         XS(XS_PerlIO_get_layers)
985           {
986           dVAR;
987 6108         dXSARGS;
988 6108 50       if (items < 1 || items % 2 == 0)
    50        
989 0         croak_xs_usage(cv, "filehandle[,args]");
990           #ifdef USE_PERLIO
991           {
992           SV * sv;
993           GV * gv;
994           IO * io;
995           bool input = TRUE;
996           bool details = FALSE;
997            
998 6108 100       if (items > 1) {
999           SV * const *svp;
1000 56 100       for (svp = MARK + 2; svp <= SP; svp += 2) {
1001           SV * const * const varp = svp;
1002           SV * const * const valp = svp + 1;
1003           STRLEN klen;
1004 36 50       const char * const key = SvPV_const(*varp, klen);
1005            
1006 36         switch (*key) {
1007           case 'i':
1008 2 50       if (klen == 5 && memEQ(key, "input", 5)) {
    50        
1009 2 50       input = SvTRUE(*valp);
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
1010 2         break;
1011           }
1012           goto fail;
1013           case 'o':
1014 18 50       if (klen == 6 && memEQ(key, "output", 6)) {
    50        
1015 18 50       input = !SvTRUE(*valp);
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
1016 18         break;
1017           }
1018           goto fail;
1019           case 'd':
1020 16 50       if (klen == 7 && memEQ(key, "details", 7)) {
    50        
1021 16 50       details = SvTRUE(*valp);
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
1022 16         break;
1023           }
1024           goto fail;
1025           default:
1026           fail:
1027 0         Perl_croak(aTHX_
1028           "get_layers: unknown argument '%s'",
1029           key);
1030           }
1031           }
1032            
1033 20         SP -= (items - 1);
1034           }
1035            
1036 6108         sv = POPs;
1037 6108 100       gv = MAYBE_DEREF_GV(sv);
    100        
    50        
    100        
    50        
    100        
    100        
    50        
    100        
1038            
1039 6108 100       if (!gv && !SvROK(sv))
    100        
1040 36         gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1041            
1042 6108 100       if (gv && (io = GvIO(gv))) {
    50        
    50        
    50        
    50        
1043 6109 100       AV* const av = PerlIO_get_layers(aTHX_ input ?
1044 18         IoIFP(io) : IoOFP(io));
1045           SSize_t i;
1046 6100         const SSize_t last = av_len(av);
1047           SSize_t nitem = 0;
1048          
1049 30632 50       for (i = last; i >= 0; i -= 3) {
    100        
1050 12266         SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1051 12266         SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1052 12266         SV * const * const flgsvp = av_fetch(av, i, FALSE);
1053            
1054 12266 50       const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
    50        
    50        
1055 12266 50       const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
    50        
    100        
1056 12266 50       const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
    50        
    50        
1057            
1058 6133         EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1059 12266 100       if (details) {
1060           /* Indents of 5? Yuck. */
1061           /* We know that PerlIO_get_layers creates a new SV for
1062           the name and flags, so we can just take a reference
1063           and "steal" it when we free the AV below. */
1064 40 50       PUSHs(namok
1065           ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1066           : &PL_sv_undef);
1067 40 100       PUSHs(argok
1068           ? newSVpvn_flags(SvPVX_const(*argsvp),
1069           SvCUR(*argsvp),
1070           (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1071           | SVs_TEMP)
1072           : &PL_sv_undef);
1073 40 50       PUSHs(flgok
1074           ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1075           : &PL_sv_undef);
1076 40         nitem += 3;
1077           }
1078           else {
1079 12226 50       if (namok && argok)
    100        
1080 34         PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1081           SVfARG(*namsvp),
1082           SVfARG(*argsvp))));
1083 12192 50       else if (namok)
1084 12192         PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1085           else
1086 0         PUSHs(&PL_sv_undef);
1087 12226         nitem++;
1088 12226 50       if (flgok) {
1089 12226         const IV flags = SvIVX(*flgsvp);
1090            
1091 12226 100       if (flags & PERLIO_F_UTF8) {
1092 52         PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1093 52         nitem++;
1094           }
1095           }
1096           }
1097           }
1098            
1099 6100         SvREFCNT_dec(av);
1100            
1101 6100         XSRETURN(nitem);
1102           }
1103           }
1104           #endif
1105            
1106 3058         XSRETURN(0);
1107           }
1108            
1109            
1110 20086         XS(XS_re_is_regexp)
1111           {
1112           dVAR;
1113 20086         dXSARGS;
1114           PERL_UNUSED_VAR(cv);
1115            
1116 20086 50       if (items != 1)
1117 0         croak_xs_usage(cv, "sv");
1118            
1119 20086 100       if (SvRXOK(ST(0))) {
1120 14788         XSRETURN_YES;
1121           } else {
1122 12692         XSRETURN_NO;
1123           }
1124           }
1125            
1126 4         XS(XS_re_regnames_count)
1127           {
1128 4 50       REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1129           SV * ret;
1130           dVAR;
1131 4         dXSARGS;
1132            
1133 4 50       if (items != 0)
1134 0         croak_xs_usage(cv, "");
1135            
1136 4         SP -= items;
1137 4         PUTBACK;
1138            
1139 4 50       if (!rx)
1140 0         XSRETURN_UNDEF;
1141            
1142 4         ret = CALLREG_NAMED_BUFF_COUNT(rx);
1143            
1144 4         SPAGAIN;
1145 4 50       PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1146 4         XSRETURN(1);
1147           }
1148            
1149 4         XS(XS_re_regname)
1150           {
1151           dVAR;
1152 4         dXSARGS;
1153           REGEXP * rx;
1154           U32 flags;
1155           SV * ret;
1156            
1157 4 50       if (items < 1 || items > 2)
1158 0         croak_xs_usage(cv, "name[, all ]");
1159            
1160 4         SP -= items;
1161 4         PUTBACK;
1162            
1163 4 50       rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1164            
1165 4 50       if (!rx)
1166 0         XSRETURN_UNDEF;
1167            
1168 4 50       if (items == 2 && SvTRUE(ST(1))) {
    50        
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
1169           flags = RXapif_ALL;
1170           } else {
1171           flags = RXapif_ONE;
1172           }
1173 4         ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1174            
1175 4         SPAGAIN;
1176 4 50       PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1177 4         XSRETURN(1);
1178           }
1179            
1180            
1181 8         XS(XS_re_regnames)
1182 8 50       {
1183           dVAR;
1184 8         dXSARGS;
1185           REGEXP * rx;
1186           U32 flags;
1187           SV *ret;
1188           AV *av;
1189           SSize_t length;
1190           SSize_t i;
1191           SV **entry;
1192            
1193 8 50       if (items > 1)
1194 0         croak_xs_usage(cv, "[all]");
1195            
1196 8 50       rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1197            
1198 8 50       if (!rx)
1199 0         XSRETURN_UNDEF;
1200            
1201 8 100       if (items == 1 && SvTRUE(ST(0))) {
    50        
    50        
    0        
    50        
    0        
    0        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
1202           flags = RXapif_ALL;
1203           } else {
1204           flags = RXapif_ONE;
1205           }
1206            
1207 8         SP -= items;
1208 8         PUTBACK;
1209            
1210 8         ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1211            
1212 8         SPAGAIN;
1213            
1214 8 50       if (!ret)
1215 0         XSRETURN_UNDEF;
1216            
1217 8         av = MUTABLE_AV(SvRV(ret));
1218 8         length = av_len(av);
1219            
1220 8         EXTEND(SP, length+1); /* better extend stack just once */
1221 22 100       for (i = 0; i <= length; i++) {
1222 18         entry = av_fetch(av, i, FALSE);
1223          
1224 18 50       if (!entry)
1225 0         Perl_croak(aTHX_ "NULL array element in re::regnames()");
1226            
1227 18         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1228           }
1229            
1230 8         SvREFCNT_dec(ret);
1231            
1232 8         PUTBACK;
1233 8         return;
1234           }
1235            
1236 26         XS(XS_re_regexp_pattern)
1237 26 50       {
1238           dVAR;
1239 26         dXSARGS;
1240           REGEXP *re;
1241            
1242 13         EXTEND(SP, 2);
1243 26         SP -= items;
1244 26 50       if (items != 1)
1245 0         croak_xs_usage(cv, "sv");
1246            
1247           /*
1248           Checks if a reference is a regex or not. If the parameter is
1249           not a ref, or is not the result of a qr// then returns false
1250           in scalar context and an empty list in list context.
1251           Otherwise in list context it returns the pattern and the
1252           modifiers, in scalar context it returns the pattern just as it
1253           would if the qr// was stringified normally, regardless as
1254           to the class of the variable and any stringification overloads
1255           on the object.
1256           */
1257            
1258 26 100       if ((re = SvRX(ST(0)))) /* assign deliberate */
1259           {
1260           /* Houston, we have a regex! */
1261           SV *pattern;
1262            
1263 24 50       if ( GIMME_V == G_ARRAY ) {
    100        
1264           STRLEN left = 0;
1265           char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1266           const char *fptr;
1267           char ch;
1268           U16 match_flags;
1269            
1270           /*
1271           we are in list context so stringify
1272           the modifiers that apply. We ignore "negative
1273           modifiers" in this scenario, and the default character set
1274           */
1275            
1276 27 100       if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1277           STRLEN len;
1278 16         const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1279           &len);
1280 16         Copy(name, reflags + left, len, char);
1281           left += len;
1282           }
1283           fptr = INT_PAT_MODS;
1284 18         match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1285           >> RXf_PMf_STD_PMMOD_SHIFT);
1286            
1287 117 100       while((ch = *fptr++)) {
1288 90 100       if(match_flags & 1) {
1289 16         reflags[left++] = ch;
1290           }
1291 90         match_flags >>= 1;
1292           }
1293            
1294 45         pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1295           (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1296            
1297           /* return the pattern and the modifiers */
1298 18         PUSHs(pattern);
1299 18         PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1300 18         XSRETURN(2);
1301           } else {
1302           /* Scalar, so use the string that Perl would return */
1303           /* return the pattern in (?msix:..) format */
1304           #if PERL_VERSION >= 11
1305 6         pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1306           #else
1307           pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1308           (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1309           #endif
1310 6         PUSHs(pattern);
1311 6         XSRETURN(1);
1312           }
1313           } else {
1314           /* It ain't a regexp folks */
1315 2 50       if ( GIMME_V == G_ARRAY ) {
    50        
1316           /* return the empty list */
1317 0         XSRETURN_UNDEF;
1318           } else {
1319           /* Because of the (?:..) wrapping involved in a
1320           stringified pattern it is impossible to get a
1321           result for a real regexp that would evaluate to
1322           false. Therefore we can return PL_sv_no to signify
1323           that the object is not a regex, this means that one
1324           can say
1325            
1326           if (regex($might_be_a_regex) eq '(?:foo)') { }
1327            
1328           and not worry about undefined values.
1329           */
1330 14         XSRETURN_NO;
1331           }
1332           }
1333           /* NOT-REACHED */
1334           }
1335            
1336           struct xsub_details {
1337           const char *name;
1338           XSUBADDR_t xsub;
1339           const char *proto;
1340           };
1341            
1342           const struct xsub_details details[] = {
1343           {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1344           {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1345           {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1346           {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1347           {"version::()", XS_version_noop, NULL},
1348           {"version::new", XS_version_new, NULL},
1349           {"version::parse", XS_version_new, NULL},
1350           {"version::(\"\"", XS_version_stringify, NULL},
1351           {"version::stringify", XS_version_stringify, NULL},
1352           {"version::(0+", XS_version_numify, NULL},
1353           {"version::numify", XS_version_numify, NULL},
1354           {"version::normal", XS_version_normal, NULL},
1355           {"version::(cmp", XS_version_vcmp, NULL},
1356           {"version::(<=>", XS_version_vcmp, NULL},
1357           {"version::vcmp", XS_version_vcmp, NULL},
1358           {"version::(bool", XS_version_boolean, NULL},
1359           {"version::boolean", XS_version_boolean, NULL},
1360           {"version::(+", XS_version_noop, NULL},
1361           {"version::(-", XS_version_noop, NULL},
1362           {"version::(*", XS_version_noop, NULL},
1363           {"version::(/", XS_version_noop, NULL},
1364           {"version::(+=", XS_version_noop, NULL},
1365           {"version::(-=", XS_version_noop, NULL},
1366           {"version::(*=", XS_version_noop, NULL},
1367           {"version::(/=", XS_version_noop, NULL},
1368           {"version::(abs", XS_version_noop, NULL},
1369           {"version::(nomethod", XS_version_noop, NULL},
1370           {"version::noop", XS_version_noop, NULL},
1371           {"version::is_alpha", XS_version_is_alpha, NULL},
1372           {"version::qv", XS_version_qv, NULL},
1373           {"version::declare", XS_version_qv, NULL},
1374           {"version::is_qv", XS_version_is_qv, NULL},
1375           {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1376           {"utf8::valid", XS_utf8_valid, NULL},
1377           {"utf8::encode", XS_utf8_encode, NULL},
1378           {"utf8::decode", XS_utf8_decode, NULL},
1379           {"utf8::upgrade", XS_utf8_upgrade, NULL},
1380           {"utf8::downgrade", XS_utf8_downgrade, NULL},
1381           {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1382           {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1383           {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1384           {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1385           {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1386           {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1387           {"re::is_regexp", XS_re_is_regexp, "$"},
1388           {"re::regname", XS_re_regname, ";$$"},
1389           {"re::regnames", XS_re_regnames, ";$"},
1390           {"re::regnames_count", XS_re_regnames_count, ""},
1391           {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1392           };
1393            
1394           void
1395 24228         Perl_boot_core_UNIVERSAL(pTHX)
1396           {
1397           dVAR;
1398           static const char file[] = __FILE__;
1399           const struct xsub_details *xsub = details;
1400           const struct xsub_details *end
1401           = details + sizeof(details) / sizeof(details[0]);
1402            
1403           do {
1404 1187172         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1405 1187172 100       } while (++xsub < end);
1406            
1407           /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1408           {
1409 24228         CV * const cv =
1410 24228         newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1411 24228         Safefree(CvFILE(cv));
1412 24228         CvFILE(cv) = (char *)file;
1413 24228         CvDYNFILE_off(cv);
1414           }
1415 24323         }
1416            
1417           /*
1418           * Local variables:
1419           * c-indentation-style: bsd
1420           * c-basic-offset: 4
1421           * indent-tabs-mode: nil
1422           * End:
1423           *
1424           * ex: set ts=8 sts=4 sw=4 et:
1425           */