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