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 | ||
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) | |
37 | static I32 | |
38 | my_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) | |
48 | static void | |
49 | my_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 |
79 | enum slu_accum { |
80 | ACC_IV, | |
81 | ACC_NV, | |
82 | ACC_SV, | |
83 | }; | |
84 | ||
85 | static 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 */ |
96 | static MGVTBL subname_vtbl; | |
97 | ||
98eca5fa | 98 | MODULE=List::Util PACKAGE=List::Util |
f4a2945e JH |
99 | |
100 | void | |
101 | min(...) | |
102 | PROTOTYPE: @ | |
103 | ALIAS: | |
104 | min = 0 | |
105 | max = 1 | |
106 | CODE: | |
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 | 150 | void |
f4a2945e JH |
151 | sum(...) |
152 | PROTOTYPE: @ | |
98eca5fa SH |
153 | ALIAS: |
154 | sum = 0 | |
155 | sum0 = 1 | |
156 | product = 2 | |
f4a2945e JH |
157 | CODE: |
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 | |
326 | void | |
327 | minstr(...) | |
328 | PROTOTYPE: @ | |
329 | ALIAS: | |
3630f57e CBW |
330 | minstr = SLU_CMP_LARGER |
331 | maxstr = SLU_CMP_SMALLER | |
f4a2945e JH |
332 | CODE: |
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 |
366 | void |
367 | reduce(block,...) | |
98eca5fa | 368 | SV *block |
f4a2945e JH |
369 | PROTOTYPE: &@ |
370 | CODE: | |
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 | ||
427 | void | |
428 | first(block,...) | |
98eca5fa | 429 | SV *block |
f4a2945e JH |
430 | PROTOTYPE: &@ |
431 | CODE: | |
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 | |
495 | void | |
52102bb4 | 496 | any(block,...) |
98eca5fa | 497 | SV *block |
52102bb4 | 498 | ALIAS: |
98eca5fa SH |
499 | none = 0 |
500 | all = 1 | |
501 | any = 2 | |
52102bb4 SH |
502 | notall = 3 |
503 | PROTOTYPE: &@ | |
504 | PPCODE: | |
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 | ||
561 | void | |
3d58dd24 SH |
562 | pairs(...) |
563 | PROTOTYPE: @ | |
564 | PPCODE: | |
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 | ||
591 | void | |
592 | unpairs(...) | |
593 | PROTOTYPE: @ | |
594 | PPCODE: | |
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 | ||
636 | void | |
637 | pairkeys(...) | |
638 | PROTOTYPE: @ | |
639 | PPCODE: | |
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 | ||
658 | void | |
659 | pairvalues(...) | |
660 | PROTOTYPE: @ | |
661 | PPCODE: | |
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 | ||
680 | void | |
6a9ebaf3 | 681 | pairfirst(block,...) |
98eca5fa | 682 | SV *block |
6a9ebaf3 SH |
683 | PROTOTYPE: &@ |
684 | PPCODE: | |
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 |
759 | void |
760 | pairgrep(block,...) | |
98eca5fa | 761 | SV *block |
2dc8d725 CBW |
762 | PROTOTYPE: &@ |
763 | PPCODE: | |
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 | ||
848 | void | |
849 | pairmap(block,...) | |
98eca5fa | 850 | SV *block |
2dc8d725 CBW |
851 | PROTOTYPE: &@ |
852 | PPCODE: | |
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 |
970 | void |
971 | shuffle(...) | |
972 | PROTOTYPE: @ | |
973 | CODE: | |
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 |
1010 | void |
1011 | uniq(...) | |
1012 | PROTOTYPE: @ | |
1013 | ALIAS: | |
1014 | uniqnum = 0 | |
1015 | uniqstr = 1 | |
1016 | uniq = 2 | |
1017 | CODE: | |
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 | 1118 | MODULE=List::Util PACKAGE=Scalar::Util |
f4a2945e JH |
1119 | |
1120 | void | |
1121 | dualvar(num,str) | |
98eca5fa SH |
1122 | SV *num |
1123 | SV *str | |
f4a2945e JH |
1124 | PROTOTYPE: $$ |
1125 | CODE: | |
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 |
1156 | void |
1157 | isdual(sv) | |
98eca5fa | 1158 | SV *sv |
8b198969 CBW |
1159 | PROTOTYPE: $ |
1160 | CODE: | |
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 |
1167 | char * |
1168 | blessed(sv) | |
98eca5fa | 1169 | SV *sv |
f4a2945e JH |
1170 | PROTOTYPE: $ |
1171 | CODE: | |
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 | } |
1180 | OUTPUT: | |
1181 | RETVAL | |
1182 | ||
1183 | char * | |
1184 | reftype(sv) | |
98eca5fa | 1185 | SV *sv |
f4a2945e JH |
1186 | PROTOTYPE: $ |
1187 | CODE: | |
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 | } |
1195 | OUTPUT: | |
1196 | RETVAL | |
1197 | ||
bd1e762a | 1198 | UV |
60f3865b | 1199 | refaddr(sv) |
98eca5fa | 1200 | SV *sv |
60f3865b GB |
1201 | PROTOTYPE: $ |
1202 | CODE: | |
1203 | { | |
3630f57e | 1204 | SvGETMAGIC(sv); |
98eca5fa SH |
1205 | if(!SvROK(sv)) |
1206 | XSRETURN_UNDEF; | |
1207 | ||
bd1e762a | 1208 | RETVAL = PTR2UV(SvRV(sv)); |
60f3865b GB |
1209 | } |
1210 | OUTPUT: | |
1211 | RETVAL | |
1212 | ||
f4a2945e JH |
1213 | void |
1214 | weaken(sv) | |
98eca5fa | 1215 | SV *sv |
f4a2945e JH |
1216 | PROTOTYPE: $ |
1217 | CODE: | |
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 | ||
1224 | void | |
1225 | unweaken(sv) | |
1226 | SV *sv | |
1227 | PROTOTYPE: $ | |
1228 | INIT: | |
1229 | SV *tsv; | |
1230 | CODE: | |
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 | 1261 | void |
f4a2945e | 1262 | isweak(sv) |
98eca5fa | 1263 | SV *sv |
f4a2945e JH |
1264 | PROTOTYPE: $ |
1265 | CODE: | |
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 | ||
1273 | int | |
1274 | readonly(sv) | |
98eca5fa | 1275 | SV *sv |
f4a2945e JH |
1276 | PROTOTYPE: $ |
1277 | CODE: | |
98eca5fa SH |
1278 | SvGETMAGIC(sv); |
1279 | RETVAL = SvREADONLY(sv); | |
f4a2945e | 1280 | OUTPUT: |
98eca5fa | 1281 | RETVAL |
f4a2945e JH |
1282 | |
1283 | int | |
1284 | tainted(sv) | |
98eca5fa | 1285 | SV *sv |
f4a2945e JH |
1286 | PROTOTYPE: $ |
1287 | CODE: | |
98eca5fa SH |
1288 | SvGETMAGIC(sv); |
1289 | RETVAL = SvTAINTED(sv); | |
f4a2945e | 1290 | OUTPUT: |
98eca5fa | 1291 | RETVAL |
f4a2945e | 1292 | |
60f3865b GB |
1293 | void |
1294 | isvstring(sv) | |
98eca5fa | 1295 | SV *sv |
60f3865b GB |
1296 | PROTOTYPE: $ |
1297 | CODE: | |
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 | 1306 | SV * |
9e7deb6c | 1307 | looks_like_number(sv) |
98eca5fa | 1308 | SV *sv |
9e7deb6c GB |
1309 | PROTOTYPE: $ |
1310 | CODE: | |
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 | 1326 | OUTPUT: |
98eca5fa | 1327 | RETVAL |
9e7deb6c | 1328 | |
c5661c80 | 1329 | void |
98eca5fa | 1330 | openhandle(SV *sv) |
3630f57e CBW |
1331 | PROTOTYPE: $ |
1332 | CODE: | |
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 |
1358 | MODULE=List::Util PACKAGE=Sub::Util |
1359 | ||
1360 | void | |
1361 | set_prototype(proto, code) | |
1362 | SV *proto | |
1363 | SV *code | |
1364 | PREINIT: | |
1365 | SV *cv; /* not CV * */ | |
1366 | PPCODE: | |
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 | ||
1387 | void | |
1388 | set_subname(name, sub) | |
1389 | char *name | |
1390 | SV *sub | |
1391 | PREINIT: | |
1392 | CV *cv = NULL; | |
1393 | GV *gv; | |
1394 | HV *stash = CopSTASH(PL_curcop); | |
1395 | char *s, *end = NULL; | |
1396 | MAGIC *mg; | |
1397 | PPCODE: | |
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 | ||
1497 | void | |
1498 | subname(code) | |
1499 | SV *code | |
1500 | PREINIT: | |
1501 | CV *cv; | |
1502 | GV *gv; | |
1503 | PPCODE: | |
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 |
1516 | BOOT: |
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 | } |