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