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