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