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