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