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