This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
undo Scalar-List-Utils customisation.dat entries
[perl5.git] / cpan / Scalar-List-Utils / ListUtil.xs
CommitLineData
f4a2945e
JH
1/* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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 */
4daffb2b 5#define PERL_NO_GET_CONTEXT /* we want efficiency */
f4a2945e
JH
6#include <EXTERN.h>
7#include <perl.h>
8#include <XSUB.h>
f4a2945e 9
3630f57e
CBW
10#define NEED_sv_2pv_flags 1
11#include "ppport.h"
92731555 12
3630f57e 13#if PERL_BCDVERSION >= 0x5006000
82f35e8b
RH
14# include "multicall.h"
15#endif
16
e8164ee7
JH
17#if PERL_BCDVERSION < 0x5023008
18# define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
19#else
20# define UNUSED_VAR_newsp NOOP
21#endif
22
3630f57e
CBW
23#ifndef CvISXSUB
24# define CvISXSUB(cv) CvXSUB(cv)
9c3c560b 25#endif
3630f57e 26
9c3c560b
JH
27/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
28 was not exported. Therefore platforms like win32, VMS etc have problems
29 so we redefine it here -- GMB
30*/
3630f57e 31#if PERL_BCDVERSION < 0x5007000
9c3c560b 32/* Not in 5.6.1. */
9c3c560b
JH
33# ifdef cxinc
34# undef cxinc
35# endif
36# define cxinc() my_cxinc(aTHX)
37static I32
38my_cxinc(pTHX)
39{
40 cxstack_max = cxstack_max * 3 / 2;
3630f57e 41 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */
9c3c560b
JH
42 return cxstack_ix + 1;
43}
1bfb5477
GB
44#endif
45
3630f57e
CBW
46#ifndef sv_copypv
47#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
48static void
49my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
50{
51 STRLEN len;
52 const char * const s = SvPV_const(ssv,len);
53 sv_setpvn(dsv,s,len);
98eca5fa 54 if(SvUTF8(ssv))
3630f57e
CBW
55 SvUTF8_on(dsv);
56 else
57 SvUTF8_off(dsv);
58}
1bfb5477
GB
59#endif
60
60f3865b 61#ifdef SVf_IVisUV
b9ae0a2d 62# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b 63#else
aaaf1885 64# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b
GB
65#endif
66
c9612cb4
CBW
67#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
68# define PERL_HAS_BAD_MULTICALL_REFCOUNT
69#endif
70
8c167fd9
CBW
71#if PERL_VERSION < 14
72# define croak_no_modify() croak("%s", PL_no_modify)
73#endif
74
e8164ee7
JH
75#ifndef SvNV_nomg
76# define SvNV_nomg SvNV
77#endif
78
b823713c
CBW
79enum slu_accum {
80 ACC_IV,
81 ACC_NV,
82 ACC_SV,
83};
84
85static enum slu_accum accum_type(SV *sv) {
86 if(SvAMAGIC(sv))
87 return ACC_SV;
88
89 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
90 return ACC_IV;
91
92 return ACC_NV;
93}
94
d81c2d6a
CBW
95/* Magic for set_subname */
96static MGVTBL subname_vtbl;
97
98eca5fa 98MODULE=List::Util PACKAGE=List::Util
f4a2945e
JH
99
100void
101min(...)
102PROTOTYPE: @
103ALIAS:
104 min = 0
105 max = 1
106CODE:
107{
108 int index;
e8164ee7 109 NV retval = 0.0; /* avoid 'uninit var' warning */
f4a2945e 110 SV *retsv;
2ff28616 111 int magic;
98eca5fa
SH
112
113 if(!items)
114 XSRETURN_UNDEF;
115
f4a2945e 116 retsv = ST(0);
a0b61ef9 117 SvGETMAGIC(retsv);
2ff28616 118 magic = SvAMAGIC(retsv);
98eca5fa 119 if(!magic)
2ff28616 120 retval = slu_sv_value(retsv);
98eca5fa 121
f4a2945e 122 for(index = 1 ; index < items ; index++) {
98eca5fa 123 SV *stacksv = ST(index);
2ff28616 124 SV *tmpsv;
a0b61ef9 125 SvGETMAGIC(stacksv);
98eca5fa
SH
126 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
127 if(SvTRUE(tmpsv) ? !ix : ix) {
2ff28616
GB
128 retsv = stacksv;
129 magic = SvAMAGIC(retsv);
98eca5fa 130 if(!magic) {
2ff28616
GB
131 retval = slu_sv_value(retsv);
132 }
133 }
134 }
135 else {
136 NV val = slu_sv_value(stacksv);
98eca5fa 137 if(magic) {
2ff28616
GB
138 retval = slu_sv_value(retsv);
139 magic = 0;
140 }
141 if(val < retval ? !ix : ix) {
142 retsv = stacksv;
143 retval = val;
144 }
145 }
f4a2945e
JH
146 }
147 ST(0) = retsv;
148 XSRETURN(1);
149}
150
151
2ff28616 152void
f4a2945e
JH
153sum(...)
154PROTOTYPE: @
98eca5fa
SH
155ALIAS:
156 sum = 0
157 sum0 = 1
158 product = 2
f4a2945e
JH
159CODE:
160{
3630f57e 161 dXSTARG;
60f3865b 162 SV *sv;
b823713c
CBW
163 IV retiv = 0;
164 NV retnv = 0.0;
2ff28616 165 SV *retsv = NULL;
f4a2945e 166 int index;
b823713c 167 enum slu_accum accum;
98eca5fa 168 int is_product = (ix == 2);
b823713c 169 SV *tmpsv;
98eca5fa
SH
170
171 if(!items)
172 switch(ix) {
173 case 0: XSRETURN_UNDEF;
174 case 1: ST(0) = newSViv(0); XSRETURN(1);
175 case 2: ST(0) = newSViv(1); XSRETURN(1);
176 }
177
3630f57e 178 sv = ST(0);
a0b61ef9 179 SvGETMAGIC(sv);
b823713c
CBW
180 switch((accum = accum_type(sv))) {
181 case ACC_SV:
3630f57e 182 retsv = TARG;
2ff28616 183 sv_setsv(retsv, sv);
b823713c
CBW
184 break;
185 case ACC_IV:
186 retiv = SvIV(sv);
187 break;
188 case ACC_NV:
189 retnv = slu_sv_value(sv);
190 break;
2ff28616 191 }
98eca5fa 192
f4a2945e 193 for(index = 1 ; index < items ; index++) {
3630f57e 194 sv = ST(index);
a0b61ef9 195 SvGETMAGIC(sv);
b823713c 196 if(accum < ACC_SV && SvAMAGIC(sv)){
98eca5fa 197 if(!retsv)
3630f57e 198 retsv = TARG;
b823713c
CBW
199 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
200 accum = ACC_SV;
3630f57e 201 }
b823713c
CBW
202 switch(accum) {
203 case ACC_SV:
204 tmpsv = amagic_call(retsv, sv,
98eca5fa
SH
205 is_product ? mult_amg : add_amg,
206 SvAMAGIC(retsv) ? AMGf_assign : 0);
3630f57e 207 if(tmpsv) {
b823713c
CBW
208 switch((accum = accum_type(tmpsv))) {
209 case ACC_SV:
3630f57e 210 retsv = tmpsv;
b823713c
CBW
211 break;
212 case ACC_IV:
213 retiv = SvIV(tmpsv);
214 break;
215 case ACC_NV:
216 retnv = slu_sv_value(tmpsv);
217 break;
3630f57e 218 }
2ff28616 219 }
3630f57e
CBW
220 else {
221 /* fall back to default */
b823713c
CBW
222 accum = ACC_NV;
223 is_product ? (retnv = SvNV(retsv) * SvNV(sv))
224 : (retnv = SvNV(retsv) + SvNV(sv));
2ff28616 225 }
b823713c
CBW
226 break;
227 case ACC_IV:
228 if(is_product) {
e8164ee7
JH
229 /* TODO: Consider if product() should shortcircuit the moment its
230 * accumulator becomes zero
231 */
232 /* XXX testing flags before running get_magic may
233 * cause some valid tied values to fallback to the NV path
234 * - DAPM */
235 if(!SvNOK(sv) && SvIOK(sv)) {
236 IV i = SvIV(sv);
237 if (retiv == 0) /* avoid later division by zero */
238 break;
239 if (retiv < 0) {
240 if (i < 0) {
241 if (i >= IV_MAX / retiv) {
242 retiv *= i;
243 break;
244 }
245 }
246 else {
247 if (i <= IV_MIN / retiv) {
248 retiv *= i;
249 break;
250 }
251 }
252 }
253 else {
254 if (i < 0) {
255 if (i >= IV_MIN / retiv) {
256 retiv *= i;
257 break;
258 }
259 }
260 else {
261 if (i <= IV_MAX / retiv) {
262 retiv *= i;
263 break;
264 }
265 }
266 }
b823713c
CBW
267 }
268 /* else fallthrough */
269 }
270 else {
e8164ee7
JH
271 /* XXX testing flags before running get_magic may
272 * cause some valid tied values to fallback to the NV path
273 * - DAPM */
274 if(!SvNOK(sv) && SvIOK(sv)) {
275 IV i = SvIV(sv);
276 if (retiv >= 0 && i >= 0) {
277 if (retiv <= IV_MAX - i) {
278 retiv += i;
279 break;
280 }
281 /* else fallthrough */
282 }
283 else if (retiv < 0 && i < 0) {
284 if (retiv >= IV_MIN - i) {
285 retiv += i;
286 break;
287 }
288 /* else fallthrough */
289 }
290 else {
291 /* mixed signs can't overflow */
292 retiv += i;
293 break;
294 }
b823713c
CBW
295 }
296 /* else fallthrough */
297 }
298
299 /* fallthrough to NV now */
300 retnv = retiv;
301 accum = ACC_NV;
302 case ACC_NV:
303 is_product ? (retnv *= slu_sv_value(sv))
304 : (retnv += slu_sv_value(sv));
305 break;
2ff28616
GB
306 }
307 }
b823713c
CBW
308
309 if(!retsv)
310 retsv = TARG;
311
312 switch(accum) {
d81c2d6a
CBW
313 case ACC_SV: /* nothing to do */
314 break;
b823713c
CBW
315 case ACC_IV:
316 sv_setiv(retsv, retiv);
317 break;
318 case ACC_NV:
319 sv_setnv(retsv, retnv);
320 break;
f4a2945e 321 }
98eca5fa 322
2ff28616
GB
323 ST(0) = retsv;
324 XSRETURN(1);
f4a2945e 325}
f4a2945e 326
3630f57e
CBW
327#define SLU_CMP_LARGER 1
328#define SLU_CMP_SMALLER -1
f4a2945e
JH
329
330void
331minstr(...)
332PROTOTYPE: @
333ALIAS:
3630f57e
CBW
334 minstr = SLU_CMP_LARGER
335 maxstr = SLU_CMP_SMALLER
f4a2945e
JH
336CODE:
337{
338 SV *left;
339 int index;
98eca5fa
SH
340
341 if(!items)
342 XSRETURN_UNDEF;
343
f4a2945e
JH
344 left = ST(0);
345#ifdef OPpLOCALE
346 if(MAXARG & OPpLOCALE) {
98eca5fa
SH
347 for(index = 1 ; index < items ; index++) {
348 SV *right = ST(index);
349 if(sv_cmp_locale(left, right) == ix)
350 left = right;
351 }
f4a2945e
JH
352 }
353 else {
354#endif
98eca5fa
SH
355 for(index = 1 ; index < items ; index++) {
356 SV *right = ST(index);
357 if(sv_cmp(left, right) == ix)
358 left = right;
359 }
f4a2945e
JH
360#ifdef OPpLOCALE
361 }
362#endif
363 ST(0) = left;
364 XSRETURN(1);
365}
366
367
368
82f35e8b 369
f4a2945e
JH
370void
371reduce(block,...)
98eca5fa 372 SV *block
f4a2945e
JH
373PROTOTYPE: &@
374CODE:
375{
09c2a9b8 376 SV *ret = sv_newmortal();
f4a2945e 377 int index;
f4a2945e
JH
378 GV *agv,*bgv,*gv;
379 HV *stash;
9850bf21 380 SV **args = &PL_stack_base[ax];
98eca5fa 381 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 382
98eca5fa
SH
383 if(cv == Nullcv)
384 croak("Not a subroutine reference");
3630f57e 385
98eca5fa
SH
386 if(items <= 1)
387 XSRETURN_UNDEF;
3630f57e
CBW
388
389 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
390 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
f4a2945e
JH
391 SAVESPTR(GvSV(agv));
392 SAVESPTR(GvSV(bgv));
09c2a9b8 393 GvSV(agv) = ret;
46274848 394 SvSetMagicSV(ret, args[1]);
98eca5fa 395#ifdef dMULTICALL
a0b61ef9 396 assert(cv);
3630f57e
CBW
397 if(!CvISXSUB(cv)) {
398 dMULTICALL;
399 I32 gimme = G_SCALAR;
400
e8164ee7 401 UNUSED_VAR_newsp;
3630f57e
CBW
402 PUSH_MULTICALL(cv);
403 for(index = 2 ; index < items ; index++) {
404 GvSV(bgv) = args[index];
405 MULTICALL;
46274848 406 SvSetMagicSV(ret, *PL_stack_sp);
3630f57e 407 }
98eca5fa
SH
408# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
409 if(CvDEPTH(multicall_cv) > 1)
410 SvREFCNT_inc_simple_void_NN(multicall_cv);
411# endif
3630f57e 412 POP_MULTICALL;
f4a2945e 413 }
98eca5fa
SH
414 else
415#endif
416 {
3630f57e
CBW
417 for(index = 2 ; index < items ; index++) {
418 dSP;
419 GvSV(bgv) = args[index];
420
421 PUSHMARK(SP);
422 call_sv((SV*)cv, G_SCALAR);
423
46274848 424 SvSetMagicSV(ret, *PL_stack_sp);
3630f57e
CBW
425 }
426 }
427
09c2a9b8 428 ST(0) = ret;
f4a2945e
JH
429 XSRETURN(1);
430}
431
432void
433first(block,...)
98eca5fa 434 SV *block
f4a2945e
JH
435PROTOTYPE: &@
436CODE:
437{
f4a2945e 438 int index;
f4a2945e
JH
439 GV *gv;
440 HV *stash;
9850bf21 441 SV **args = &PL_stack_base[ax];
3630f57e 442 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 443
98eca5fa
SH
444 if(cv == Nullcv)
445 croak("Not a subroutine reference");
3630f57e 446
98eca5fa
SH
447 if(items <= 1)
448 XSRETURN_UNDEF;
60f3865b 449
98eca5fa
SH
450 SAVESPTR(GvSV(PL_defgv));
451#ifdef dMULTICALL
a0b61ef9 452 assert(cv);
3630f57e
CBW
453 if(!CvISXSUB(cv)) {
454 dMULTICALL;
455 I32 gimme = G_SCALAR;
e8164ee7
JH
456
457 UNUSED_VAR_newsp;
3630f57e
CBW
458 PUSH_MULTICALL(cv);
459
460 for(index = 1 ; index < items ; index++) {
e8164ee7
JH
461 SV *def_sv = GvSV(PL_defgv) = args[index];
462# ifdef SvTEMP_off
463 SvTEMP_off(def_sv);
464# endif
3630f57e 465 MULTICALL;
98eca5fa
SH
466 if(SvTRUEx(*PL_stack_sp)) {
467# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
468 if(CvDEPTH(multicall_cv) > 1)
469 SvREFCNT_inc_simple_void_NN(multicall_cv);
470# endif
3630f57e
CBW
471 POP_MULTICALL;
472 ST(0) = ST(index);
473 XSRETURN(1);
474 }
475 }
98eca5fa
SH
476# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
477 if(CvDEPTH(multicall_cv) > 1)
478 SvREFCNT_inc_simple_void_NN(multicall_cv);
479# endif
3630f57e
CBW
480 POP_MULTICALL;
481 }
98eca5fa
SH
482 else
483#endif
484 {
3630f57e
CBW
485 for(index = 1 ; index < items ; index++) {
486 dSP;
487 GvSV(PL_defgv) = args[index];
488
489 PUSHMARK(SP);
490 call_sv((SV*)cv, G_SCALAR);
98eca5fa 491 if(SvTRUEx(*PL_stack_sp)) {
3630f57e
CBW
492 ST(0) = ST(index);
493 XSRETURN(1);
494 }
495 }
f4a2945e
JH
496 }
497 XSRETURN_UNDEF;
498}
499
6a9ebaf3
SH
500
501void
52102bb4 502any(block,...)
98eca5fa 503 SV *block
52102bb4 504ALIAS:
98eca5fa
SH
505 none = 0
506 all = 1
507 any = 2
52102bb4
SH
508 notall = 3
509PROTOTYPE: &@
510PPCODE:
511{
98eca5fa
SH
512 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
513 int invert = (ix & 1); /* invert block test for all/notall */
52102bb4
SH
514 GV *gv;
515 HV *stash;
516 SV **args = &PL_stack_base[ax];
517 CV *cv = sv_2cv(block, &stash, &gv, 0);
98eca5fa
SH
518
519 if(cv == Nullcv)
520 croak("Not a subroutine reference");
52102bb4
SH
521
522 SAVESPTR(GvSV(PL_defgv));
523#ifdef dMULTICALL
a0b61ef9 524 assert(cv);
52102bb4 525 if(!CvISXSUB(cv)) {
98eca5fa
SH
526 dMULTICALL;
527 I32 gimme = G_SCALAR;
528 int index;
529
e8164ee7 530 UNUSED_VAR_newsp;
98eca5fa
SH
531 PUSH_MULTICALL(cv);
532 for(index = 1; index < items; index++) {
e8164ee7
JH
533 SV *def_sv = GvSV(PL_defgv) = args[index];
534# ifdef SvTEMP_off
535 SvTEMP_off(def_sv);
536# endif
98eca5fa
SH
537
538 MULTICALL;
539 if(SvTRUEx(*PL_stack_sp) ^ invert) {
540 POP_MULTICALL;
541 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
542 XSRETURN(1);
543 }
544 }
545 POP_MULTICALL;
52102bb4
SH
546 }
547 else
548#endif
549 {
98eca5fa
SH
550 int index;
551 for(index = 1; index < items; index++) {
552 dSP;
553 GvSV(PL_defgv) = args[index];
554
555 PUSHMARK(SP);
556 call_sv((SV*)cv, G_SCALAR);
557 if(SvTRUEx(*PL_stack_sp) ^ invert) {
558 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
559 XSRETURN(1);
560 }
561 }
52102bb4
SH
562 }
563
98eca5fa 564 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
52102bb4
SH
565 XSRETURN(1);
566}
567
568void
3d58dd24
SH
569pairs(...)
570PROTOTYPE: @
571PPCODE:
572{
573 int argi = 0;
574 int reti = 0;
575 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
576
577 if(items % 2 && ckWARN(WARN_MISC))
578 warn("Odd number of elements in pairs");
579
580 {
581 for(; argi < items; argi += 2) {
582 SV *a = ST(argi);
583 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
584
585 AV *av = newAV();
586 av_push(av, newSVsv(a));
587 av_push(av, newSVsv(b));
588
589 ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
590 sv_bless(ST(reti), pairstash);
591 reti++;
592 }
593 }
594
595 XSRETURN(reti);
596}
597
598void
599unpairs(...)
600PROTOTYPE: @
601PPCODE:
602{
603 /* Unlike pairs(), we're going to trash the input values on the stack
604 * almost as soon as we start generating output. So clone them first
605 */
606 int i;
607 SV **args_copy;
608 Newx(args_copy, items, SV *);
609 SAVEFREEPV(args_copy);
610
611 Copy(&ST(0), args_copy, items, SV *);
612
613 for(i = 0; i < items; i++) {
614 SV *pair = args_copy[i];
869a9612
SH
615 AV *pairav;
616
3d58dd24
SH
617 SvGETMAGIC(pair);
618
619 if(SvTYPE(pair) != SVt_RV)
620 croak("Not a reference at List::Util::unpack() argument %d", i);
621 if(SvTYPE(SvRV(pair)) != SVt_PVAV)
622 croak("Not an ARRAY reference at List::Util::unpack() argument %d", i);
623
e8164ee7 624 /* TODO: assert pair is an ARRAY ref */
869a9612 625 pairav = (AV *)SvRV(pair);
3d58dd24
SH
626
627 EXTEND(SP, 2);
628
629 if(AvFILL(pairav) >= 0)
630 mPUSHs(newSVsv(AvARRAY(pairav)[0]));
631 else
632 PUSHs(&PL_sv_undef);
633
634 if(AvFILL(pairav) >= 1)
635 mPUSHs(newSVsv(AvARRAY(pairav)[1]));
636 else
637 PUSHs(&PL_sv_undef);
638 }
639
640 XSRETURN(items * 2);
641}
642
643void
644pairkeys(...)
645PROTOTYPE: @
646PPCODE:
647{
648 int argi = 0;
649 int reti = 0;
650
651 if(items % 2 && ckWARN(WARN_MISC))
652 warn("Odd number of elements in pairkeys");
653
654 {
655 for(; argi < items; argi += 2) {
656 SV *a = ST(argi);
657
658 ST(reti++) = sv_2mortal(newSVsv(a));
659 }
660 }
661
662 XSRETURN(reti);
663}
664
665void
666pairvalues(...)
667PROTOTYPE: @
668PPCODE:
669{
670 int argi = 0;
671 int reti = 0;
672
673 if(items % 2 && ckWARN(WARN_MISC))
674 warn("Odd number of elements in pairvalues");
675
676 {
677 for(; argi < items; argi += 2) {
678 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
679
680 ST(reti++) = sv_2mortal(newSVsv(b));
681 }
682 }
683
684 XSRETURN(reti);
685}
686
687void
6a9ebaf3 688pairfirst(block,...)
98eca5fa 689 SV *block
6a9ebaf3
SH
690PROTOTYPE: &@
691PPCODE:
692{
693 GV *agv,*bgv,*gv;
694 HV *stash;
695 CV *cv = sv_2cv(block, &stash, &gv, 0);
696 I32 ret_gimme = GIMME_V;
e99e4210 697 int argi = 1; /* "shift" the block */
6a9ebaf3 698
cdc31f74 699 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 700 warn("Odd number of elements in pairfirst");
cdc31f74 701
6a9ebaf3
SH
702 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
703 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
704 SAVESPTR(GvSV(agv));
705 SAVESPTR(GvSV(bgv));
706#ifdef dMULTICALL
a0b61ef9 707 assert(cv);
6a9ebaf3 708 if(!CvISXSUB(cv)) {
98eca5fa
SH
709 /* Since MULTICALL is about to move it */
710 SV **stack = PL_stack_base + ax;
6a9ebaf3 711
98eca5fa
SH
712 dMULTICALL;
713 I32 gimme = G_SCALAR;
6a9ebaf3 714
e8164ee7 715 UNUSED_VAR_newsp;
98eca5fa
SH
716 PUSH_MULTICALL(cv);
717 for(; argi < items; argi += 2) {
718 SV *a = GvSV(agv) = stack[argi];
719 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
6a9ebaf3 720
98eca5fa 721 MULTICALL;
6a9ebaf3
SH
722
723 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
724 continue;
725
726 POP_MULTICALL;
727 if(ret_gimme == G_ARRAY) {
728 ST(0) = sv_mortalcopy(a);
729 ST(1) = sv_mortalcopy(b);
730 XSRETURN(2);
731 }
732 else
733 XSRETURN_YES;
734 }
735 POP_MULTICALL;
736 XSRETURN(0);
6a9ebaf3
SH
737 }
738 else
739#endif
740 {
98eca5fa
SH
741 for(; argi < items; argi += 2) {
742 dSP;
743 SV *a = GvSV(agv) = ST(argi);
744 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
6a9ebaf3 745
98eca5fa
SH
746 PUSHMARK(SP);
747 call_sv((SV*)cv, G_SCALAR);
6a9ebaf3 748
98eca5fa 749 SPAGAIN;
6a9ebaf3
SH
750
751 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
752 continue;
753
754 if(ret_gimme == G_ARRAY) {
755 ST(0) = sv_mortalcopy(a);
756 ST(1) = sv_mortalcopy(b);
757 XSRETURN(2);
758 }
759 else
760 XSRETURN_YES;
761 }
6a9ebaf3
SH
762 }
763
764 XSRETURN(0);
765}
766
2dc8d725
CBW
767void
768pairgrep(block,...)
98eca5fa 769 SV *block
2dc8d725
CBW
770PROTOTYPE: &@
771PPCODE:
772{
773 GV *agv,*bgv,*gv;
774 HV *stash;
775 CV *cv = sv_2cv(block, &stash, &gv, 0);
6a9ebaf3 776 I32 ret_gimme = GIMME_V;
2dc8d725
CBW
777
778 /* This function never returns more than it consumed in arguments. So we
779 * can build the results "live", behind the arguments
780 */
e99e4210 781 int argi = 1; /* "shift" the block */
2dc8d725
CBW
782 int reti = 0;
783
cdc31f74 784 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 785 warn("Odd number of elements in pairgrep");
cdc31f74 786
2dc8d725
CBW
787 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
788 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
789 SAVESPTR(GvSV(agv));
790 SAVESPTR(GvSV(bgv));
6a9ebaf3 791#ifdef dMULTICALL
a0b61ef9 792 assert(cv);
6a9ebaf3 793 if(!CvISXSUB(cv)) {
98eca5fa
SH
794 /* Since MULTICALL is about to move it */
795 SV **stack = PL_stack_base + ax;
796 int i;
6a9ebaf3 797
98eca5fa
SH
798 dMULTICALL;
799 I32 gimme = G_SCALAR;
6a9ebaf3 800
e8164ee7 801 UNUSED_VAR_newsp;
98eca5fa
SH
802 PUSH_MULTICALL(cv);
803 for(; argi < items; argi += 2) {
804 SV *a = GvSV(agv) = stack[argi];
805 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
2dc8d725 806
98eca5fa 807 MULTICALL;
6a9ebaf3
SH
808
809 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
810 if(ret_gimme == G_ARRAY) {
811 /* We can't mortalise yet or they'd be mortal too early */
812 stack[reti++] = newSVsv(a);
813 stack[reti++] = newSVsv(b);
814 }
815 else if(ret_gimme == G_SCALAR)
816 reti++;
817 }
818 }
819 POP_MULTICALL;
820
821 if(ret_gimme == G_ARRAY)
822 for(i = 0; i < reti; i++)
823 sv_2mortal(stack[i]);
6a9ebaf3
SH
824 }
825 else
826#endif
2dc8d725 827 {
98eca5fa
SH
828 for(; argi < items; argi += 2) {
829 dSP;
830 SV *a = GvSV(agv) = ST(argi);
831 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
2dc8d725 832
98eca5fa
SH
833 PUSHMARK(SP);
834 call_sv((SV*)cv, G_SCALAR);
2dc8d725 835
98eca5fa 836 SPAGAIN;
2dc8d725 837
6a9ebaf3 838 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
839 if(ret_gimme == G_ARRAY) {
840 ST(reti++) = sv_mortalcopy(a);
841 ST(reti++) = sv_mortalcopy(b);
842 }
843 else if(ret_gimme == G_SCALAR)
844 reti++;
845 }
846 }
2dc8d725
CBW
847 }
848
6a9ebaf3 849 if(ret_gimme == G_ARRAY)
98eca5fa 850 XSRETURN(reti);
6a9ebaf3 851 else if(ret_gimme == G_SCALAR) {
98eca5fa
SH
852 ST(0) = newSViv(reti);
853 XSRETURN(1);
2dc8d725
CBW
854 }
855}
856
857void
858pairmap(block,...)
98eca5fa 859 SV *block
2dc8d725
CBW
860PROTOTYPE: &@
861PPCODE:
862{
863 GV *agv,*bgv,*gv;
864 HV *stash;
865 CV *cv = sv_2cv(block, &stash, &gv, 0);
866 SV **args_copy = NULL;
6a9ebaf3 867 I32 ret_gimme = GIMME_V;
2dc8d725 868
e99e4210 869 int argi = 1; /* "shift" the block */
2dc8d725
CBW
870 int reti = 0;
871
cdc31f74 872 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 873 warn("Odd number of elements in pairmap");
cdc31f74 874
2dc8d725
CBW
875 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
876 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
877 SAVESPTR(GvSV(agv));
878 SAVESPTR(GvSV(bgv));
ad434879
SH
879/* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
880 * Skip it on those versions (RT#87857)
881 */
882#if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
a0b61ef9 883 assert(cv);
6a9ebaf3 884 if(!CvISXSUB(cv)) {
98eca5fa
SH
885 /* Since MULTICALL is about to move it */
886 SV **stack = PL_stack_base + ax;
887 I32 ret_gimme = GIMME_V;
888 int i;
889
890 dMULTICALL;
891 I32 gimme = G_ARRAY;
892
e8164ee7 893 UNUSED_VAR_newsp;
98eca5fa
SH
894 PUSH_MULTICALL(cv);
895 for(; argi < items; argi += 2) {
e8164ee7
JH
896 int count;
897
898 GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
899 GvSV(bgv) = argi < items-1 ?
98eca5fa
SH
900 (args_copy ? args_copy[argi+1] : stack[argi+1]) :
901 &PL_sv_undef;
98eca5fa
SH
902
903 MULTICALL;
904 count = PL_stack_sp - PL_stack_base;
905
906 if(count > 2 && !args_copy) {
907 /* We can't return more than 2 results for a given input pair
908 * without trashing the remaining argmuents on the stack still
909 * to be processed. So, we'll copy them out to a temporary
910 * buffer and work from there instead.
911 * We didn't do this initially because in the common case, most
912 * code blocks will return only 1 or 2 items so it won't be
913 * necessary
914 */
915 int n_args = items - argi;
916 Newx(args_copy, n_args, SV *);
917 SAVEFREEPV(args_copy);
918
919 Copy(stack + argi, args_copy, n_args, SV *);
920
921 argi = 0;
922 items = n_args;
923 }
924
925 for(i = 0; i < count; i++)
926 stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
927 }
928 POP_MULTICALL;
929
930 if(ret_gimme == G_ARRAY)
931 for(i = 0; i < reti; i++)
932 sv_2mortal(stack[i]);
6a9ebaf3
SH
933 }
934 else
935#endif
936 {
98eca5fa
SH
937 for(; argi < items; argi += 2) {
938 dSP;
98eca5fa
SH
939 int count;
940 int i;
941
e8164ee7
JH
942 GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
943 GvSV(bgv) = argi < items-1 ?
944 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
945 &PL_sv_undef;
946
98eca5fa
SH
947 PUSHMARK(SP);
948 count = call_sv((SV*)cv, G_ARRAY);
949
950 SPAGAIN;
951
952 if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
953 int n_args = items - argi;
954 Newx(args_copy, n_args, SV *);
955 SAVEFREEPV(args_copy);
956
957 Copy(&ST(argi), args_copy, n_args, SV *);
958
959 argi = 0;
960 items = n_args;
961 }
962
963 if(ret_gimme == G_ARRAY)
964 for(i = 0; i < count; i++)
965 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
966 else
967 reti += count;
968
969 PUTBACK;
970 }
2dc8d725
CBW
971 }
972
cdc31f74 973 if(ret_gimme == G_ARRAY)
98eca5fa 974 XSRETURN(reti);
cdc31f74
CBW
975
976 ST(0) = sv_2mortal(newSViv(reti));
977 XSRETURN(1);
2dc8d725
CBW
978}
979
1bfb5477
GB
980void
981shuffle(...)
982PROTOTYPE: @
983CODE:
984{
985 int index;
ddf53ba4 986#if (PERL_VERSION < 9)
1bfb5477
GB
987 struct op dmy_op;
988 struct op *old_op = PL_op;
1bfb5477 989
c29e891d
GB
990 /* We call pp_rand here so that Drand01 get initialized if rand()
991 or srand() has not already been called
992 */
1bfb5477 993 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
994 /* we let pp_rand() borrow the TARG allocated for this XS sub */
995 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 996 PL_op = &dmy_op;
20d72259 997 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 998 PL_op = old_op;
82f35e8b
RH
999#else
1000 /* Initialize Drand01 if rand() or srand() has
1001 not already been called
1002 */
98eca5fa 1003 if(!PL_srand_called) {
82f35e8b
RH
1004 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
1005 PL_srand_called = TRUE;
1006 }
1007#endif
1008
1bfb5477 1009 for (index = items ; index > 1 ; ) {
98eca5fa
SH
1010 int swap = (int)(Drand01() * (double)(index--));
1011 SV *tmp = ST(swap);
1012 ST(swap) = ST(index);
1013 ST(index) = tmp;
1bfb5477 1014 }
98eca5fa 1015
1bfb5477
GB
1016 XSRETURN(items);
1017}
1018
1019
e8164ee7
JH
1020void
1021uniq(...)
1022PROTOTYPE: @
1023ALIAS:
1024 uniqnum = 0
1025 uniqstr = 1
1026 uniq = 2
1027CODE:
1028{
1029 int retcount = 0;
1030 int index;
1031 SV **args = &PL_stack_base[ax];
1032 HV *seen;
1033
1034 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
1035 /* Optimise for the case of the empty list or a defined nonmagic
1036 * singleton. Leave a singleton magical||undef for the regular case */
1037 retcount = items;
1038 goto finish;
1039 }
1040
1041 sv_2mortal((SV *)(seen = newHV()));
1042
1043 if(ix == 0) {
1044 /* uniqnum */
1045 /* A temporary buffer for number stringification */
1046 SV *keysv = sv_newmortal();
1047
1048 for(index = 0 ; index < items ; index++) {
1049 SV *arg = args[index];
9d293ddb
AC
1050#ifdef HV_FETCH_EMPTY_HE
1051 HE* he;
1052#endif
e8164ee7
JH
1053
1054 if(SvGAMAGIC(arg))
1055 /* clone the value so we don't invoke magic again */
1056 arg = sv_mortalcopy(arg);
1057
1058 if(SvUOK(arg))
1059 sv_setpvf(keysv, "%"UVuf, SvUV(arg));
1060 else if(SvIOK(arg))
1061 sv_setpvf(keysv, "%"IVdf, SvIV(arg));
1062 else
1063 sv_setpvf(keysv, "%"NVgf, SvNV(arg));
1064#ifdef HV_FETCH_EMPTY_HE
9d293ddb 1065 he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
e8164ee7
JH
1066 if (HeVAL(he))
1067 continue;
1068
1069 HeVAL(he) = &PL_sv_undef;
1070#else
1071 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
1072 continue;
1073
1074 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_undef, 0);
1075#endif
1076
1077 if(GIMME_V == G_ARRAY)
1078 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
1079 retcount++;
1080 }
1081 }
1082 else {
1083 /* uniqstr or uniq */
1084 int seen_undef = 0;
1085
1086 for(index = 0 ; index < items ; index++) {
1087 SV *arg = args[index];
9d293ddb
AC
1088#ifdef HV_FETCH_EMPTY_HE
1089 HE *he;
1090#endif
e8164ee7
JH
1091
1092 if(SvGAMAGIC(arg))
1093 /* clone the value so we don't invoke magic again */
1094 arg = sv_mortalcopy(arg);
1095
1096 if(ix == 2 && !SvOK(arg)) {
1097 /* special handling of undef for uniq() */
1098 if(seen_undef)
1099 continue;
1100
1101 seen_undef++;
1102
1103 if(GIMME_V == G_ARRAY)
1104 ST(retcount) = arg;
1105 retcount++;
1106 continue;
1107 }
1108#ifdef HV_FETCH_EMPTY_HE
9d293ddb 1109 he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
e8164ee7
JH
1110 if (HeVAL(he))
1111 continue;
1112
1113 HeVAL(he) = &PL_sv_undef;
1114#else
1115 if (hv_exists_ent(seen, arg, 0))
1116 continue;
1117
1118 hv_store_ent(seen, arg, &PL_sv_undef, 0);
1119#endif
1120
1121 if(GIMME_V == G_ARRAY)
1122 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
1123 retcount++;
1124 }
1125 }
1126
1127 finish:
1128 if(GIMME_V == G_ARRAY)
1129 XSRETURN(retcount);
1130 else
1131 ST(0) = sv_2mortal(newSViv(retcount));
1132}
1133
98eca5fa 1134MODULE=List::Util PACKAGE=Scalar::Util
f4a2945e
JH
1135
1136void
1137dualvar(num,str)
98eca5fa
SH
1138 SV *num
1139 SV *str
f4a2945e
JH
1140PROTOTYPE: $$
1141CODE:
1142{
3630f57e 1143 dXSTARG;
98eca5fa 1144
3630f57e 1145 (void)SvUPGRADE(TARG, SVt_PVNV);
98eca5fa 1146
3630f57e 1147 sv_copypv(TARG,str);
98eca5fa 1148
1bfb5477 1149 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
98eca5fa
SH
1150 SvNV_set(TARG, SvNV(num));
1151 SvNOK_on(TARG);
f4a2945e 1152 }
1bfb5477 1153#ifdef SVf_IVisUV
98eca5fa
SH
1154 else if(SvUOK(num)) {
1155 SvUV_set(TARG, SvUV(num));
1156 SvIOK_on(TARG);
1157 SvIsUV_on(TARG);
1bfb5477
GB
1158 }
1159#endif
f4a2945e 1160 else {
98eca5fa
SH
1161 SvIV_set(TARG, SvIV(num));
1162 SvIOK_on(TARG);
f4a2945e 1163 }
98eca5fa 1164
f4a2945e 1165 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
98eca5fa
SH
1166 SvTAINTED_on(TARG);
1167
1168 ST(0) = TARG;
f4a2945e
JH
1169 XSRETURN(1);
1170}
1171
8b198969
CBW
1172void
1173isdual(sv)
98eca5fa 1174 SV *sv
8b198969
CBW
1175PROTOTYPE: $
1176CODE:
98eca5fa
SH
1177 if(SvMAGICAL(sv))
1178 mg_get(sv);
1179
8b198969
CBW
1180 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
1181 XSRETURN(1);
1182
f4a2945e
JH
1183char *
1184blessed(sv)
98eca5fa 1185 SV *sv
f4a2945e
JH
1186PROTOTYPE: $
1187CODE:
1188{
3630f57e 1189 SvGETMAGIC(sv);
98eca5fa
SH
1190
1191 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
1192 XSRETURN_UNDEF;
1193
4a61a419 1194 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
1195}
1196OUTPUT:
1197 RETVAL
1198
1199char *
1200reftype(sv)
98eca5fa 1201 SV *sv
f4a2945e
JH
1202PROTOTYPE: $
1203CODE:
1204{
3630f57e 1205 SvGETMAGIC(sv);
98eca5fa
SH
1206 if(!SvROK(sv))
1207 XSRETURN_UNDEF;
1208
4a61a419 1209 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
1210}
1211OUTPUT:
1212 RETVAL
1213
bd1e762a 1214UV
60f3865b 1215refaddr(sv)
98eca5fa 1216 SV *sv
60f3865b
GB
1217PROTOTYPE: $
1218CODE:
1219{
3630f57e 1220 SvGETMAGIC(sv);
98eca5fa
SH
1221 if(!SvROK(sv))
1222 XSRETURN_UNDEF;
1223
bd1e762a 1224 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
1225}
1226OUTPUT:
1227 RETVAL
1228
f4a2945e
JH
1229void
1230weaken(sv)
98eca5fa 1231 SV *sv
f4a2945e
JH
1232PROTOTYPE: $
1233CODE:
1234#ifdef SvWEAKREF
98eca5fa 1235 sv_rvweaken(sv);
f4a2945e 1236#else
98eca5fa 1237 croak("weak references are not implemented in this release of perl");
8c167fd9
CBW
1238#endif
1239
1240void
1241unweaken(sv)
1242 SV *sv
1243PROTOTYPE: $
1244INIT:
1245 SV *tsv;
1246CODE:
1247#ifdef SvWEAKREF
1248 /* This code stolen from core's sv_rvweaken() and modified */
1249 if (!SvOK(sv))
1250 return;
1251 if (!SvROK(sv))
1252 croak("Can't unweaken a nonreference");
1253 else if (!SvWEAKREF(sv)) {
6fbeaf2c
SH
1254 if(ckWARN(WARN_MISC))
1255 warn("Reference is not weak");
8c167fd9
CBW
1256 return;
1257 }
1258 else if (SvREADONLY(sv)) croak_no_modify();
1259
1260 tsv = SvRV(sv);
1261#if PERL_VERSION >= 14
1262 SvWEAKREF_off(sv); SvROK_on(sv);
1263 SvREFCNT_inc_NN(tsv);
1264 Perl_sv_del_backref(aTHX_ tsv, sv);
1265#else
1266 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
1267 * then set a new strong one
1268 */
568d025d 1269 sv_setsv(sv, &PL_sv_undef);
8c167fd9
CBW
1270 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
1271 SvROK_on(sv);
1272#endif
1273#else
1274 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
1275#endif
1276
c6c619a9 1277void
f4a2945e 1278isweak(sv)
98eca5fa 1279 SV *sv
f4a2945e
JH
1280PROTOTYPE: $
1281CODE:
1282#ifdef SvWEAKREF
98eca5fa
SH
1283 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1284 XSRETURN(1);
f4a2945e 1285#else
98eca5fa 1286 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
1287#endif
1288
1289int
1290readonly(sv)
98eca5fa 1291 SV *sv
f4a2945e
JH
1292PROTOTYPE: $
1293CODE:
98eca5fa
SH
1294 SvGETMAGIC(sv);
1295 RETVAL = SvREADONLY(sv);
f4a2945e 1296OUTPUT:
98eca5fa 1297 RETVAL
f4a2945e
JH
1298
1299int
1300tainted(sv)
98eca5fa 1301 SV *sv
f4a2945e
JH
1302PROTOTYPE: $
1303CODE:
98eca5fa
SH
1304 SvGETMAGIC(sv);
1305 RETVAL = SvTAINTED(sv);
f4a2945e 1306OUTPUT:
98eca5fa 1307 RETVAL
f4a2945e 1308
60f3865b
GB
1309void
1310isvstring(sv)
98eca5fa 1311 SV *sv
60f3865b
GB
1312PROTOTYPE: $
1313CODE:
1314#ifdef SvVOK
98eca5fa
SH
1315 SvGETMAGIC(sv);
1316 ST(0) = boolSV(SvVOK(sv));
1317 XSRETURN(1);
60f3865b 1318#else
98eca5fa 1319 croak("vstrings are not implemented in this release of perl");
60f3865b
GB
1320#endif
1321
d81c2d6a 1322SV *
9e7deb6c 1323looks_like_number(sv)
98eca5fa 1324 SV *sv
9e7deb6c
GB
1325PROTOTYPE: $
1326CODE:
98eca5fa
SH
1327 SV *tempsv;
1328 SvGETMAGIC(sv);
1329 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1330 sv = tempsv;
1331 }
3630f57e 1332#if PERL_BCDVERSION < 0x5008005
98eca5fa 1333 if(SvPOK(sv) || SvPOKp(sv)) {
d81c2d6a 1334 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
98eca5fa
SH
1335 }
1336 else {
d81c2d6a 1337 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
98eca5fa 1338 }
4984adac 1339#else
d81c2d6a 1340 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
4984adac 1341#endif
9e7deb6c 1342OUTPUT:
98eca5fa 1343 RETVAL
9e7deb6c 1344
c5661c80 1345void
98eca5fa 1346openhandle(SV *sv)
3630f57e
CBW
1347PROTOTYPE: $
1348CODE:
1349{
98eca5fa 1350 IO *io = NULL;
3630f57e
CBW
1351 SvGETMAGIC(sv);
1352 if(SvROK(sv)){
1353 /* deref first */
1354 sv = SvRV(sv);
1355 }
1356
1357 /* must be GLOB or IO */
1358 if(isGV(sv)){
1359 io = GvIO((GV*)sv);
1360 }
1361 else if(SvTYPE(sv) == SVt_PVIO){
1362 io = (IO*)sv;
1363 }
1364
1365 if(io){
1366 /* real or tied filehandle? */
1367 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1368 XSRETURN(1);
1369 }
1370 }
1371 XSRETURN_UNDEF;
1372}
1373
d81c2d6a
CBW
1374MODULE=List::Util PACKAGE=Sub::Util
1375
1376void
1377set_prototype(proto, code)
1378 SV *proto
1379 SV *code
1380PREINIT:
1381 SV *cv; /* not CV * */
1382PPCODE:
1383 SvGETMAGIC(code);
1384 if(!SvROK(code))
1385 croak("set_prototype: not a reference");
1386
1387 cv = SvRV(code);
1388 if(SvTYPE(cv) != SVt_PVCV)
1389 croak("set_prototype: not a subroutine reference");
1390
1391 if(SvPOK(proto)) {
1392 /* set the prototype */
1393 sv_copypv(cv, proto);
1394 }
1395 else {
1396 /* delete the prototype */
1397 SvPOK_off(cv);
1398 }
1399
1400 PUSHs(code);
1401 XSRETURN(1);
1402
1403void
1404set_subname(name, sub)
1405 char *name
1406 SV *sub
1407PREINIT:
1408 CV *cv = NULL;
1409 GV *gv;
1410 HV *stash = CopSTASH(PL_curcop);
1411 char *s, *end = NULL;
1412 MAGIC *mg;
1413PPCODE:
1414 if (!SvROK(sub) && SvGMAGICAL(sub))
1415 mg_get(sub);
1416 if (SvROK(sub))
1417 cv = (CV *) SvRV(sub);
1418 else if (SvTYPE(sub) == SVt_PVGV)
1419 cv = GvCVu(sub);
1420 else if (!SvOK(sub))
1421 croak(PL_no_usym, "a subroutine");
1422 else if (PL_op->op_private & HINT_STRICT_REFS)
1423 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
1424 SvPV_nolen(sub), "a subroutine");
1425 else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
1426 cv = GvCVu(gv);
1427 if (!cv)
1428 croak("Undefined subroutine %s", SvPV_nolen(sub));
1429 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
1430 croak("Not a subroutine reference");
1431 for (s = name; *s++; ) {
1432 if (*s == ':' && s[-1] == ':')
1433 end = ++s;
1434 else if (*s && s[-1] == '\'')
1435 end = s;
1436 }
1437 s--;
1438 if (end) {
1439 char *namepv = savepvn(name, end - name);
1440 stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
1441 Safefree(namepv);
1442 name = end;
1443 }
1444
1445 /* under debugger, provide information about sub location */
1446 if (PL_DBsub && CvGV(cv)) {
1447 HV *hv = GvHV(PL_DBsub);
1448
46274848 1449 char *new_pkg = HvNAME(stash);
d81c2d6a 1450
46274848
SH
1451 char *old_name = GvNAME( CvGV(cv) );
1452 char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
d81c2d6a
CBW
1453
1454 int old_len = strlen(old_name) + strlen(old_pkg);
1455 int new_len = strlen(name) + strlen(new_pkg);
1456
46274848
SH
1457 SV **old_data;
1458 char *full_name;
1459
d81c2d6a
CBW
1460 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
1461
1462 strcat(full_name, old_pkg);
1463 strcat(full_name, "::");
1464 strcat(full_name, old_name);
1465
ca81d151 1466 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
d81c2d6a
CBW
1467
1468 if (old_data) {
1469 strcpy(full_name, new_pkg);
1470 strcat(full_name, "::");
1471 strcat(full_name, name);
1472
1473 SvREFCNT_inc(*old_data);
1474 if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
1475 SvREFCNT_dec(*old_data);
1476 }
1477 Safefree(full_name);
1478 }
1479
1480 gv = (GV *) newSV(0);
1481 gv_init(gv, stash, name, s - name, TRUE);
1482
1483 /*
1484 * set_subname needs to create a GV to store the name. The CvGV field of a
1485 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
1486 * it destroys the containing CV. We use a MAGIC with an empty vtable
1487 * simply for the side-effect of using MGf_REFCOUNTED to store the
1488 * actually-counted reference to the GV.
1489 */
1490 mg = SvMAGIC(cv);
1491 while (mg && mg->mg_virtual != &subname_vtbl)
1492 mg = mg->mg_moremagic;
1493 if (!mg) {
1494 Newxz(mg, 1, MAGIC);
1495 mg->mg_moremagic = SvMAGIC(cv);
1496 mg->mg_type = PERL_MAGIC_ext;
1497 mg->mg_virtual = &subname_vtbl;
1498 SvMAGIC_set(cv, mg);
1499 }
1500 if (mg->mg_flags & MGf_REFCOUNTED)
1501 SvREFCNT_dec(mg->mg_obj);
1502 mg->mg_flags |= MGf_REFCOUNTED;
1503 mg->mg_obj = (SV *) gv;
1504 SvRMAGICAL_on(cv);
1505 CvANON_off(cv);
1506#ifndef CvGV_set
1507 CvGV(cv) = gv;
1508#else
1509 CvGV_set(cv, gv);
1510#endif
1511 PUSHs(sub);
1512
1513void
1514subname(code)
1515 SV *code
1516PREINIT:
1517 CV *cv;
1518 GV *gv;
1519PPCODE:
1520 if (!SvROK(code) && SvGMAGICAL(code))
1521 mg_get(code);
1522
1523 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
1524 croak("Not a subroutine reference");
1525
1526 if(!(gv = CvGV(cv)))
1527 XSRETURN(0);
1528
1529 mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)));
1530 XSRETURN(1);
1531
f4a2945e
JH
1532BOOT:
1533{
9850bf21
RH
1534 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
1535 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
1536 SV *rmcsv;
60f3865b 1537#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
1538 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
1539 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e 1540 AV *varav;
98eca5fa
SH
1541 if(SvTYPE(vargv) != SVt_PVGV)
1542 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 1543 varav = GvAVn(vargv);
60f3865b 1544#endif
98eca5fa
SH
1545 if(SvTYPE(rmcgv) != SVt_PVGV)
1546 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 1547 rmcsv = GvSVn(rmcgv);
60f3865b 1548#ifndef SvWEAKREF
f4a2945e
JH
1549 av_push(varav, newSVpv("weaken",6));
1550 av_push(varav, newSVpv("isweak",6));
1551#endif
60f3865b
GB
1552#ifndef SvVOK
1553 av_push(varav, newSVpv("isvstring",9));
1554#endif
9850bf21
RH
1555#ifdef REAL_MULTICALL
1556 sv_setsv(rmcsv, &PL_sv_yes);
1557#else
1558 sv_setsv(rmcsv, &PL_sv_no);
1559#endif
f4a2945e 1560}