1 /* pp.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14 */
15
16 #include "EXTERN.h"
17 #define PERL_IN_PP_C
18 #include "perl.h"
19 #include "keywords.h"
20
21 #include "reentr.h"
22
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
25 --AD 2/20/1998
26 */
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
29 #endif
30
31 /* variations on pp_null */
32
PP(pp_stub)33 PP(pp_stub)
34 {
35 dSP;
36 if (GIMME_V == G_SCALAR)
37 XPUSHs(&PL_sv_undef);
38 RETURN;
39 }
40
PP(pp_scalar)41 PP(pp_scalar)
42 {
43 return NORMAL;
44 }
45
46 /* Pushy stuff. */
47
PP(pp_padav)48 PP(pp_padav)
49 {
50 dSP; dTARGET;
51 I32 gimme;
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
54 EXTEND(SP, 1);
55 if (PL_op->op_flags & OPf_REF) {
56 PUSHs(TARG);
57 RETURN;
58 } else if (LVRET) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
61 PUSHs(TARG);
62 RETURN;
63 }
64 gimme = GIMME_V;
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
67 EXTEND(SP, maxarg);
68 if (SvMAGICAL(TARG)) {
69 U32 i;
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
73 }
74 }
75 else {
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
77 }
78 SP += maxarg;
79 }
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
83 sv_setiv(sv, maxarg);
84 PUSHs(sv);
85 }
86 RETURN;
87 }
88
PP(pp_padhv)89 PP(pp_padhv)
90 {
91 dSP; dTARGET;
92 I32 gimme;
93
94 XPUSHs(TARG);
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
98 RETURN;
99 else if (LVRET) {
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
102 RETURN;
103 }
104 gimme = GIMME_V;
105 if (gimme == G_ARRAY) {
106 RETURNOP(do_kv());
107 }
108 else if (gimme == G_SCALAR) {
109 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
110 SETs(sv);
111 }
112 RETURN;
113 }
114
PP(pp_padany)115 PP(pp_padany)
116 {
117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
118 }
119
120 /* Translations. */
121
PP(pp_rv2gv)122 PP(pp_rv2gv)
123 {
124 dSP; dTOPss;
125
126 if (SvROK(sv)) {
127 wasref:
128 tryAMAGICunDEREF(to_gv);
129
130 sv = SvRV(sv);
131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
135 (void)SvREFCNT_inc(sv);
136 sv = (SV*) gv;
137 }
138 else if (SvTYPE(sv) != SVt_PVGV)
139 DIE(aTHX_ "Not a GLOB reference");
140 }
141 else {
142 if (SvTYPE(sv) != SVt_PVGV) {
143 char *sym;
144 STRLEN len;
145
146 if (SvGMAGICAL(sv)) {
147 mg_get(sv);
148 if (SvROK(sv))
149 goto wasref;
150 }
151 if (!SvOK(sv) && sv != &PL_sv_undef) {
152 /* If this is a 'my' scalar and flag is set then vivify
153 * NI-S 1999/05/07
154 */
155 if (PL_op->op_private & OPpDEREF) {
156 char *name;
157 GV *gv;
158 if (cUNOP->op_targ) {
159 STRLEN len;
160 SV *namesv = PAD_SV(cUNOP->op_targ);
161 name = SvPV(namesv, len);
162 gv = (GV*)NEWSV(0,0);
163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
164 }
165 else {
166 name = CopSTASHPV(PL_curcop);
167 gv = newGVgen(name);
168 }
169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
171 if (SvPVX(sv)) {
172 (void)SvOOK_off(sv); /* backoff */
173 if (SvLEN(sv))
174 Safefree(SvPVX(sv));
175 SvLEN(sv)=SvCUR(sv)=0;
176 }
177 SvRV(sv) = (SV*)gv;
178 SvROK_on(sv);
179 SvSETMAGIC(sv);
180 goto wasref;
181 }
182 if (PL_op->op_flags & OPf_REF ||
183 PL_op->op_private & HINT_STRICT_REFS)
184 DIE(aTHX_ PL_no_usym, "a symbol");
185 if (ckWARN(WARN_UNINITIALIZED))
186 report_uninit();
187 RETSETUNDEF;
188 }
189 sym = SvPV(sv,len);
190 if ((PL_op->op_flags & OPf_SPECIAL) &&
191 !(PL_op->op_flags & OPf_MOD))
192 {
193 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
194 if (!sv
195 && (!is_gv_magical(sym,len,0)
196 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
197 {
198 RETSETUNDEF;
199 }
200 }
201 else {
202 if (PL_op->op_private & HINT_STRICT_REFS)
203 DIE(aTHX_ PL_no_symref, sym, "a symbol");
204 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
205 }
206 }
207 }
208 if (PL_op->op_private & OPpLVAL_INTRO)
209 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
210 SETs(sv);
211 RETURN;
212 }
213
PP(pp_rv2sv)214 PP(pp_rv2sv)
215 {
216 GV *gv = Nullgv;
217 dSP; dTOPss;
218
219 if (SvROK(sv)) {
220 wasref:
221 tryAMAGICunDEREF(to_sv);
222
223 sv = SvRV(sv);
224 switch (SvTYPE(sv)) {
225 case SVt_PVAV:
226 case SVt_PVHV:
227 case SVt_PVCV:
228 DIE(aTHX_ "Not a SCALAR reference");
229 }
230 }
231 else {
232 char *sym;
233 STRLEN len;
234 gv = (GV*)sv;
235
236 if (SvTYPE(gv) != SVt_PVGV) {
237 if (SvGMAGICAL(sv)) {
238 mg_get(sv);
239 if (SvROK(sv))
240 goto wasref;
241 }
242 if (!SvOK(sv)) {
243 if (PL_op->op_flags & OPf_REF ||
244 PL_op->op_private & HINT_STRICT_REFS)
245 DIE(aTHX_ PL_no_usym, "a SCALAR");
246 if (ckWARN(WARN_UNINITIALIZED))
247 report_uninit();
248 RETSETUNDEF;
249 }
250 sym = SvPV(sv, len);
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
253 {
254 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
255 if (!gv
256 && (!is_gv_magical(sym,len,0)
257 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
258 {
259 RETSETUNDEF;
260 }
261 }
262 else {
263 if (PL_op->op_private & HINT_STRICT_REFS)
264 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
265 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
266 }
267 }
268 sv = GvSV(gv);
269 }
270 if (PL_op->op_flags & OPf_MOD) {
271 if (PL_op->op_private & OPpLVAL_INTRO) {
272 if (cUNOP->op_first->op_type == OP_NULL)
273 sv = save_scalar((GV*)TOPs);
274 else if (gv)
275 sv = save_scalar(gv);
276 else
277 Perl_croak(aTHX_ PL_no_localize_ref);
278 }
279 else if (PL_op->op_private & OPpDEREF)
280 vivify_ref(sv, PL_op->op_private & OPpDEREF);
281 }
282 SETs(sv);
283 RETURN;
284 }
285
PP(pp_av2arylen)286 PP(pp_av2arylen)
287 {
288 dSP;
289 AV *av = (AV*)TOPs;
290 SV *sv = AvARYLEN(av);
291 if (!sv) {
292 AvARYLEN(av) = sv = NEWSV(0,0);
293 sv_upgrade(sv, SVt_IV);
294 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
295 }
296 SETs(sv);
297 RETURN;
298 }
299
PP(pp_pos)300 PP(pp_pos)
301 {
302 dSP; dTARGET; dPOPss;
303
304 if (PL_op->op_flags & OPf_MOD || LVRET) {
305 if (SvTYPE(TARG) < SVt_PVLV) {
306 sv_upgrade(TARG, SVt_PVLV);
307 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
308 }
309
310 LvTYPE(TARG) = '.';
311 if (LvTARG(TARG) != sv) {
312 if (LvTARG(TARG))
313 SvREFCNT_dec(LvTARG(TARG));
314 LvTARG(TARG) = SvREFCNT_inc(sv);
315 }
316 PUSHs(TARG); /* no SvSETMAGIC */
317 RETURN;
318 }
319 else {
320 MAGIC* mg;
321
322 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
323 mg = mg_find(sv, PERL_MAGIC_regex_global);
324 if (mg && mg->mg_len >= 0) {
325 I32 i = mg->mg_len;
326 if (DO_UTF8(sv))
327 sv_pos_b2u(sv, &i);
328 PUSHi(i + PL_curcop->cop_arybase);
329 RETURN;
330 }
331 }
332 RETPUSHUNDEF;
333 }
334 }
335
PP(pp_rv2cv)336 PP(pp_rv2cv)
337 {
338 dSP;
339 GV *gv;
340 HV *stash;
341
342 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
343 /* (But not in defined().) */
344 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
345 if (cv) {
346 if (CvCLONE(cv))
347 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
348 if ((PL_op->op_private & OPpLVAL_INTRO)) {
349 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
350 cv = GvCV(gv);
351 if (!CvLVALUE(cv))
352 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
353 }
354 }
355 else
356 cv = (CV*)&PL_sv_undef;
357 SETs((SV*)cv);
358 RETURN;
359 }
360
PP(pp_prototype)361 PP(pp_prototype)
362 {
363 dSP;
364 CV *cv;
365 HV *stash;
366 GV *gv;
367 SV *ret;
368
369 ret = &PL_sv_undef;
370 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
371 char *s = SvPVX(TOPs);
372 if (strnEQ(s, "CORE::", 6)) {
373 int code;
374
375 code = keyword(s + 6, SvCUR(TOPs) - 6);
376 if (code < 0) { /* Overridable. */
377 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
378 int i = 0, n = 0, seen_question = 0;
379 I32 oa;
380 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
381
382 if (code == -KEY_chop || code == -KEY_chomp)
383 goto set;
384 while (i < MAXO) { /* The slow way. */
385 if (strEQ(s + 6, PL_op_name[i])
386 || strEQ(s + 6, PL_op_desc[i]))
387 {
388 goto found;
389 }
390 i++;
391 }
392 goto nonesuch; /* Should not happen... */
393 found:
394 oa = PL_opargs[i] >> OASHIFT;
395 while (oa) {
396 if (oa & OA_OPTIONAL && !seen_question) {
397 seen_question = 1;
398 str[n++] = ';';
399 }
400 else if (n && str[0] == ';' && seen_question)
401 goto set; /* XXXX system, exec */
402 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
403 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
404 /* But globs are already references (kinda) */
405 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
406 ) {
407 str[n++] = '\\';
408 }
409 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
410 oa = oa >> 4;
411 }
412 str[n++] = '\0';
413 ret = sv_2mortal(newSVpvn(str, n - 1));
414 }
415 else if (code) /* Non-Overridable */
416 goto set;
417 else { /* None such */
418 nonesuch:
419 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
420 }
421 }
422 }
423 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
424 if (cv && SvPOK(cv))
425 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
426 set:
427 SETs(ret);
428 RETURN;
429 }
430
PP(pp_anoncode)431 PP(pp_anoncode)
432 {
433 dSP;
434 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
435 if (CvCLONE(cv))
436 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
437 EXTEND(SP,1);
438 PUSHs((SV*)cv);
439 RETURN;
440 }
441
PP(pp_srefgen)442 PP(pp_srefgen)
443 {
444 dSP;
445 *SP = refto(*SP);
446 RETURN;
447 }
448
PP(pp_refgen)449 PP(pp_refgen)
450 {
451 dSP; dMARK;
452 if (GIMME != G_ARRAY) {
453 if (++MARK <= SP)
454 *MARK = *SP;
455 else
456 *MARK = &PL_sv_undef;
457 *MARK = refto(*MARK);
458 SP = MARK;
459 RETURN;
460 }
461 EXTEND_MORTAL(SP - MARK);
462 while (++MARK <= SP)
463 *MARK = refto(*MARK);
464 RETURN;
465 }
466
467 STATIC SV*
S_refto(pTHX_ SV * sv)468 S_refto(pTHX_ SV *sv)
469 {
470 SV* rv;
471
472 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473 if (LvTARGLEN(sv))
474 vivify_defelem(sv);
475 if (!(sv = LvTARG(sv)))
476 sv = &PL_sv_undef;
477 else
478 (void)SvREFCNT_inc(sv);
479 }
480 else if (SvTYPE(sv) == SVt_PVAV) {
481 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
482 av_reify((AV*)sv);
483 SvTEMP_off(sv);
484 (void)SvREFCNT_inc(sv);
485 }
486 else if (SvPADTMP(sv) && !IS_PADGV(sv))
487 sv = newSVsv(sv);
488 else {
489 SvTEMP_off(sv);
490 (void)SvREFCNT_inc(sv);
491 }
492 rv = sv_newmortal();
493 sv_upgrade(rv, SVt_RV);
494 SvRV(rv) = sv;
495 SvROK_on(rv);
496 return rv;
497 }
498
PP(pp_ref)499 PP(pp_ref)
500 {
501 dSP; dTARGET;
502 SV *sv;
503 char *pv;
504
505 sv = POPs;
506
507 if (sv && SvGMAGICAL(sv))
508 mg_get(sv);
509
510 if (!sv || !SvROK(sv))
511 RETPUSHNO;
512
513 sv = SvRV(sv);
514 pv = sv_reftype(sv,TRUE);
515 PUSHp(pv, strlen(pv));
516 RETURN;
517 }
518
PP(pp_bless)519 PP(pp_bless)
520 {
521 dSP;
522 HV *stash;
523
524 if (MAXARG == 1)
525 stash = CopSTASH(PL_curcop);
526 else {
527 SV *ssv = POPs;
528 STRLEN len;
529 char *ptr;
530
531 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
532 Perl_croak(aTHX_ "Attempt to bless into a reference");
533 ptr = SvPV(ssv,len);
534 if (ckWARN(WARN_MISC) && len == 0)
535 Perl_warner(aTHX_ packWARN(WARN_MISC),
536 "Explicit blessing to '' (assuming package main)");
537 stash = gv_stashpvn(ptr, len, TRUE);
538 }
539
540 (void)sv_bless(TOPs, stash);
541 RETURN;
542 }
543
PP(pp_gelem)544 PP(pp_gelem)
545 {
546 GV *gv;
547 SV *sv;
548 SV *tmpRef;
549 char *elem;
550 dSP;
551 STRLEN n_a;
552
553 sv = POPs;
554 elem = SvPV(sv, n_a);
555 gv = (GV*)POPs;
556 tmpRef = Nullsv;
557 sv = Nullsv;
558 switch (elem ? *elem : '\0')
559 {
560 case 'A':
561 if (strEQ(elem, "ARRAY"))
562 tmpRef = (SV*)GvAV(gv);
563 break;
564 case 'C':
565 if (strEQ(elem, "CODE"))
566 tmpRef = (SV*)GvCVu(gv);
567 break;
568 case 'F':
569 if (strEQ(elem, "FILEHANDLE")) {
570 /* finally deprecated in 5.8.0 */
571 deprecate("*glob{FILEHANDLE}");
572 tmpRef = (SV*)GvIOp(gv);
573 }
574 else
575 if (strEQ(elem, "FORMAT"))
576 tmpRef = (SV*)GvFORM(gv);
577 break;
578 case 'G':
579 if (strEQ(elem, "GLOB"))
580 tmpRef = (SV*)gv;
581 break;
582 case 'H':
583 if (strEQ(elem, "HASH"))
584 tmpRef = (SV*)GvHV(gv);
585 break;
586 case 'I':
587 if (strEQ(elem, "IO"))
588 tmpRef = (SV*)GvIOp(gv);
589 break;
590 case 'N':
591 if (strEQ(elem, "NAME"))
592 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
593 break;
594 case 'P':
595 if (strEQ(elem, "PACKAGE"))
596 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
597 break;
598 case 'S':
599 if (strEQ(elem, "SCALAR"))
600 tmpRef = GvSV(gv);
601 break;
602 }
603 if (tmpRef)
604 sv = newRV(tmpRef);
605 if (sv)
606 sv_2mortal(sv);
607 else
608 sv = &PL_sv_undef;
609 XPUSHs(sv);
610 RETURN;
611 }
612
613 /* Pattern matching */
614
PP(pp_study)615 PP(pp_study)
616 {
617 dSP; dPOPss;
618 register unsigned char *s;
619 register I32 pos;
620 register I32 ch;
621 register I32 *sfirst;
622 register I32 *snext;
623 STRLEN len;
624
625 if (sv == PL_lastscream) {
626 if (SvSCREAM(sv))
627 RETPUSHYES;
628 }
629 else {
630 if (PL_lastscream) {
631 SvSCREAM_off(PL_lastscream);
632 SvREFCNT_dec(PL_lastscream);
633 }
634 PL_lastscream = SvREFCNT_inc(sv);
635 }
636
637 s = (unsigned char*)(SvPV(sv, len));
638 pos = len;
639 if (pos <= 0)
640 RETPUSHNO;
641 if (pos > PL_maxscream) {
642 if (PL_maxscream < 0) {
643 PL_maxscream = pos + 80;
644 New(301, PL_screamfirst, 256, I32);
645 New(302, PL_screamnext, PL_maxscream, I32);
646 }
647 else {
648 PL_maxscream = pos + pos / 4;
649 Renew(PL_screamnext, PL_maxscream, I32);
650 }
651 }
652
653 sfirst = PL_screamfirst;
654 snext = PL_screamnext;
655
656 if (!sfirst || !snext)
657 DIE(aTHX_ "do_study: out of memory");
658
659 for (ch = 256; ch; --ch)
660 *sfirst++ = -1;
661 sfirst -= 256;
662
663 while (--pos >= 0) {
664 ch = s[pos];
665 if (sfirst[ch] >= 0)
666 snext[pos] = sfirst[ch] - pos;
667 else
668 snext[pos] = -pos;
669 sfirst[ch] = pos;
670 }
671
672 SvSCREAM_on(sv);
673 /* piggyback on m//g magic */
674 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
675 RETPUSHYES;
676 }
677
PP(pp_trans)678 PP(pp_trans)
679 {
680 dSP; dTARG;
681 SV *sv;
682
683 if (PL_op->op_flags & OPf_STACKED)
684 sv = POPs;
685 else {
686 sv = DEFSV;
687 EXTEND(SP,1);
688 }
689 TARG = sv_newmortal();
690 PUSHi(do_trans(sv));
691 RETURN;
692 }
693
694 /* Lvalue operators. */
695
PP(pp_schop)696 PP(pp_schop)
697 {
698 dSP; dTARGET;
699 do_chop(TARG, TOPs);
700 SETTARG;
701 RETURN;
702 }
703
PP(pp_chop)704 PP(pp_chop)
705 {
706 dSP; dMARK; dTARGET; dORIGMARK;
707 while (MARK < SP)
708 do_chop(TARG, *++MARK);
709 SP = ORIGMARK;
710 PUSHTARG;
711 RETURN;
712 }
713
PP(pp_schomp)714 PP(pp_schomp)
715 {
716 dSP; dTARGET;
717 SETi(do_chomp(TOPs));
718 RETURN;
719 }
720
PP(pp_chomp)721 PP(pp_chomp)
722 {
723 dSP; dMARK; dTARGET;
724 register I32 count = 0;
725
726 while (SP > MARK)
727 count += do_chomp(POPs);
728 PUSHi(count);
729 RETURN;
730 }
731
PP(pp_defined)732 PP(pp_defined)
733 {
734 dSP;
735 register SV* sv;
736
737 sv = POPs;
738 if (!sv || !SvANY(sv))
739 RETPUSHNO;
740 switch (SvTYPE(sv)) {
741 case SVt_PVAV:
742 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
743 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
744 RETPUSHYES;
745 break;
746 case SVt_PVHV:
747 if (HvARRAY(sv) || SvGMAGICAL(sv)
748 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
749 RETPUSHYES;
750 break;
751 case SVt_PVCV:
752 if (CvROOT(sv) || CvXSUB(sv))
753 RETPUSHYES;
754 break;
755 default:
756 if (SvGMAGICAL(sv))
757 mg_get(sv);
758 if (SvOK(sv))
759 RETPUSHYES;
760 }
761 RETPUSHNO;
762 }
763
PP(pp_undef)764 PP(pp_undef)
765 {
766 dSP;
767 SV *sv;
768
769 if (!PL_op->op_private) {
770 EXTEND(SP, 1);
771 RETPUSHUNDEF;
772 }
773
774 sv = POPs;
775 if (!sv)
776 RETPUSHUNDEF;
777
778 if (SvTHINKFIRST(sv))
779 sv_force_normal(sv);
780
781 switch (SvTYPE(sv)) {
782 case SVt_NULL:
783 break;
784 case SVt_PVAV:
785 av_undef((AV*)sv);
786 break;
787 case SVt_PVHV:
788 hv_undef((HV*)sv);
789 break;
790 case SVt_PVCV:
791 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
792 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
793 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
794 /* FALL THROUGH */
795 case SVt_PVFM:
796 {
797 /* let user-undef'd sub keep its identity */
798 GV* gv = CvGV((CV*)sv);
799 cv_undef((CV*)sv);
800 CvGV((CV*)sv) = gv;
801 }
802 break;
803 case SVt_PVGV:
804 if (SvFAKE(sv))
805 SvSetMagicSV(sv, &PL_sv_undef);
806 else {
807 GP *gp;
808 gp_free((GV*)sv);
809 Newz(602, gp, 1, GP);
810 GvGP(sv) = gp_ref(gp);
811 GvSV(sv) = NEWSV(72,0);
812 GvLINE(sv) = CopLINE(PL_curcop);
813 GvEGV(sv) = (GV*)sv;
814 GvMULTI_on(sv);
815 }
816 break;
817 default:
818 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
819 (void)SvOOK_off(sv);
820 Safefree(SvPVX(sv));
821 SvPV_set(sv, Nullch);
822 SvLEN_set(sv, 0);
823 }
824 (void)SvOK_off(sv);
825 SvSETMAGIC(sv);
826 }
827
828 RETPUSHUNDEF;
829 }
830
PP(pp_predec)831 PP(pp_predec)
832 {
833 dSP;
834 if (SvTYPE(TOPs) > SVt_PVLV)
835 DIE(aTHX_ PL_no_modify);
836 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
837 && SvIVX(TOPs) != IV_MIN)
838 {
839 --SvIVX(TOPs);
840 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 }
842 else
843 sv_dec(TOPs);
844 SvSETMAGIC(TOPs);
845 return NORMAL;
846 }
847
PP(pp_postinc)848 PP(pp_postinc)
849 {
850 dSP; dTARGET;
851 if (SvTYPE(TOPs) > SVt_PVLV)
852 DIE(aTHX_ PL_no_modify);
853 sv_setsv(TARG, TOPs);
854 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
855 && SvIVX(TOPs) != IV_MAX)
856 {
857 ++SvIVX(TOPs);
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859 }
860 else
861 sv_inc(TOPs);
862 SvSETMAGIC(TOPs);
863 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
864 if (!SvOK(TARG))
865 sv_setiv(TARG, 0);
866 SETs(TARG);
867 return NORMAL;
868 }
869
PP(pp_postdec)870 PP(pp_postdec)
871 {
872 dSP; dTARGET;
873 if (SvTYPE(TOPs) > SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 sv_setsv(TARG, TOPs);
876 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
877 && SvIVX(TOPs) != IV_MIN)
878 {
879 --SvIVX(TOPs);
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881 }
882 else
883 sv_dec(TOPs);
884 SvSETMAGIC(TOPs);
885 SETs(TARG);
886 return NORMAL;
887 }
888
889 /* Ordinary operators. */
890
PP(pp_pow)891 PP(pp_pow)
892 {
893 dSP; dATARGET;
894 #ifdef PERL_PRESERVE_IVUV
895 bool is_int = 0;
896 #endif
897 tryAMAGICbin(pow,opASSIGN);
898 #ifdef PERL_PRESERVE_IVUV
899 /* For integer to integer power, we do the calculation by hand wherever
900 we're sure it is safe; otherwise we call pow() and try to convert to
901 integer afterwards. */
902 {
903 SvIV_please(TOPm1s);
904 if (SvIOK(TOPm1s)) {
905 bool baseuok = SvUOK(TOPm1s);
906 UV baseuv;
907
908 if (baseuok) {
909 baseuv = SvUVX(TOPm1s);
910 } else {
911 IV iv = SvIVX(TOPm1s);
912 if (iv >= 0) {
913 baseuv = iv;
914 baseuok = TRUE; /* effectively it's a UV now */
915 } else {
916 baseuv = -iv; /* abs, baseuok == false records sign */
917 }
918 }
919 SvIV_please(TOPs);
920 if (SvIOK(TOPs)) {
921 UV power;
922
923 if (SvUOK(TOPs)) {
924 power = SvUVX(TOPs);
925 } else {
926 IV iv = SvIVX(TOPs);
927 if (iv >= 0) {
928 power = iv;
929 } else {
930 goto float_it; /* Can't do negative powers this way. */
931 }
932 }
933 /* now we have integer ** positive integer. */
934 is_int = 1;
935
936 /* foo & (foo - 1) is zero only for a power of 2. */
937 if (!(baseuv & (baseuv - 1))) {
938 /* We are raising power-of-2 to a positive integer.
939 The logic here will work for any base (even non-integer
940 bases) but it can be less accurate than
941 pow (base,power) or exp (power * log (base)) when the
942 intermediate values start to spill out of the mantissa.
943 With powers of 2 we know this can't happen.
944 And powers of 2 are the favourite thing for perl
945 programmers to notice ** not doing what they mean. */
946 NV result = 1.0;
947 NV base = baseuok ? baseuv : -(NV)baseuv;
948 int n = 0;
949
950 for (; power; base *= base, n++) {
951 /* Do I look like I trust gcc with long longs here?
952 Do I hell. */
953 UV bit = (UV)1 << (UV)n;
954 if (power & bit) {
955 result *= base;
956 /* Only bother to clear the bit if it is set. */
957 power -= bit;
958 /* Avoid squaring base again if we're done. */
959 if (power == 0) break;
960 }
961 }
962 SP--;
963 SETn( result );
964 SvIV_please(TOPs);
965 RETURN;
966 } else {
967 register unsigned int highbit = 8 * sizeof(UV);
968 register unsigned int lowbit = 0;
969 register unsigned int diff;
970 bool odd_power = (bool)(power & 1);
971 while ((diff = (highbit - lowbit) >> 1)) {
972 if (baseuv & ~((1 << (lowbit + diff)) - 1))
973 lowbit += diff;
974 else
975 highbit -= diff;
976 }
977 /* we now have baseuv < 2 ** highbit */
978 if (power * highbit <= 8 * sizeof(UV)) {
979 /* result will definitely fit in UV, so use UV math
980 on same algorithm as above */
981 register UV result = 1;
982 register UV base = baseuv;
983 register int n = 0;
984 for (; power; base *= base, n++) {
985 register UV bit = (UV)1 << (UV)n;
986 if (power & bit) {
987 result *= base;
988 power -= bit;
989 if (power == 0) break;
990 }
991 }
992 SP--;
993 if (baseuok || !odd_power)
994 /* answer is positive */
995 SETu( result );
996 else if (result <= (UV)IV_MAX)
997 /* answer negative, fits in IV */
998 SETi( -(IV)result );
999 else if (result == (UV)IV_MIN)
1000 /* 2's complement assumption: special case IV_MIN */
1001 SETi( IV_MIN );
1002 else
1003 /* answer negative, doesn't fit */
1004 SETn( -(NV)result );
1005 RETURN;
1006 }
1007 }
1008 }
1009 }
1010 }
1011 float_it:
1012 #endif
1013 {
1014 dPOPTOPnnrl;
1015 SETn( Perl_pow( left, right) );
1016 #ifdef PERL_PRESERVE_IVUV
1017 if (is_int)
1018 SvIV_please(TOPs);
1019 #endif
1020 RETURN;
1021 }
1022 }
1023
PP(pp_multiply)1024 PP(pp_multiply)
1025 {
1026 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1027 #ifdef PERL_PRESERVE_IVUV
1028 SvIV_please(TOPs);
1029 if (SvIOK(TOPs)) {
1030 /* Unless the left argument is integer in range we are going to have to
1031 use NV maths. Hence only attempt to coerce the right argument if
1032 we know the left is integer. */
1033 /* Left operand is defined, so is it IV? */
1034 SvIV_please(TOPm1s);
1035 if (SvIOK(TOPm1s)) {
1036 bool auvok = SvUOK(TOPm1s);
1037 bool buvok = SvUOK(TOPs);
1038 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1039 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1040 UV alow;
1041 UV ahigh;
1042 UV blow;
1043 UV bhigh;
1044
1045 if (auvok) {
1046 alow = SvUVX(TOPm1s);
1047 } else {
1048 IV aiv = SvIVX(TOPm1s);
1049 if (aiv >= 0) {
1050 alow = aiv;
1051 auvok = TRUE; /* effectively it's a UV now */
1052 } else {
1053 alow = -aiv; /* abs, auvok == false records sign */
1054 }
1055 }
1056 if (buvok) {
1057 blow = SvUVX(TOPs);
1058 } else {
1059 IV biv = SvIVX(TOPs);
1060 if (biv >= 0) {
1061 blow = biv;
1062 buvok = TRUE; /* effectively it's a UV now */
1063 } else {
1064 blow = -biv; /* abs, buvok == false records sign */
1065 }
1066 }
1067
1068 /* If this does sign extension on unsigned it's time for plan B */
1069 ahigh = alow >> (4 * sizeof (UV));
1070 alow &= botmask;
1071 bhigh = blow >> (4 * sizeof (UV));
1072 blow &= botmask;
1073 if (ahigh && bhigh) {
1074 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1075 which is overflow. Drop to NVs below. */
1076 } else if (!ahigh && !bhigh) {
1077 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1078 so the unsigned multiply cannot overflow. */
1079 UV product = alow * blow;
1080 if (auvok == buvok) {
1081 /* -ve * -ve or +ve * +ve gives a +ve result. */
1082 SP--;
1083 SETu( product );
1084 RETURN;
1085 } else if (product <= (UV)IV_MIN) {
1086 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1087 /* -ve result, which could overflow an IV */
1088 SP--;
1089 SETi( -(IV)product );
1090 RETURN;
1091 } /* else drop to NVs below. */
1092 } else {
1093 /* One operand is large, 1 small */
1094 UV product_middle;
1095 if (bhigh) {
1096 /* swap the operands */
1097 ahigh = bhigh;
1098 bhigh = blow; /* bhigh now the temp var for the swap */
1099 blow = alow;
1100 alow = bhigh;
1101 }
1102 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1103 multiplies can't overflow. shift can, add can, -ve can. */
1104 product_middle = ahigh * blow;
1105 if (!(product_middle & topmask)) {
1106 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1107 UV product_low;
1108 product_middle <<= (4 * sizeof (UV));
1109 product_low = alow * blow;
1110
1111 /* as for pp_add, UV + something mustn't get smaller.
1112 IIRC ANSI mandates this wrapping *behaviour* for
1113 unsigned whatever the actual representation*/
1114 product_low += product_middle;
1115 if (product_low >= product_middle) {
1116 /* didn't overflow */
1117 if (auvok == buvok) {
1118 /* -ve * -ve or +ve * +ve gives a +ve result. */
1119 SP--;
1120 SETu( product_low );
1121 RETURN;
1122 } else if (product_low <= (UV)IV_MIN) {
1123 /* 2s complement assumption again */
1124 /* -ve result, which could overflow an IV */
1125 SP--;
1126 SETi( -(IV)product_low );
1127 RETURN;
1128 } /* else drop to NVs below. */
1129 }
1130 } /* product_middle too large */
1131 } /* ahigh && bhigh */
1132 } /* SvIOK(TOPm1s) */
1133 } /* SvIOK(TOPs) */
1134 #endif
1135 {
1136 dPOPTOPnnrl;
1137 SETn( left * right );
1138 RETURN;
1139 }
1140 }
1141
PP(pp_divide)1142 PP(pp_divide)
1143 {
1144 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1145 /* Only try to do UV divide first
1146 if ((SLOPPYDIVIDE is true) or
1147 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1148 to preserve))
1149 The assumption is that it is better to use floating point divide
1150 whenever possible, only doing integer divide first if we can't be sure.
1151 If NV_PRESERVES_UV is true then we know at compile time that no UV
1152 can be too large to preserve, so don't need to compile the code to
1153 test the size of UVs. */
1154
1155 #ifdef SLOPPYDIVIDE
1156 # define PERL_TRY_UV_DIVIDE
1157 /* ensure that 20./5. == 4. */
1158 #else
1159 # ifdef PERL_PRESERVE_IVUV
1160 # ifndef NV_PRESERVES_UV
1161 # define PERL_TRY_UV_DIVIDE
1162 # endif
1163 # endif
1164 #endif
1165
1166 #ifdef PERL_TRY_UV_DIVIDE
1167 SvIV_please(TOPs);
1168 if (SvIOK(TOPs)) {
1169 SvIV_please(TOPm1s);
1170 if (SvIOK(TOPm1s)) {
1171 bool left_non_neg = SvUOK(TOPm1s);
1172 bool right_non_neg = SvUOK(TOPs);
1173 UV left;
1174 UV right;
1175
1176 if (right_non_neg) {
1177 right = SvUVX(TOPs);
1178 }
1179 else {
1180 IV biv = SvIVX(TOPs);
1181 if (biv >= 0) {
1182 right = biv;
1183 right_non_neg = TRUE; /* effectively it's a UV now */
1184 }
1185 else {
1186 right = -biv;
1187 }
1188 }
1189 /* historically undef()/0 gives a "Use of uninitialized value"
1190 warning before dieing, hence this test goes here.
1191 If it were immediately before the second SvIV_please, then
1192 DIE() would be invoked before left was even inspected, so
1193 no inpsection would give no warning. */
1194 if (right == 0)
1195 DIE(aTHX_ "Illegal division by zero");
1196
1197 if (left_non_neg) {
1198 left = SvUVX(TOPm1s);
1199 }
1200 else {
1201 IV aiv = SvIVX(TOPm1s);
1202 if (aiv >= 0) {
1203 left = aiv;
1204 left_non_neg = TRUE; /* effectively it's a UV now */
1205 }
1206 else {
1207 left = -aiv;
1208 }
1209 }
1210
1211 if (left >= right
1212 #ifdef SLOPPYDIVIDE
1213 /* For sloppy divide we always attempt integer division. */
1214 #else
1215 /* Otherwise we only attempt it if either or both operands
1216 would not be preserved by an NV. If both fit in NVs
1217 we fall through to the NV divide code below. However,
1218 as left >= right to ensure integer result here, we know that
1219 we can skip the test on the right operand - right big
1220 enough not to be preserved can't get here unless left is
1221 also too big. */
1222
1223 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1224 #endif
1225 ) {
1226 /* Integer division can't overflow, but it can be imprecise. */
1227 UV result = left / right;
1228 if (result * right == left) {
1229 SP--; /* result is valid */
1230 if (left_non_neg == right_non_neg) {
1231 /* signs identical, result is positive. */
1232 SETu( result );
1233 RETURN;
1234 }
1235 /* 2s complement assumption */
1236 if (result <= (UV)IV_MIN)
1237 SETi( -(IV)result );
1238 else {
1239 /* It's exact but too negative for IV. */
1240 SETn( -(NV)result );
1241 }
1242 RETURN;
1243 } /* tried integer divide but it was not an integer result */
1244 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1245 } /* left wasn't SvIOK */
1246 } /* right wasn't SvIOK */
1247 #endif /* PERL_TRY_UV_DIVIDE */
1248 {
1249 dPOPPOPnnrl;
1250 if (right == 0.0)
1251 DIE(aTHX_ "Illegal division by zero");
1252 PUSHn( left / right );
1253 RETURN;
1254 }
1255 }
1256
PP(pp_modulo)1257 PP(pp_modulo)
1258 {
1259 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1260 {
1261 UV left = 0;
1262 UV right = 0;
1263 bool left_neg = FALSE;
1264 bool right_neg = FALSE;
1265 bool use_double = FALSE;
1266 bool dright_valid = FALSE;
1267 NV dright = 0.0;
1268 NV dleft = 0.0;
1269
1270 SvIV_please(TOPs);
1271 if (SvIOK(TOPs)) {
1272 right_neg = !SvUOK(TOPs);
1273 if (!right_neg) {
1274 right = SvUVX(POPs);
1275 } else {
1276 IV biv = SvIVX(POPs);
1277 if (biv >= 0) {
1278 right = biv;
1279 right_neg = FALSE; /* effectively it's a UV now */
1280 } else {
1281 right = -biv;
1282 }
1283 }
1284 }
1285 else {
1286 dright = POPn;
1287 right_neg = dright < 0;
1288 if (right_neg)
1289 dright = -dright;
1290 if (dright < UV_MAX_P1) {
1291 right = U_V(dright);
1292 dright_valid = TRUE; /* In case we need to use double below. */
1293 } else {
1294 use_double = TRUE;
1295 }
1296 }
1297
1298 /* At this point use_double is only true if right is out of range for
1299 a UV. In range NV has been rounded down to nearest UV and
1300 use_double false. */
1301 SvIV_please(TOPs);
1302 if (!use_double && SvIOK(TOPs)) {
1303 if (SvIOK(TOPs)) {
1304 left_neg = !SvUOK(TOPs);
1305 if (!left_neg) {
1306 left = SvUVX(POPs);
1307 } else {
1308 IV aiv = SvIVX(POPs);
1309 if (aiv >= 0) {
1310 left = aiv;
1311 left_neg = FALSE; /* effectively it's a UV now */
1312 } else {
1313 left = -aiv;
1314 }
1315 }
1316 }
1317 }
1318 else {
1319 dleft = POPn;
1320 left_neg = dleft < 0;
1321 if (left_neg)
1322 dleft = -dleft;
1323
1324 /* This should be exactly the 5.6 behaviour - if left and right are
1325 both in range for UV then use U_V() rather than floor. */
1326 if (!use_double) {
1327 if (dleft < UV_MAX_P1) {
1328 /* right was in range, so is dleft, so use UVs not double.
1329 */
1330 left = U_V(dleft);
1331 }
1332 /* left is out of range for UV, right was in range, so promote
1333 right (back) to double. */
1334 else {
1335 /* The +0.5 is used in 5.6 even though it is not strictly
1336 consistent with the implicit +0 floor in the U_V()
1337 inside the #if 1. */
1338 dleft = Perl_floor(dleft + 0.5);
1339 use_double = TRUE;
1340 if (dright_valid)
1341 dright = Perl_floor(dright + 0.5);
1342 else
1343 dright = right;
1344 }
1345 }
1346 }
1347 if (use_double) {
1348 NV dans;
1349
1350 if (!dright)
1351 DIE(aTHX_ "Illegal modulus zero");
1352
1353 dans = Perl_fmod(dleft, dright);
1354 if ((left_neg != right_neg) && dans)
1355 dans = dright - dans;
1356 if (right_neg)
1357 dans = -dans;
1358 sv_setnv(TARG, dans);
1359 }
1360 else {
1361 UV ans;
1362
1363 if (!right)
1364 DIE(aTHX_ "Illegal modulus zero");
1365
1366 ans = left % right;
1367 if ((left_neg != right_neg) && ans)
1368 ans = right - ans;
1369 if (right_neg) {
1370 /* XXX may warn: unary minus operator applied to unsigned type */
1371 /* could change -foo to be (~foo)+1 instead */
1372 if (ans <= ~((UV)IV_MAX)+1)
1373 sv_setiv(TARG, ~ans+1);
1374 else
1375 sv_setnv(TARG, -(NV)ans);
1376 }
1377 else
1378 sv_setuv(TARG, ans);
1379 }
1380 PUSHTARG;
1381 RETURN;
1382 }
1383 }
1384
PP(pp_repeat)1385 PP(pp_repeat)
1386 {
1387 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1388 {
1389 register IV count = POPi;
1390 if (count < 0)
1391 count = 0;
1392 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1393 dMARK;
1394 I32 items = SP - MARK;
1395 I32 max;
1396 static const char list_extend[] = "panic: list extend";
1397
1398 max = items * count;
1399 MEM_WRAP_CHECK_1(max, SV*, list_extend);
1400 if (items > 0 && max > 0 && (max < items || max < count))
1401 Perl_croak(aTHX_ list_extend);
1402 MEXTEND(MARK, max);
1403 if (count > 1) {
1404 while (SP > MARK) {
1405 #if 0
1406 /* This code was intended to fix 20010809.028:
1407
1408 $x = 'abcd';
1409 for (($x =~ /./g) x 2) {
1410 print chop; # "abcdabcd" expected as output.
1411 }
1412
1413 * but that change (#11635) broke this code:
1414
1415 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1416
1417 * I can't think of a better fix that doesn't introduce
1418 * an efficiency hit by copying the SVs. The stack isn't
1419 * refcounted, and mortalisation obviously doesn't
1420 * Do The Right Thing when the stack has more than
1421 * one pointer to the same mortal value.
1422 * .robin.
1423 */
1424 if (*SP) {
1425 *SP = sv_2mortal(newSVsv(*SP));
1426 SvREADONLY_on(*SP);
1427 }
1428 #else
1429 if (*SP)
1430 SvTEMP_off((*SP));
1431 #endif
1432 SP--;
1433 }
1434 MARK++;
1435 repeatcpy((char*)(MARK + items), (char*)MARK,
1436 items * sizeof(SV*), count - 1);
1437 SP += max;
1438 }
1439 else if (count <= 0)
1440 SP -= items;
1441 }
1442 else { /* Note: mark already snarfed by pp_list */
1443 SV *tmpstr = POPs;
1444 STRLEN len;
1445 bool isutf;
1446
1447 SvSetSV(TARG, tmpstr);
1448 SvPV_force(TARG, len);
1449 isutf = DO_UTF8(TARG);
1450 if (count != 1) {
1451 if (count < 1)
1452 SvCUR_set(TARG, 0);
1453 else {
1454 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1455 SvGROW(TARG, (count * len) + 1);
1456 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1457 SvCUR(TARG) *= count;
1458 }
1459 *SvEND(TARG) = '\0';
1460 }
1461 if (isutf)
1462 (void)SvPOK_only_UTF8(TARG);
1463 else
1464 (void)SvPOK_only(TARG);
1465
1466 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1467 /* The parser saw this as a list repeat, and there
1468 are probably several items on the stack. But we're
1469 in scalar context, and there's no pp_list to save us
1470 now. So drop the rest of the items -- robin@kitsite.com
1471 */
1472 dMARK;
1473 SP = MARK;
1474 }
1475 PUSHTARG;
1476 }
1477 RETURN;
1478 }
1479 }
1480
PP(pp_subtract)1481 PP(pp_subtract)
1482 {
1483 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1484 useleft = USE_LEFT(TOPm1s);
1485 #ifdef PERL_PRESERVE_IVUV
1486 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1487 "bad things" happen if you rely on signed integers wrapping. */
1488 SvIV_please(TOPs);
1489 if (SvIOK(TOPs)) {
1490 /* Unless the left argument is integer in range we are going to have to
1491 use NV maths. Hence only attempt to coerce the right argument if
1492 we know the left is integer. */
1493 register UV auv = 0;
1494 bool auvok = FALSE;
1495 bool a_valid = 0;
1496
1497 if (!useleft) {
1498 auv = 0;
1499 a_valid = auvok = 1;
1500 /* left operand is undef, treat as zero. */
1501 } else {
1502 /* Left operand is defined, so is it IV? */
1503 SvIV_please(TOPm1s);
1504 if (SvIOK(TOPm1s)) {
1505 if ((auvok = SvUOK(TOPm1s)))
1506 auv = SvUVX(TOPm1s);
1507 else {
1508 register IV aiv = SvIVX(TOPm1s);
1509 if (aiv >= 0) {
1510 auv = aiv;
1511 auvok = 1; /* Now acting as a sign flag. */
1512 } else { /* 2s complement assumption for IV_MIN */
1513 auv = (UV)-aiv;
1514 }
1515 }
1516 a_valid = 1;
1517 }
1518 }
1519 if (a_valid) {
1520 bool result_good = 0;
1521 UV result;
1522 register UV buv;
1523 bool buvok = SvUOK(TOPs);
1524
1525 if (buvok)
1526 buv = SvUVX(TOPs);
1527 else {
1528 register IV biv = SvIVX(TOPs);
1529 if (biv >= 0) {
1530 buv = biv;
1531 buvok = 1;
1532 } else
1533 buv = (UV)-biv;
1534 }
1535 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1536 else "IV" now, independent of how it came in.
1537 if a, b represents positive, A, B negative, a maps to -A etc
1538 a - b => (a - b)
1539 A - b => -(a + b)
1540 a - B => (a + b)
1541 A - B => -(a - b)
1542 all UV maths. negate result if A negative.
1543 subtract if signs same, add if signs differ. */
1544
1545 if (auvok ^ buvok) {
1546 /* Signs differ. */
1547 result = auv + buv;
1548 if (result >= auv)
1549 result_good = 1;
1550 } else {
1551 /* Signs same */
1552 if (auv >= buv) {
1553 result = auv - buv;
1554 /* Must get smaller */
1555 if (result <= auv)
1556 result_good = 1;
1557 } else {
1558 result = buv - auv;
1559 if (result <= buv) {
1560 /* result really should be -(auv-buv). as its negation
1561 of true value, need to swap our result flag */
1562 auvok = !auvok;
1563 result_good = 1;
1564 }
1565 }
1566 }
1567 if (result_good) {
1568 SP--;
1569 if (auvok)
1570 SETu( result );
1571 else {
1572 /* Negate result */
1573 if (result <= (UV)IV_MIN)
1574 SETi( -(IV)result );
1575 else {
1576 /* result valid, but out of range for IV. */
1577 SETn( -(NV)result );
1578 }
1579 }
1580 RETURN;
1581 } /* Overflow, drop through to NVs. */
1582 }
1583 }
1584 #endif
1585 useleft = USE_LEFT(TOPm1s);
1586 {
1587 dPOPnv;
1588 if (!useleft) {
1589 /* left operand is undef, treat as zero - value */
1590 SETn(-value);
1591 RETURN;
1592 }
1593 SETn( TOPn - value );
1594 RETURN;
1595 }
1596 }
1597
PP(pp_left_shift)1598 PP(pp_left_shift)
1599 {
1600 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1601 {
1602 IV shift = POPi;
1603 if (PL_op->op_private & HINT_INTEGER) {
1604 IV i = TOPi;
1605 SETi(i << shift);
1606 }
1607 else {
1608 UV u = TOPu;
1609 SETu(u << shift);
1610 }
1611 RETURN;
1612 }
1613 }
1614
PP(pp_right_shift)1615 PP(pp_right_shift)
1616 {
1617 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1618 {
1619 IV shift = POPi;
1620 if (PL_op->op_private & HINT_INTEGER) {
1621 IV i = TOPi;
1622 SETi(i >> shift);
1623 }
1624 else {
1625 UV u = TOPu;
1626 SETu(u >> shift);
1627 }
1628 RETURN;
1629 }
1630 }
1631
PP(pp_lt)1632 PP(pp_lt)
1633 {
1634 dSP; tryAMAGICbinSET(lt,0);
1635 #ifdef PERL_PRESERVE_IVUV
1636 SvIV_please(TOPs);
1637 if (SvIOK(TOPs)) {
1638 SvIV_please(TOPm1s);
1639 if (SvIOK(TOPm1s)) {
1640 bool auvok = SvUOK(TOPm1s);
1641 bool buvok = SvUOK(TOPs);
1642
1643 if (!auvok && !buvok) { /* ## IV < IV ## */
1644 IV aiv = SvIVX(TOPm1s);
1645 IV biv = SvIVX(TOPs);
1646
1647 SP--;
1648 SETs(boolSV(aiv < biv));
1649 RETURN;
1650 }
1651 if (auvok && buvok) { /* ## UV < UV ## */
1652 UV auv = SvUVX(TOPm1s);
1653 UV buv = SvUVX(TOPs);
1654
1655 SP--;
1656 SETs(boolSV(auv < buv));
1657 RETURN;
1658 }
1659 if (auvok) { /* ## UV < IV ## */
1660 UV auv;
1661 IV biv;
1662
1663 biv = SvIVX(TOPs);
1664 SP--;
1665 if (biv < 0) {
1666 /* As (a) is a UV, it's >=0, so it cannot be < */
1667 SETs(&PL_sv_no);
1668 RETURN;
1669 }
1670 auv = SvUVX(TOPs);
1671 SETs(boolSV(auv < (UV)biv));
1672 RETURN;
1673 }
1674 { /* ## IV < UV ## */
1675 IV aiv;
1676 UV buv;
1677
1678 aiv = SvIVX(TOPm1s);
1679 if (aiv < 0) {
1680 /* As (b) is a UV, it's >=0, so it must be < */
1681 SP--;
1682 SETs(&PL_sv_yes);
1683 RETURN;
1684 }
1685 buv = SvUVX(TOPs);
1686 SP--;
1687 SETs(boolSV((UV)aiv < buv));
1688 RETURN;
1689 }
1690 }
1691 }
1692 #endif
1693 #ifndef NV_PRESERVES_UV
1694 #ifdef PERL_PRESERVE_IVUV
1695 else
1696 #endif
1697 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1698 SP--;
1699 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1700 RETURN;
1701 }
1702 #endif
1703 {
1704 dPOPnv;
1705 SETs(boolSV(TOPn < value));
1706 RETURN;
1707 }
1708 }
1709
PP(pp_gt)1710 PP(pp_gt)
1711 {
1712 dSP; tryAMAGICbinSET(gt,0);
1713 #ifdef PERL_PRESERVE_IVUV
1714 SvIV_please(TOPs);
1715 if (SvIOK(TOPs)) {
1716 SvIV_please(TOPm1s);
1717 if (SvIOK(TOPm1s)) {
1718 bool auvok = SvUOK(TOPm1s);
1719 bool buvok = SvUOK(TOPs);
1720
1721 if (!auvok && !buvok) { /* ## IV > IV ## */
1722 IV aiv = SvIVX(TOPm1s);
1723 IV biv = SvIVX(TOPs);
1724
1725 SP--;
1726 SETs(boolSV(aiv > biv));
1727 RETURN;
1728 }
1729 if (auvok && buvok) { /* ## UV > UV ## */
1730 UV auv = SvUVX(TOPm1s);
1731 UV buv = SvUVX(TOPs);
1732
1733 SP--;
1734 SETs(boolSV(auv > buv));
1735 RETURN;
1736 }
1737 if (auvok) { /* ## UV > IV ## */
1738 UV auv;
1739 IV biv;
1740
1741 biv = SvIVX(TOPs);
1742 SP--;
1743 if (biv < 0) {
1744 /* As (a) is a UV, it's >=0, so it must be > */
1745 SETs(&PL_sv_yes);
1746 RETURN;
1747 }
1748 auv = SvUVX(TOPs);
1749 SETs(boolSV(auv > (UV)biv));
1750 RETURN;
1751 }
1752 { /* ## IV > UV ## */
1753 IV aiv;
1754 UV buv;
1755
1756 aiv = SvIVX(TOPm1s);
1757 if (aiv < 0) {
1758 /* As (b) is a UV, it's >=0, so it cannot be > */
1759 SP--;
1760 SETs(&PL_sv_no);
1761 RETURN;
1762 }
1763 buv = SvUVX(TOPs);
1764 SP--;
1765 SETs(boolSV((UV)aiv > buv));
1766 RETURN;
1767 }
1768 }
1769 }
1770 #endif
1771 #ifndef NV_PRESERVES_UV
1772 #ifdef PERL_PRESERVE_IVUV
1773 else
1774 #endif
1775 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1776 SP--;
1777 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1778 RETURN;
1779 }
1780 #endif
1781 {
1782 dPOPnv;
1783 SETs(boolSV(TOPn > value));
1784 RETURN;
1785 }
1786 }
1787
PP(pp_le)1788 PP(pp_le)
1789 {
1790 dSP; tryAMAGICbinSET(le,0);
1791 #ifdef PERL_PRESERVE_IVUV
1792 SvIV_please(TOPs);
1793 if (SvIOK(TOPs)) {
1794 SvIV_please(TOPm1s);
1795 if (SvIOK(TOPm1s)) {
1796 bool auvok = SvUOK(TOPm1s);
1797 bool buvok = SvUOK(TOPs);
1798
1799 if (!auvok && !buvok) { /* ## IV <= IV ## */
1800 IV aiv = SvIVX(TOPm1s);
1801 IV biv = SvIVX(TOPs);
1802
1803 SP--;
1804 SETs(boolSV(aiv <= biv));
1805 RETURN;
1806 }
1807 if (auvok && buvok) { /* ## UV <= UV ## */
1808 UV auv = SvUVX(TOPm1s);
1809 UV buv = SvUVX(TOPs);
1810
1811 SP--;
1812 SETs(boolSV(auv <= buv));
1813 RETURN;
1814 }
1815 if (auvok) { /* ## UV <= IV ## */
1816 UV auv;
1817 IV biv;
1818
1819 biv = SvIVX(TOPs);
1820 SP--;
1821 if (biv < 0) {
1822 /* As (a) is a UV, it's >=0, so a cannot be <= */
1823 SETs(&PL_sv_no);
1824 RETURN;
1825 }
1826 auv = SvUVX(TOPs);
1827 SETs(boolSV(auv <= (UV)biv));
1828 RETURN;
1829 }
1830 { /* ## IV <= UV ## */
1831 IV aiv;
1832 UV buv;
1833
1834 aiv = SvIVX(TOPm1s);
1835 if (aiv < 0) {
1836 /* As (b) is a UV, it's >=0, so a must be <= */
1837 SP--;
1838 SETs(&PL_sv_yes);
1839 RETURN;
1840 }
1841 buv = SvUVX(TOPs);
1842 SP--;
1843 SETs(boolSV((UV)aiv <= buv));
1844 RETURN;
1845 }
1846 }
1847 }
1848 #endif
1849 #ifndef NV_PRESERVES_UV
1850 #ifdef PERL_PRESERVE_IVUV
1851 else
1852 #endif
1853 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1854 SP--;
1855 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1856 RETURN;
1857 }
1858 #endif
1859 {
1860 dPOPnv;
1861 SETs(boolSV(TOPn <= value));
1862 RETURN;
1863 }
1864 }
1865
PP(pp_ge)1866 PP(pp_ge)
1867 {
1868 dSP; tryAMAGICbinSET(ge,0);
1869 #ifdef PERL_PRESERVE_IVUV
1870 SvIV_please(TOPs);
1871 if (SvIOK(TOPs)) {
1872 SvIV_please(TOPm1s);
1873 if (SvIOK(TOPm1s)) {
1874 bool auvok = SvUOK(TOPm1s);
1875 bool buvok = SvUOK(TOPs);
1876
1877 if (!auvok && !buvok) { /* ## IV >= IV ## */
1878 IV aiv = SvIVX(TOPm1s);
1879 IV biv = SvIVX(TOPs);
1880
1881 SP--;
1882 SETs(boolSV(aiv >= biv));
1883 RETURN;
1884 }
1885 if (auvok && buvok) { /* ## UV >= UV ## */
1886 UV auv = SvUVX(TOPm1s);
1887 UV buv = SvUVX(TOPs);
1888
1889 SP--;
1890 SETs(boolSV(auv >= buv));
1891 RETURN;
1892 }
1893 if (auvok) { /* ## UV >= IV ## */
1894 UV auv;
1895 IV biv;
1896
1897 biv = SvIVX(TOPs);
1898 SP--;
1899 if (biv < 0) {
1900 /* As (a) is a UV, it's >=0, so it must be >= */
1901 SETs(&PL_sv_yes);
1902 RETURN;
1903 }
1904 auv = SvUVX(TOPs);
1905 SETs(boolSV(auv >= (UV)biv));
1906 RETURN;
1907 }
1908 { /* ## IV >= UV ## */
1909 IV aiv;
1910 UV buv;
1911
1912 aiv = SvIVX(TOPm1s);
1913 if (aiv < 0) {
1914 /* As (b) is a UV, it's >=0, so a cannot be >= */
1915 SP--;
1916 SETs(&PL_sv_no);
1917 RETURN;
1918 }
1919 buv = SvUVX(TOPs);
1920 SP--;
1921 SETs(boolSV((UV)aiv >= buv));
1922 RETURN;
1923 }
1924 }
1925 }
1926 #endif
1927 #ifndef NV_PRESERVES_UV
1928 #ifdef PERL_PRESERVE_IVUV
1929 else
1930 #endif
1931 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1932 SP--;
1933 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1934 RETURN;
1935 }
1936 #endif
1937 {
1938 dPOPnv;
1939 SETs(boolSV(TOPn >= value));
1940 RETURN;
1941 }
1942 }
1943
PP(pp_ne)1944 PP(pp_ne)
1945 {
1946 dSP; tryAMAGICbinSET(ne,0);
1947 #ifndef NV_PRESERVES_UV
1948 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1949 SP--;
1950 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1951 RETURN;
1952 }
1953 #endif
1954 #ifdef PERL_PRESERVE_IVUV
1955 SvIV_please(TOPs);
1956 if (SvIOK(TOPs)) {
1957 SvIV_please(TOPm1s);
1958 if (SvIOK(TOPm1s)) {
1959 bool auvok = SvUOK(TOPm1s);
1960 bool buvok = SvUOK(TOPs);
1961
1962 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1963 /* Casting IV to UV before comparison isn't going to matter
1964 on 2s complement. On 1s complement or sign&magnitude
1965 (if we have any of them) it could make negative zero
1966 differ from normal zero. As I understand it. (Need to
1967 check - is negative zero implementation defined behaviour
1968 anyway?). NWC */
1969 UV buv = SvUVX(POPs);
1970 UV auv = SvUVX(TOPs);
1971
1972 SETs(boolSV(auv != buv));
1973 RETURN;
1974 }
1975 { /* ## Mixed IV,UV ## */
1976 IV iv;
1977 UV uv;
1978
1979 /* != is commutative so swap if needed (save code) */
1980 if (auvok) {
1981 /* swap. top of stack (b) is the iv */
1982 iv = SvIVX(TOPs);
1983 SP--;
1984 if (iv < 0) {
1985 /* As (a) is a UV, it's >0, so it cannot be == */
1986 SETs(&PL_sv_yes);
1987 RETURN;
1988 }
1989 uv = SvUVX(TOPs);
1990 } else {
1991 iv = SvIVX(TOPm1s);
1992 SP--;
1993 if (iv < 0) {
1994 /* As (b) is a UV, it's >0, so it cannot be == */
1995 SETs(&PL_sv_yes);
1996 RETURN;
1997 }
1998 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1999 }
2000 SETs(boolSV((UV)iv != uv));
2001 RETURN;
2002 }
2003 }
2004 }
2005 #endif
2006 {
2007 dPOPnv;
2008 SETs(boolSV(TOPn != value));
2009 RETURN;
2010 }
2011 }
2012
PP(pp_ncmp)2013 PP(pp_ncmp)
2014 {
2015 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2016 #ifndef NV_PRESERVES_UV
2017 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2018 UV right = PTR2UV(SvRV(POPs));
2019 UV left = PTR2UV(SvRV(TOPs));
2020 SETi((left > right) - (left < right));
2021 RETURN;
2022 }
2023 #endif
2024 #ifdef PERL_PRESERVE_IVUV
2025 /* Fortunately it seems NaN isn't IOK */
2026 SvIV_please(TOPs);
2027 if (SvIOK(TOPs)) {
2028 SvIV_please(TOPm1s);
2029 if (SvIOK(TOPm1s)) {
2030 bool leftuvok = SvUOK(TOPm1s);
2031 bool rightuvok = SvUOK(TOPs);
2032 I32 value;
2033 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2034 IV leftiv = SvIVX(TOPm1s);
2035 IV rightiv = SvIVX(TOPs);
2036
2037 if (leftiv > rightiv)
2038 value = 1;
2039 else if (leftiv < rightiv)
2040 value = -1;
2041 else
2042 value = 0;
2043 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2044 UV leftuv = SvUVX(TOPm1s);
2045 UV rightuv = SvUVX(TOPs);
2046
2047 if (leftuv > rightuv)
2048 value = 1;
2049 else if (leftuv < rightuv)
2050 value = -1;
2051 else
2052 value = 0;
2053 } else if (leftuvok) { /* ## UV <=> IV ## */
2054 UV leftuv;
2055 IV rightiv;
2056
2057 rightiv = SvIVX(TOPs);
2058 if (rightiv < 0) {
2059 /* As (a) is a UV, it's >=0, so it cannot be < */
2060 value = 1;
2061 } else {
2062 leftuv = SvUVX(TOPm1s);
2063 if (leftuv > (UV)rightiv) {
2064 value = 1;
2065 } else if (leftuv < (UV)rightiv) {
2066 value = -1;
2067 } else {
2068 value = 0;
2069 }
2070 }
2071 } else { /* ## IV <=> UV ## */
2072 IV leftiv;
2073 UV rightuv;
2074
2075 leftiv = SvIVX(TOPm1s);
2076 if (leftiv < 0) {
2077 /* As (b) is a UV, it's >=0, so it must be < */
2078 value = -1;
2079 } else {
2080 rightuv = SvUVX(TOPs);
2081 if ((UV)leftiv > rightuv) {
2082 value = 1;
2083 } else if ((UV)leftiv < rightuv) {
2084 value = -1;
2085 } else {
2086 value = 0;
2087 }
2088 }
2089 }
2090 SP--;
2091 SETi(value);
2092 RETURN;
2093 }
2094 }
2095 #endif
2096 {
2097 dPOPTOPnnrl;
2098 I32 value;
2099
2100 #ifdef Perl_isnan
2101 if (Perl_isnan(left) || Perl_isnan(right)) {
2102 SETs(&PL_sv_undef);
2103 RETURN;
2104 }
2105 value = (left > right) - (left < right);
2106 #else
2107 if (left == right)
2108 value = 0;
2109 else if (left < right)
2110 value = -1;
2111 else if (left > right)
2112 value = 1;
2113 else {
2114 SETs(&PL_sv_undef);
2115 RETURN;
2116 }
2117 #endif
2118 SETi(value);
2119 RETURN;
2120 }
2121 }
2122
PP(pp_slt)2123 PP(pp_slt)
2124 {
2125 dSP; tryAMAGICbinSET(slt,0);
2126 {
2127 dPOPTOPssrl;
2128 int cmp = (IN_LOCALE_RUNTIME
2129 ? sv_cmp_locale(left, right)
2130 : sv_cmp(left, right));
2131 SETs(boolSV(cmp < 0));
2132 RETURN;
2133 }
2134 }
2135
PP(pp_sgt)2136 PP(pp_sgt)
2137 {
2138 dSP; tryAMAGICbinSET(sgt,0);
2139 {
2140 dPOPTOPssrl;
2141 int cmp = (IN_LOCALE_RUNTIME
2142 ? sv_cmp_locale(left, right)
2143 : sv_cmp(left, right));
2144 SETs(boolSV(cmp > 0));
2145 RETURN;
2146 }
2147 }
2148
PP(pp_sle)2149 PP(pp_sle)
2150 {
2151 dSP; tryAMAGICbinSET(sle,0);
2152 {
2153 dPOPTOPssrl;
2154 int cmp = (IN_LOCALE_RUNTIME
2155 ? sv_cmp_locale(left, right)
2156 : sv_cmp(left, right));
2157 SETs(boolSV(cmp <= 0));
2158 RETURN;
2159 }
2160 }
2161
PP(pp_sge)2162 PP(pp_sge)
2163 {
2164 dSP; tryAMAGICbinSET(sge,0);
2165 {
2166 dPOPTOPssrl;
2167 int cmp = (IN_LOCALE_RUNTIME
2168 ? sv_cmp_locale(left, right)
2169 : sv_cmp(left, right));
2170 SETs(boolSV(cmp >= 0));
2171 RETURN;
2172 }
2173 }
2174
PP(pp_seq)2175 PP(pp_seq)
2176 {
2177 dSP; tryAMAGICbinSET(seq,0);
2178 {
2179 dPOPTOPssrl;
2180 SETs(boolSV(sv_eq(left, right)));
2181 RETURN;
2182 }
2183 }
2184
PP(pp_sne)2185 PP(pp_sne)
2186 {
2187 dSP; tryAMAGICbinSET(sne,0);
2188 {
2189 dPOPTOPssrl;
2190 SETs(boolSV(!sv_eq(left, right)));
2191 RETURN;
2192 }
2193 }
2194
PP(pp_scmp)2195 PP(pp_scmp)
2196 {
2197 dSP; dTARGET; tryAMAGICbin(scmp,0);
2198 {
2199 dPOPTOPssrl;
2200 int cmp = (IN_LOCALE_RUNTIME
2201 ? sv_cmp_locale(left, right)
2202 : sv_cmp(left, right));
2203 SETi( cmp );
2204 RETURN;
2205 }
2206 }
2207
PP(pp_bit_and)2208 PP(pp_bit_and)
2209 {
2210 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2211 {
2212 dPOPTOPssrl;
2213 if (SvNIOKp(left) || SvNIOKp(right)) {
2214 if (PL_op->op_private & HINT_INTEGER) {
2215 IV i = SvIV(left) & SvIV(right);
2216 SETi(i);
2217 }
2218 else {
2219 UV u = SvUV(left) & SvUV(right);
2220 SETu(u);
2221 }
2222 }
2223 else {
2224 do_vop(PL_op->op_type, TARG, left, right);
2225 SETTARG;
2226 }
2227 RETURN;
2228 }
2229 }
2230
PP(pp_bit_xor)2231 PP(pp_bit_xor)
2232 {
2233 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2234 {
2235 dPOPTOPssrl;
2236 if (SvNIOKp(left) || SvNIOKp(right)) {
2237 if (PL_op->op_private & HINT_INTEGER) {
2238 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2239 SETi(i);
2240 }
2241 else {
2242 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2243 SETu(u);
2244 }
2245 }
2246 else {
2247 do_vop(PL_op->op_type, TARG, left, right);
2248 SETTARG;
2249 }
2250 RETURN;
2251 }
2252 }
2253
PP(pp_bit_or)2254 PP(pp_bit_or)
2255 {
2256 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2257 {
2258 dPOPTOPssrl;
2259 if (SvNIOKp(left) || SvNIOKp(right)) {
2260 if (PL_op->op_private & HINT_INTEGER) {
2261 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2262 SETi(i);
2263 }
2264 else {
2265 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2266 SETu(u);
2267 }
2268 }
2269 else {
2270 do_vop(PL_op->op_type, TARG, left, right);
2271 SETTARG;
2272 }
2273 RETURN;
2274 }
2275 }
2276
PP(pp_negate)2277 PP(pp_negate)
2278 {
2279 dSP; dTARGET; tryAMAGICun(neg);
2280 {
2281 dTOPss;
2282 int flags = SvFLAGS(sv);
2283 if (SvGMAGICAL(sv))
2284 mg_get(sv);
2285 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2286 /* It's publicly an integer, or privately an integer-not-float */
2287 oops_its_an_int:
2288 if (SvIsUV(sv)) {
2289 if (SvIVX(sv) == IV_MIN) {
2290 /* 2s complement assumption. */
2291 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2292 RETURN;
2293 }
2294 else if (SvUVX(sv) <= IV_MAX) {
2295 SETi(-SvIVX(sv));
2296 RETURN;
2297 }
2298 }
2299 else if (SvIVX(sv) != IV_MIN) {
2300 SETi(-SvIVX(sv));
2301 RETURN;
2302 }
2303 #ifdef PERL_PRESERVE_IVUV
2304 else {
2305 SETu((UV)IV_MIN);
2306 RETURN;
2307 }
2308 #endif
2309 }
2310 if (SvNIOKp(sv))
2311 SETn(-SvNV(sv));
2312 else if (SvPOKp(sv)) {
2313 STRLEN len;
2314 char *s = SvPV(sv, len);
2315 if (isIDFIRST(*s)) {
2316 sv_setpvn(TARG, "-", 1);
2317 sv_catsv(TARG, sv);
2318 }
2319 else if (*s == '+' || *s == '-') {
2320 sv_setsv(TARG, sv);
2321 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2322 }
2323 else if (DO_UTF8(sv)) {
2324 SvIV_please(sv);
2325 if (SvIOK(sv))
2326 goto oops_its_an_int;
2327 if (SvNOK(sv))
2328 sv_setnv(TARG, -SvNV(sv));
2329 else {
2330 sv_setpvn(TARG, "-", 1);
2331 sv_catsv(TARG, sv);
2332 }
2333 }
2334 else {
2335 SvIV_please(sv);
2336 if (SvIOK(sv))
2337 goto oops_its_an_int;
2338 sv_setnv(TARG, -SvNV(sv));
2339 }
2340 SETTARG;
2341 }
2342 else
2343 SETn(-SvNV(sv));
2344 }
2345 RETURN;
2346 }
2347
PP(pp_not)2348 PP(pp_not)
2349 {
2350 dSP; tryAMAGICunSET(not);
2351 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2352 return NORMAL;
2353 }
2354
PP(pp_complement)2355 PP(pp_complement)
2356 {
2357 dSP; dTARGET; tryAMAGICun(compl);
2358 {
2359 dTOPss;
2360 if (SvNIOKp(sv)) {
2361 if (PL_op->op_private & HINT_INTEGER) {
2362 IV i = ~SvIV(sv);
2363 SETi(i);
2364 }
2365 else {
2366 UV u = ~SvUV(sv);
2367 SETu(u);
2368 }
2369 }
2370 else {
2371 register U8 *tmps;
2372 register I32 anum;
2373 STRLEN len;
2374
2375 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2376 SvSetSV(TARG, sv);
2377 tmps = (U8*)SvPV_force(TARG, len);
2378 anum = len;
2379 if (SvUTF8(TARG)) {
2380 /* Calculate exact length, let's not estimate. */
2381 STRLEN targlen = 0;
2382 U8 *result;
2383 U8 *send;
2384 STRLEN l;
2385 UV nchar = 0;
2386 UV nwide = 0;
2387
2388 send = tmps + len;
2389 while (tmps < send) {
2390 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2391 tmps += UTF8SKIP(tmps);
2392 targlen += UNISKIP(~c);
2393 nchar++;
2394 if (c > 0xff)
2395 nwide++;
2396 }
2397
2398 /* Now rewind strings and write them. */
2399 tmps -= len;
2400
2401 if (nwide) {
2402 Newz(0, result, targlen + 1, U8);
2403 while (tmps < send) {
2404 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2405 tmps += UTF8SKIP(tmps);
2406 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2407 }
2408 *result = '\0';
2409 result -= targlen;
2410 sv_setpvn(TARG, (char*)result, targlen);
2411 SvUTF8_on(TARG);
2412 }
2413 else {
2414 Newz(0, result, nchar + 1, U8);
2415 while (tmps < send) {
2416 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2417 tmps += UTF8SKIP(tmps);
2418 *result++ = ~c;
2419 }
2420 *result = '\0';
2421 result -= nchar;
2422 sv_setpvn(TARG, (char*)result, nchar);
2423 SvUTF8_off(TARG);
2424 }
2425 Safefree(result);
2426 SETs(TARG);
2427 RETURN;
2428 }
2429 #ifdef LIBERAL
2430 {
2431 register long *tmpl;
2432 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2433 *tmps = ~*tmps;
2434 tmpl = (long*)tmps;
2435 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2436 *tmpl = ~*tmpl;
2437 tmps = (U8*)tmpl;
2438 }
2439 #endif
2440 for ( ; anum > 0; anum--, tmps++)
2441 *tmps = ~*tmps;
2442
2443 SETs(TARG);
2444 }
2445 RETURN;
2446 }
2447 }
2448
2449 /* integer versions of some of the above */
2450
PP(pp_i_multiply)2451 PP(pp_i_multiply)
2452 {
2453 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2454 {
2455 dPOPTOPiirl;
2456 SETi( left * right );
2457 RETURN;
2458 }
2459 }
2460
PP(pp_i_divide)2461 PP(pp_i_divide)
2462 {
2463 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2464 {
2465 dPOPiv;
2466 if (value == 0)
2467 DIE(aTHX_ "Illegal division by zero");
2468 value = POPi / value;
2469 PUSHi( value );
2470 RETURN;
2471 }
2472 }
2473
2474 STATIC
PP(pp_i_modulo_0)2475 PP(pp_i_modulo_0)
2476 {
2477 /* This is the vanilla old i_modulo. */
2478 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2479 {
2480 dPOPTOPiirl;
2481 if (!right)
2482 DIE(aTHX_ "Illegal modulus zero");
2483 SETi( left % right );
2484 RETURN;
2485 }
2486 }
2487
2488 #if defined(__GLIBC__) && IVSIZE == 8
2489 STATIC
PP(pp_i_modulo_1)2490 PP(pp_i_modulo_1)
2491 {
2492 /* This is the i_modulo with the workaround for the _moddi3 bug
2493 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2494 * See below for pp_i_modulo. */
2495 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2496 {
2497 dPOPTOPiirl;
2498 if (!right)
2499 DIE(aTHX_ "Illegal modulus zero");
2500 SETi( left % PERL_ABS(right) );
2501 RETURN;
2502 }
2503 }
2504 #endif
2505
PP(pp_i_modulo)2506 PP(pp_i_modulo)
2507 {
2508 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2509 {
2510 dPOPTOPiirl;
2511 if (!right)
2512 DIE(aTHX_ "Illegal modulus zero");
2513 /* The assumption is to use hereafter the old vanilla version... */
2514 PL_op->op_ppaddr =
2515 PL_ppaddr[OP_I_MODULO] =
2516 &Perl_pp_i_modulo_0;
2517 /* .. but if we have glibc, we might have a buggy _moddi3
2518 * (at least glicb 2.2.5 is known to have this bug), in other
2519 * words our integer modulus with negative quad as the second
2520 * argument might be broken. Test for this and re-patch the
2521 * opcode dispatch table if that is the case, remembering to
2522 * also apply the workaround so that this first round works
2523 * right, too. See [perl #9402] for more information. */
2524 #if defined(__GLIBC__) && IVSIZE == 8
2525 {
2526 IV l = 3;
2527 IV r = -10;
2528 /* Cannot do this check with inlined IV constants since
2529 * that seems to work correctly even with the buggy glibc. */
2530 if (l % r == -3) {
2531 /* Yikes, we have the bug.
2532 * Patch in the workaround version. */
2533 PL_op->op_ppaddr =
2534 PL_ppaddr[OP_I_MODULO] =
2535 &Perl_pp_i_modulo_1;
2536 /* Make certain we work right this time, too. */
2537 right = PERL_ABS(right);
2538 }
2539 }
2540 #endif
2541 SETi( left % right );
2542 RETURN;
2543 }
2544 }
2545
PP(pp_i_add)2546 PP(pp_i_add)
2547 {
2548 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2549 {
2550 dPOPTOPiirl_ul;
2551 SETi( left + right );
2552 RETURN;
2553 }
2554 }
2555
PP(pp_i_subtract)2556 PP(pp_i_subtract)
2557 {
2558 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2559 {
2560 dPOPTOPiirl_ul;
2561 SETi( left - right );
2562 RETURN;
2563 }
2564 }
2565
PP(pp_i_lt)2566 PP(pp_i_lt)
2567 {
2568 dSP; tryAMAGICbinSET(lt,0);
2569 {
2570 dPOPTOPiirl;
2571 SETs(boolSV(left < right));
2572 RETURN;
2573 }
2574 }
2575
PP(pp_i_gt)2576 PP(pp_i_gt)
2577 {
2578 dSP; tryAMAGICbinSET(gt,0);
2579 {
2580 dPOPTOPiirl;
2581 SETs(boolSV(left > right));
2582 RETURN;
2583 }
2584 }
2585
PP(pp_i_le)2586 PP(pp_i_le)
2587 {
2588 dSP; tryAMAGICbinSET(le,0);
2589 {
2590 dPOPTOPiirl;
2591 SETs(boolSV(left <= right));
2592 RETURN;
2593 }
2594 }
2595
PP(pp_i_ge)2596 PP(pp_i_ge)
2597 {
2598 dSP; tryAMAGICbinSET(ge,0);
2599 {
2600 dPOPTOPiirl;
2601 SETs(boolSV(left >= right));
2602 RETURN;
2603 }
2604 }
2605
PP(pp_i_eq)2606 PP(pp_i_eq)
2607 {
2608 dSP; tryAMAGICbinSET(eq,0);
2609 {
2610 dPOPTOPiirl;
2611 SETs(boolSV(left == right));
2612 RETURN;
2613 }
2614 }
2615
PP(pp_i_ne)2616 PP(pp_i_ne)
2617 {
2618 dSP; tryAMAGICbinSET(ne,0);
2619 {
2620 dPOPTOPiirl;
2621 SETs(boolSV(left != right));
2622 RETURN;
2623 }
2624 }
2625
PP(pp_i_ncmp)2626 PP(pp_i_ncmp)
2627 {
2628 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2629 {
2630 dPOPTOPiirl;
2631 I32 value;
2632
2633 if (left > right)
2634 value = 1;
2635 else if (left < right)
2636 value = -1;
2637 else
2638 value = 0;
2639 SETi(value);
2640 RETURN;
2641 }
2642 }
2643
PP(pp_i_negate)2644 PP(pp_i_negate)
2645 {
2646 dSP; dTARGET; tryAMAGICun(neg);
2647 SETi(-TOPi);
2648 RETURN;
2649 }
2650
2651 /* High falutin' math. */
2652
PP(pp_atan2)2653 PP(pp_atan2)
2654 {
2655 dSP; dTARGET; tryAMAGICbin(atan2,0);
2656 {
2657 dPOPTOPnnrl;
2658 SETn(Perl_atan2(left, right));
2659 RETURN;
2660 }
2661 }
2662
PP(pp_sin)2663 PP(pp_sin)
2664 {
2665 dSP; dTARGET; tryAMAGICun(sin);
2666 {
2667 NV value;
2668 value = POPn;
2669 value = Perl_sin(value);
2670 XPUSHn(value);
2671 RETURN;
2672 }
2673 }
2674
PP(pp_cos)2675 PP(pp_cos)
2676 {
2677 dSP; dTARGET; tryAMAGICun(cos);
2678 {
2679 NV value;
2680 value = POPn;
2681 value = Perl_cos(value);
2682 XPUSHn(value);
2683 RETURN;
2684 }
2685 }
2686
2687 /* Support Configure command-line overrides for rand() functions.
2688 After 5.005, perhaps we should replace this by Configure support
2689 for drand48(), random(), or rand(). For 5.005, though, maintain
2690 compatibility by calling rand() but allow the user to override it.
2691 See INSTALL for details. --Andy Dougherty 15 July 1998
2692 */
2693 /* Now it's after 5.005, and Configure supports drand48() and random(),
2694 in addition to rand(). So the overrides should not be needed any more.
2695 --Jarkko Hietaniemi 27 September 1998
2696 */
2697
2698 #ifndef HAS_DRAND48_PROTO
2699 extern double drand48 (void);
2700 #endif
2701
PP(pp_rand)2702 PP(pp_rand)
2703 {
2704 dSP; dTARGET;
2705 NV value;
2706 if (MAXARG < 1)
2707 value = 1.0;
2708 else
2709 value = POPn;
2710 if (value == 0.0)
2711 value = 1.0;
2712 if (!PL_srand_called) {
2713 (void)seedDrand01((Rand_seed_t)seed());
2714 PL_srand_called = TRUE;
2715 }
2716 value *= Drand01();
2717 XPUSHn(value);
2718 RETURN;
2719 }
2720
PP(pp_srand)2721 PP(pp_srand)
2722 {
2723 dSP;
2724 UV anum;
2725 if (MAXARG < 1)
2726 anum = seed();
2727 else
2728 anum = POPu;
2729 (void)seedDrand01((Rand_seed_t)anum);
2730 PL_srand_called = TRUE;
2731 EXTEND(SP, 1);
2732 RETPUSHYES;
2733 }
2734
PP(pp_exp)2735 PP(pp_exp)
2736 {
2737 dSP; dTARGET; tryAMAGICun(exp);
2738 {
2739 NV value;
2740 value = POPn;
2741 value = Perl_exp(value);
2742 XPUSHn(value);
2743 RETURN;
2744 }
2745 }
2746
PP(pp_log)2747 PP(pp_log)
2748 {
2749 dSP; dTARGET; tryAMAGICun(log);
2750 {
2751 NV value;
2752 value = POPn;
2753 if (value <= 0.0) {
2754 SET_NUMERIC_STANDARD();
2755 DIE(aTHX_ "Can't take log of %"NVgf, value);
2756 }
2757 value = Perl_log(value);
2758 XPUSHn(value);
2759 RETURN;
2760 }
2761 }
2762
PP(pp_sqrt)2763 PP(pp_sqrt)
2764 {
2765 dSP; dTARGET; tryAMAGICun(sqrt);
2766 {
2767 NV value;
2768 value = POPn;
2769 if (value < 0.0) {
2770 SET_NUMERIC_STANDARD();
2771 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2772 }
2773 value = Perl_sqrt(value);
2774 XPUSHn(value);
2775 RETURN;
2776 }
2777 }
2778
PP(pp_int)2779 PP(pp_int)
2780 {
2781 dSP; dTARGET; tryAMAGICun(int);
2782 {
2783 NV value;
2784 IV iv = TOPi; /* attempt to convert to IV if possible. */
2785 /* XXX it's arguable that compiler casting to IV might be subtly
2786 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2787 else preferring IV has introduced a subtle behaviour change bug. OTOH
2788 relying on floating point to be accurate is a bug. */
2789
2790 if (!SvOK(TOPs))
2791 SETu(0);
2792 else if (SvIOK(TOPs)) {
2793 if (SvIsUV(TOPs)) {
2794 UV uv = TOPu;
2795 SETu(uv);
2796 } else
2797 SETi(iv);
2798 } else {
2799 value = TOPn;
2800 if (value >= 0.0) {
2801 if (value < (NV)UV_MAX + 0.5) {
2802 SETu(U_V(value));
2803 } else {
2804 SETn(Perl_floor(value));
2805 }
2806 }
2807 else {
2808 if (value > (NV)IV_MIN - 0.5) {
2809 SETi(I_V(value));
2810 } else {
2811 SETn(Perl_ceil(value));
2812 }
2813 }
2814 }
2815 }
2816 RETURN;
2817 }
2818
PP(pp_abs)2819 PP(pp_abs)
2820 {
2821 dSP; dTARGET; tryAMAGICun(abs);
2822 {
2823 /* This will cache the NV value if string isn't actually integer */
2824 IV iv = TOPi;
2825
2826 if (!SvOK(TOPs))
2827 SETu(0);
2828 else if (SvIOK(TOPs)) {
2829 /* IVX is precise */
2830 if (SvIsUV(TOPs)) {
2831 SETu(TOPu); /* force it to be numeric only */
2832 } else {
2833 if (iv >= 0) {
2834 SETi(iv);
2835 } else {
2836 if (iv != IV_MIN) {
2837 SETi(-iv);
2838 } else {
2839 /* 2s complement assumption. Also, not really needed as
2840 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2841 SETu(IV_MIN);
2842 }
2843 }
2844 }
2845 } else{
2846 NV value = TOPn;
2847 if (value < 0.0)
2848 value = -value;
2849 SETn(value);
2850 }
2851 }
2852 RETURN;
2853 }
2854
2855
PP(pp_hex)2856 PP(pp_hex)
2857 {
2858 dSP; dTARGET;
2859 char *tmps;
2860 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2861 STRLEN len;
2862 NV result_nv;
2863 UV result_uv;
2864 SV* sv = POPs;
2865
2866 tmps = (SvPVx(sv, len));
2867 if (DO_UTF8(sv)) {
2868 /* If Unicode, try to downgrade
2869 * If not possible, croak. */
2870 SV* tsv = sv_2mortal(newSVsv(sv));
2871
2872 SvUTF8_on(tsv);
2873 sv_utf8_downgrade(tsv, FALSE);
2874 tmps = SvPVX(tsv);
2875 }
2876 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2877 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2878 XPUSHn(result_nv);
2879 }
2880 else {
2881 XPUSHu(result_uv);
2882 }
2883 RETURN;
2884 }
2885
PP(pp_oct)2886 PP(pp_oct)
2887 {
2888 dSP; dTARGET;
2889 char *tmps;
2890 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2891 STRLEN len;
2892 NV result_nv;
2893 UV result_uv;
2894 SV* sv = POPs;
2895
2896 tmps = (SvPVx(sv, len));
2897 if (DO_UTF8(sv)) {
2898 /* If Unicode, try to downgrade
2899 * If not possible, croak. */
2900 SV* tsv = sv_2mortal(newSVsv(sv));
2901
2902 SvUTF8_on(tsv);
2903 sv_utf8_downgrade(tsv, FALSE);
2904 tmps = SvPVX(tsv);
2905 }
2906 while (*tmps && len && isSPACE(*tmps))
2907 tmps++, len--;
2908 if (*tmps == '0')
2909 tmps++, len--;
2910 if (*tmps == 'x')
2911 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2912 else if (*tmps == 'b')
2913 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2914 else
2915 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2916
2917 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2918 XPUSHn(result_nv);
2919 }
2920 else {
2921 XPUSHu(result_uv);
2922 }
2923 RETURN;
2924 }
2925
2926 /* String stuff. */
2927
PP(pp_length)2928 PP(pp_length)
2929 {
2930 dSP; dTARGET;
2931 SV *sv = TOPs;
2932
2933 if (DO_UTF8(sv))
2934 SETi(sv_len_utf8(sv));
2935 else
2936 SETi(sv_len(sv));
2937 RETURN;
2938 }
2939
PP(pp_substr)2940 PP(pp_substr)
2941 {
2942 dSP; dTARGET;
2943 SV *sv;
2944 I32 len = 0;
2945 STRLEN curlen;
2946 STRLEN utf8_curlen;
2947 I32 pos;
2948 I32 rem;
2949 I32 fail;
2950 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2951 char *tmps;
2952 I32 arybase = PL_curcop->cop_arybase;
2953 SV *repl_sv = NULL;
2954 char *repl = 0;
2955 STRLEN repl_len;
2956 int num_args = PL_op->op_private & 7;
2957 bool repl_need_utf8_upgrade = FALSE;
2958 bool repl_is_utf8 = FALSE;
2959
2960 SvTAINTED_off(TARG); /* decontaminate */
2961 SvUTF8_off(TARG); /* decontaminate */
2962 if (num_args > 2) {
2963 if (num_args > 3) {
2964 repl_sv = POPs;
2965 repl = SvPV(repl_sv, repl_len);
2966 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2967 }
2968 len = POPi;
2969 }
2970 pos = POPi;
2971 sv = POPs;
2972 PUTBACK;
2973 if (repl_sv) {
2974 if (repl_is_utf8) {
2975 if (!DO_UTF8(sv))
2976 sv_utf8_upgrade(sv);
2977 }
2978 else if (DO_UTF8(sv))
2979 repl_need_utf8_upgrade = TRUE;
2980 }
2981 tmps = SvPV(sv, curlen);
2982 if (DO_UTF8(sv)) {
2983 utf8_curlen = sv_len_utf8(sv);
2984 if (utf8_curlen == curlen)
2985 utf8_curlen = 0;
2986 else
2987 curlen = utf8_curlen;
2988 }
2989 else
2990 utf8_curlen = 0;
2991
2992 if (pos >= arybase) {
2993 pos -= arybase;
2994 rem = curlen-pos;
2995 fail = rem;
2996 if (num_args > 2) {
2997 if (len < 0) {
2998 rem += len;
2999 if (rem < 0)
3000 rem = 0;
3001 }
3002 else if (rem > len)
3003 rem = len;
3004 }
3005 }
3006 else {
3007 pos += curlen;
3008 if (num_args < 3)
3009 rem = curlen;
3010 else if (len >= 0) {
3011 rem = pos+len;
3012 if (rem > (I32)curlen)
3013 rem = curlen;
3014 }
3015 else {
3016 rem = curlen+len;
3017 if (rem < pos)
3018 rem = pos;
3019 }
3020 if (pos < 0)
3021 pos = 0;
3022 fail = rem;
3023 rem -= pos;
3024 }
3025 if (fail < 0) {
3026 if (lvalue || repl)
3027 Perl_croak(aTHX_ "substr outside of string");
3028 if (ckWARN(WARN_SUBSTR))
3029 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3030 RETPUSHUNDEF;
3031 }
3032 else {
3033 I32 upos = pos;
3034 I32 urem = rem;
3035 if (utf8_curlen)
3036 sv_pos_u2b(sv, &pos, &rem);
3037 tmps += pos;
3038 /* we either return a PV or an LV. If the TARG hasn't been used
3039 * before, or is of that type, reuse it; otherwise use a mortal
3040 * instead. Note that LVs can have an extended lifetime, so also
3041 * dont reuse if refcount > 1 (bug #20933) */
3042 if (SvTYPE(TARG) > SVt_NULL) {
3043 if ( (SvTYPE(TARG) == SVt_PVLV)
3044 ? (!lvalue || SvREFCNT(TARG) > 1)
3045 : lvalue)
3046 {
3047 TARG = sv_newmortal();
3048 }
3049 }
3050
3051 sv_setpvn(TARG, tmps, rem);
3052 #ifdef USE_LOCALE_COLLATE
3053 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3054 #endif
3055 if (utf8_curlen)
3056 SvUTF8_on(TARG);
3057 if (repl) {
3058 SV* repl_sv_copy = NULL;
3059
3060 if (repl_need_utf8_upgrade) {
3061 repl_sv_copy = newSVsv(repl_sv);
3062 sv_utf8_upgrade(repl_sv_copy);
3063 repl = SvPV(repl_sv_copy, repl_len);
3064 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3065 }
3066 sv_insert(sv, pos, rem, repl, repl_len);
3067 if (repl_is_utf8)
3068 SvUTF8_on(sv);
3069 if (repl_sv_copy)
3070 SvREFCNT_dec(repl_sv_copy);
3071 }
3072 else if (lvalue) { /* it's an lvalue! */
3073 if (!SvGMAGICAL(sv)) {
3074 if (SvROK(sv)) {
3075 STRLEN n_a;
3076 SvPV_force(sv,n_a);
3077 if (ckWARN(WARN_SUBSTR))
3078 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3079 "Attempt to use reference as lvalue in substr");
3080 }
3081 if (SvOK(sv)) /* is it defined ? */
3082 (void)SvPOK_only_UTF8(sv);
3083 else
3084 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3085 }
3086
3087 if (SvTYPE(TARG) < SVt_PVLV) {
3088 sv_upgrade(TARG, SVt_PVLV);
3089 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3090 }
3091 else
3092 (void)SvOK_off(TARG);
3093
3094 LvTYPE(TARG) = 'x';
3095 if (LvTARG(TARG) != sv) {
3096 if (LvTARG(TARG))
3097 SvREFCNT_dec(LvTARG(TARG));
3098 LvTARG(TARG) = SvREFCNT_inc(sv);
3099 }
3100 LvTARGOFF(TARG) = upos;
3101 LvTARGLEN(TARG) = urem;
3102 }
3103 }
3104 SPAGAIN;
3105 PUSHs(TARG); /* avoid SvSETMAGIC here */
3106 RETURN;
3107 }
3108
PP(pp_vec)3109 PP(pp_vec)
3110 {
3111 dSP; dTARGET;
3112 register IV size = POPi;
3113 register IV offset = POPi;
3114 register SV *src = POPs;
3115 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3116
3117 SvTAINTED_off(TARG); /* decontaminate */
3118 if (lvalue) { /* it's an lvalue! */
3119 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3120 TARG = sv_newmortal();
3121 if (SvTYPE(TARG) < SVt_PVLV) {
3122 sv_upgrade(TARG, SVt_PVLV);
3123 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3124 }
3125 LvTYPE(TARG) = 'v';
3126 if (LvTARG(TARG) != src) {
3127 if (LvTARG(TARG))
3128 SvREFCNT_dec(LvTARG(TARG));
3129 LvTARG(TARG) = SvREFCNT_inc(src);
3130 }
3131 LvTARGOFF(TARG) = offset;
3132 LvTARGLEN(TARG) = size;
3133 }
3134
3135 sv_setuv(TARG, do_vecget(src, offset, size));
3136 PUSHs(TARG);
3137 RETURN;
3138 }
3139
PP(pp_index)3140 PP(pp_index)
3141 {
3142 dSP; dTARGET;
3143 SV *big;
3144 SV *little;
3145 I32 offset;
3146 I32 retval;
3147 char *tmps;
3148 char *tmps2;
3149 STRLEN biglen;
3150 I32 arybase = PL_curcop->cop_arybase;
3151
3152 if (MAXARG < 3)
3153 offset = 0;
3154 else
3155 offset = POPi - arybase;
3156 little = POPs;
3157 big = POPs;
3158 tmps = SvPV(big, biglen);
3159 if (offset > 0 && DO_UTF8(big))
3160 sv_pos_u2b(big, &offset, 0);
3161 if (offset < 0)
3162 offset = 0;
3163 else if (offset > (I32)biglen)
3164 offset = biglen;
3165 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3166 (unsigned char*)tmps + biglen, little, 0)))
3167 retval = -1;
3168 else
3169 retval = tmps2 - tmps;
3170 if (retval > 0 && DO_UTF8(big))
3171 sv_pos_b2u(big, &retval);
3172 PUSHi(retval + arybase);
3173 RETURN;
3174 }
3175
PP(pp_rindex)3176 PP(pp_rindex)
3177 {
3178 dSP; dTARGET;
3179 SV *big;
3180 SV *little;
3181 STRLEN blen;
3182 STRLEN llen;
3183 I32 offset;
3184 I32 retval;
3185 char *tmps;
3186 char *tmps2;
3187 I32 arybase = PL_curcop->cop_arybase;
3188
3189 if (MAXARG >= 3)
3190 offset = POPi;
3191 little = POPs;
3192 big = POPs;
3193 tmps2 = SvPV(little, llen);
3194 tmps = SvPV(big, blen);
3195 if (MAXARG < 3)
3196 offset = blen;
3197 else {
3198 if (offset > 0 && DO_UTF8(big))
3199 sv_pos_u2b(big, &offset, 0);
3200 offset = offset - arybase + llen;
3201 }
3202 if (offset < 0)
3203 offset = 0;
3204 else if (offset > (I32)blen)
3205 offset = blen;
3206 if (!(tmps2 = rninstr(tmps, tmps + offset,
3207 tmps2, tmps2 + llen)))
3208 retval = -1;
3209 else
3210 retval = tmps2 - tmps;
3211 if (retval > 0 && DO_UTF8(big))
3212 sv_pos_b2u(big, &retval);
3213 PUSHi(retval + arybase);
3214 RETURN;
3215 }
3216
PP(pp_sprintf)3217 PP(pp_sprintf)
3218 {
3219 dSP; dMARK; dORIGMARK; dTARGET;
3220 do_sprintf(TARG, SP-MARK, MARK+1);
3221 TAINT_IF(SvTAINTED(TARG));
3222 if (DO_UTF8(*(MARK+1)))
3223 SvUTF8_on(TARG);
3224 SP = ORIGMARK;
3225 PUSHTARG;
3226 RETURN;
3227 }
3228
PP(pp_ord)3229 PP(pp_ord)
3230 {
3231 dSP; dTARGET;
3232 SV *argsv = POPs;
3233 STRLEN len;
3234 U8 *s = (U8*)SvPVx(argsv, len);
3235 SV *tmpsv;
3236
3237 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3238 tmpsv = sv_2mortal(newSVsv(argsv));
3239 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3240 argsv = tmpsv;
3241 }
3242
3243 XPUSHu(DO_UTF8(argsv) ?
3244 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3245 (*s & 0xff));
3246
3247 RETURN;
3248 }
3249
PP(pp_chr)3250 PP(pp_chr)
3251 {
3252 dSP; dTARGET;
3253 char *tmps;
3254 UV value = POPu;
3255
3256 (void)SvUPGRADE(TARG,SVt_PV);
3257
3258 if (value > 255 && !IN_BYTES) {
3259 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3260 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3261 SvCUR_set(TARG, tmps - SvPVX(TARG));
3262 *tmps = '\0';
3263 (void)SvPOK_only(TARG);
3264 SvUTF8_on(TARG);
3265 XPUSHs(TARG);
3266 RETURN;
3267 }
3268
3269 SvGROW(TARG,2);
3270 SvCUR_set(TARG, 1);
3271 tmps = SvPVX(TARG);
3272 *tmps++ = (char)value;
3273 *tmps = '\0';
3274 (void)SvPOK_only(TARG);
3275 if (PL_encoding && !IN_BYTES) {
3276 sv_recode_to_utf8(TARG, PL_encoding);
3277 tmps = SvPVX(TARG);
3278 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3279 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3280 SvGROW(TARG, 3);
3281 tmps = SvPVX(TARG);
3282 SvCUR_set(TARG, 2);
3283 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3284 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3285 *tmps = '\0';
3286 SvUTF8_on(TARG);
3287 }
3288 }
3289 XPUSHs(TARG);
3290 RETURN;
3291 }
3292
PP(pp_crypt)3293 PP(pp_crypt)
3294 {
3295 dSP; dTARGET;
3296 #ifdef HAS_CRYPT
3297 dPOPTOPssrl;
3298 STRLEN n_a;
3299 STRLEN len;
3300 char *tmps = SvPV(left, len);
3301
3302 if (DO_UTF8(left)) {
3303 /* If Unicode, try to downgrade.
3304 * If not possible, croak.
3305 * Yes, we made this up. */
3306 SV* tsv = sv_2mortal(newSVsv(left));
3307
3308 SvUTF8_on(tsv);
3309 sv_utf8_downgrade(tsv, FALSE);
3310 tmps = SvPVX(tsv);
3311 }
3312 # ifdef USE_ITHREADS
3313 # ifdef HAS_CRYPT_R
3314 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3315 /* This should be threadsafe because in ithreads there is only
3316 * one thread per interpreter. If this would not be true,
3317 * we would need a mutex to protect this malloc. */
3318 PL_reentrant_buffer->_crypt_struct_buffer =
3319 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3320 #if defined(__GLIBC__) || defined(__EMX__)
3321 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3322 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3323 /* work around glibc-2.2.5 bug */
3324 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3325 }
3326 #endif
3327 }
3328 # endif /* HAS_CRYPT_R */
3329 # endif /* USE_ITHREADS */
3330 # ifdef FCRYPT
3331 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3332 # else
3333 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3334 # endif
3335 SETs(TARG);
3336 RETURN;
3337 #else
3338 DIE(aTHX_
3339 "The crypt() function is unimplemented due to excessive paranoia.");
3340 #endif
3341 }
3342
PP(pp_ucfirst)3343 PP(pp_ucfirst)
3344 {
3345 dSP;
3346 SV *sv = TOPs;
3347 register U8 *s;
3348 STRLEN slen;
3349
3350 SvGETMAGIC(sv);
3351 if (DO_UTF8(sv) &&
3352 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3353 UTF8_IS_START(*s)) {
3354 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3355 STRLEN ulen;
3356 STRLEN tculen;
3357
3358 utf8_to_uvchr(s, &ulen);
3359 toTITLE_utf8(s, tmpbuf, &tculen);
3360 utf8_to_uvchr(tmpbuf, 0);
3361
3362 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3363 dTARGET;
3364 /* slen is the byte length of the whole SV.
3365 * ulen is the byte length of the original Unicode character
3366 * stored as UTF-8 at s.
3367 * tculen is the byte length of the freshly titlecased
3368 * Unicode character stored as UTF-8 at tmpbuf.
3369 * We first set the result to be the titlecased character,
3370 * and then append the rest of the SV data. */
3371 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3372 if (slen > ulen)
3373 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3374 SvUTF8_on(TARG);
3375 SETs(TARG);
3376 }
3377 else {
3378 s = (U8*)SvPV_force_nomg(sv, slen);
3379 Copy(tmpbuf, s, tculen, U8);
3380 }
3381 }
3382 else {
3383 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3384 dTARGET;
3385 SvUTF8_off(TARG); /* decontaminate */
3386 sv_setsv_nomg(TARG, sv);
3387 sv = TARG;
3388 SETs(sv);
3389 }
3390 s = (U8*)SvPV_force_nomg(sv, slen);
3391 if (*s) {
3392 if (IN_LOCALE_RUNTIME) {
3393 TAINT;
3394 SvTAINTED_on(sv);
3395 *s = toUPPER_LC(*s);
3396 }
3397 else
3398 *s = toUPPER(*s);
3399 }
3400 }
3401 SvSETMAGIC(sv);
3402 RETURN;
3403 }
3404
PP(pp_lcfirst)3405 PP(pp_lcfirst)
3406 {
3407 dSP;
3408 SV *sv = TOPs;
3409 register U8 *s;
3410 STRLEN slen;
3411
3412 SvGETMAGIC(sv);
3413 if (DO_UTF8(sv) &&
3414 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3415 UTF8_IS_START(*s)) {
3416 STRLEN ulen;
3417 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3418 U8 *tend;
3419 UV uv;
3420
3421 toLOWER_utf8(s, tmpbuf, &ulen);
3422 uv = utf8_to_uvchr(tmpbuf, 0);
3423 tend = uvchr_to_utf8(tmpbuf, uv);
3424
3425 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3426 dTARGET;
3427 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3428 if (slen > ulen)
3429 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3430 SvUTF8_on(TARG);
3431 SETs(TARG);
3432 }
3433 else {
3434 s = (U8*)SvPV_force_nomg(sv, slen);
3435 Copy(tmpbuf, s, ulen, U8);
3436 }
3437 }
3438 else {
3439 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3440 dTARGET;
3441 SvUTF8_off(TARG); /* decontaminate */
3442 sv_setsv_nomg(TARG, sv);
3443 sv = TARG;
3444 SETs(sv);
3445 }
3446 s = (U8*)SvPV_force_nomg(sv, slen);
3447 if (*s) {
3448 if (IN_LOCALE_RUNTIME) {
3449 TAINT;
3450 SvTAINTED_on(sv);
3451 *s = toLOWER_LC(*s);
3452 }
3453 else
3454 *s = toLOWER(*s);
3455 }
3456 }
3457 SvSETMAGIC(sv);
3458 RETURN;
3459 }
3460
PP(pp_uc)3461 PP(pp_uc)
3462 {
3463 dSP;
3464 SV *sv = TOPs;
3465 register U8 *s;
3466 STRLEN len;
3467
3468 SvGETMAGIC(sv);
3469 if (DO_UTF8(sv)) {
3470 dTARGET;
3471 STRLEN ulen;
3472 register U8 *d;
3473 U8 *send;
3474 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3475
3476 s = (U8*)SvPV_nomg(sv,len);
3477 if (!len) {
3478 SvUTF8_off(TARG); /* decontaminate */
3479 sv_setpvn(TARG, "", 0);
3480 SETs(TARG);
3481 }
3482 else {
3483 STRLEN nchar = utf8_length(s, s + len);
3484
3485 (void)SvUPGRADE(TARG, SVt_PV);
3486 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3487 (void)SvPOK_only(TARG);
3488 d = (U8*)SvPVX(TARG);
3489 send = s + len;
3490 while (s < send) {
3491 toUPPER_utf8(s, tmpbuf, &ulen);
3492 Copy(tmpbuf, d, ulen, U8);
3493 d += ulen;
3494 s += UTF8SKIP(s);
3495 }
3496 *d = '\0';
3497 SvUTF8_on(TARG);
3498 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3499 SETs(TARG);
3500 }
3501 }
3502 else {
3503 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3504 dTARGET;
3505 SvUTF8_off(TARG); /* decontaminate */
3506 sv_setsv_nomg(TARG, sv);
3507 sv = TARG;
3508 SETs(sv);
3509 }
3510 s = (U8*)SvPV_force_nomg(sv, len);
3511 if (len) {
3512 register U8 *send = s + len;
3513
3514 if (IN_LOCALE_RUNTIME) {
3515 TAINT;
3516 SvTAINTED_on(sv);
3517 for (; s < send; s++)
3518 *s = toUPPER_LC(*s);
3519 }
3520 else {
3521 for (; s < send; s++)
3522 *s = toUPPER(*s);
3523 }
3524 }
3525 }
3526 SvSETMAGIC(sv);
3527 RETURN;
3528 }
3529
PP(pp_lc)3530 PP(pp_lc)
3531 {
3532 dSP;
3533 SV *sv = TOPs;
3534 register U8 *s;
3535 STRLEN len;
3536
3537 SvGETMAGIC(sv);
3538 if (DO_UTF8(sv)) {
3539 dTARGET;
3540 STRLEN ulen;
3541 register U8 *d;
3542 U8 *send;
3543 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3544
3545 s = (U8*)SvPV_nomg(sv,len);
3546 if (!len) {
3547 SvUTF8_off(TARG); /* decontaminate */
3548 sv_setpvn(TARG, "", 0);
3549 SETs(TARG);
3550 }
3551 else {
3552 STRLEN nchar = utf8_length(s, s + len);
3553
3554 (void)SvUPGRADE(TARG, SVt_PV);
3555 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3556 (void)SvPOK_only(TARG);
3557 d = (U8*)SvPVX(TARG);
3558 send = s + len;
3559 while (s < send) {
3560 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3561 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3562 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3563 /*
3564 * Now if the sigma is NOT followed by
3565 * /$ignorable_sequence$cased_letter/;
3566 * and it IS preceded by
3567 * /$cased_letter$ignorable_sequence/;
3568 * where $ignorable_sequence is
3569 * [\x{2010}\x{AD}\p{Mn}]*
3570 * and $cased_letter is
3571 * [\p{Ll}\p{Lo}\p{Lt}]
3572 * then it should be mapped to 0x03C2,
3573 * (GREEK SMALL LETTER FINAL SIGMA),
3574 * instead of staying 0x03A3.
3575 * See lib/unicore/SpecCase.txt.
3576 */
3577 }
3578 Copy(tmpbuf, d, ulen, U8);
3579 d += ulen;
3580 s += UTF8SKIP(s);
3581 }
3582 *d = '\0';
3583 SvUTF8_on(TARG);
3584 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3585 SETs(TARG);
3586 }
3587 }
3588 else {
3589 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3590 dTARGET;
3591 SvUTF8_off(TARG); /* decontaminate */
3592 sv_setsv_nomg(TARG, sv);
3593 sv = TARG;
3594 SETs(sv);
3595 }
3596
3597 s = (U8*)SvPV_force_nomg(sv, len);
3598 if (len) {
3599 register U8 *send = s + len;
3600
3601 if (IN_LOCALE_RUNTIME) {
3602 TAINT;
3603 SvTAINTED_on(sv);
3604 for (; s < send; s++)
3605 *s = toLOWER_LC(*s);
3606 }
3607 else {
3608 for (; s < send; s++)
3609 *s = toLOWER(*s);
3610 }
3611 }
3612 }
3613 SvSETMAGIC(sv);
3614 RETURN;
3615 }
3616
PP(pp_quotemeta)3617 PP(pp_quotemeta)
3618 {
3619 dSP; dTARGET;
3620 SV *sv = TOPs;
3621 STRLEN len;
3622 register char *s = SvPV(sv,len);
3623 register char *d;
3624
3625 SvUTF8_off(TARG); /* decontaminate */
3626 if (len) {
3627 (void)SvUPGRADE(TARG, SVt_PV);
3628 SvGROW(TARG, (len * 2) + 1);
3629 d = SvPVX(TARG);
3630 if (DO_UTF8(sv)) {
3631 while (len) {
3632 if (UTF8_IS_CONTINUED(*s)) {
3633 STRLEN ulen = UTF8SKIP(s);
3634 if (ulen > len)
3635 ulen = len;
3636 len -= ulen;
3637 while (ulen--)
3638 *d++ = *s++;
3639 }
3640 else {
3641 if (!isALNUM(*s))
3642 *d++ = '\\';
3643 *d++ = *s++;
3644 len--;
3645 }
3646 }
3647 SvUTF8_on(TARG);
3648 }
3649 else {
3650 while (len--) {
3651 if (!isALNUM(*s))
3652 *d++ = '\\';
3653 *d++ = *s++;
3654 }
3655 }
3656 *d = '\0';
3657 SvCUR_set(TARG, d - SvPVX(TARG));
3658 (void)SvPOK_only_UTF8(TARG);
3659 }
3660 else
3661 sv_setpvn(TARG, s, len);
3662 SETs(TARG);
3663 if (SvSMAGICAL(TARG))
3664 mg_set(TARG);
3665 RETURN;
3666 }
3667
3668 /* Arrays. */
3669
PP(pp_aslice)3670 PP(pp_aslice)
3671 {
3672 dSP; dMARK; dORIGMARK;
3673 register SV** svp;
3674 register AV* av = (AV*)POPs;
3675 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3676 I32 arybase = PL_curcop->cop_arybase;
3677 I32 elem;
3678
3679 if (SvTYPE(av) == SVt_PVAV) {
3680 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3681 I32 max = -1;
3682 for (svp = MARK + 1; svp <= SP; svp++) {
3683 elem = SvIVx(*svp);
3684 if (elem > max)
3685 max = elem;
3686 }
3687 if (max > AvMAX(av))
3688 av_extend(av, max);
3689 }
3690 while (++MARK <= SP) {
3691 elem = SvIVx(*MARK);
3692
3693 if (elem > 0)
3694 elem -= arybase;
3695 svp = av_fetch(av, elem, lval);
3696 if (lval) {
3697 if (!svp || *svp == &PL_sv_undef)
3698 DIE(aTHX_ PL_no_aelem, elem);
3699 if (PL_op->op_private & OPpLVAL_INTRO)
3700 save_aelem(av, elem, svp);
3701 }
3702 *MARK = svp ? *svp : &PL_sv_undef;
3703 }
3704 }
3705 if (GIMME != G_ARRAY) {
3706 MARK = ORIGMARK;
3707 *++MARK = *SP;
3708 SP = MARK;
3709 }
3710 RETURN;
3711 }
3712
3713 /* Associative arrays. */
3714
PP(pp_each)3715 PP(pp_each)
3716 {
3717 dSP;
3718 HV *hash = (HV*)POPs;
3719 HE *entry;
3720 I32 gimme = GIMME_V;
3721 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3722
3723 PUTBACK;
3724 /* might clobber stack_sp */
3725 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3726 SPAGAIN;
3727
3728 EXTEND(SP, 2);
3729 if (entry) {
3730 SV* sv = hv_iterkeysv(entry);
3731 PUSHs(sv); /* won't clobber stack_sp */
3732 if (gimme == G_ARRAY) {
3733 SV *val;
3734 PUTBACK;
3735 /* might clobber stack_sp */
3736 val = realhv ?
3737 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3738 SPAGAIN;
3739 PUSHs(val);
3740 }
3741 }
3742 else if (gimme == G_SCALAR)
3743 RETPUSHUNDEF;
3744
3745 RETURN;
3746 }
3747
PP(pp_values)3748 PP(pp_values)
3749 {
3750 return do_kv();
3751 }
3752
PP(pp_keys)3753 PP(pp_keys)
3754 {
3755 return do_kv();
3756 }
3757
PP(pp_delete)3758 PP(pp_delete)
3759 {
3760 dSP;
3761 I32 gimme = GIMME_V;
3762 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3763 SV *sv;
3764 HV *hv;
3765
3766 if (PL_op->op_private & OPpSLICE) {
3767 dMARK; dORIGMARK;
3768 U32 hvtype;
3769 hv = (HV*)POPs;
3770 hvtype = SvTYPE(hv);
3771 if (hvtype == SVt_PVHV) { /* hash element */
3772 while (++MARK <= SP) {
3773 sv = hv_delete_ent(hv, *MARK, discard, 0);
3774 *MARK = sv ? sv : &PL_sv_undef;
3775 }
3776 }
3777 else if (hvtype == SVt_PVAV) {
3778 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3779 while (++MARK <= SP) {
3780 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3781 *MARK = sv ? sv : &PL_sv_undef;
3782 }
3783 }
3784 else { /* pseudo-hash element */
3785 while (++MARK <= SP) {
3786 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3787 *MARK = sv ? sv : &PL_sv_undef;
3788 }
3789 }
3790 }
3791 else
3792 DIE(aTHX_ "Not a HASH reference");
3793 if (discard)
3794 SP = ORIGMARK;
3795 else if (gimme == G_SCALAR) {
3796 MARK = ORIGMARK;
3797 if (SP > MARK)
3798 *++MARK = *SP;
3799 else
3800 *++MARK = &PL_sv_undef;
3801 SP = MARK;
3802 }
3803 }
3804 else {
3805 SV *keysv = POPs;
3806 hv = (HV*)POPs;
3807 if (SvTYPE(hv) == SVt_PVHV)
3808 sv = hv_delete_ent(hv, keysv, discard, 0);
3809 else if (SvTYPE(hv) == SVt_PVAV) {
3810 if (PL_op->op_flags & OPf_SPECIAL)
3811 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3812 else
3813 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3814 }
3815 else
3816 DIE(aTHX_ "Not a HASH reference");
3817 if (!sv)
3818 sv = &PL_sv_undef;
3819 if (!discard)
3820 PUSHs(sv);
3821 }
3822 RETURN;
3823 }
3824
PP(pp_exists)3825 PP(pp_exists)
3826 {
3827 dSP;
3828 SV *tmpsv;
3829 HV *hv;
3830
3831 if (PL_op->op_private & OPpEXISTS_SUB) {
3832 GV *gv;
3833 CV *cv;
3834 SV *sv = POPs;
3835 cv = sv_2cv(sv, &hv, &gv, FALSE);
3836 if (cv)
3837 RETPUSHYES;
3838 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3839 RETPUSHYES;
3840 RETPUSHNO;
3841 }
3842 tmpsv = POPs;
3843 hv = (HV*)POPs;
3844 if (SvTYPE(hv) == SVt_PVHV) {
3845 if (hv_exists_ent(hv, tmpsv, 0))
3846 RETPUSHYES;
3847 }
3848 else if (SvTYPE(hv) == SVt_PVAV) {
3849 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3850 if (av_exists((AV*)hv, SvIV(tmpsv)))
3851 RETPUSHYES;
3852 }
3853 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3854 RETPUSHYES;
3855 }
3856 else {
3857 DIE(aTHX_ "Not a HASH reference");
3858 }
3859 RETPUSHNO;
3860 }
3861
PP(pp_hslice)3862 PP(pp_hslice)
3863 {
3864 dSP; dMARK; dORIGMARK;
3865 register HV *hv = (HV*)POPs;
3866 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3867 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3868 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3869 bool other_magic = FALSE;
3870
3871 if (localizing) {
3872 MAGIC *mg;
3873 HV *stash;
3874
3875 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3876 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3877 /* Try to preserve the existenceness of a tied hash
3878 * element by using EXISTS and DELETE if possible.
3879 * Fallback to FETCH and STORE otherwise */
3880 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3881 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3882 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3883 }
3884
3885 if (!realhv && localizing)
3886 DIE(aTHX_ "Can't localize pseudo-hash element");
3887
3888 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3889 while (++MARK <= SP) {
3890 SV *keysv = *MARK;
3891 SV **svp;
3892 bool preeminent = FALSE;
3893
3894 if (localizing) {
3895 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3896 realhv ? hv_exists_ent(hv, keysv, 0)
3897 : avhv_exists_ent((AV*)hv, keysv, 0);
3898 }
3899
3900 if (realhv) {
3901 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3902 svp = he ? &HeVAL(he) : 0;
3903 }
3904 else {
3905 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3906 }
3907 if (lval) {
3908 if (!svp || *svp == &PL_sv_undef) {
3909 STRLEN n_a;
3910 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3911 }
3912 if (localizing) {
3913 if (preeminent)
3914 save_helem(hv, keysv, svp);
3915 else {
3916 STRLEN keylen;
3917 char *key = SvPV(keysv, keylen);
3918 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3919 }
3920 }
3921 }
3922 *MARK = svp ? *svp : &PL_sv_undef;
3923 }
3924 }
3925 if (GIMME != G_ARRAY) {
3926 MARK = ORIGMARK;
3927 *++MARK = *SP;
3928 SP = MARK;
3929 }
3930 RETURN;
3931 }
3932
3933 /* List operators. */
3934
PP(pp_list)3935 PP(pp_list)
3936 {
3937 dSP; dMARK;
3938 if (GIMME != G_ARRAY) {
3939 if (++MARK <= SP)
3940 *MARK = *SP; /* unwanted list, return last item */
3941 else
3942 *MARK = &PL_sv_undef;
3943 SP = MARK;
3944 }
3945 RETURN;
3946 }
3947
PP(pp_lslice)3948 PP(pp_lslice)
3949 {
3950 dSP;
3951 SV **lastrelem = PL_stack_sp;
3952 SV **lastlelem = PL_stack_base + POPMARK;
3953 SV **firstlelem = PL_stack_base + POPMARK + 1;
3954 register SV **firstrelem = lastlelem + 1;
3955 I32 arybase = PL_curcop->cop_arybase;
3956 I32 lval = PL_op->op_flags & OPf_MOD;
3957 I32 is_something_there = lval;
3958
3959 register I32 max = lastrelem - lastlelem;
3960 register SV **lelem;
3961 register I32 ix;
3962
3963 if (GIMME != G_ARRAY) {
3964 ix = SvIVx(*lastlelem);
3965 if (ix < 0)
3966 ix += max;
3967 else
3968 ix -= arybase;
3969 if (ix < 0 || ix >= max)
3970 *firstlelem = &PL_sv_undef;
3971 else
3972 *firstlelem = firstrelem[ix];
3973 SP = firstlelem;
3974 RETURN;
3975 }
3976
3977 if (max == 0) {
3978 SP = firstlelem - 1;
3979 RETURN;
3980 }
3981
3982 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3983 ix = SvIVx(*lelem);
3984 if (ix < 0)
3985 ix += max;
3986 else
3987 ix -= arybase;
3988 if (ix < 0 || ix >= max)
3989 *lelem = &PL_sv_undef;
3990 else {
3991 is_something_there = TRUE;
3992 if (!(*lelem = firstrelem[ix]))
3993 *lelem = &PL_sv_undef;
3994 }
3995 }
3996 if (is_something_there)
3997 SP = lastlelem;
3998 else
3999 SP = firstlelem - 1;
4000 RETURN;
4001 }
4002
PP(pp_anonlist)4003 PP(pp_anonlist)
4004 {
4005 dSP; dMARK; dORIGMARK;
4006 I32 items = SP - MARK;
4007 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4008 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4009 XPUSHs(av);
4010 RETURN;
4011 }
4012
PP(pp_anonhash)4013 PP(pp_anonhash)
4014 {
4015 dSP; dMARK; dORIGMARK;
4016 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4017
4018 while (MARK < SP) {
4019 SV* key = *++MARK;
4020 SV *val = NEWSV(46, 0);
4021 if (MARK < SP)
4022 sv_setsv(val, *++MARK);
4023 else if (ckWARN(WARN_MISC))
4024 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4025 (void)hv_store_ent(hv,key,val,0);
4026 }
4027 SP = ORIGMARK;
4028 XPUSHs((SV*)hv);
4029 RETURN;
4030 }
4031
PP(pp_splice)4032 PP(pp_splice)
4033 {
4034 dSP; dMARK; dORIGMARK;
4035 register AV *ary = (AV*)*++MARK;
4036 register SV **src;
4037 register SV **dst;
4038 register I32 i;
4039 register I32 offset;
4040 register I32 length;
4041 I32 newlen;
4042 I32 after;
4043 I32 diff;
4044 SV **tmparyval = 0;
4045 MAGIC *mg;
4046
4047 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4048 *MARK-- = SvTIED_obj((SV*)ary, mg);
4049 PUSHMARK(MARK);
4050 PUTBACK;
4051 ENTER;
4052 call_method("SPLICE",GIMME_V);
4053 LEAVE;
4054 SPAGAIN;
4055 RETURN;
4056 }
4057
4058 SP++;
4059
4060 if (++MARK < SP) {
4061 offset = i = SvIVx(*MARK);
4062 if (offset < 0)
4063 offset += AvFILLp(ary) + 1;
4064 else
4065 offset -= PL_curcop->cop_arybase;
4066 if (offset < 0)
4067 DIE(aTHX_ PL_no_aelem, i);
4068 if (++MARK < SP) {
4069 length = SvIVx(*MARK++);
4070 if (length < 0) {
4071 length += AvFILLp(ary) - offset + 1;
4072 if (length < 0)
4073 length = 0;
4074 }
4075 }
4076 else
4077 length = AvMAX(ary) + 1; /* close enough to infinity */
4078 }
4079 else {
4080 offset = 0;
4081 length = AvMAX(ary) + 1;
4082 }
4083 if (offset > AvFILLp(ary) + 1) {
4084 if (ckWARN(WARN_MISC))
4085 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4086 offset = AvFILLp(ary) + 1;
4087 }
4088 after = AvFILLp(ary) + 1 - (offset + length);
4089 if (after < 0) { /* not that much array */
4090 length += after; /* offset+length now in array */
4091 after = 0;
4092 if (!AvALLOC(ary))
4093 av_extend(ary, 0);
4094 }
4095
4096 /* At this point, MARK .. SP-1 is our new LIST */
4097
4098 newlen = SP - MARK;
4099 diff = newlen - length;
4100 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4101 av_reify(ary);
4102
4103 if (diff < 0) { /* shrinking the area */
4104 if (newlen) {
4105 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4106 Copy(MARK, tmparyval, newlen, SV*);
4107 }
4108
4109 MARK = ORIGMARK + 1;
4110 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4111 MEXTEND(MARK, length);
4112 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4113 if (AvREAL(ary)) {
4114 EXTEND_MORTAL(length);
4115 for (i = length, dst = MARK; i; i--) {
4116 sv_2mortal(*dst); /* free them eventualy */
4117 dst++;
4118 }
4119 }
4120 MARK += length - 1;
4121 }
4122 else {
4123 *MARK = AvARRAY(ary)[offset+length-1];
4124 if (AvREAL(ary)) {
4125 sv_2mortal(*MARK);
4126 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4127 SvREFCNT_dec(*dst++); /* free them now */
4128 }
4129 }
4130 AvFILLp(ary) += diff;
4131
4132 /* pull up or down? */
4133
4134 if (offset < after) { /* easier to pull up */
4135 if (offset) { /* esp. if nothing to pull */
4136 src = &AvARRAY(ary)[offset-1];
4137 dst = src - diff; /* diff is negative */
4138 for (i = offset; i > 0; i--) /* can't trust Copy */
4139 *dst-- = *src--;
4140 }
4141 dst = AvARRAY(ary);
4142 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4143 AvMAX(ary) += diff;
4144 }
4145 else {
4146 if (after) { /* anything to pull down? */
4147 src = AvARRAY(ary) + offset + length;
4148 dst = src + diff; /* diff is negative */
4149 Move(src, dst, after, SV*);
4150 }
4151 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4152 /* avoid later double free */
4153 }
4154 i = -diff;
4155 while (i)
4156 dst[--i] = &PL_sv_undef;
4157
4158 if (newlen) {
4159 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4160 newlen; newlen--) {
4161 *dst = NEWSV(46, 0);
4162 sv_setsv(*dst++, *src++);
4163 }
4164 Safefree(tmparyval);
4165 }
4166 }
4167 else { /* no, expanding (or same) */
4168 if (length) {
4169 New(452, tmparyval, length, SV*); /* so remember deletion */
4170 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4171 }
4172
4173 if (diff > 0) { /* expanding */
4174
4175 /* push up or down? */
4176
4177 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4178 if (offset) {
4179 src = AvARRAY(ary);
4180 dst = src - diff;
4181 Move(src, dst, offset, SV*);
4182 }
4183 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4184 AvMAX(ary) += diff;
4185 AvFILLp(ary) += diff;
4186 }
4187 else {
4188 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4189 av_extend(ary, AvFILLp(ary) + diff);
4190 AvFILLp(ary) += diff;
4191
4192 if (after) {
4193 dst = AvARRAY(ary) + AvFILLp(ary);
4194 src = dst - diff;
4195 for (i = after; i; i--) {
4196 *dst-- = *src--;
4197 }
4198 }
4199 }
4200 }
4201
4202 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4203 *dst = NEWSV(46, 0);
4204 sv_setsv(*dst++, *src++);
4205 }
4206 MARK = ORIGMARK + 1;
4207 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4208 if (length) {
4209 Copy(tmparyval, MARK, length, SV*);
4210 if (AvREAL(ary)) {
4211 EXTEND_MORTAL(length);
4212 for (i = length, dst = MARK; i; i--) {
4213 sv_2mortal(*dst); /* free them eventualy */
4214 dst++;
4215 }
4216 }
4217 Safefree(tmparyval);
4218 }
4219 MARK += length - 1;
4220 }
4221 else if (length--) {
4222 *MARK = tmparyval[length];
4223 if (AvREAL(ary)) {
4224 sv_2mortal(*MARK);
4225 while (length-- > 0)
4226 SvREFCNT_dec(tmparyval[length]);
4227 }
4228 Safefree(tmparyval);
4229 }
4230 else
4231 *MARK = &PL_sv_undef;
4232 }
4233 SP = MARK;
4234 RETURN;
4235 }
4236
PP(pp_push)4237 PP(pp_push)
4238 {
4239 dSP; dMARK; dORIGMARK; dTARGET;
4240 register AV *ary = (AV*)*++MARK;
4241 register SV *sv = &PL_sv_undef;
4242 MAGIC *mg;
4243
4244 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4245 *MARK-- = SvTIED_obj((SV*)ary, mg);
4246 PUSHMARK(MARK);
4247 PUTBACK;
4248 ENTER;
4249 call_method("PUSH",G_SCALAR|G_DISCARD);
4250 LEAVE;
4251 SPAGAIN;
4252 }
4253 else {
4254 /* Why no pre-extend of ary here ? */
4255 for (++MARK; MARK <= SP; MARK++) {
4256 sv = NEWSV(51, 0);
4257 if (*MARK)
4258 sv_setsv(sv, *MARK);
4259 av_push(ary, sv);
4260 }
4261 }
4262 SP = ORIGMARK;
4263 PUSHi( AvFILL(ary) + 1 );
4264 RETURN;
4265 }
4266
PP(pp_pop)4267 PP(pp_pop)
4268 {
4269 dSP;
4270 AV *av = (AV*)POPs;
4271 SV *sv = av_pop(av);
4272 if (AvREAL(av))
4273 (void)sv_2mortal(sv);
4274 PUSHs(sv);
4275 RETURN;
4276 }
4277
PP(pp_shift)4278 PP(pp_shift)
4279 {
4280 dSP;
4281 AV *av = (AV*)POPs;
4282 SV *sv = av_shift(av);
4283 EXTEND(SP, 1);
4284 if (!sv)
4285 RETPUSHUNDEF;
4286 if (AvREAL(av))
4287 (void)sv_2mortal(sv);
4288 PUSHs(sv);
4289 RETURN;
4290 }
4291
PP(pp_unshift)4292 PP(pp_unshift)
4293 {
4294 dSP; dMARK; dORIGMARK; dTARGET;
4295 register AV *ary = (AV*)*++MARK;
4296 register SV *sv;
4297 register I32 i = 0;
4298 MAGIC *mg;
4299
4300 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4301 *MARK-- = SvTIED_obj((SV*)ary, mg);
4302 PUSHMARK(MARK);
4303 PUTBACK;
4304 ENTER;
4305 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4306 LEAVE;
4307 SPAGAIN;
4308 }
4309 else {
4310 av_unshift(ary, SP - MARK);
4311 while (MARK < SP) {
4312 sv = NEWSV(27, 0);
4313 sv_setsv(sv, *++MARK);
4314 (void)av_store(ary, i++, sv);
4315 }
4316 }
4317 SP = ORIGMARK;
4318 PUSHi( AvFILL(ary) + 1 );
4319 RETURN;
4320 }
4321
PP(pp_reverse)4322 PP(pp_reverse)
4323 {
4324 dSP; dMARK;
4325 register SV *tmp;
4326 SV **oldsp = SP;
4327
4328 if (GIMME == G_ARRAY) {
4329 MARK++;
4330 while (MARK < SP) {
4331 tmp = *MARK;
4332 *MARK++ = *SP;
4333 *SP-- = tmp;
4334 }
4335 /* safe as long as stack cannot get extended in the above */
4336 SP = oldsp;
4337 }
4338 else {
4339 register char *up;
4340 register char *down;
4341 register I32 tmp;
4342 dTARGET;
4343 STRLEN len;
4344
4345 SvUTF8_off(TARG); /* decontaminate */
4346 if (SP - MARK > 1)
4347 do_join(TARG, &PL_sv_no, MARK, SP);
4348 else
4349 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4350 up = SvPV_force(TARG, len);
4351 if (len > 1) {
4352 if (DO_UTF8(TARG)) { /* first reverse each character */
4353 U8* s = (U8*)SvPVX(TARG);
4354 U8* send = (U8*)(s + len);
4355 while (s < send) {
4356 if (UTF8_IS_INVARIANT(*s)) {
4357 s++;
4358 continue;
4359 }
4360 else {
4361 if (!utf8_to_uvchr(s, 0))
4362 break;
4363 up = (char*)s;
4364 s += UTF8SKIP(s);
4365 down = (char*)(s - 1);
4366 /* reverse this character */
4367 while (down > up) {
4368 tmp = *up;
4369 *up++ = *down;
4370 *down-- = (char)tmp;
4371 }
4372 }
4373 }
4374 up = SvPVX(TARG);
4375 }
4376 down = SvPVX(TARG) + len - 1;
4377 while (down > up) {
4378 tmp = *up;
4379 *up++ = *down;
4380 *down-- = (char)tmp;
4381 }
4382 (void)SvPOK_only_UTF8(TARG);
4383 }
4384 SP = MARK + 1;
4385 SETTARG;
4386 }
4387 RETURN;
4388 }
4389
PP(pp_split)4390 PP(pp_split)
4391 {
4392 dSP; dTARG;
4393 AV *ary;
4394 register IV limit = POPi; /* note, negative is forever */
4395 SV *sv = POPs;
4396 STRLEN len;
4397 register char *s = SvPV(sv, len);
4398 bool do_utf8 = DO_UTF8(sv);
4399 char *strend = s + len;
4400 register PMOP *pm;
4401 register REGEXP *rx;
4402 register SV *dstr;
4403 register char *m;
4404 I32 iters = 0;
4405 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4406 I32 maxiters = slen + 10;
4407 I32 i;
4408 char *orig;
4409 I32 origlimit = limit;
4410 I32 realarray = 0;
4411 I32 base;
4412 AV *oldstack = PL_curstack;
4413 I32 gimme = GIMME_V;
4414 I32 oldsave = PL_savestack_ix;
4415 I32 make_mortal = 1;
4416 MAGIC *mg = (MAGIC *) NULL;
4417
4418 #ifdef DEBUGGING
4419 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4420 #else
4421 pm = (PMOP*)POPs;
4422 #endif
4423 if (!pm || !s)
4424 DIE(aTHX_ "panic: pp_split");
4425 rx = PM_GETRE(pm);
4426
4427 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4428 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4429
4430 RX_MATCH_UTF8_set(rx, do_utf8);
4431
4432 if (pm->op_pmreplroot) {
4433 #ifdef USE_ITHREADS
4434 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4435 #else
4436 ary = GvAVn((GV*)pm->op_pmreplroot);
4437 #endif
4438 }
4439 else if (gimme != G_ARRAY)
4440 #ifdef USE_5005THREADS
4441 ary = (AV*)PAD_SVl(0);
4442 #else
4443 ary = GvAVn(PL_defgv);
4444 #endif /* USE_5005THREADS */
4445 else
4446 ary = Nullav;
4447 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4448 realarray = 1;
4449 PUTBACK;
4450 av_extend(ary,0);
4451 av_clear(ary);
4452 SPAGAIN;
4453 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4454 PUSHMARK(SP);
4455 XPUSHs(SvTIED_obj((SV*)ary, mg));
4456 }
4457 else {
4458 if (!AvREAL(ary)) {
4459 AvREAL_on(ary);
4460 AvREIFY_off(ary);
4461 for (i = AvFILLp(ary); i >= 0; i--)
4462 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4463 }
4464 /* temporarily switch stacks */
4465 SWITCHSTACK(PL_curstack, ary);
4466 PL_curstackinfo->si_stack = ary;
4467 make_mortal = 0;
4468 }
4469 }
4470 base = SP - PL_stack_base;
4471 orig = s;
4472 if (pm->op_pmflags & PMf_SKIPWHITE) {
4473 if (pm->op_pmflags & PMf_LOCALE) {
4474 while (isSPACE_LC(*s))
4475 s++;
4476 }
4477 else {
4478 while (isSPACE(*s))
4479 s++;
4480 }
4481 }
4482 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4483 SAVEINT(PL_multiline);
4484 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4485 }
4486
4487 if (!limit)
4488 limit = maxiters + 2;
4489 if (pm->op_pmflags & PMf_WHITE) {
4490 while (--limit) {
4491 m = s;
4492 while (m < strend &&
4493 !((pm->op_pmflags & PMf_LOCALE)
4494 ? isSPACE_LC(*m) : isSPACE(*m)))
4495 ++m;
4496 if (m >= strend)
4497 break;
4498
4499 dstr = NEWSV(30, m-s);
4500 sv_setpvn(dstr, s, m-s);
4501 if (make_mortal)
4502 sv_2mortal(dstr);
4503 if (do_utf8)
4504 (void)SvUTF8_on(dstr);
4505 XPUSHs(dstr);
4506
4507 s = m + 1;
4508 while (s < strend &&
4509 ((pm->op_pmflags & PMf_LOCALE)
4510 ? isSPACE_LC(*s) : isSPACE(*s)))
4511 ++s;
4512 }
4513 }
4514 else if (strEQ("^", rx->precomp)) {
4515 while (--limit) {
4516 /*SUPPRESS 530*/
4517 for (m = s; m < strend && *m != '\n'; m++) ;
4518 m++;
4519 if (m >= strend)
4520 break;
4521 dstr = NEWSV(30, m-s);
4522 sv_setpvn(dstr, s, m-s);
4523 if (make_mortal)
4524 sv_2mortal(dstr);
4525 if (do_utf8)
4526 (void)SvUTF8_on(dstr);
4527 XPUSHs(dstr);
4528 s = m;
4529 }
4530 }
4531 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4532 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4533 && (rx->reganch & ROPT_CHECK_ALL)
4534 && !(rx->reganch & ROPT_ANCH)) {
4535 int tail = (rx->reganch & RE_INTUIT_TAIL);
4536 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4537
4538 len = rx->minlen;
4539 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4540 STRLEN n_a;
4541 char c = *SvPV(csv, n_a);
4542 while (--limit) {
4543 /*SUPPRESS 530*/
4544 for (m = s; m < strend && *m != c; m++) ;
4545 if (m >= strend)
4546 break;
4547 dstr = NEWSV(30, m-s);
4548 sv_setpvn(dstr, s, m-s);
4549 if (make_mortal)
4550 sv_2mortal(dstr);
4551 if (do_utf8)
4552 (void)SvUTF8_on(dstr);
4553 XPUSHs(dstr);
4554 /* The rx->minlen is in characters but we want to step
4555 * s ahead by bytes. */
4556 if (do_utf8)
4557 s = (char*)utf8_hop((U8*)m, len);
4558 else
4559 s = m + len; /* Fake \n at the end */
4560 }
4561 }
4562 else {
4563 #ifndef lint
4564 while (s < strend && --limit &&
4565 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4566 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4567 #endif
4568 {
4569 dstr = NEWSV(31, m-s);
4570 sv_setpvn(dstr, s, m-s);
4571 if (make_mortal)
4572 sv_2mortal(dstr);
4573 if (do_utf8)
4574 (void)SvUTF8_on(dstr);
4575 XPUSHs(dstr);
4576 /* The rx->minlen is in characters but we want to step
4577 * s ahead by bytes. */
4578 if (do_utf8)
4579 s = (char*)utf8_hop((U8*)m, len);
4580 else
4581 s = m + len; /* Fake \n at the end */
4582 }
4583 }
4584 }
4585 else {
4586 maxiters += slen * rx->nparens;
4587 while (s < strend && --limit)
4588 {
4589 PUTBACK;
4590 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4591 SPAGAIN;
4592 if (i == 0)
4593 break;
4594 TAINT_IF(RX_MATCH_TAINTED(rx));
4595 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4596 m = s;
4597 s = orig;
4598 orig = rx->subbeg;
4599 s = orig + (m - s);
4600 strend = s + (strend - m);
4601 }
4602 m = rx->startp[0] + orig;
4603 dstr = NEWSV(32, m-s);
4604 sv_setpvn(dstr, s, m-s);
4605 if (make_mortal)
4606 sv_2mortal(dstr);
4607 if (do_utf8)
4608 (void)SvUTF8_on(dstr);
4609 XPUSHs(dstr);
4610 if (rx->nparens) {
4611 for (i = 1; i <= (I32)rx->nparens; i++) {
4612 s = rx->startp[i] + orig;
4613 m = rx->endp[i] + orig;
4614
4615 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4616 parens that didn't match -- they should be set to
4617 undef, not the empty string */
4618 if (m >= orig && s >= orig) {
4619 dstr = NEWSV(33, m-s);
4620 sv_setpvn(dstr, s, m-s);
4621 }
4622 else
4623 dstr = &PL_sv_undef; /* undef, not "" */
4624 if (make_mortal)
4625 sv_2mortal(dstr);
4626 if (do_utf8)
4627 (void)SvUTF8_on(dstr);
4628 XPUSHs(dstr);
4629 }
4630 }
4631 s = rx->endp[0] + orig;
4632 }
4633 }
4634
4635 LEAVE_SCOPE(oldsave);
4636 iters = (SP - PL_stack_base) - base;
4637 if (iters > maxiters)
4638 DIE(aTHX_ "Split loop");
4639
4640 /* keep field after final delim? */
4641 if (s < strend || (iters && origlimit)) {
4642 STRLEN l = strend - s;
4643 dstr = NEWSV(34, l);
4644 sv_setpvn(dstr, s, l);
4645 if (make_mortal)
4646 sv_2mortal(dstr);
4647 if (do_utf8)
4648 (void)SvUTF8_on(dstr);
4649 XPUSHs(dstr);
4650 iters++;
4651 }
4652 else if (!origlimit) {
4653 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4654 if (TOPs && !make_mortal)
4655 sv_2mortal(TOPs);
4656 iters--;
4657 *SP-- = &PL_sv_undef;
4658 }
4659 }
4660
4661 if (realarray) {
4662 if (!mg) {
4663 SWITCHSTACK(ary, oldstack);
4664 PL_curstackinfo->si_stack = oldstack;
4665 if (SvSMAGICAL(ary)) {
4666 PUTBACK;
4667 mg_set((SV*)ary);
4668 SPAGAIN;
4669 }
4670 if (gimme == G_ARRAY) {
4671 EXTEND(SP, iters);
4672 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4673 SP += iters;
4674 RETURN;
4675 }
4676 }
4677 else {
4678 PUTBACK;
4679 ENTER;
4680 call_method("PUSH",G_SCALAR|G_DISCARD);
4681 LEAVE;
4682 SPAGAIN;
4683 if (gimme == G_ARRAY) {
4684 /* EXTEND should not be needed - we just popped them */
4685 EXTEND(SP, iters);
4686 for (i=0; i < iters; i++) {
4687 SV **svp = av_fetch(ary, i, FALSE);
4688 PUSHs((svp) ? *svp : &PL_sv_undef);
4689 }
4690 RETURN;
4691 }
4692 }
4693 }
4694 else {
4695 if (gimme == G_ARRAY)
4696 RETURN;
4697 }
4698
4699 GETTARGET;
4700 PUSHi(iters);
4701 RETURN;
4702 }
4703
4704 #ifdef USE_5005THREADS
4705 void
Perl_unlock_condpair(pTHX_ void * svv)4706 Perl_unlock_condpair(pTHX_ void *svv)
4707 {
4708 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4709
4710 if (!mg)
4711 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4712 MUTEX_LOCK(MgMUTEXP(mg));
4713 if (MgOWNER(mg) != thr)
4714 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4715 MgOWNER(mg) = 0;
4716 COND_SIGNAL(MgOWNERCONDP(mg));
4717 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4718 PTR2UV(thr), PTR2UV(svv)));
4719 MUTEX_UNLOCK(MgMUTEXP(mg));
4720 }
4721 #endif /* USE_5005THREADS */
4722
PP(pp_lock)4723 PP(pp_lock)
4724 {
4725 dSP;
4726 dTOPss;
4727 SV *retsv = sv;
4728 SvLOCK(sv);
4729 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4730 || SvTYPE(retsv) == SVt_PVCV) {
4731 retsv = refto(retsv);
4732 }
4733 SETs(retsv);
4734 RETURN;
4735 }
4736
PP(pp_threadsv)4737 PP(pp_threadsv)
4738 {
4739 #ifdef USE_5005THREADS
4740 dSP;
4741 EXTEND(SP, 1);
4742 if (PL_op->op_private & OPpLVAL_INTRO)
4743 PUSHs(*save_threadsv(PL_op->op_targ));
4744 else
4745 PUSHs(THREADSV(PL_op->op_targ));
4746 RETURN;
4747 #else
4748 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4749 #endif /* USE_5005THREADS */
4750 }
4751