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