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