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