This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable should not assume that sizeof(mg_len) is 4.
[perl5.git] / cpan / List-Util / ListUtil.xs
CommitLineData
f4a2945e
JH
1/* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
2 * This program is free software; you can redistribute it and/or
3 * modify it under the same terms as Perl itself.
4 */
4daffb2b 5#define PERL_NO_GET_CONTEXT /* we want efficiency */
f4a2945e
JH
6#include <EXTERN.h>
7#include <perl.h>
8#include <XSUB.h>
f4a2945e 9
3630f57e
CBW
10#define NEED_sv_2pv_flags 1
11#include "ppport.h"
92731555 12
3630f57e 13#if PERL_BCDVERSION >= 0x5006000
82f35e8b
RH
14# include "multicall.h"
15#endif
16
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)
31static I32
32my_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)
42static void
43my_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
65MODULE=List::Util PACKAGE=List::Util
66
67void
68min(...)
69PROTOTYPE: @
70ALIAS:
71 min = 0
72 max = 1
73CODE:
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 117void
f4a2945e
JH
118sum(...)
119PROTOTYPE: @
120CODE:
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
181void
182minstr(...)
183PROTOTYPE: @
184ALIAS:
3630f57e
CBW
185 minstr = SLU_CMP_LARGER
186 maxstr = SLU_CMP_SMALLER
f4a2945e
JH
187CODE:
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
221void
222reduce(block,...)
223 SV * block
224PROTOTYPE: &@
225CODE:
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
281void
282first(block,...)
283 SV * block
284PROTOTYPE: &@
285CODE:
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
2dc8d725
CBW
342void
343pairgrep(block,...)
344 SV * block
345PROTOTYPE: &@
346PPCODE:
347{
348 GV *agv,*bgv,*gv;
349 HV *stash;
350 CV *cv = sv_2cv(block, &stash, &gv, 0);
351
352 /* This function never returns more than it consumed in arguments. So we
353 * can build the results "live", behind the arguments
354 */
355 int argi = 1; // "shift" the block
356 int reti = 0;
357
358 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
359 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
360 SAVESPTR(GvSV(agv));
361 SAVESPTR(GvSV(bgv));
362
363 {
364 for(; argi < items; argi += 2) {
365 dSP;
366 SV *a = GvSV(agv) = ST(argi);
367 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
368
369 PUSHMARK(SP);
370 call_sv((SV*)cv, G_SCALAR);
371
372 SPAGAIN;
373
374 if (SvTRUEx(*PL_stack_sp)) {
375 if(GIMME_V == G_ARRAY) {
376 ST(reti++) = sv_mortalcopy(a);
377 ST(reti++) = sv_mortalcopy(b);
378 }
379 else if(GIMME_V == G_SCALAR)
380 reti++;
381 }
382 }
383 }
384
385 if(GIMME_V == G_ARRAY)
386 XSRETURN(reti);
387 else if(GIMME_V == G_SCALAR) {
388 ST(0) = newSViv(reti);
389 XSRETURN(1);
390 }
391}
392
393void
394pairmap(block,...)
395 SV * block
396PROTOTYPE: &@
397PPCODE:
398{
399 GV *agv,*bgv,*gv;
400 HV *stash;
401 CV *cv = sv_2cv(block, &stash, &gv, 0);
402 SV **args_copy = NULL;
403
404 int argi = 1; // "shift" the block
405 int reti = 0;
406
407 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
408 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
409 SAVESPTR(GvSV(agv));
410 SAVESPTR(GvSV(bgv));
411
412 {
413 for(; argi < items; argi += 2) {
414 dSP;
415 SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
416 SV *b = GvSV(bgv) = argi < items-1 ?
417 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
418 &PL_sv_undef;
419
420 PUSHMARK(SP);
421 int count = call_sv((SV*)cv, G_ARRAY);
422
423 SPAGAIN;
424
425 if(count > 2 && !args_copy) {
426 /* We can't return more than 2 results for a given input pair
427 * without trashing the remaining argmuents on the stack still
428 * to be processed. So, we'll copy them out to a temporary
429 * buffer and work from there instead.
430 * We didn't do this initially because in the common case, most
431 * code blocks will return only 1 or 2 items so it won't be
432 * necessary
433 */
434 int n_args = items - argi;
435 Newx(args_copy, n_args, SV *);
436 SAVEFREEPV(args_copy);
437
438 Copy(&ST(argi), args_copy, n_args, SV *);
439
440 argi = 0;
441 items = n_args;
442 }
443
444 int i;
445 for(i = 0; i < count; i++)
446 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
447
448 PUTBACK;
449 }
450 }
451
452 XSRETURN(reti);
453}
454
82f35e8b
RH
455#endif
456
1bfb5477 457void
2dc8d725
CBW
458pairs(...)
459PROTOTYPE: @
460PPCODE:
461{
462 int argi = 0;
463 int reti = 0;
464
465 {
466 for(; argi < items; argi += 2) {
467 SV *a = ST(argi);
468 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
469
470 AV *av = newAV();
471 av_push(av, newSVsv(a));
472 av_push(av, newSVsv(b));
473
474 ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
475 }
476 }
477
478 XSRETURN(reti);
479}
480
481void
482pairkeys(...)
483PROTOTYPE: @
484PPCODE:
485{
486 int argi = 0;
487 int reti = 0;
488
489 {
490 for(; argi < items; argi += 2) {
491 SV *a = ST(argi);
492
493 ST(reti++) = sv_2mortal(newSVsv(a));
494 }
495 }
496
497 XSRETURN(reti);
498}
499
500void
501pairvalues(...)
502PROTOTYPE: @
503PPCODE:
504{
505 int argi = 0;
506 int reti = 0;
507
508 {
509 for(; argi < items; argi += 2) {
510 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
511
512 ST(reti++) = sv_2mortal(newSVsv(b));
513 }
514 }
515
516 XSRETURN(reti);
517}
518
519void
1bfb5477
GB
520shuffle(...)
521PROTOTYPE: @
522CODE:
523{
524 int index;
ddf53ba4 525#if (PERL_VERSION < 9)
1bfb5477
GB
526 struct op dmy_op;
527 struct op *old_op = PL_op;
1bfb5477 528
c29e891d
GB
529 /* We call pp_rand here so that Drand01 get initialized if rand()
530 or srand() has not already been called
531 */
1bfb5477 532 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
533 /* we let pp_rand() borrow the TARG allocated for this XS sub */
534 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 535 PL_op = &dmy_op;
20d72259 536 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 537 PL_op = old_op;
82f35e8b
RH
538#else
539 /* Initialize Drand01 if rand() or srand() has
540 not already been called
541 */
542 if (!PL_srand_called) {
543 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
544 PL_srand_called = TRUE;
545 }
546#endif
547
1bfb5477
GB
548 for (index = items ; index > 1 ; ) {
549 int swap = (int)(Drand01() * (double)(index--));
550 SV *tmp = ST(swap);
551 ST(swap) = ST(index);
552 ST(index) = tmp;
553 }
554 XSRETURN(items);
555}
556
557
f4a2945e
JH
558MODULE=List::Util PACKAGE=Scalar::Util
559
560void
561dualvar(num,str)
562 SV * num
563 SV * str
564PROTOTYPE: $$
565CODE:
566{
3630f57e
CBW
567 dXSTARG;
568 (void)SvUPGRADE(TARG, SVt_PVNV);
569 sv_copypv(TARG,str);
1bfb5477 570 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
3630f57e
CBW
571 SvNV_set(TARG, SvNV(num));
572 SvNOK_on(TARG);
f4a2945e 573 }
1bfb5477
GB
574#ifdef SVf_IVisUV
575 else if (SvUOK(num)) {
3630f57e
CBW
576 SvUV_set(TARG, SvUV(num));
577 SvIOK_on(TARG);
578 SvIsUV_on(TARG);
1bfb5477
GB
579 }
580#endif
f4a2945e 581 else {
3630f57e
CBW
582 SvIV_set(TARG, SvIV(num));
583 SvIOK_on(TARG);
f4a2945e
JH
584 }
585 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
3630f57e
CBW
586 SvTAINTED_on(TARG);
587 ST(0) = TARG;
f4a2945e
JH
588 XSRETURN(1);
589}
590
8b198969
CBW
591void
592isdual(sv)
593 SV *sv
594PROTOTYPE: $
595CODE:
596 if (SvMAGICAL(sv))
597 mg_get(sv);
598 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
599 XSRETURN(1);
600
f4a2945e
JH
601char *
602blessed(sv)
603 SV * sv
604PROTOTYPE: $
605CODE:
606{
3630f57e 607 SvGETMAGIC(sv);
4daffb2b 608 if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) {
f4a2945e
JH
609 XSRETURN_UNDEF;
610 }
4a61a419 611 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
612}
613OUTPUT:
614 RETVAL
615
616char *
617reftype(sv)
618 SV * sv
619PROTOTYPE: $
620CODE:
621{
3630f57e 622 SvGETMAGIC(sv);
f4a2945e
JH
623 if(!SvROK(sv)) {
624 XSRETURN_UNDEF;
625 }
4a61a419 626 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
627}
628OUTPUT:
629 RETVAL
630
bd1e762a 631UV
60f3865b
GB
632refaddr(sv)
633 SV * sv
634PROTOTYPE: $
635CODE:
636{
3630f57e 637 SvGETMAGIC(sv);
60f3865b
GB
638 if(!SvROK(sv)) {
639 XSRETURN_UNDEF;
640 }
bd1e762a 641 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
642}
643OUTPUT:
644 RETVAL
645
f4a2945e
JH
646void
647weaken(sv)
648 SV *sv
649PROTOTYPE: $
650CODE:
651#ifdef SvWEAKREF
652 sv_rvweaken(sv);
653#else
654 croak("weak references are not implemented in this release of perl");
655#endif
656
c6c619a9 657void
f4a2945e
JH
658isweak(sv)
659 SV *sv
660PROTOTYPE: $
661CODE:
662#ifdef SvWEAKREF
663 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
664 XSRETURN(1);
665#else
666 croak("weak references are not implemented in this release of perl");
667#endif
668
669int
670readonly(sv)
671 SV *sv
672PROTOTYPE: $
673CODE:
3630f57e 674 SvGETMAGIC(sv);
f4a2945e
JH
675 RETVAL = SvREADONLY(sv);
676OUTPUT:
677 RETVAL
678
679int
680tainted(sv)
681 SV *sv
682PROTOTYPE: $
683CODE:
3630f57e 684 SvGETMAGIC(sv);
f4a2945e
JH
685 RETVAL = SvTAINTED(sv);
686OUTPUT:
687 RETVAL
688
60f3865b
GB
689void
690isvstring(sv)
691 SV *sv
692PROTOTYPE: $
693CODE:
694#ifdef SvVOK
3630f57e 695 SvGETMAGIC(sv);
60f3865b
GB
696 ST(0) = boolSV(SvVOK(sv));
697 XSRETURN(1);
698#else
699 croak("vstrings are not implemented in this release of perl");
700#endif
701
9e7deb6c
GB
702int
703looks_like_number(sv)
704 SV *sv
705PROTOTYPE: $
706CODE:
2ff28616 707 SV *tempsv;
3630f57e 708 SvGETMAGIC(sv);
2ff28616
GB
709 if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
710 sv = tempsv;
711 }
3630f57e 712#if PERL_BCDVERSION < 0x5008005
4984adac
GB
713 if (SvPOK(sv) || SvPOKp(sv)) {
714 RETVAL = looks_like_number(sv);
715 }
716 else {
717 RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
718 }
719#else
9e7deb6c 720 RETVAL = looks_like_number(sv);
4984adac 721#endif
9e7deb6c
GB
722OUTPUT:
723 RETVAL
724
c5661c80 725void
97605c51
GB
726set_prototype(subref, proto)
727 SV *subref
728 SV *proto
729PROTOTYPE: &$
730CODE:
731{
732 if (SvROK(subref)) {
733 SV *sv = SvRV(subref);
734 if (SvTYPE(sv) != SVt_PVCV) {
735 /* not a subroutine reference */
736 croak("set_prototype: not a subroutine reference");
737 }
738 if (SvPOK(proto)) {
739 /* set the prototype */
3630f57e 740 sv_copypv(sv, proto);
97605c51
GB
741 }
742 else {
743 /* delete the prototype */
744 SvPOK_off(sv);
745 }
746 }
747 else {
748 croak("set_prototype: not a reference");
749 }
750 XSRETURN(1);
751}
60f3865b 752
3630f57e
CBW
753void
754openhandle(SV* sv)
755PROTOTYPE: $
756CODE:
757{
758 IO* io = NULL;
759 SvGETMAGIC(sv);
760 if(SvROK(sv)){
761 /* deref first */
762 sv = SvRV(sv);
763 }
764
765 /* must be GLOB or IO */
766 if(isGV(sv)){
767 io = GvIO((GV*)sv);
768 }
769 else if(SvTYPE(sv) == SVt_PVIO){
770 io = (IO*)sv;
771 }
772
773 if(io){
774 /* real or tied filehandle? */
775 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
776 XSRETURN(1);
777 }
778 }
779 XSRETURN_UNDEF;
780}
781
f4a2945e
JH
782BOOT:
783{
9850bf21
RH
784 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
785 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
786 SV *rmcsv;
60f3865b 787#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
788 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
789 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e
JH
790 AV *varav;
791 if (SvTYPE(vargv) != SVt_PVGV)
9850bf21 792 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 793 varav = GvAVn(vargv);
60f3865b 794#endif
9850bf21 795 if (SvTYPE(rmcgv) != SVt_PVGV)
3630f57e 796 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 797 rmcsv = GvSVn(rmcgv);
60f3865b 798#ifndef SvWEAKREF
f4a2945e
JH
799 av_push(varav, newSVpv("weaken",6));
800 av_push(varav, newSVpv("isweak",6));
801#endif
60f3865b
GB
802#ifndef SvVOK
803 av_push(varav, newSVpv("isvstring",9));
804#endif
9850bf21
RH
805#ifdef REAL_MULTICALL
806 sv_setsv(rmcsv, &PL_sv_yes);
807#else
808 sv_setsv(rmcsv, &PL_sv_no);
809#endif
f4a2945e 810}