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