File Coverage

cpan/List-Util/ListUtil.xs
Criterion Covered Total %
statement 288 342 84.2
branch n/a
condition n/a
subroutine n/a
total 288 342 84.2


line stmt bran cond sub time code
1           /* Copyright (c) 1997-2000 Graham Barr . All rights reserved.
2           * This program is free software; you can redistribute it and/or
3           * modify it under the same terms as Perl itself.
4           */
5           #define PERL_NO_GET_CONTEXT /* we want efficiency */
6           #include
7           #include
8           #include
9            
10           #define NEED_sv_2pv_flags 1
11           #include "ppport.h"
12            
13           #if PERL_BCDVERSION >= 0x5006000
14           # include "multicall.h"
15           #endif
16            
17           #ifndef CvISXSUB
18           # define CvISXSUB(cv) CvXSUB(cv)
19           #endif
20            
21           /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
22           was not exported. Therefore platforms like win32, VMS etc have problems
23           so we redefine it here -- GMB
24           */
25           #if PERL_BCDVERSION < 0x5007000
26           /* Not in 5.6.1. */
27           # ifdef cxinc
28           # undef cxinc
29           # endif
30           # define cxinc() my_cxinc(aTHX)
31           static I32
32           my_cxinc(pTHX)
33           {
34           cxstack_max = cxstack_max * 3 / 2;
35           Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */
36           return cxstack_ix + 1;
37           }
38           #endif
39            
40           #ifndef sv_copypv
41           #define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
42           static void
43           my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
44           {
45           STRLEN len;
46           const char * const s = SvPV_const(ssv,len);
47           sv_setpvn(dsv,s,len);
48           if (SvUTF8(ssv))
49           SvUTF8_on(dsv);
50           else
51           SvUTF8_off(dsv);
52           }
53           #endif
54            
55           #ifdef SVf_IVisUV
56           # define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
57           #else
58           # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
59           #endif
60            
61           #if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
62           # define PERL_HAS_BAD_MULTICALL_REFCOUNT
63           #endif
64            
65           MODULE=List::Util PACKAGE=List::Util
66            
67           void
68           min(...)
69           PROTOTYPE: @
70           ALIAS:
71           min = 0
72           max = 1
73           CODE:
74           {
75           int index;
76           NV retval;
77           SV *retsv;
78           int magic;
79 122504         if(!items) {
80 0         XSRETURN_UNDEF;
81           }
82 122504         retsv = ST(0);
83 122504         magic = SvAMAGIC(retsv);
84 122504         if (!magic) {
85 122488         retval = slu_sv_value(retsv);
86           }
87 122646         for(index = 1 ; index < items ; index++) {
88 122646         SV *stacksv = ST(index);
89           SV *tmpsv;
90 122646         if ((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
91 38         if (SvTRUE(tmpsv) ? !ix : ix) {
92           retsv = stacksv;
93 16         magic = SvAMAGIC(retsv);
94 16         if (!magic) {
95 2         retval = slu_sv_value(retsv);
96           }
97           }
98           }
99           else {
100 122608         NV val = slu_sv_value(stacksv);
101 122608         if (magic) {
102 4         retval = slu_sv_value(retsv);
103           magic = 0;
104           }
105 122608         if(val < retval ? !ix : ix) {
106           retsv = stacksv;
107           retval = val;
108           }
109           }
110           }
111 122504         ST(0) = retsv;
112 122504         XSRETURN(1);
113           }
114            
115            
116            
117           void
118           sum(...)
119           PROTOTYPE: @
120           CODE:
121           {
122 30         dXSTARG;
123           SV *sv;
124           SV *retsv = NULL;
125           int index;
126           NV retval = 0;
127           int magic;
128 30         if(!items) {
129 2         XSRETURN_UNDEF;
130           }
131 28         sv = ST(0);
132 28         magic = SvAMAGIC(sv);
133 28         if (magic) {
134           retsv = TARG;
135 6         sv_setsv(retsv, sv);
136           }
137           else {
138 22         retval = slu_sv_value(sv);
139           }
140 40         for(index = 1 ; index < items ; index++) {
141 40         sv = ST(index);
142 40         if(!magic && SvAMAGIC(sv)){
143           magic = TRUE;
144 10         if (!retsv)
145           retsv = TARG;
146 10         sv_setnv(retsv,retval);
147           }
148 40         if (magic) {
149 18         SV* const tmpsv = amagic_call(retsv, sv, add_amg, SvAMAGIC(retsv) ? AMGf_assign : 0);
150 18         if(tmpsv) {
151 8         magic = SvAMAGIC(tmpsv);
152 8         if (!magic) {
153 0         retval = slu_sv_value(tmpsv);
154           }
155           else {
156           retsv = tmpsv;
157           }
158           }
159           else {
160           /* fall back to default */
161           magic = FALSE;
162 10         retval = SvNV(retsv) + SvNV(sv);
163           }
164           }
165           else {
166 22         retval += slu_sv_value(sv);
167           }
168           }
169 28         if (!magic) {
170 22         if (!retsv)
171           retsv = TARG;
172 22         sv_setnv(retsv,retval);
173           }
174 28         ST(0) = retsv;
175 28         XSRETURN(1);
176           }
177            
178           #define SLU_CMP_LARGER 1
179           #define SLU_CMP_SMALLER -1
180            
181           void
182           minstr(...)
183           PROTOTYPE: @
184           ALIAS:
185           minstr = SLU_CMP_LARGER
186           maxstr = SLU_CMP_SMALLER
187           CODE:
188           {
189           SV *left;
190           int index;
191 18         if(!items) {
192 0         XSRETURN_UNDEF;
193           }
194 18         left = ST(0);
195           #ifdef OPpLOCALE
196           if(MAXARG & OPpLOCALE) {
197           for(index = 1 ; index < items ; index++) {
198           SV *right = ST(index);
199           if(sv_cmp_locale(left, right) == ix)
200           left = right;
201           }
202           }
203           else {
204           #endif
205 136         for(index = 1 ; index < items ; index++) {
206 118         SV *right = ST(index);
207 118         if(sv_cmp(left, right) == ix)
208           left = right;
209           }
210           #ifdef OPpLOCALE
211           }
212           #endif
213 18         ST(0) = left;
214 18         XSRETURN(1);
215           }
216            
217            
218            
219           #ifdef dMULTICALL
220            
221           void
222           reduce(block,...)
223           SV * block
224           PROTOTYPE: &@
225           CODE:
226           {
227 62         SV *ret = sv_newmortal();
228           int index;
229           GV *agv,*bgv,*gv;
230           HV *stash;
231 62         SV **args = &PL_stack_base[ax];
232 62         CV* cv = sv_2cv(block, &stash, &gv, 0);
233            
234 56         if (cv == Nullcv) {
235 8         croak("Not a subroutine reference");
236           }
237            
238 48         if(items <= 1) {
239 2         XSRETURN_UNDEF;
240           }
241            
242 46         agv = gv_fetchpv("a", GV_ADD, SVt_PV);
243 46         bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
244 46         SAVESPTR(GvSV(agv));
245 46         SAVESPTR(GvSV(bgv));
246 46         GvSV(agv) = ret;
247 46         SvSetSV(ret, args[1]);
248            
249 46         if(!CvISXSUB(cv)) {
250           dMULTICALL;
251           I32 gimme = G_SCALAR;
252            
253 266         PUSH_MULTICALL(cv);
254 198         for(index = 2 ; index < items ; index++) {
255 162         GvSV(bgv) = args[index];
256 162         MULTICALL;
257 154         SvSetSV(ret, *PL_stack_sp);
258           }
259           #ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
260           if (CvDEPTH(multicall_cv) > 1)
261           SvREFCNT_inc_simple_void_NN(multicall_cv);
262           #endif
263 72         POP_MULTICALL;
264           }
265           else {
266 4         for(index = 2 ; index < items ; index++) {
267 4         dSP;
268 4         GvSV(bgv) = args[index];
269            
270 4         PUSHMARK(SP);
271 4         call_sv((SV*)cv, G_SCALAR);
272            
273 4         SvSetSV(ret, *PL_stack_sp);
274           }
275           }
276            
277 38         ST(0) = ret;
278 38         XSRETURN(1);
279           }
280            
281           void
282           first(block,...)
283           SV * block
284           PROTOTYPE: &@
285           CODE:
286           {
287           int index;
288           GV *gv;
289           HV *stash;
290 50         SV **args = &PL_stack_base[ax];
291 50         CV *cv = sv_2cv(block, &stash, &gv, 0);
292 46         if (cv == Nullcv) {
293 6         croak("Not a subroutine reference");
294           }
295            
296 40         if(items <= 1) {
297 2         XSRETURN_UNDEF;
298           }
299            
300 38         SAVESPTR(GvSV(PL_defgv));
301            
302 38         if(!CvISXSUB(cv)) {
303           dMULTICALL;
304           I32 gimme = G_SCALAR;
305 210         PUSH_MULTICALL(cv);
306            
307 98         for(index = 1 ; index < items ; index++) {
308 92         GvSV(PL_defgv) = args[index];
309 92         MULTICALL;
310 84         if (SvTRUEx(*PL_stack_sp)) {
311           #ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
312           if (CvDEPTH(multicall_cv) > 1)
313           SvREFCNT_inc_simple_void_NN(multicall_cv);
314           #endif
315 40         POP_MULTICALL;
316 20         ST(0) = ST(index);
317 20         XSRETURN(1);
318           }
319           }
320           #ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
321           if (CvDEPTH(multicall_cv) > 1)
322           SvREFCNT_inc_simple_void_NN(multicall_cv);
323           #endif
324 12         POP_MULTICALL;
325           }
326           else {
327 8         for(index = 1 ; index < items ; index++) {
328 10         dSP;
329 10         GvSV(PL_defgv) = args[index];
330            
331 10         PUSHMARK(SP);
332 10         call_sv((SV*)cv, G_SCALAR);
333 10         if (SvTRUEx(*PL_stack_sp)) {
334 2         ST(0) = ST(index);
335 2         XSRETURN(1);
336           }
337           }
338           }
339 8         XSRETURN_UNDEF;
340           }
341            
342           #endif
343            
344           void
345           pairfirst(block,...)
346           SV * block
347           PROTOTYPE: &@
348           PPCODE:
349           {
350           GV *agv,*bgv,*gv;
351           HV *stash;
352 8         CV *cv = sv_2cv(block, &stash, &gv, 0);
353 8         I32 ret_gimme = GIMME_V;
354           int argi = 1; // "shift" the block
355            
356 8         if(!(items % 2) && ckWARN(WARN_MISC))
357 0         warn("Odd number of elements in pairfirst");
358            
359 8         agv = gv_fetchpv("a", GV_ADD, SVt_PV);
360 8         bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
361 8         SAVESPTR(GvSV(agv));
362 8         SAVESPTR(GvSV(bgv));
363           #ifdef dMULTICALL
364 8         if(!CvISXSUB(cv)) {
365           // Since MULTICALL is about to move it
366 8         SV **stack = PL_stack_base + ax;
367            
368           dMULTICALL;
369           I32 gimme = G_SCALAR;
370            
371 48         PUSH_MULTICALL(cv);
372 56         for(; argi < items; argi += 2) {
373 24         SV *a = GvSV(agv) = stack[argi];
374 24         SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
375            
376 24         MULTICALL;
377            
378 24         if(!SvTRUEx(*PL_stack_sp))
379 20         continue;
380            
381 8         POP_MULTICALL;
382 4         if(ret_gimme == G_ARRAY) {
383 2         ST(0) = sv_mortalcopy(a);
384 2         ST(1) = sv_mortalcopy(b);
385 2         XSRETURN(2);
386           }
387           else
388 2         XSRETURN_YES;
389           }
390 8         POP_MULTICALL;
391 4         XSRETURN(0);
392           }
393           else
394           #endif
395           {
396 0         for(; argi < items; argi += 2) {
397 0         dSP;
398 0         SV *a = GvSV(agv) = ST(argi);
399 0         SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
400            
401 0         PUSHMARK(SP);
402 0         call_sv((SV*)cv, G_SCALAR);
403            
404           SPAGAIN;
405            
406 0         if(!SvTRUEx(*PL_stack_sp))
407 0         continue;
408            
409 0         if(ret_gimme == G_ARRAY) {
410 0         ST(0) = sv_mortalcopy(a);
411 0         ST(1) = sv_mortalcopy(b);
412 0         XSRETURN(2);
413           }
414           else
415 0         XSRETURN_YES;
416           }
417           }
418            
419 0         XSRETURN(0);
420           }
421            
422           void
423           pairgrep(block,...)
424           SV * block
425           PROTOTYPE: &@
426           PPCODE:
427           {
428           GV *agv,*bgv,*gv;
429           HV *stash;
430 12         CV *cv = sv_2cv(block, &stash, &gv, 0);
431 12         I32 ret_gimme = GIMME_V;
432            
433           /* This function never returns more than it consumed in arguments. So we
434           * can build the results "live", behind the arguments
435           */
436           int argi = 1; // "shift" the block
437           int reti = 0;
438            
439 12         if(!(items % 2) && ckWARN(WARN_MISC))
440 2         warn("Odd number of elements in pairgrep");
441            
442 12         agv = gv_fetchpv("a", GV_ADD, SVt_PV);
443 12         bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
444 12         SAVESPTR(GvSV(agv));
445 12         SAVESPTR(GvSV(bgv));
446           #ifdef dMULTICALL
447 12         if(!CvISXSUB(cv)) {
448           // Since MULTICALL is about to move it
449 12         SV **stack = PL_stack_base + ax;
450           int i;
451            
452           dMULTICALL;
453           I32 gimme = G_SCALAR;
454            
455 72         PUSH_MULTICALL(cv);
456 42         for(; argi < items; argi += 2) {
457 30         SV *a = GvSV(agv) = stack[argi];
458 30         SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
459            
460 30         MULTICALL;
461            
462 30         if(SvTRUEx(*PL_stack_sp)) {
463 16         if(ret_gimme == G_ARRAY) {
464           // We can't mortalise yet or they'd be mortal too early
465 8         stack[reti++] = newSVsv(a);
466 8         stack[reti++] = newSVsv(b);
467           }
468 8         else if(ret_gimme == G_SCALAR)
469 4         reti++;
470           }
471           }
472 24         POP_MULTICALL;
473            
474 12         if(ret_gimme == G_ARRAY)
475 16         for(i = 0; i < reti; i++)
476 16         sv_2mortal(stack[i]);
477           }
478           else
479           #endif
480           {
481 0         for(; argi < items; argi += 2) {
482 0         dSP;
483 0         SV *a = GvSV(agv) = ST(argi);
484 0         SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
485            
486 0         PUSHMARK(SP);
487 0         call_sv((SV*)cv, G_SCALAR);
488            
489           SPAGAIN;
490            
491 0         if(SvTRUEx(*PL_stack_sp)) {
492 0         if(ret_gimme == G_ARRAY) {
493 0         ST(reti++) = sv_mortalcopy(a);
494 0         ST(reti++) = sv_mortalcopy(b);
495           }
496 0         else if(ret_gimme == G_SCALAR)
497 0         reti++;
498           }
499           }
500           }
501            
502 12         if(ret_gimme == G_ARRAY)
503 4         XSRETURN(reti);
504 8         else if(ret_gimme == G_SCALAR) {
505 2         ST(0) = newSViv(reti);
506 2         XSRETURN(1);
507           }
508           }
509            
510           void
511           pairmap(block,...)
512           SV * block
513           PROTOTYPE: &@
514           PPCODE:
515           {
516           GV *agv,*bgv,*gv;
517           HV *stash;
518 12         CV *cv = sv_2cv(block, &stash, &gv, 0);
519           SV **args_copy = NULL;
520 12         I32 ret_gimme = GIMME_V;
521            
522           int argi = 1; // "shift" the block
523           int reti = 0;
524            
525 12         if(!(items % 2) && ckWARN(WARN_MISC))
526 0         warn("Odd number of elements in pairmap");
527            
528 12         agv = gv_fetchpv("a", GV_ADD, SVt_PV);
529 12         bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
530 12         SAVESPTR(GvSV(agv));
531 12         SAVESPTR(GvSV(bgv));
532           /* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
533           * Skip it on those versions (RT#87857)
534           */
535           #if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
536 12         if(!CvISXSUB(cv)) {
537           // Since MULTICALL is about to move it
538 12         SV **stack = PL_stack_base + ax;
539 12         I32 ret_gimme = GIMME_V;
540           int i;
541            
542           dMULTICALL;
543           I32 gimme = G_ARRAY;
544            
545 72         PUSH_MULTICALL(cv);
546 44         for(; argi < items; argi += 2) {
547 32         SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
548 64         SV *b = GvSV(bgv) = argi < items-1 ?
549 32         (args_copy ? args_copy[argi+1] : stack[argi+1]) :
550           &PL_sv_undef;
551           int count;
552            
553 32         MULTICALL;
554 32         count = PL_stack_sp - PL_stack_base;
555            
556 32         if(count > 2 && !args_copy) {
557           /* We can't return more than 2 results for a given input pair
558           * without trashing the remaining argmuents on the stack still
559           * to be processed. So, we'll copy them out to a temporary
560           * buffer and work from there instead.
561           * We didn't do this initially because in the common case, most
562           * code blocks will return only 1 or 2 items so it won't be
563           * necessary
564           */
565 4         int n_args = items - argi;
566 4         Newx(args_copy, n_args, SV *);
567 4         SAVEFREEPV(args_copy);
568            
569 4         Copy(stack + argi, args_copy, n_args, SV *);
570            
571           argi = 0;
572           items = n_args;
573           }
574            
575 96         for(i = 0; i < count; i++)
576 64         stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
577           }
578 24         POP_MULTICALL;
579            
580 12         if(ret_gimme == G_ARRAY)
581 48         for(i = 0; i < reti; i++)
582 48         sv_2mortal(stack[i]);
583           }
584           else
585           #endif
586           {
587 0         for(; argi < items; argi += 2) {
588 0         dSP;
589 0         SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
590 0         SV *b = GvSV(bgv) = argi < items-1 ?
591 0         (args_copy ? args_copy[argi+1] : ST(argi+1)) :
592           &PL_sv_undef;
593           int count;
594           int i;
595            
596 0         PUSHMARK(SP);
597 0         count = call_sv((SV*)cv, G_ARRAY);
598            
599 0         SPAGAIN;
600            
601 0         if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
602 0         int n_args = items - argi;
603 0         Newx(args_copy, n_args, SV *);
604 0         SAVEFREEPV(args_copy);
605            
606 0         Copy(&ST(argi), args_copy, n_args, SV *);
607            
608           argi = 0;
609           items = n_args;
610           }
611            
612 0         if(ret_gimme == G_ARRAY)
613 0         for(i = 0; i < count; i++)
614 0         ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
615           else
616 0         reti += count;
617            
618 0         PUTBACK;
619           }
620           }
621            
622 12         if(ret_gimme == G_ARRAY)
623 8         XSRETURN(reti);
624            
625 4         ST(0) = sv_2mortal(newSViv(reti));
626 4         XSRETURN(1);
627           }
628            
629           void
630           pairs(...)
631           PROTOTYPE: @
632           PPCODE:
633           {
634           int argi = 0;
635           int reti = 0;
636            
637 4         if(items % 2 && ckWARN(WARN_MISC))
638 0         warn("Odd number of elements in pairs");
639            
640           {
641 10         for(; argi < items; argi += 2) {
642 10         SV *a = ST(argi);
643 10         SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
644            
645 10         AV *av = newAV();
646 10         av_push(av, newSVsv(a));
647 10         av_push(av, newSVsv(b));
648            
649 10         ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
650           }
651           }
652            
653 4         XSRETURN(reti);
654           }
655            
656           void
657           pairkeys(...)
658           PROTOTYPE: @
659           PPCODE:
660           {
661           int argi = 0;
662           int reti = 0;
663            
664 2         if(items % 2 && ckWARN(WARN_MISC))
665 0         warn("Odd number of elements in pairkeys");
666            
667           {
668 4         for(; argi < items; argi += 2) {
669 4         SV *a = ST(argi);
670            
671 4         ST(reti++) = sv_2mortal(newSVsv(a));
672           }
673           }
674            
675 2         XSRETURN(reti);
676           }
677            
678           void
679           pairvalues(...)
680           PROTOTYPE: @
681           PPCODE:
682           {
683           int argi = 0;
684           int reti = 0;
685            
686 2         if(items % 2 && ckWARN(WARN_MISC))
687 0         warn("Odd number of elements in pairvalues");
688            
689           {
690 4         for(; argi < items; argi += 2) {
691 4         SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
692            
693 4         ST(reti++) = sv_2mortal(newSVsv(b));
694           }
695           }
696            
697 2         XSRETURN(reti);
698           }
699            
700           void
701           shuffle(...)
702           PROTOTYPE: @
703           CODE:
704           {
705           int index;
706           #if (PERL_VERSION < 9)
707           struct op dmy_op;
708           struct op *old_op = PL_op;
709            
710           /* We call pp_rand here so that Drand01 get initialized if rand()
711           or srand() has not already been called
712           */
713           memzero((char*)(&dmy_op), sizeof(struct op));
714           /* we let pp_rand() borrow the TARG allocated for this XS sub */
715           dmy_op.op_targ = PL_op->op_targ;
716           PL_op = &dmy_op;
717           (void)*(PL_ppaddr[OP_RAND])(aTHX);
718           PL_op = old_op;
719           #else
720           /* Initialize Drand01 if rand() or srand() has
721           not already been called
722           */
723 6         if (!PL_srand_called) {
724 2         (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
725 2         PL_srand_called = TRUE;
726           }
727           #endif
728            
729 210         for (index = items ; index > 1 ; ) {
730 198         int swap = (int)(Drand01() * (double)(index--));
731 198         SV *tmp = ST(swap);
732 198         ST(swap) = ST(index);
733 198         ST(index) = tmp;
734           }
735 6         XSRETURN(items);
736           }
737            
738            
739           MODULE=List::Util PACKAGE=Scalar::Util
740            
741           void
742           dualvar(num,str)
743           SV * num
744           SV * str
745           PROTOTYPE: $$
746           CODE:
747 576         {
748 576         dXSTARG;
749 636         (void)SvUPGRADE(TARG, SVt_PVNV);
750 576         sv_copypv(TARG,str);
751 576         if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
752 8         SvNV_set(TARG, SvNV(num));
753 8         SvNOK_on(TARG);
754           }
755           #ifdef SVf_IVisUV
756 568         else if (SvUOK(num)) {
757 2         SvUV_set(TARG, SvUV(num));
758 2         SvIOK_on(TARG);
759 2         SvIsUV_on(TARG);
760           }
761           #endif
762           else {
763 566         SvIV_set(TARG, SvIV(num));
764 566         SvIOK_on(TARG);
765           }
766 576         if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
767 0         SvTAINTED_on(TARG);
768 576         ST(0) = TARG;
769 576         XSRETURN(1);
770           }
771            
772           void
773           isdual(sv)
774           SV *sv
775           PROTOTYPE: $
776           CODE:
777 16         if (SvMAGICAL(sv))
778 0         mg_get(sv);
779 16         ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
780 16         XSRETURN(1);
781            
782           char *
783           blessed(sv)
784           SV * sv
785           PROTOTYPE: $
786           CODE:
787           {
788 75304         SvGETMAGIC(sv);
789 75302         if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) {
790 61798         XSRETURN_UNDEF;
791           }
792 13504         RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
793           }
794           OUTPUT:
795           RETVAL
796            
797           char *
798           reftype(sv)
799           SV * sv
800           PROTOTYPE: $
801           CODE:
802           {
803 29284         SvGETMAGIC(sv);
804 29282         if(!SvROK(sv)) {
805 24240         XSRETURN_UNDEF;
806           }
807 5042         RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
808           }
809           OUTPUT:
810           RETVAL
811            
812           UV
813           refaddr(sv)
814           SV * sv
815           PROTOTYPE: $
816           CODE:
817           {
818 23290         SvGETMAGIC(sv);
819 23284         if(!SvROK(sv)) {
820 6         XSRETURN_UNDEF;
821           }
822 23278         RETVAL = PTR2UV(SvRV(sv));
823           }
824           OUTPUT:
825           RETVAL
826            
827           void
828           weaken(sv)
829           SV *sv
830           PROTOTYPE: $
831           CODE:
832           #ifdef SvWEAKREF
833 90         sv_rvweaken(sv);
834           #else
835           croak("weak references are not implemented in this release of perl");
836           #endif
837            
838           void
839           isweak(sv)
840           SV *sv
841           PROTOTYPE: $
842           CODE:
843           #ifdef SvWEAKREF
844 82         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
845 82         XSRETURN(1);
846           #else
847           croak("weak references are not implemented in this release of perl");
848           #endif
849            
850           int
851           readonly(sv)
852           SV *sv
853           PROTOTYPE: $
854           CODE:
855 1164898         SvGETMAGIC(sv);
856 1163694         RETVAL = SvREADONLY(sv);
857           OUTPUT:
858           RETVAL
859            
860           int
861           tainted(sv)
862           SV *sv
863           PROTOTYPE: $
864           CODE:
865 6         SvGETMAGIC(sv);
866 4         RETVAL = SvTAINTED(sv);
867           OUTPUT:
868           RETVAL
869            
870           void
871           isvstring(sv)
872           SV *sv
873           PROTOTYPE: $
874           CODE:
875           #ifdef SvVOK
876 4         SvGETMAGIC(sv);
877 4         ST(0) = boolSV(SvVOK(sv));
878 4         XSRETURN(1);
879           #else
880           croak("vstrings are not implemented in this release of perl");
881           #endif
882            
883           int
884           looks_like_number(sv)
885           SV *sv
886           PROTOTYPE: $
887           CODE:
888           SV *tempsv;
889 112         SvGETMAGIC(sv);
890 108         if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
891           sv = tempsv;
892           }
893           #if PERL_BCDVERSION < 0x5008005
894           if (SvPOK(sv) || SvPOKp(sv)) {
895           RETVAL = looks_like_number(sv);
896           }
897           else {
898           RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
899           }
900           #else
901 108         RETVAL = looks_like_number(sv);
902           #endif
903           OUTPUT:
904           RETVAL
905            
906           void
907           set_prototype(subref, proto)
908           SV *subref
909           SV *proto
910           PROTOTYPE: &$
911           CODE:
912           {
913 2746         if (SvROK(subref)) {
914 2744         SV *sv = SvRV(subref);
915 2744         if (SvTYPE(sv) != SVt_PVCV) {
916           /* not a subroutine reference */
917 2         croak("set_prototype: not a subroutine reference");
918           }
919 2742         if (SvPOK(proto)) {
920           /* set the prototype */
921 2738         sv_copypv(sv, proto);
922           }
923           else {
924           /* delete the prototype */
925 4         SvPOK_off(sv);
926           }
927           }
928           else {
929 2         croak("set_prototype: not a reference");
930           }
931 2742         XSRETURN(1);
932           }
933            
934           void
935           openhandle(SV* sv)
936           PROTOTYPE: $
937           CODE:
938 40         {
939           IO* io = NULL;
940 40         SvGETMAGIC(sv);
941 40         if(SvROK(sv)){
942           /* deref first */
943 26         sv = SvRV(sv);
944           }
945            
946           /* must be GLOB or IO */
947 40         if(isGV(sv)){
948 32         io = GvIO((GV*)sv);
949           }
950 8         else if(SvTYPE(sv) == SVt_PVIO){
951           io = (IO*)sv;
952           }
953            
954 40         if(io){
955           /* real or tied filehandle? */
956 28         if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
957 22         XSRETURN(1);
958           }
959           }
960 18         XSRETURN_UNDEF;
961           }
962            
963           BOOT:
964           {
965 5956         HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
966 5956         GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
967           SV *rmcsv;
968           #if !defined(SvWEAKREF) || !defined(SvVOK)
969           HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
970           GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
971           AV *varav;
972           if (SvTYPE(vargv) != SVt_PVGV)
973           gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
974           varav = GvAVn(vargv);
975           #endif
976 5956         if (SvTYPE(rmcgv) != SVt_PVGV)
977 5956         gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
978 5956         rmcsv = GvSVn(rmcgv);
979           #ifndef SvWEAKREF
980           av_push(varav, newSVpv("weaken",6));
981           av_push(varav, newSVpv("isweak",6));
982           #endif
983           #ifndef SvVOK
984           av_push(varav, newSVpv("isvstring",9));
985           #endif
986           #ifdef REAL_MULTICALL
987 5956         sv_setsv(rmcsv, &PL_sv_yes);
988           #else
989           sv_setsv(rmcsv, &PL_sv_no);
990           #endif
991           }