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