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