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