This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid initializing GvCV slot for autovivified filehandles
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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
36477c24 19/*
ef2d312d
TH
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 */
26#ifdef CXUX_BROKEN_CONSTANT_CONVERT
27static double UV_MAX_cxux = ((double)UV_MAX);
8ec5e241 28#endif
ef2d312d
TH
29
30/*
d0ba1bd2
JH
31 * Types used in bitwise operations.
32 *
33 * Normally we'd just use IV and UV. However, some hardware and
34 * software combinations (e.g. Alpha and current OSF/1) don't have a
35 * floating-point type to use for NV that has adequate bits to fully
36 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
37 *
38 * It just so happens that "int" is the right size almost everywhere.
39 */
40typedef int IBW;
41typedef unsigned UBW;
42
43/*
44 * Mask used after bitwise operations.
45 *
46 * There is at least one realm (Cray word machines) that doesn't
47 * have an integral type (except char) small enough to be represented
48 * in a double without loss; that is, it has no 32-bit type.
49 */
50#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
51# define BW_BITS 32
52# define BW_MASK ((1 << BW_BITS) - 1)
53# define BW_SIGN (1 << (BW_BITS - 1))
54# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
55# define BWu(u) ((u) & BW_MASK)
56#else
57# define BWi(i) (i)
58# define BWu(u) (u)
59#endif
60
61/*
96e4d5b1 62 * Offset for integer pack/unpack.
63 *
64 * On architectures where I16 and I32 aren't really 16 and 32 bits,
65 * which for now are all Crays, pack and unpack have to play games.
66 */
67
68/*
69 * These values are required for portability of pack() output.
70 * If they're not right on your machine, then pack() and unpack()
71 * wouldn't work right anyway; you'll need to apply the Cray hack.
72 * (I'd like to check them with #if, but you can't use sizeof() in
dc45a647
MB
73 * the preprocessor.) --???
74 */
75/*
76 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
77 defines are now in config.h. --Andy Dougherty April 1998
96e4d5b1 78 */
79#define SIZE16 2
80#define SIZE32 4
81
9851f69c
JH
82/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
83 --jhi Feb 1999 */
84
726ea183
JH
85#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
86# define PERL_NATINT_PACK
87#endif
88
96e4d5b1 89#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
90# if BYTEORDER == 0x12345678
91# define OFF16(p) (char*)(p)
92# define OFF32(p) (char*)(p)
93# else
94# if BYTEORDER == 0x87654321
95# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
96# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
97# else
98 }}}} bad cray byte order
99# endif
100# endif
101# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
102# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
ef54e1a4 103# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
96e4d5b1 104# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
105# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
106#else
107# define COPY16(s,p) Copy(s, p, SIZE16, char)
108# define COPY32(s,p) Copy(s, p, SIZE32, char)
ef54e1a4 109# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
96e4d5b1 110# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
111# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
112#endif
113
a0d0e21e 114/* variations on pp_null */
79072805 115
8ac85365
NIS
116#ifdef I_UNISTD
117#include <unistd.h>
118#endif
dfe9444c
AD
119
120/* XXX I can't imagine anyone who doesn't have this actually _needs_
121 it, since pid_t is an integral type.
122 --AD 2/20/1998
123*/
124#ifdef NEED_GETPID_PROTO
125extern Pid_t getpid (void);
8ac85365
NIS
126#endif
127
93a17b20
LW
128PP(pp_stub)
129{
4e35701f 130 djSP;
54310121 131 if (GIMME_V == G_SCALAR)
3280af22 132 XPUSHs(&PL_sv_undef);
93a17b20
LW
133 RETURN;
134}
135
79072805
LW
136PP(pp_scalar)
137{
138 return NORMAL;
139}
140
141/* Pushy stuff. */
142
93a17b20
LW
143PP(pp_padav)
144{
4e35701f 145 djSP; dTARGET;
533c011a
NIS
146 if (PL_op->op_private & OPpLVAL_INTRO)
147 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
85e6fe83 148 EXTEND(SP, 1);
533c011a 149 if (PL_op->op_flags & OPf_REF) {
85e6fe83 150 PUSHs(TARG);
93a17b20 151 RETURN;
85e6fe83
LW
152 }
153 if (GIMME == G_ARRAY) {
154 I32 maxarg = AvFILL((AV*)TARG) + 1;
155 EXTEND(SP, maxarg);
93965878
NIS
156 if (SvMAGICAL(TARG)) {
157 U32 i;
158 for (i=0; i < maxarg; i++) {
159 SV **svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 160 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
161 }
162 }
163 else {
164 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
165 }
85e6fe83
LW
166 SP += maxarg;
167 }
168 else {
169 SV* sv = sv_newmortal();
170 I32 maxarg = AvFILL((AV*)TARG) + 1;
171 sv_setiv(sv, maxarg);
172 PUSHs(sv);
173 }
174 RETURN;
93a17b20
LW
175}
176
177PP(pp_padhv)
178{
4e35701f 179 djSP; dTARGET;
54310121 180 I32 gimme;
181
93a17b20 182 XPUSHs(TARG);
533c011a
NIS
183 if (PL_op->op_private & OPpLVAL_INTRO)
184 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
185 if (PL_op->op_flags & OPf_REF)
93a17b20 186 RETURN;
54310121 187 gimme = GIMME_V;
188 if (gimme == G_ARRAY) {
cea2e8a9 189 RETURNOP(do_kv());
85e6fe83 190 }
54310121 191 else if (gimme == G_SCALAR) {
85e6fe83 192 SV* sv = sv_newmortal();
46fc3d4c 193 if (HvFILL((HV*)TARG))
cea2e8a9 194 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
46fc3d4c 195 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW
196 else
197 sv_setiv(sv, 0);
198 SETs(sv);
85e6fe83 199 }
54310121 200 RETURN;
93a17b20
LW
201}
202
ed6116ce
LW
203PP(pp_padany)
204{
cea2e8a9 205 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW
206}
207
79072805
LW
208/* Translations. */
209
210PP(pp_rv2gv)
211{
853846ea 212 djSP; dTOPss;
8ec5e241 213
ed6116ce 214 if (SvROK(sv)) {
a0d0e21e 215 wasref:
f5284f61
IZ
216 tryAMAGICunDEREF(to_gv);
217
ed6116ce 218 sv = SvRV(sv);
b1dadf13 219 if (SvTYPE(sv) == SVt_PVIO) {
220 GV *gv = (GV*) sv_newmortal();
221 gv_init(gv, 0, "", 0, 0);
222 GvIOp(gv) = (IO *)sv;
3e3baf6d 223 (void)SvREFCNT_inc(sv);
b1dadf13 224 sv = (SV*) gv;
ef54e1a4
JH
225 }
226 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 227 DIE(aTHX_ "Not a GLOB reference");
79072805
LW
228 }
229 else {
93a17b20 230 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 231 char *sym;
2d8e6c8d 232 STRLEN n_a;
748a9306 233
a0d0e21e
LW
234 if (SvGMAGICAL(sv)) {
235 mg_get(sv);
236 if (SvROK(sv))
237 goto wasref;
238 }
239 if (!SvOK(sv)) {
853846ea
NIS
240 /* If this is a 'my' scalar and flag is set then vivify
241 * NI-S 1999/05/07
242 */
1d8d4d2a 243 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS
244 char *name;
245 GV *gv;
246 if (cUNOP->op_targ) {
247 STRLEN len;
248 SV *namesv = PL_curpad[cUNOP->op_targ];
249 name = SvPV(namesv, len);
2d6d9f7a 250 gv = (GV*)NEWSV(0,0);
2c8ac474
GS
251 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
252 }
253 else {
254 name = CopSTASHPV(PL_curcop);
255 gv = newGVgen(name);
1d8d4d2a 256 }
853846ea 257 sv_upgrade(sv, SVt_RV);
2c8ac474 258 SvRV(sv) = (SV*)gv;
853846ea 259 SvROK_on(sv);
1d8d4d2a 260 SvSETMAGIC(sv);
853846ea 261 goto wasref;
2c8ac474 262 }
533c011a
NIS
263 if (PL_op->op_flags & OPf_REF ||
264 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 265 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 266 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 267 report_uninit();
a0d0e21e
LW
268 RETSETUNDEF;
269 }
2d8e6c8d 270 sym = SvPV(sv, n_a);
35cd451c
GS
271 if ((PL_op->op_flags & OPf_SPECIAL) &&
272 !(PL_op->op_flags & OPf_MOD))
273 {
274 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
275 if (!sv)
276 RETSETUNDEF;
277 }
278 else {
279 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 280 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS
281 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
282 }
93a17b20 283 }
79072805 284 }
533c011a
NIS
285 if (PL_op->op_private & OPpLVAL_INTRO)
286 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW
287 SETs(sv);
288 RETURN;
289}
290
79072805
LW
291PP(pp_rv2sv)
292{
4e35701f 293 djSP; dTOPss;
79072805 294
ed6116ce 295 if (SvROK(sv)) {
a0d0e21e 296 wasref:
f5284f61
IZ
297 tryAMAGICunDEREF(to_sv);
298
ed6116ce 299 sv = SvRV(sv);
79072805
LW
300 switch (SvTYPE(sv)) {
301 case SVt_PVAV:
302 case SVt_PVHV:
303 case SVt_PVCV:
cea2e8a9 304 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW
305 }
306 }
307 else {
f12c7020 308 GV *gv = (GV*)sv;
748a9306 309 char *sym;
2d8e6c8d 310 STRLEN n_a;
748a9306 311
463ee0b2 312 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW
313 if (SvGMAGICAL(sv)) {
314 mg_get(sv);
315 if (SvROK(sv))
316 goto wasref;
317 }
318 if (!SvOK(sv)) {
533c011a
NIS
319 if (PL_op->op_flags & OPf_REF ||
320 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 321 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 322 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 323 report_uninit();
a0d0e21e
LW
324 RETSETUNDEF;
325 }
2d8e6c8d 326 sym = SvPV(sv, n_a);
35cd451c
GS
327 if ((PL_op->op_flags & OPf_SPECIAL) &&
328 !(PL_op->op_flags & OPf_MOD))
329 {
330 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
331 if (!gv)
332 RETSETUNDEF;
333 }
334 else {
335 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 336 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS
337 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
338 }
463ee0b2
LW
339 }
340 sv = GvSV(gv);
a0d0e21e 341 }
533c011a
NIS
342 if (PL_op->op_flags & OPf_MOD) {
343 if (PL_op->op_private & OPpLVAL_INTRO)
a0d0e21e 344 sv = save_scalar((GV*)TOPs);
533c011a
NIS
345 else if (PL_op->op_private & OPpDEREF)
346 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 347 }
a0d0e21e 348 SETs(sv);
79072805
LW
349 RETURN;
350}
351
352PP(pp_av2arylen)
353{
4e35701f 354 djSP;
79072805
LW
355 AV *av = (AV*)TOPs;
356 SV *sv = AvARYLEN(av);
357 if (!sv) {
358 AvARYLEN(av) = sv = NEWSV(0,0);
359 sv_upgrade(sv, SVt_IV);
360 sv_magic(sv, (SV*)av, '#', Nullch, 0);
361 }
362 SETs(sv);
363 RETURN;
364}
365
a0d0e21e
LW
366PP(pp_pos)
367{
4e35701f 368 djSP; dTARGET; dPOPss;
8ec5e241 369
533c011a 370 if (PL_op->op_flags & OPf_MOD) {
5f05dabc 371 if (SvTYPE(TARG) < SVt_PVLV) {
372 sv_upgrade(TARG, SVt_PVLV);
373 sv_magic(TARG, Nullsv, '.', Nullch, 0);
374 }
375
376 LvTYPE(TARG) = '.';
6ff81951
GS
377 if (LvTARG(TARG) != sv) {
378 if (LvTARG(TARG))
379 SvREFCNT_dec(LvTARG(TARG));
380 LvTARG(TARG) = SvREFCNT_inc(sv);
381 }
a0d0e21e
LW
382 PUSHs(TARG); /* no SvSETMAGIC */
383 RETURN;
384 }
385 else {
8ec5e241 386 MAGIC* mg;
a0d0e21e
LW
387
388 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
389 mg = mg_find(sv, 'g');
565764a8 390 if (mg && mg->mg_len >= 0) {
a0ed51b3
LW
391 I32 i = mg->mg_len;
392 if (IN_UTF8)
393 sv_pos_b2u(sv, &i);
394 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW
395 RETURN;
396 }
397 }
398 RETPUSHUNDEF;
399 }
400}
401
79072805
LW
402PP(pp_rv2cv)
403{
4e35701f 404 djSP;
79072805
LW
405 GV *gv;
406 HV *stash;
8990e307 407
4633a7c4
LW
408 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
409 /* (But not in defined().) */
533c011a 410 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS
411 if (cv) {
412 if (CvCLONE(cv))
413 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
cd06dffe 414 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
d470f89e 415 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
07055b4c
CS
416 }
417 else
3280af22 418 cv = (CV*)&PL_sv_undef;
79072805
LW
419 SETs((SV*)cv);
420 RETURN;
421}
422
c07a80fd 423PP(pp_prototype)
424{
4e35701f 425 djSP;
c07a80fd 426 CV *cv;
427 HV *stash;
428 GV *gv;
429 SV *ret;
430
3280af22 431 ret = &PL_sv_undef;
b6c543e3
IZ
432 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
433 char *s = SvPVX(TOPs);
434 if (strnEQ(s, "CORE::", 6)) {
435 int code;
436
437 code = keyword(s + 6, SvCUR(TOPs) - 6);
438 if (code < 0) { /* Overridable. */
439#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
440 int i = 0, n = 0, seen_question = 0;
441 I32 oa;
442 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
443
444 while (i < MAXO) { /* The slow way. */
22c35a8c
GS
445 if (strEQ(s + 6, PL_op_name[i])
446 || strEQ(s + 6, PL_op_desc[i]))
447 {
b6c543e3 448 goto found;
22c35a8c 449 }
b6c543e3
IZ
450 i++;
451 }
452 goto nonesuch; /* Should not happen... */
453 found:
22c35a8c 454 oa = PL_opargs[i] >> OASHIFT;
b6c543e3
IZ
455 while (oa) {
456 if (oa & OA_OPTIONAL) {
457 seen_question = 1;
458 str[n++] = ';';
ef54e1a4
JH
459 }
460 else if (seen_question)
b6c543e3
IZ
461 goto set; /* XXXX system, exec */
462 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
463 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
464 str[n++] = '\\';
465 }
466 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
467 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
468 oa = oa >> 4;
469 }
470 str[n++] = '\0';
79cb57f6 471 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH
472 }
473 else if (code) /* Non-Overridable */
b6c543e3
IZ
474 goto set;
475 else { /* None such */
476 nonesuch:
d470f89e 477 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ
478 }
479 }
480 }
c07a80fd 481 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 482 if (cv && SvPOK(cv))
79cb57f6 483 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 484 set:
c07a80fd 485 SETs(ret);
486 RETURN;
487}
488
a0d0e21e
LW
489PP(pp_anoncode)
490{
4e35701f 491 djSP;
533c011a 492 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
a5f75d66 493 if (CvCLONE(cv))
b355b4e0 494 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 495 EXTEND(SP,1);
748a9306 496 PUSHs((SV*)cv);
a0d0e21e
LW
497 RETURN;
498}
499
500PP(pp_srefgen)
79072805 501{
4e35701f 502 djSP;
71be2cbc 503 *SP = refto(*SP);
79072805 504 RETURN;
8ec5e241 505}
a0d0e21e
LW
506
507PP(pp_refgen)
508{
4e35701f 509 djSP; dMARK;
a0d0e21e 510 if (GIMME != G_ARRAY) {
5f0b1d4e
GS
511 if (++MARK <= SP)
512 *MARK = *SP;
513 else
3280af22 514 *MARK = &PL_sv_undef;
5f0b1d4e
GS
515 *MARK = refto(*MARK);
516 SP = MARK;
517 RETURN;
a0d0e21e 518 }
bbce6d69 519 EXTEND_MORTAL(SP - MARK);
71be2cbc 520 while (++MARK <= SP)
521 *MARK = refto(*MARK);
a0d0e21e 522 RETURN;
79072805
LW
523}
524
76e3520e 525STATIC SV*
cea2e8a9 526S_refto(pTHX_ SV *sv)
71be2cbc 527{
528 SV* rv;
529
530 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
531 if (LvTARGLEN(sv))
68dc0745 532 vivify_defelem(sv);
533 if (!(sv = LvTARG(sv)))
3280af22 534 sv = &PL_sv_undef;
0dd88869 535 else
a6c40364 536 (void)SvREFCNT_inc(sv);
71be2cbc 537 }
d8b46c1b
GS
538 else if (SvTYPE(sv) == SVt_PVAV) {
539 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
540 av_reify((AV*)sv);
541 SvTEMP_off(sv);
542 (void)SvREFCNT_inc(sv);
543 }
71be2cbc 544 else if (SvPADTMP(sv))
545 sv = newSVsv(sv);
546 else {
547 SvTEMP_off(sv);
548 (void)SvREFCNT_inc(sv);
549 }
550 rv = sv_newmortal();
551 sv_upgrade(rv, SVt_RV);
552 SvRV(rv) = sv;
553 SvROK_on(rv);
554 return rv;
555}
556
79072805
LW
557PP(pp_ref)
558{
4e35701f 559 djSP; dTARGET;
463ee0b2 560 SV *sv;
79072805
LW
561 char *pv;
562
a0d0e21e 563 sv = POPs;
f12c7020 564
565 if (sv && SvGMAGICAL(sv))
8ec5e241 566 mg_get(sv);
f12c7020 567
a0d0e21e 568 if (!sv || !SvROK(sv))
4633a7c4 569 RETPUSHNO;
79072805 570
ed6116ce 571 sv = SvRV(sv);
a0d0e21e 572 pv = sv_reftype(sv,TRUE);
463ee0b2 573 PUSHp(pv, strlen(pv));
79072805
LW
574 RETURN;
575}
576
577PP(pp_bless)
578{
4e35701f 579 djSP;
463ee0b2 580 HV *stash;
79072805 581
463ee0b2 582 if (MAXARG == 1)
11faa288 583 stash = CopSTASH(PL_curcop);
7b8d334a
GS
584 else {
585 SV *ssv = POPs;
586 STRLEN len;
587 char *ptr = SvPV(ssv,len);
599cee73 588 if (ckWARN(WARN_UNSAFE) && len == 0)
cea2e8a9 589 Perl_warner(aTHX_ WARN_UNSAFE,
599cee73 590 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS
591 stash = gv_stashpvn(ptr, len, TRUE);
592 }
a0d0e21e 593
5d3fdfeb 594 (void)sv_bless(TOPs, stash);
79072805
LW
595 RETURN;
596}
597
fb73857a 598PP(pp_gelem)
599{
600 GV *gv;
601 SV *sv;
76e3520e 602 SV *tmpRef;
fb73857a 603 char *elem;
4e35701f 604 djSP;
2d8e6c8d
GS
605 STRLEN n_a;
606
fb73857a 607 sv = POPs;
2d8e6c8d 608 elem = SvPV(sv, n_a);
fb73857a 609 gv = (GV*)POPs;
76e3520e 610 tmpRef = Nullsv;
fb73857a 611 sv = Nullsv;
612 switch (elem ? *elem : '\0')
613 {
614 case 'A':
615 if (strEQ(elem, "ARRAY"))
76e3520e 616 tmpRef = (SV*)GvAV(gv);
fb73857a 617 break;
618 case 'C':
619 if (strEQ(elem, "CODE"))
76e3520e 620 tmpRef = (SV*)GvCVu(gv);
fb73857a 621 break;
622 case 'F':
623 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 624 tmpRef = (SV*)GvIOp(gv);
fb73857a 625 break;
626 case 'G':
627 if (strEQ(elem, "GLOB"))
76e3520e 628 tmpRef = (SV*)gv;
fb73857a 629 break;
630 case 'H':
631 if (strEQ(elem, "HASH"))
76e3520e 632 tmpRef = (SV*)GvHV(gv);
fb73857a 633 break;
634 case 'I':
635 if (strEQ(elem, "IO"))
76e3520e 636 tmpRef = (SV*)GvIOp(gv);
fb73857a 637 break;
638 case 'N':
639 if (strEQ(elem, "NAME"))
79cb57f6 640 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a 641 break;
642 case 'P':
643 if (strEQ(elem, "PACKAGE"))
644 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
645 break;
646 case 'S':
647 if (strEQ(elem, "SCALAR"))
76e3520e 648 tmpRef = GvSV(gv);
fb73857a 649 break;
650 }
76e3520e
GS
651 if (tmpRef)
652 sv = newRV(tmpRef);
fb73857a 653 if (sv)
654 sv_2mortal(sv);
655 else
3280af22 656 sv = &PL_sv_undef;
fb73857a 657 XPUSHs(sv);
658 RETURN;
659}
660
a0d0e21e 661/* Pattern matching */
79072805 662
a0d0e21e 663PP(pp_study)
79072805 664{
4e35701f 665 djSP; dPOPss;
a0d0e21e
LW
666 register unsigned char *s;
667 register I32 pos;
668 register I32 ch;
669 register I32 *sfirst;
670 register I32 *snext;
a0d0e21e
LW
671 STRLEN len;
672
3280af22 673 if (sv == PL_lastscream) {
1e422769 674 if (SvSCREAM(sv))
675 RETPUSHYES;
676 }
c07a80fd 677 else {
3280af22
NIS
678 if (PL_lastscream) {
679 SvSCREAM_off(PL_lastscream);
680 SvREFCNT_dec(PL_lastscream);
c07a80fd 681 }
3280af22 682 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 683 }
1e422769 684
685 s = (unsigned char*)(SvPV(sv, len));
686 pos = len;
687 if (pos <= 0)
688 RETPUSHNO;
3280af22
NIS
689 if (pos > PL_maxscream) {
690 if (PL_maxscream < 0) {
691 PL_maxscream = pos + 80;
692 New(301, PL_screamfirst, 256, I32);
693 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW
694 }
695 else {
3280af22
NIS
696 PL_maxscream = pos + pos / 4;
697 Renew(PL_screamnext, PL_maxscream, I32);
79072805 698 }
79072805 699 }
a0d0e21e 700
3280af22
NIS
701 sfirst = PL_screamfirst;
702 snext = PL_screamnext;
a0d0e21e
LW
703
704 if (!sfirst || !snext)
cea2e8a9 705 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW
706
707 for (ch = 256; ch; --ch)
708 *sfirst++ = -1;
709 sfirst -= 256;
710
711 while (--pos >= 0) {
712 ch = s[pos];
713 if (sfirst[ch] >= 0)
714 snext[pos] = sfirst[ch] - pos;
715 else
716 snext[pos] = -pos;
717 sfirst[ch] = pos;
79072805
LW
718 }
719
c07a80fd 720 SvSCREAM_on(sv);
464e2e8a 721 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 722 RETPUSHYES;
79072805
LW
723}
724
a0d0e21e 725PP(pp_trans)
79072805 726{
4e35701f 727 djSP; dTARG;
a0d0e21e
LW
728 SV *sv;
729
533c011a 730 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 731 sv = POPs;
79072805 732 else {
54b9620d 733 sv = DEFSV;
a0d0e21e 734 EXTEND(SP,1);
79072805 735 }
adbc6bb1 736 TARG = sv_newmortal();
4757a243 737 PUSHi(do_trans(sv));
a0d0e21e 738 RETURN;
79072805
LW
739}
740
a0d0e21e 741/* Lvalue operators. */
79072805 742
a0d0e21e
LW
743PP(pp_schop)
744{
4e35701f 745 djSP; dTARGET;
a0d0e21e
LW
746 do_chop(TARG, TOPs);
747 SETTARG;
748 RETURN;
79072805
LW
749}
750
a0d0e21e 751PP(pp_chop)
79072805 752{
4e35701f 753 djSP; dMARK; dTARGET;
a0d0e21e
LW
754 while (SP > MARK)
755 do_chop(TARG, POPs);
756 PUSHTARG;
757 RETURN;
79072805
LW
758}
759
a0d0e21e 760PP(pp_schomp)
79072805 761{
4e35701f 762 djSP; dTARGET;
a0d0e21e
LW
763 SETi(do_chomp(TOPs));
764 RETURN;
79072805
LW
765}
766
a0d0e21e 767PP(pp_chomp)
79072805 768{
4e35701f 769 djSP; dMARK; dTARGET;
a0d0e21e 770 register I32 count = 0;
8ec5e241 771
a0d0e21e
LW
772 while (SP > MARK)
773 count += do_chomp(POPs);
774 PUSHi(count);
775 RETURN;
79072805
LW
776}
777
a0d0e21e 778PP(pp_defined)
463ee0b2 779{
4e35701f 780 djSP;
a0d0e21e
LW
781 register SV* sv;
782
783 sv = POPs;
784 if (!sv || !SvANY(sv))
785 RETPUSHNO;
786 switch (SvTYPE(sv)) {
787 case SVt_PVAV:
6051dbdb 788 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
789 RETPUSHYES;
790 break;
791 case SVt_PVHV:
6051dbdb 792 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
793 RETPUSHYES;
794 break;
795 case SVt_PVCV:
796 if (CvROOT(sv) || CvXSUB(sv))
797 RETPUSHYES;
798 break;
799 default:
800 if (SvGMAGICAL(sv))
801 mg_get(sv);
802 if (SvOK(sv))
803 RETPUSHYES;
804 }
805 RETPUSHNO;
463ee0b2
LW
806}
807
a0d0e21e
LW
808PP(pp_undef)
809{
4e35701f 810 djSP;
a0d0e21e
LW
811 SV *sv;
812
533c011a 813 if (!PL_op->op_private) {
774d564b 814 EXTEND(SP, 1);
a0d0e21e 815 RETPUSHUNDEF;
774d564b 816 }
79072805 817
a0d0e21e
LW
818 sv = POPs;
819 if (!sv)
820 RETPUSHUNDEF;
85e6fe83 821
6fc92669
GS
822 if (SvTHINKFIRST(sv))
823 sv_force_normal(sv);
85e6fe83 824
a0d0e21e
LW
825 switch (SvTYPE(sv)) {
826 case SVt_NULL:
827 break;
828 case SVt_PVAV:
829 av_undef((AV*)sv);
830 break;
831 case SVt_PVHV:
832 hv_undef((HV*)sv);
833 break;
834 case SVt_PVCV:
599cee73 835 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
cea2e8a9 836 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
54310121 837 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 838 /* FALL THROUGH */
839 case SVt_PVFM:
6fc92669
GS
840 {
841 /* let user-undef'd sub keep its identity */
842 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
843 cv_undef((CV*)sv);
844 CvGV((CV*)sv) = gv;
845 }
a0d0e21e 846 break;
8e07c86e 847 case SVt_PVGV:
44a8e56a 848 if (SvFAKE(sv))
3280af22 849 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS
850 else {
851 GP *gp;
852 gp_free((GV*)sv);
853 Newz(602, gp, 1, GP);
854 GvGP(sv) = gp_ref(gp);
855 GvSV(sv) = NEWSV(72,0);
57843af0 856 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS
857 GvEGV(sv) = (GV*)sv;
858 GvMULTI_on(sv);
859 }
44a8e56a 860 break;
a0d0e21e 861 default:
1e422769 862 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW
863 (void)SvOOK_off(sv);
864 Safefree(SvPVX(sv));
865 SvPV_set(sv, Nullch);
866 SvLEN_set(sv, 0);
a0d0e21e 867 }
4633a7c4
LW
868 (void)SvOK_off(sv);
869 SvSETMAGIC(sv);
79072805 870 }
a0d0e21e
LW
871
872 RETPUSHUNDEF;
79072805
LW
873}
874
a0d0e21e 875PP(pp_predec)
79072805 876{
4e35701f 877 djSP;
68dc0745 878 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 879 DIE(aTHX_ PL_no_modify);
25da4f38 880 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 881 SvIVX(TOPs) != IV_MIN)
882 {
748a9306 883 --SvIVX(TOPs);
55497cff 884 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
885 }
886 else
887 sv_dec(TOPs);
a0d0e21e
LW
888 SvSETMAGIC(TOPs);
889 return NORMAL;
890}
79072805 891
a0d0e21e
LW
892PP(pp_postinc)
893{
4e35701f 894 djSP; dTARGET;
68dc0745 895 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 896 DIE(aTHX_ PL_no_modify);
a0d0e21e 897 sv_setsv(TARG, TOPs);
25da4f38 898 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 899 SvIVX(TOPs) != IV_MAX)
900 {
748a9306 901 ++SvIVX(TOPs);
55497cff 902 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
903 }
904 else
905 sv_inc(TOPs);
a0d0e21e
LW
906 SvSETMAGIC(TOPs);
907 if (!SvOK(TARG))
908 sv_setiv(TARG, 0);
909 SETs(TARG);
910 return NORMAL;
911}
79072805 912
a0d0e21e
LW
913PP(pp_postdec)
914{
4e35701f 915 djSP; dTARGET;
43192e07 916 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 917 DIE(aTHX_ PL_no_modify);
a0d0e21e 918 sv_setsv(TARG, TOPs);
25da4f38 919 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 920 SvIVX(TOPs) != IV_MIN)
921 {
748a9306 922 --SvIVX(TOPs);
55497cff 923 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
924 }
925 else
926 sv_dec(TOPs);
a0d0e21e
LW
927 SvSETMAGIC(TOPs);
928 SETs(TARG);
929 return NORMAL;
930}
79072805 931
a0d0e21e
LW
932/* Ordinary operators. */
933
934PP(pp_pow)
935{
8ec5e241 936 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
a0d0e21e
LW
937 {
938 dPOPTOPnnrl;
939 SETn( pow( left, right) );
940 RETURN;
93a17b20 941 }
a0d0e21e
LW
942}
943
944PP(pp_multiply)
945{
8ec5e241 946 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
947 {
948 dPOPTOPnnrl;
949 SETn( left * right );
950 RETURN;
79072805 951 }
a0d0e21e
LW
952}
953
954PP(pp_divide)
955{
8ec5e241 956 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e 957 {
77676ba1 958 dPOPPOPnnrl;
65202027 959 NV value;
7a4c00b4 960 if (right == 0.0)
cea2e8a9 961 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
962#ifdef SLOPPYDIVIDE
963 /* insure that 20./5. == 4. */
964 {
7a4c00b4 965 IV k;
65202027
DS
966 if ((NV)I_V(left) == left &&
967 (NV)I_V(right) == right &&
7a4c00b4 968 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e 969 value = k;
ef54e1a4
JH
970 }
971 else {
7a4c00b4 972 value = left / right;
79072805 973 }
a0d0e21e
LW
974 }
975#else
7a4c00b4 976 value = left / right;
a0d0e21e
LW
977#endif
978 PUSHn( value );
979 RETURN;
79072805 980 }
a0d0e21e
LW
981}
982
983PP(pp_modulo)
984{
76e3520e 985 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 986 {
787eafbd
IZ
987 UV left;
988 UV right;
989 bool left_neg;
990 bool right_neg;
991 bool use_double = 0;
65202027
DS
992 NV dright;
993 NV dleft;
787eafbd
IZ
994
995 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
996 IV i = SvIVX(POPs);
997 right = (right_neg = (i < 0)) ? -i : i;
998 }
999 else {
1000 dright = POPn;
1001 use_double = 1;
1002 right_neg = dright < 0;
1003 if (right_neg)
1004 dright = -dright;
1005 }
a0d0e21e 1006
787eafbd
IZ
1007 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1008 IV i = SvIVX(POPs);
1009 left = (left_neg = (i < 0)) ? -i : i;
1010 }
1011 else {
1012 dleft = POPn;
1013 if (!use_double) {
a1bd196e
GS
1014 use_double = 1;
1015 dright = right;
787eafbd
IZ
1016 }
1017 left_neg = dleft < 0;
1018 if (left_neg)
1019 dleft = -dleft;
1020 }
68dc0745 1021
787eafbd 1022 if (use_double) {
65202027 1023 NV dans;
787eafbd
IZ
1024
1025#if 1
787eafbd
IZ
1026/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1027# if CASTFLAGS & 2
1028# define CAST_D2UV(d) U_V(d)
1029# else
1030# define CAST_D2UV(d) ((UV)(d))
1031# endif
a1bd196e
GS
1032 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1033 * or, in other words, precision of UV more than of NV.
1034 * But in fact the approach below turned out to be an
1035 * optimization - floor() may be slow */
787eafbd
IZ
1036 if (dright <= UV_MAX && dleft <= UV_MAX) {
1037 right = CAST_D2UV(dright);
1038 left = CAST_D2UV(dleft);
1039 goto do_uv;
1040 }
1041#endif
1042
1043 /* Backward-compatibility clause: */
853846ea
NIS
1044 dright = floor(dright + 0.5);
1045 dleft = floor(dleft + 0.5);
787eafbd
IZ
1046
1047 if (!dright)
cea2e8a9 1048 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1049
65202027 1050 dans = Perl_fmod(dleft, dright);
787eafbd
IZ
1051 if ((left_neg != right_neg) && dans)
1052 dans = dright - dans;
1053 if (right_neg)
1054 dans = -dans;
1055 sv_setnv(TARG, dans);
1056 }
1057 else {
1058 UV ans;
1059
1060 do_uv:
1061 if (!right)
cea2e8a9 1062 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1063
1064 ans = left % right;
1065 if ((left_neg != right_neg) && ans)
1066 ans = right - ans;
1067 if (right_neg) {
1068 /* XXX may warn: unary minus operator applied to unsigned type */
1069 /* could change -foo to be (~foo)+1 instead */
1070 if (ans <= ~((UV)IV_MAX)+1)
1071 sv_setiv(TARG, ~ans+1);
1072 else
65202027 1073 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1074 }
1075 else
1076 sv_setuv(TARG, ans);
1077 }
1078 PUSHTARG;
1079 RETURN;
79072805 1080 }
a0d0e21e 1081}
79072805 1082
a0d0e21e
LW
1083PP(pp_repeat)
1084{
4e35701f 1085 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1086 {
a0d0e21e 1087 register I32 count = POPi;
533c011a 1088 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW
1089 dMARK;
1090 I32 items = SP - MARK;
1091 I32 max;
79072805 1092
a0d0e21e
LW
1093 max = items * count;
1094 MEXTEND(MARK, max);
1095 if (count > 1) {
1096 while (SP > MARK) {
1097 if (*SP)
1098 SvTEMP_off((*SP));
1099 SP--;
79072805 1100 }
a0d0e21e
LW
1101 MARK++;
1102 repeatcpy((char*)(MARK + items), (char*)MARK,
1103 items * sizeof(SV*), count - 1);
1104 SP += max;
79072805 1105 }
a0d0e21e
LW
1106 else if (count <= 0)
1107 SP -= items;
79072805 1108 }
a0d0e21e
LW
1109 else { /* Note: mark already snarfed by pp_list */
1110 SV *tmpstr;
1111 STRLEN len;
1112
1113 tmpstr = POPs;
a0d0e21e
LW
1114 SvSetSV(TARG, tmpstr);
1115 SvPV_force(TARG, len);
8ebc5c01 1116 if (count != 1) {
1117 if (count < 1)
1118 SvCUR_set(TARG, 0);
1119 else {
1120 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1121 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1122 SvCUR(TARG) *= count;
7a4c00b4 1123 }
a0d0e21e 1124 *SvEND(TARG) = '\0';
a0d0e21e 1125 }
8ebc5c01 1126 (void)SvPOK_only(TARG);
a0d0e21e 1127 PUSHTARG;
79072805 1128 }
a0d0e21e 1129 RETURN;
748a9306 1130 }
a0d0e21e 1131}
79072805 1132
a0d0e21e
LW
1133PP(pp_subtract)
1134{
8ec5e241 1135 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1136 {
7a4c00b4 1137 dPOPTOPnnrl_ul;
a0d0e21e
LW
1138 SETn( left - right );
1139 RETURN;
79072805 1140 }
a0d0e21e 1141}
79072805 1142
a0d0e21e
LW
1143PP(pp_left_shift)
1144{
8ec5e241 1145 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1146 {
d0ba1bd2
JH
1147 IBW shift = POPi;
1148 if (PL_op->op_private & HINT_INTEGER) {
1149 IBW i = TOPi;
1150 i = BWi(i) << shift;
1151 SETi(BWi(i));
1152 }
1153 else {
1154 UBW u = TOPu;
1155 u <<= shift;
1156 SETu(BWu(u));
1157 }
55497cff 1158 RETURN;
79072805 1159 }
a0d0e21e 1160}
79072805 1161
a0d0e21e
LW
1162PP(pp_right_shift)
1163{
8ec5e241 1164 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1165 {
d0ba1bd2
JH
1166 IBW shift = POPi;
1167 if (PL_op->op_private & HINT_INTEGER) {
1168 IBW i = TOPi;
1169 i = BWi(i) >> shift;
1170 SETi(BWi(i));
1171 }
1172 else {
1173 UBW u = TOPu;
1174 u >>= shift;
1175 SETu(BWu(u));
1176 }
a0d0e21e 1177 RETURN;
93a17b20 1178 }
79072805
LW
1179}
1180
a0d0e21e 1181PP(pp_lt)
79072805 1182{
8ec5e241 1183 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
1184 {
1185 dPOPnv;
54310121 1186 SETs(boolSV(TOPn < value));
a0d0e21e 1187 RETURN;
79072805 1188 }
a0d0e21e 1189}
79072805 1190
a0d0e21e
LW
1191PP(pp_gt)
1192{
8ec5e241 1193 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
1194 {
1195 dPOPnv;
54310121 1196 SETs(boolSV(TOPn > value));
a0d0e21e 1197 RETURN;
79072805 1198 }
a0d0e21e
LW
1199}
1200
1201PP(pp_le)
1202{
8ec5e241 1203 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
1204 {
1205 dPOPnv;
54310121 1206 SETs(boolSV(TOPn <= value));
a0d0e21e 1207 RETURN;
79072805 1208 }
a0d0e21e
LW
1209}
1210
1211PP(pp_ge)
1212{
8ec5e241 1213 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
1214 {
1215 dPOPnv;
54310121 1216 SETs(boolSV(TOPn >= value));
a0d0e21e 1217 RETURN;
79072805 1218 }
a0d0e21e 1219}
79072805 1220
a0d0e21e
LW
1221PP(pp_ne)
1222{
8ec5e241 1223 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
1224 {
1225 dPOPnv;
54310121 1226 SETs(boolSV(TOPn != value));
a0d0e21e
LW
1227 RETURN;
1228 }
79072805
LW
1229}
1230
a0d0e21e 1231PP(pp_ncmp)
79072805 1232{
8ec5e241 1233 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
1234 {
1235 dPOPTOPnnrl;
1236 I32 value;
79072805 1237
ff0cee69 1238 if (left == right)
a0d0e21e 1239 value = 0;
a0d0e21e
LW
1240 else if (left < right)
1241 value = -1;
44a8e56a 1242 else if (left > right)
1243 value = 1;
1244 else {
3280af22 1245 SETs(&PL_sv_undef);
44a8e56a 1246 RETURN;
1247 }
a0d0e21e
LW
1248 SETi(value);
1249 RETURN;
79072805 1250 }
a0d0e21e 1251}
79072805 1252
a0d0e21e
LW
1253PP(pp_slt)
1254{
8ec5e241 1255 djSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW
1256 {
1257 dPOPTOPssrl;
533c011a 1258 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1259 ? sv_cmp_locale(left, right)
1260 : sv_cmp(left, right));
54310121 1261 SETs(boolSV(cmp < 0));
a0d0e21e
LW
1262 RETURN;
1263 }
79072805
LW
1264}
1265
a0d0e21e 1266PP(pp_sgt)
79072805 1267{
8ec5e241 1268 djSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW
1269 {
1270 dPOPTOPssrl;
533c011a 1271 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1272 ? sv_cmp_locale(left, right)
1273 : sv_cmp(left, right));
54310121 1274 SETs(boolSV(cmp > 0));
a0d0e21e
LW
1275 RETURN;
1276 }
1277}
79072805 1278
a0d0e21e
LW
1279PP(pp_sle)
1280{
8ec5e241 1281 djSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW
1282 {
1283 dPOPTOPssrl;
533c011a 1284 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1285 ? sv_cmp_locale(left, right)
1286 : sv_cmp(left, right));
54310121 1287 SETs(boolSV(cmp <= 0));
a0d0e21e 1288 RETURN;
79072805 1289 }
79072805
LW
1290}
1291
a0d0e21e
LW
1292PP(pp_sge)
1293{
8ec5e241 1294 djSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW
1295 {
1296 dPOPTOPssrl;
533c011a 1297 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1298 ? sv_cmp_locale(left, right)
1299 : sv_cmp(left, right));
54310121 1300 SETs(boolSV(cmp >= 0));
a0d0e21e
LW
1301 RETURN;
1302 }
1303}
79072805 1304
36477c24 1305PP(pp_seq)
1306{
8ec5e241 1307 djSP; tryAMAGICbinSET(seq,0);
36477c24 1308 {
1309 dPOPTOPssrl;
54310121 1310 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW
1311 RETURN;
1312 }
1313}
79072805 1314
a0d0e21e 1315PP(pp_sne)
79072805 1316{
8ec5e241 1317 djSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW
1318 {
1319 dPOPTOPssrl;
54310121 1320 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1321 RETURN;
463ee0b2 1322 }
79072805
LW
1323}
1324
a0d0e21e 1325PP(pp_scmp)
79072805 1326{
4e35701f 1327 djSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW
1328 {
1329 dPOPTOPssrl;
533c011a 1330 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1331 ? sv_cmp_locale(left, right)
1332 : sv_cmp(left, right));
1333 SETi( cmp );
a0d0e21e
LW
1334 RETURN;
1335 }
1336}
79072805 1337
55497cff 1338PP(pp_bit_and)
1339{
8ec5e241 1340 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW
1341 {
1342 dPOPTOPssrl;
4633a7c4 1343 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2
JH
1344 if (PL_op->op_private & HINT_INTEGER) {
1345 IBW value = SvIV(left) & SvIV(right);
1346 SETi(BWi(value));
1347 }
1348 else {
1349 UBW value = SvUV(left) & SvUV(right);
1350 SETu(BWu(value));
1351 }
a0d0e21e
LW
1352 }
1353 else {
533c011a 1354 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1355 SETTARG;
1356 }
1357 RETURN;
1358 }
1359}
79072805 1360
a0d0e21e
LW
1361PP(pp_bit_xor)
1362{
8ec5e241 1363 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW
1364 {
1365 dPOPTOPssrl;
4633a7c4 1366 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2
JH
1367 if (PL_op->op_private & HINT_INTEGER) {
1368 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1369 SETi(BWi(value));
1370 }
1371 else {
1372 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1373 SETu(BWu(value));
1374 }
a0d0e21e
LW
1375 }
1376 else {
533c011a 1377 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1378 SETTARG;
1379 }
1380 RETURN;
1381 }
1382}
79072805 1383
a0d0e21e
LW
1384PP(pp_bit_or)
1385{
8ec5e241 1386 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW
1387 {
1388 dPOPTOPssrl;
4633a7c4 1389 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2
JH
1390 if (PL_op->op_private & HINT_INTEGER) {
1391 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1392 SETi(BWi(value));
1393 }
1394 else {
1395 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1396 SETu(BWu(value));
1397 }
a0d0e21e
LW
1398 }
1399 else {
533c011a 1400 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1401 SETTARG;
1402 }
1403 RETURN;
79072805 1404 }
a0d0e21e 1405}
79072805 1406
a0d0e21e
LW
1407PP(pp_negate)
1408{
4e35701f 1409 djSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW
1410 {
1411 dTOPss;
4633a7c4
LW
1412 if (SvGMAGICAL(sv))
1413 mg_get(sv);
55497cff 1414 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1415 SETi(-SvIVX(sv));
1416 else if (SvNIOKp(sv))
a0d0e21e 1417 SETn(-SvNV(sv));
4633a7c4 1418 else if (SvPOKp(sv)) {
a0d0e21e
LW
1419 STRLEN len;
1420 char *s = SvPV(sv, len);
bbce6d69 1421 if (isIDFIRST(*s)) {
a0d0e21e
LW
1422 sv_setpvn(TARG, "-", 1);
1423 sv_catsv(TARG, sv);
79072805 1424 }
a0d0e21e
LW
1425 else if (*s == '+' || *s == '-') {
1426 sv_setsv(TARG, sv);
1427 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 1428 }
b86a2fa7 1429 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
834a4ddd
LW
1430 sv_setpvn(TARG, "-", 1);
1431 sv_catsv(TARG, sv);
1432 }
79072805 1433 else
a0d0e21e
LW
1434 sv_setnv(TARG, -SvNV(sv));
1435 SETTARG;
79072805 1436 }
4633a7c4
LW
1437 else
1438 SETn(-SvNV(sv));
79072805 1439 }
a0d0e21e 1440 RETURN;
79072805
LW
1441}
1442
a0d0e21e 1443PP(pp_not)
79072805 1444{
4e35701f 1445 djSP; tryAMAGICunSET(not);
3280af22 1446 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 1447 return NORMAL;
79072805
LW
1448}
1449
a0d0e21e 1450PP(pp_complement)
79072805 1451{
8ec5e241 1452 djSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW
1453 {
1454 dTOPss;
4633a7c4 1455 if (SvNIOKp(sv)) {
d0ba1bd2
JH
1456 if (PL_op->op_private & HINT_INTEGER) {
1457 IBW value = ~SvIV(sv);
1458 SETi(BWi(value));
1459 }
1460 else {
1461 UBW value = ~SvUV(sv);
1462 SETu(BWu(value));
1463 }
a0d0e21e
LW
1464 }
1465 else {
1466 register char *tmps;
1467 register long *tmpl;
55497cff 1468 register I32 anum;
a0d0e21e
LW
1469 STRLEN len;
1470
1471 SvSetSV(TARG, sv);
1472 tmps = SvPV_force(TARG, len);
1473 anum = len;
1474#ifdef LIBERAL
1475 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1476 *tmps = ~*tmps;
1477 tmpl = (long*)tmps;
1478 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1479 *tmpl = ~*tmpl;
1480 tmps = (char*)tmpl;
1481#endif
1482 for ( ; anum > 0; anum--, tmps++)
1483 *tmps = ~*tmps;
1484
1485 SETs(TARG);
1486 }
1487 RETURN;
1488 }
79072805
LW
1489}
1490
a0d0e21e
LW
1491/* integer versions of some of the above */
1492
a0d0e21e 1493PP(pp_i_multiply)
79072805 1494{
8ec5e241 1495 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
1496 {
1497 dPOPTOPiirl;
1498 SETi( left * right );
1499 RETURN;
1500 }
79072805
LW
1501}
1502
a0d0e21e 1503PP(pp_i_divide)
79072805 1504{
8ec5e241 1505 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW
1506 {
1507 dPOPiv;
1508 if (value == 0)
cea2e8a9 1509 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
1510 value = POPi / value;
1511 PUSHi( value );
1512 RETURN;
1513 }
79072805
LW
1514}
1515
a0d0e21e 1516PP(pp_i_modulo)
79072805 1517{
76e3520e 1518 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 1519 {
a0d0e21e 1520 dPOPTOPiirl;
aa306039 1521 if (!right)
cea2e8a9 1522 DIE(aTHX_ "Illegal modulus zero");
a0d0e21e
LW
1523 SETi( left % right );
1524 RETURN;
79072805 1525 }
79072805
LW
1526}
1527
a0d0e21e 1528PP(pp_i_add)
79072805 1529{
8ec5e241 1530 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e
LW
1531 {
1532 dPOPTOPiirl;
1533 SETi( left + right );
1534 RETURN;
79072805 1535 }
79072805
LW
1536}
1537
a0d0e21e 1538PP(pp_i_subtract)
79072805 1539{
8ec5e241 1540 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e
LW
1541 {
1542 dPOPTOPiirl;
1543 SETi( left - right );
1544 RETURN;
79072805 1545 }
79072805
LW
1546}
1547
a0d0e21e 1548PP(pp_i_lt)
79072805 1549{
8ec5e241 1550 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
1551 {
1552 dPOPTOPiirl;
54310121 1553 SETs(boolSV(left < right));
a0d0e21e
LW
1554 RETURN;
1555 }
79072805
LW
1556}
1557
a0d0e21e 1558PP(pp_i_gt)
79072805 1559{
8ec5e241 1560 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
1561 {
1562 dPOPTOPiirl;
54310121 1563 SETs(boolSV(left > right));
a0d0e21e
LW
1564 RETURN;
1565 }
79072805
LW
1566}
1567
a0d0e21e 1568PP(pp_i_le)
79072805 1569{
8ec5e241 1570 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
1571 {
1572 dPOPTOPiirl;
54310121 1573 SETs(boolSV(left <= right));
a0d0e21e 1574 RETURN;
85e6fe83 1575 }
79072805
LW
1576}
1577
a0d0e21e 1578PP(pp_i_ge)
79072805 1579{
8ec5e241 1580 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
1581 {
1582 dPOPTOPiirl;
54310121 1583 SETs(boolSV(left >= right));
a0d0e21e
LW
1584 RETURN;
1585 }
79072805
LW
1586}
1587
a0d0e21e 1588PP(pp_i_eq)
79072805 1589{
8ec5e241 1590 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW
1591 {
1592 dPOPTOPiirl;
54310121 1593 SETs(boolSV(left == right));
a0d0e21e
LW
1594 RETURN;
1595 }
79072805
LW
1596}
1597
a0d0e21e 1598PP(pp_i_ne)
79072805 1599{
8ec5e241 1600 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
1601 {
1602 dPOPTOPiirl;
54310121 1603 SETs(boolSV(left != right));
a0d0e21e
LW
1604 RETURN;
1605 }
79072805
LW
1606}
1607
a0d0e21e 1608PP(pp_i_ncmp)
79072805 1609{
8ec5e241 1610 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
1611 {
1612 dPOPTOPiirl;
1613 I32 value;
79072805 1614
a0d0e21e 1615 if (left > right)
79072805 1616 value = 1;
a0d0e21e 1617 else if (left < right)
79072805 1618 value = -1;
a0d0e21e 1619 else
79072805 1620 value = 0;
a0d0e21e
LW
1621 SETi(value);
1622 RETURN;
79072805 1623 }
85e6fe83
LW
1624}
1625
1626PP(pp_i_negate)
1627{
4e35701f 1628 djSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW
1629 SETi(-TOPi);
1630 RETURN;
1631}
1632
79072805
LW
1633/* High falutin' math. */
1634
1635PP(pp_atan2)
1636{
8ec5e241 1637 djSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW
1638 {
1639 dPOPTOPnnrl;
65202027 1640 SETn(Perl_atan2(left, right));
a0d0e21e
LW
1641 RETURN;
1642 }
79072805
LW
1643}
1644
1645PP(pp_sin)
1646{
4e35701f 1647 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 1648 {
65202027 1649 NV value;
a0d0e21e 1650 value = POPn;
65202027 1651 value = Perl_sin(value);
a0d0e21e
LW
1652 XPUSHn(value);
1653 RETURN;
1654 }
79072805
LW
1655}
1656
1657PP(pp_cos)
1658{
4e35701f 1659 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 1660 {
65202027 1661 NV value;
a0d0e21e 1662 value = POPn;
65202027 1663 value = Perl_cos(value);
a0d0e21e
LW
1664 XPUSHn(value);
1665 RETURN;
1666 }
79072805
LW
1667}
1668
56cb0a1c
AD
1669/* Support Configure command-line overrides for rand() functions.
1670 After 5.005, perhaps we should replace this by Configure support
1671 for drand48(), random(), or rand(). For 5.005, though, maintain
1672 compatibility by calling rand() but allow the user to override it.
1673 See INSTALL for details. --Andy Dougherty 15 July 1998
1674*/
85ab1d1d
JH
1675/* Now it's after 5.005, and Configure supports drand48() and random(),
1676 in addition to rand(). So the overrides should not be needed any more.
1677 --Jarkko Hietaniemi 27 September 1998
1678 */
1679
1680#ifndef HAS_DRAND48_PROTO
20ce7b12 1681extern double drand48 (void);
56cb0a1c
AD
1682#endif
1683
79072805
LW
1684PP(pp_rand)
1685{
4e35701f 1686 djSP; dTARGET;
65202027 1687 NV value;
79072805
LW
1688 if (MAXARG < 1)
1689 value = 1.0;
1690 else
1691 value = POPn;
1692 if (value == 0.0)
1693 value = 1.0;
80252599 1694 if (!PL_srand_called) {
85ab1d1d 1695 (void)seedDrand01((Rand_seed_t)seed());
80252599 1696 PL_srand_called = TRUE;
93dc8474 1697 }
85ab1d1d 1698 value *= Drand01();
79072805
LW
1699 XPUSHn(value);
1700 RETURN;
1701}
1702
1703PP(pp_srand)
1704{
4e35701f 1705 djSP;
93dc8474
CS
1706 UV anum;
1707 if (MAXARG < 1)
1708 anum = seed();
79072805 1709 else
93dc8474 1710 anum = POPu;
85ab1d1d 1711 (void)seedDrand01((Rand_seed_t)anum);
80252599 1712 PL_srand_called = TRUE;
79072805
LW
1713 EXTEND(SP, 1);
1714 RETPUSHYES;
1715}
1716
76e3520e 1717STATIC U32
cea2e8a9 1718S_seed(pTHX)
93dc8474 1719{
54310121 1720 /*
1721 * This is really just a quick hack which grabs various garbage
1722 * values. It really should be a real hash algorithm which
1723 * spreads the effect of every input bit onto every output bit,
85ab1d1d 1724 * if someone who knows about such things would bother to write it.
54310121 1725 * Might be a good idea to add that function to CORE as well.
85ab1d1d 1726 * No numbers below come from careful analysis or anything here,
54310121 1727 * except they are primes and SEED_C1 > 1E6 to get a full-width
1728 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1729 * probably be bigger too.
1730 */
1731#if RANDBITS > 16
1732# define SEED_C1 1000003
1733#define SEED_C4 73819
1734#else
1735# define SEED_C1 25747
1736#define SEED_C4 20639
1737#endif
1738#define SEED_C2 3
1739#define SEED_C3 269
1740#define SEED_C5 26107
1741
e858de61 1742 dTHR;
73c60299
RS
1743#ifndef PERL_NO_DEV_RANDOM
1744 int fd;
1745#endif
93dc8474 1746 U32 u;
f12c7020 1747#ifdef VMS
1748# include <starlet.h>
43c92808
HF
1749 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1750 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 1751 unsigned int when[2];
73c60299
RS
1752#else
1753# ifdef HAS_GETTIMEOFDAY
1754 struct timeval when;
1755# else
1756 Time_t when;
1757# endif
1758#endif
1759
1760/* This test is an escape hatch, this symbol isn't set by Configure. */
1761#ifndef PERL_NO_DEV_RANDOM
1762#ifndef PERL_RANDOM_DEVICE
1763 /* /dev/random isn't used by default because reads from it will block
1764 * if there isn't enough entropy available. You can compile with
1765 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1766 * is enough real entropy to fill the seed. */
1767# define PERL_RANDOM_DEVICE "/dev/urandom"
1768#endif
1769 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1770 if (fd != -1) {
1771 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1772 u = 0;
1773 PerlLIO_close(fd);
1774 if (u)
1775 return u;
1776 }
1777#endif
1778
1779#ifdef VMS
93dc8474 1780 _ckvmssts(sys$gettim(when));
54310121 1781 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1782#else
5f05dabc 1783# ifdef HAS_GETTIMEOFDAY
93dc8474 1784 gettimeofday(&when,(struct timezone *) 0);
54310121 1785 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1786# else
93dc8474 1787 (void)time(&when);
54310121 1788 u = (U32)SEED_C1 * when;
f12c7020 1789# endif
1790#endif
7766f137 1791 u += SEED_C3 * (U32)PerlProc_getpid();
56431972 1792 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
54310121 1793#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
56431972 1794 u += SEED_C5 * (U32)PTR2UV(&when);
f12c7020 1795#endif
93dc8474 1796 return u;
79072805
LW
1797}
1798
1799PP(pp_exp)
1800{
4e35701f 1801 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 1802 {
65202027 1803 NV value;
a0d0e21e 1804 value = POPn;
65202027 1805 value = Perl_exp(value);
a0d0e21e
LW
1806 XPUSHn(value);
1807 RETURN;
1808 }
79072805
LW
1809}
1810
1811PP(pp_log)
1812{
4e35701f 1813 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e 1814 {
65202027 1815 NV value;
a0d0e21e 1816 value = POPn;
bbce6d69 1817 if (value <= 0.0) {
097ee67d 1818 RESTORE_NUMERIC_STANDARD();
cea2e8a9 1819 DIE(aTHX_ "Can't take log of %g", value);
bbce6d69 1820 }
65202027 1821 value = Perl_log(value);
a0d0e21e
LW
1822 XPUSHn(value);
1823 RETURN;
1824 }
79072805
LW
1825}
1826
1827PP(pp_sqrt)
1828{
4e35701f 1829 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 1830 {
65202027 1831 NV value;
a0d0e21e 1832 value = POPn;
bbce6d69 1833 if (value < 0.0) {
097ee67d 1834 RESTORE_NUMERIC_STANDARD();
cea2e8a9 1835 DIE(aTHX_ "Can't take sqrt of %g", value);
bbce6d69 1836 }
65202027 1837 value = Perl_sqrt(value);
a0d0e21e
LW
1838 XPUSHn(value);
1839 RETURN;
1840 }
79072805
LW
1841}
1842
1843PP(pp_int)
1844{
4e35701f 1845 djSP; dTARGET;
774d564b 1846 {
65202027 1847 NV value = TOPn;
774d564b 1848 IV iv;
1849
1850 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1851 iv = SvIVX(TOPs);
1852 SETi(iv);
1853 }
1854 else {
1855 if (value >= 0.0)
65202027 1856 (void)Perl_modf(value, &value);
774d564b 1857 else {
65202027 1858 (void)Perl_modf(-value, &value);
774d564b 1859 value = -value;
1860 }
1861 iv = I_V(value);
1862 if (iv == value)
1863 SETi(iv);
1864 else
1865 SETn(value);
1866 }
79072805 1867 }
79072805
LW
1868 RETURN;
1869}
1870
463ee0b2
LW
1871PP(pp_abs)
1872{
4e35701f 1873 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 1874 {
65202027 1875 NV value = TOPn;
774d564b 1876 IV iv;
463ee0b2 1877
774d564b 1878 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1879 (iv = SvIVX(TOPs)) != IV_MIN) {
1880 if (iv < 0)
1881 iv = -iv;
1882 SETi(iv);
1883 }
1884 else {
1885 if (value < 0.0)
1886 value = -value;
1887 SETn(value);
1888 }
a0d0e21e 1889 }
774d564b 1890 RETURN;
463ee0b2
LW
1891}
1892
79072805
LW
1893PP(pp_hex)
1894{
4e35701f 1895 djSP; dTARGET;
79072805
LW
1896 char *tmps;
1897 I32 argtype;
2d8e6c8d 1898 STRLEN n_a;
79072805 1899
2d8e6c8d 1900 tmps = POPpx;
9e24b6e2 1901 XPUSHn(scan_hex(tmps, 99, &argtype));
79072805
LW
1902 RETURN;
1903}
1904
1905PP(pp_oct)
1906{
4e35701f 1907 djSP; dTARGET;
9e24b6e2 1908 NV value;
79072805
LW
1909 I32 argtype;
1910 char *tmps;
2d8e6c8d 1911 STRLEN n_a;
79072805 1912
2d8e6c8d 1913 tmps = POPpx;
464e2e8a 1914 while (*tmps && isSPACE(*tmps))
1915 tmps++;
9e24b6e2
JH
1916 if (*tmps == '0')
1917 tmps++;
1918 if (*tmps == 'x')
1919 value = scan_hex(++tmps, 99, &argtype);
1920 else if (*tmps == 'b')
1921 value = scan_bin(++tmps, 99, &argtype);
464e2e8a 1922 else
9e24b6e2
JH
1923 value = scan_oct(tmps, 99, &argtype);
1924 XPUSHn(value);
79072805
LW
1925 RETURN;
1926}
1927
1928/* String stuff. */
1929
1930PP(pp_length)
1931{
4e35701f 1932 djSP; dTARGET;
a0ed51b3
LW
1933
1934 if (IN_UTF8) {
1935 SETi( sv_len_utf8(TOPs) );
1936 RETURN;
1937 }
1938
a0d0e21e 1939 SETi( sv_len(TOPs) );
79072805
LW
1940 RETURN;
1941}
1942
1943PP(pp_substr)
1944{
4e35701f 1945 djSP; dTARGET;
79072805
LW
1946 SV *sv;
1947 I32 len;
463ee0b2 1948 STRLEN curlen;
a0ed51b3 1949 STRLEN utfcurlen;
79072805
LW
1950 I32 pos;
1951 I32 rem;
84902520 1952 I32 fail;
533c011a 1953 I32 lvalue = PL_op->op_flags & OPf_MOD;
79072805 1954 char *tmps;
3280af22 1955 I32 arybase = PL_curcop->cop_arybase;
7b8d334a
GS
1956 char *repl = 0;
1957 STRLEN repl_len;
79072805 1958
20408e3c 1959 SvTAINTED_off(TARG); /* decontaminate */
5d82c453
GA
1960 if (MAXARG > 2) {
1961 if (MAXARG > 3) {
1962 sv = POPs;
1963 repl = SvPV(sv, repl_len);
7b8d334a 1964 }
79072805 1965 len = POPi;
5d82c453 1966 }
84902520 1967 pos = POPi;
79072805 1968 sv = POPs;
849ca7ee 1969 PUTBACK;
a0d0e21e 1970 tmps = SvPV(sv, curlen);
a0ed51b3
LW
1971 if (IN_UTF8) {
1972 utfcurlen = sv_len_utf8(sv);
1973 if (utfcurlen == curlen)
1974 utfcurlen = 0;
1975 else
1976 curlen = utfcurlen;
1977 }
d1c2b58a
LW
1978 else
1979 utfcurlen = 0;
a0ed51b3 1980
84902520
TB
1981 if (pos >= arybase) {
1982 pos -= arybase;
1983 rem = curlen-pos;
1984 fail = rem;
5d82c453
GA
1985 if (MAXARG > 2) {
1986 if (len < 0) {
1987 rem += len;
1988 if (rem < 0)
1989 rem = 0;
1990 }
1991 else if (rem > len)
1992 rem = len;
1993 }
68dc0745 1994 }
84902520 1995 else {
5d82c453
GA
1996 pos += curlen;
1997 if (MAXARG < 3)
1998 rem = curlen;
1999 else if (len >= 0) {
2000 rem = pos+len;
2001 if (rem > (I32)curlen)
2002 rem = curlen;
2003 }
2004 else {
2005 rem = curlen+len;
2006 if (rem < pos)
2007 rem = pos;
2008 }
2009 if (pos < 0)
2010 pos = 0;
2011 fail = rem;
2012 rem -= pos;
84902520
TB
2013 }
2014 if (fail < 0) {
599cee73 2015 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
cea2e8a9 2016 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD
2017 RETPUSHUNDEF;
2018 }
79072805 2019 else {
a0ed51b3
LW
2020 if (utfcurlen)
2021 sv_pos_u2b(sv, &pos, &rem);
79072805 2022 tmps += pos;
79072805
LW
2023 sv_setpvn(TARG, tmps, rem);
2024 if (lvalue) { /* it's an lvalue! */
dedeecda 2025 if (!SvGMAGICAL(sv)) {
2026 if (SvROK(sv)) {
2d8e6c8d
GS
2027 STRLEN n_a;
2028 SvPV_force(sv,n_a);
599cee73 2029 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2030 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2031 "Attempt to use reference as lvalue in substr");
dedeecda 2032 }
2033 if (SvOK(sv)) /* is it defined ? */
2034 (void)SvPOK_only(sv);
2035 else
2036 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2037 }
5f05dabc 2038
a0d0e21e
LW
2039 if (SvTYPE(TARG) < SVt_PVLV) {
2040 sv_upgrade(TARG, SVt_PVLV);
2041 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2042 }
a0d0e21e 2043
5f05dabc 2044 LvTYPE(TARG) = 'x';
6ff81951
GS
2045 if (LvTARG(TARG) != sv) {
2046 if (LvTARG(TARG))
2047 SvREFCNT_dec(LvTARG(TARG));
2048 LvTARG(TARG) = SvREFCNT_inc(sv);
2049 }
a0d0e21e 2050 LvTARGOFF(TARG) = pos;
8ec5e241 2051 LvTARGLEN(TARG) = rem;
79072805 2052 }
5d82c453 2053 else if (repl)
7b8d334a 2054 sv_insert(sv, pos, rem, repl, repl_len);
79072805 2055 }
849ca7ee 2056 SPAGAIN;
79072805
LW
2057 PUSHs(TARG); /* avoid SvSETMAGIC here */
2058 RETURN;
2059}
2060
2061PP(pp_vec)
2062{
4e35701f 2063 djSP; dTARGET;
79072805
LW
2064 register I32 size = POPi;
2065 register I32 offset = POPi;
2066 register SV *src = POPs;
533c011a 2067 I32 lvalue = PL_op->op_flags & OPf_MOD;
a0d0e21e 2068
81e118e0
JH
2069 SvTAINTED_off(TARG); /* decontaminate */
2070 if (lvalue) { /* it's an lvalue! */
2071 if (SvTYPE(TARG) < SVt_PVLV) {
2072 sv_upgrade(TARG, SVt_PVLV);
2073 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2074 }
81e118e0
JH
2075 LvTYPE(TARG) = 'v';
2076 if (LvTARG(TARG) != src) {
2077 if (LvTARG(TARG))
2078 SvREFCNT_dec(LvTARG(TARG));
2079 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2080 }
81e118e0
JH
2081 LvTARGOFF(TARG) = offset;
2082 LvTARGLEN(TARG) = size;
79072805
LW
2083 }
2084
81e118e0 2085 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW
2086 PUSHs(TARG);
2087 RETURN;
2088}
2089
2090PP(pp_index)
2091{
4e35701f 2092 djSP; dTARGET;
79072805
LW
2093 SV *big;
2094 SV *little;
2095 I32 offset;
2096 I32 retval;
2097 char *tmps;
2098 char *tmps2;
463ee0b2 2099 STRLEN biglen;
3280af22 2100 I32 arybase = PL_curcop->cop_arybase;
79072805
LW
2101
2102 if (MAXARG < 3)
2103 offset = 0;
2104 else
2105 offset = POPi - arybase;
2106 little = POPs;
2107 big = POPs;
463ee0b2 2108 tmps = SvPV(big, biglen);
a0ed51b3
LW
2109 if (IN_UTF8 && offset > 0)
2110 sv_pos_u2b(big, &offset, 0);
79072805
LW
2111 if (offset < 0)
2112 offset = 0;
93a17b20
LW
2113 else if (offset > biglen)
2114 offset = biglen;
79072805 2115 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2116 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2117 retval = -1;
79072805 2118 else
a0ed51b3
LW
2119 retval = tmps2 - tmps;
2120 if (IN_UTF8 && retval > 0)
2121 sv_pos_b2u(big, &retval);
2122 PUSHi(retval + arybase);
79072805
LW
2123 RETURN;
2124}
2125
2126PP(pp_rindex)
2127{
4e35701f 2128 djSP; dTARGET;
79072805
LW
2129 SV *big;
2130 SV *little;
463ee0b2
LW
2131 STRLEN blen;
2132 STRLEN llen;
79072805
LW
2133 I32 offset;
2134 I32 retval;
2135 char *tmps;
2136 char *tmps2;
3280af22 2137 I32 arybase = PL_curcop->cop_arybase;
79072805 2138
a0d0e21e 2139 if (MAXARG >= 3)
a0ed51b3 2140 offset = POPi;
79072805
LW
2141 little = POPs;
2142 big = POPs;
463ee0b2
LW
2143 tmps2 = SvPV(little, llen);
2144 tmps = SvPV(big, blen);
79072805 2145 if (MAXARG < 3)
463ee0b2 2146 offset = blen;
a0ed51b3
LW
2147 else {
2148 if (IN_UTF8 && offset > 0)
2149 sv_pos_u2b(big, &offset, 0);
2150 offset = offset - arybase + llen;
2151 }
79072805
LW
2152 if (offset < 0)
2153 offset = 0;
463ee0b2
LW
2154 else if (offset > blen)
2155 offset = blen;
79072805 2156 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2157 tmps2, tmps2 + llen)))
a0ed51b3 2158 retval = -1;
79072805 2159 else
a0ed51b3
LW
2160 retval = tmps2 - tmps;
2161 if (IN_UTF8 && retval > 0)
2162 sv_pos_b2u(big, &retval);
2163 PUSHi(retval + arybase);
79072805
LW
2164 RETURN;
2165}
2166
2167PP(pp_sprintf)
2168{
4e35701f 2169 djSP; dMARK; dORIGMARK; dTARGET;
79072805 2170 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2171 TAINT_IF(SvTAINTED(TARG));
79072805
LW
2172 SP = ORIGMARK;
2173 PUSHTARG;
2174 RETURN;
2175}
2176
79072805
LW
2177PP(pp_ord)
2178{
4e35701f 2179 djSP; dTARGET;
bdeef251 2180 UV value;
2d8e6c8d
GS
2181 STRLEN n_a;
2182 U8 *tmps = (U8*)POPpx;
a0ed51b3 2183 I32 retlen;
79072805 2184
a0ed51b3 2185 if (IN_UTF8 && (*tmps & 0x80))
bdeef251 2186 value = utf8_to_uv(tmps, &retlen);
a0ed51b3 2187 else
bdeef251
GA
2188 value = (UV)(*tmps & 255);
2189 XPUSHu(value);
79072805
LW
2190 RETURN;
2191}
2192
463ee0b2
LW
2193PP(pp_chr)
2194{
4e35701f 2195 djSP; dTARGET;
463ee0b2 2196 char *tmps;
3b9be786 2197 U32 value = POPu;
463ee0b2 2198
748a9306 2199 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3
LW
2200
2201 if (IN_UTF8 && value >= 128) {
2202 SvGROW(TARG,8);
2203 tmps = SvPVX(TARG);
dfe13c55 2204 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
a0ed51b3
LW
2205 SvCUR_set(TARG, tmps - SvPVX(TARG));
2206 *tmps = '\0';
2207 (void)SvPOK_only(TARG);
2208 XPUSHs(TARG);
2209 RETURN;
2210 }
2211
748a9306 2212 SvGROW(TARG,2);
463ee0b2
LW
2213 SvCUR_set(TARG, 1);
2214 tmps = SvPVX(TARG);
a0ed51b3 2215 *tmps++ = value;
748a9306 2216 *tmps = '\0';
a0d0e21e 2217 (void)SvPOK_only(TARG);
463ee0b2
LW
2218 XPUSHs(TARG);
2219 RETURN;
2220}
2221
79072805
LW
2222PP(pp_crypt)
2223{
4e35701f 2224 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2225 STRLEN n_a;
79072805 2226#ifdef HAS_CRYPT
2d8e6c8d 2227 char *tmps = SvPV(left, n_a);
79072805 2228#ifdef FCRYPT
2d8e6c8d 2229 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2230#else
2d8e6c8d 2231 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW
2232#endif
2233#else
cea2e8a9 2234 DIE(aTHX_
79072805
LW
2235 "The crypt() function is unimplemented due to excessive paranoia.");
2236#endif
2237 SETs(TARG);
2238 RETURN;
2239}
2240
2241PP(pp_ucfirst)
2242{
4e35701f 2243 djSP;
79072805 2244 SV *sv = TOPs;
a0ed51b3
LW
2245 register U8 *s;
2246 STRLEN slen;
2247
dfe13c55 2248 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3
LW
2249 I32 ulen;
2250 U8 tmpbuf[10];
2251 U8 *tend;
2252 UV uv = utf8_to_uv(s, &ulen);
2253
2254 if (PL_op->op_private & OPpLOCALE) {
2255 TAINT;
2256 SvTAINTED_on(sv);
2257 uv = toTITLE_LC_uni(uv);
2258 }
2259 else
2260 uv = toTITLE_utf8(s);
2261
2262 tend = uv_to_utf8(tmpbuf, uv);
2263
014822e4 2264 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2265 dTARGET;
dfe13c55
GS
2266 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2267 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
a0ed51b3
LW
2268 SETs(TARG);
2269 }
2270 else {
dfe13c55 2271 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2272 Copy(tmpbuf, s, ulen, U8);
2273 }
a0ed51b3 2274 }
626727d5 2275 else {
014822e4 2276 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04
JS
2277 dTARGET;
2278 sv_setsv(TARG, sv);
2279 sv = TARG;
2280 SETs(sv);
2281 }
2282 s = (U8*)SvPV_force(sv, slen);
2283 if (*s) {
2284 if (PL_op->op_private & OPpLOCALE) {
2285 TAINT;
2286 SvTAINTED_on(sv);
2287 *s = toUPPER_LC(*s);
2288 }
2289 else
2290 *s = toUPPER(*s);
bbce6d69 2291 }
bbce6d69 2292 }
31351b04
JS
2293 if (SvSMAGICAL(sv))
2294 mg_set(sv);
79072805
LW
2295 RETURN;
2296}
2297
2298PP(pp_lcfirst)
2299{
4e35701f 2300 djSP;
79072805 2301 SV *sv = TOPs;
a0ed51b3
LW
2302 register U8 *s;
2303 STRLEN slen;
2304
dfe13c55 2305 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3
LW
2306 I32 ulen;
2307 U8 tmpbuf[10];
2308 U8 *tend;
2309 UV uv = utf8_to_uv(s, &ulen);
2310
2311 if (PL_op->op_private & OPpLOCALE) {
2312 TAINT;
2313 SvTAINTED_on(sv);
2314 uv = toLOWER_LC_uni(uv);
2315 }
2316 else
2317 uv = toLOWER_utf8(s);
2318
2319 tend = uv_to_utf8(tmpbuf, uv);
2320
014822e4 2321 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2322 dTARGET;
dfe13c55
GS
2323 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2324 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
a0ed51b3
LW
2325 SETs(TARG);
2326 }
2327 else {
dfe13c55 2328 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2329 Copy(tmpbuf, s, ulen, U8);
2330 }
a0ed51b3 2331 }
626727d5 2332 else {
014822e4 2333 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04
JS
2334 dTARGET;
2335 sv_setsv(TARG, sv);
2336 sv = TARG;
2337 SETs(sv);
2338 }
2339 s = (U8*)SvPV_force(sv, slen);
2340 if (*s) {
2341 if (PL_op->op_private & OPpLOCALE) {
2342 TAINT;
2343 SvTAINTED_on(sv);
2344 *s = toLOWER_LC(*s);
2345 }
2346 else
2347 *s = toLOWER(*s);
bbce6d69 2348 }
31351b04 2349 SETs(sv);
bbce6d69 2350 }
31351b04
JS
2351 if (SvSMAGICAL(sv))
2352 mg_set(sv);
79072805
LW
2353 RETURN;
2354}
2355
2356PP(pp_uc)
2357{
4e35701f 2358 djSP;
79072805 2359 SV *sv = TOPs;
a0ed51b3 2360 register U8 *s;
463ee0b2 2361 STRLEN len;
79072805 2362
a0ed51b3
LW
2363 if (IN_UTF8) {
2364 dTARGET;
2365 I32 ulen;
2366 register U8 *d;
2367 U8 *send;
2368
dfe13c55 2369 s = (U8*)SvPV(sv,len);
a5a20234
LW
2370 if (!len) {
2371 sv_setpvn(TARG, "", 0);
2372 SETs(TARG);
a0ed51b3
LW
2373 }
2374 else {
31351b04
JS
2375 (void)SvUPGRADE(TARG, SVt_PV);
2376 SvGROW(TARG, (len * 2) + 1);
2377 (void)SvPOK_only(TARG);
2378 d = (U8*)SvPVX(TARG);
2379 send = s + len;
2380 if (PL_op->op_private & OPpLOCALE) {
2381 TAINT;
2382 SvTAINTED_on(TARG);
2383 while (s < send) {
2384 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2385 s += ulen;
2386 }
a0ed51b3 2387 }
31351b04
JS
2388 else {
2389 while (s < send) {
2390 d = uv_to_utf8(d, toUPPER_utf8( s ));
2391 s += UTF8SKIP(s);
2392 }
a0ed51b3 2393 }
31351b04
JS
2394 *d = '\0';
2395 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2396 SETs(TARG);
a0ed51b3 2397 }
a0ed51b3 2398 }
626727d5 2399 else {
014822e4 2400 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04
JS
2401 dTARGET;
2402 sv_setsv(TARG, sv);
2403 sv = TARG;
2404 SETs(sv);
2405 }
2406 s = (U8*)SvPV_force(sv, len);
2407 if (len) {
2408 register U8 *send = s + len;
2409
2410 if (PL_op->op_private & OPpLOCALE) {
2411 TAINT;
2412 SvTAINTED_on(sv);
2413 for (; s < send; s++)
2414 *s = toUPPER_LC(*s);
2415 }
2416 else {
2417 for (; s < send; s++)
2418 *s = toUPPER(*s);
2419 }
bbce6d69 2420 }
79072805 2421 }
31351b04
JS
2422 if (SvSMAGICAL(sv))
2423 mg_set(sv);
79072805
LW
2424 RETURN;
2425}
2426
2427PP(pp_lc)
2428{
4e35701f 2429 djSP;
79072805 2430 SV *sv = TOPs;
a0ed51b3 2431 register U8 *s;
463ee0b2 2432 STRLEN len;
79072805 2433
a0ed51b3
LW
2434 if (IN_UTF8) {
2435 dTARGET;
2436 I32 ulen;
2437 register U8 *d;
2438 U8 *send;
2439
dfe13c55 2440 s = (U8*)SvPV(sv,len);
a5a20234
LW
2441 if (!len) {
2442 sv_setpvn(TARG, "", 0);
2443 SETs(TARG);
a0ed51b3
LW
2444 }
2445 else {
31351b04
JS
2446 (void)SvUPGRADE(TARG, SVt_PV);
2447 SvGROW(TARG, (len * 2) + 1);
2448 (void)SvPOK_only(TARG);
2449 d = (U8*)SvPVX(TARG);
2450 send = s + len;
2451 if (PL_op->op_private & OPpLOCALE) {
2452 TAINT;
2453 SvTAINTED_on(TARG);
2454 while (s < send) {
2455 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2456 s += ulen;
2457 }
a0ed51b3 2458 }
31351b04
JS
2459 else {
2460 while (s < send) {
2461 d = uv_to_utf8(d, toLOWER_utf8(s));
2462 s += UTF8SKIP(s);
2463 }
a0ed51b3 2464 }
31351b04
JS
2465 *d = '\0';
2466 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2467 SETs(TARG);
a0ed51b3 2468 }
79072805 2469 }
626727d5 2470 else {
014822e4 2471 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04
JS
2472 dTARGET;
2473 sv_setsv(TARG, sv);
2474 sv = TARG;
2475 SETs(sv);
a0ed51b3 2476 }
bbce6d69 2477
31351b04
JS
2478 s = (U8*)SvPV_force(sv, len);
2479 if (len) {
2480 register U8 *send = s + len;
bbce6d69 2481
31351b04
JS
2482 if (PL_op->op_private & OPpLOCALE) {
2483 TAINT;
2484 SvTAINTED_on(sv);
2485 for (; s < send; s++)
2486 *s = toLOWER_LC(*s);
2487 }
2488 else {
2489 for (; s < send; s++)
2490 *s = toLOWER(*s);
2491 }
bbce6d69 2492 }
79072805 2493 }
31351b04
JS
2494 if (SvSMAGICAL(sv))
2495 mg_set(sv);
79072805
LW
2496 RETURN;
2497}
2498
a0d0e21e 2499PP(pp_quotemeta)
79072805 2500{
4e35701f 2501 djSP; dTARGET;
a0d0e21e
LW
2502 SV *sv = TOPs;
2503 STRLEN len;
2504 register char *s = SvPV(sv,len);
2505 register char *d;
79072805 2506
a0d0e21e
LW
2507 if (len) {
2508 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2509 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 2510 d = SvPVX(TARG);
0dd2cdef
LW
2511 if (IN_UTF8) {
2512 while (len) {
2513 if (*s & 0x80) {
2514 STRLEN ulen = UTF8SKIP(s);
2515 if (ulen > len)
2516 ulen = len;
2517 len -= ulen;
2518 while (ulen--)
2519 *d++ = *s++;
2520 }
2521 else {
2522 if (!isALNUM(*s))
2523 *d++ = '\\';
2524 *d++ = *s++;
2525 len--;
2526 }
2527 }
2528 }
2529 else {
2530 while (len--) {
2531 if (!isALNUM(*s))
2532 *d++ = '\\';
2533 *d++ = *s++;
2534 }
79072805 2535 }
a0d0e21e
LW
2536 *d = '\0';
2537 SvCUR_set(TARG, d - SvPVX(TARG));
2538 (void)SvPOK_only(TARG);
79072805 2539 }
a0d0e21e
LW
2540 else
2541 sv_setpvn(TARG, s, len);
2542 SETs(TARG);
31351b04
JS
2543 if (SvSMAGICAL(TARG))
2544 mg_set(TARG);
79072805
LW
2545 RETURN;
2546}
2547
a0d0e21e 2548/* Arrays. */
79072805 2549
a0d0e21e 2550PP(pp_aslice)
79072805 2551{
4e35701f 2552 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2553 register SV** svp;
2554 register AV* av = (AV*)POPs;
533c011a 2555 register I32 lval = PL_op->op_flags & OPf_MOD;
3280af22 2556 I32 arybase = PL_curcop->cop_arybase;
748a9306 2557 I32 elem;
79072805 2558
a0d0e21e 2559 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2560 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2561 I32 max = -1;
924508f0 2562 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW
2563 elem = SvIVx(*svp);
2564 if (elem > max)
2565 max = elem;
2566 }
2567 if (max > AvMAX(av))
2568 av_extend(av, max);
2569 }
a0d0e21e 2570 while (++MARK <= SP) {
748a9306 2571 elem = SvIVx(*MARK);
a0d0e21e 2572
748a9306
LW
2573 if (elem > 0)
2574 elem -= arybase;
a0d0e21e
LW
2575 svp = av_fetch(av, elem, lval);
2576 if (lval) {
3280af22 2577 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 2578 DIE(aTHX_ PL_no_aelem, elem);
533c011a 2579 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2580 save_aelem(av, elem, svp);
79072805 2581 }
3280af22 2582 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2583 }
2584 }
748a9306 2585 if (GIMME != G_ARRAY) {
a0d0e21e
LW
2586 MARK = ORIGMARK;
2587 *++MARK = *SP;
2588 SP = MARK;
2589 }
79072805
LW
2590 RETURN;
2591}
2592
2593/* Associative arrays. */
2594
2595PP(pp_each)
2596{
59af0135 2597 djSP;
79072805 2598 HV *hash = (HV*)POPs;
c07a80fd 2599 HE *entry;
54310121 2600 I32 gimme = GIMME_V;
c750a3ec 2601 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2602
c07a80fd 2603 PUTBACK;
c750a3ec
MB
2604 /* might clobber stack_sp */
2605 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2606 SPAGAIN;
79072805 2607
79072805
LW
2608 EXTEND(SP, 2);
2609 if (entry) {
54310121 2610 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2611 if (gimme == G_ARRAY) {
59af0135 2612 SV *val;
c07a80fd 2613 PUTBACK;
c750a3ec 2614 /* might clobber stack_sp */
59af0135
GS
2615 val = realhv ?
2616 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 2617 SPAGAIN;
59af0135 2618 PUSHs(val);
79072805 2619 }
79072805 2620 }
54310121 2621 else if (gimme == G_SCALAR)
79072805
LW
2622 RETPUSHUNDEF;
2623
2624 RETURN;
2625}
2626
2627PP(pp_values)
2628{
cea2e8a9 2629 return do_kv();
79072805
LW
2630}
2631
2632PP(pp_keys)
2633{
cea2e8a9 2634 return do_kv();
79072805
LW
2635}
2636
2637PP(pp_delete)
2638{
4e35701f 2639 djSP;
54310121 2640 I32 gimme = GIMME_V;
2641 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2642 SV *sv;
5f05dabc 2643 HV *hv;
2644
533c011a 2645 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2646 dMARK; dORIGMARK;
97fcbf96 2647 U32 hvtype;
5f05dabc 2648 hv = (HV*)POPs;
97fcbf96 2649 hvtype = SvTYPE(hv);
5f05dabc 2650 while (++MARK <= SP) {
ae77835f
MB
2651 if (hvtype == SVt_PVHV)
2652 sv = hv_delete_ent(hv, *MARK, discard, 0);
ae77835f 2653 else
cea2e8a9 2654 DIE(aTHX_ "Not a HASH reference");
3280af22 2655 *MARK = sv ? sv : &PL_sv_undef;
5f05dabc 2656 }
54310121 2657 if (discard)
2658 SP = ORIGMARK;
2659 else if (gimme == G_SCALAR) {
5f05dabc 2660 MARK = ORIGMARK;
2661 *++MARK = *SP;
2662 SP = MARK;
2663 }
2664 }
2665 else {
2666 SV *keysv = POPs;
2667 hv = (HV*)POPs;
97fcbf96
MB
2668 if (SvTYPE(hv) == SVt_PVHV)
2669 sv = hv_delete_ent(hv, keysv, discard, 0);
97fcbf96 2670 else
cea2e8a9 2671 DIE(aTHX_ "Not a HASH reference");
5f05dabc 2672 if (!sv)
3280af22 2673 sv = &PL_sv_undef;
54310121 2674 if (!discard)
2675 PUSHs(sv);
79072805 2676 }
79072805
LW
2677 RETURN;
2678}
2679
a0d0e21e 2680PP(pp_exists)
79072805 2681{
4e35701f 2682 djSP;
a0d0e21e
LW
2683 SV *tmpsv = POPs;
2684 HV *hv = (HV*)POPs;
c750a3ec 2685 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2686 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2687 RETPUSHYES;
ef54e1a4
JH
2688 }
2689 else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2690 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec 2691 RETPUSHYES;
ef54e1a4
JH
2692 }
2693 else {
cea2e8a9 2694 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 2695 }
a0d0e21e
LW
2696 RETPUSHNO;
2697}
79072805 2698
a0d0e21e
LW
2699PP(pp_hslice)
2700{
4e35701f 2701 djSP; dMARK; dORIGMARK;
a0d0e21e 2702 register HV *hv = (HV*)POPs;
533c011a 2703 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2704 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2705
0ebe0038 2706 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 2707 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 2708
c750a3ec 2709 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2710 while (++MARK <= SP) {
f12c7020 2711 SV *keysv = *MARK;
ae77835f
MB
2712 SV **svp;
2713 if (realhv) {
800e9ae0 2714 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2715 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH
2716 }
2717 else {
97fcbf96 2718 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2719 }
a0d0e21e 2720 if (lval) {
2d8e6c8d
GS
2721 if (!svp || *svp == &PL_sv_undef) {
2722 STRLEN n_a;
cea2e8a9 2723 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 2724 }
533c011a 2725 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2726 save_helem(hv, keysv, svp);
93a17b20 2727 }
3280af22 2728 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2729 }
2730 }
a0d0e21e
LW
2731 if (GIMME != G_ARRAY) {
2732 MARK = ORIGMARK;
2733 *++MARK = *SP;
2734 SP = MARK;
79072805 2735 }
a0d0e21e
LW
2736 RETURN;
2737}
2738
2739/* List operators. */
2740
2741PP(pp_list)
2742{
4e35701f 2743 djSP; dMARK;
a0d0e21e
LW
2744 if (GIMME != G_ARRAY) {
2745 if (++MARK <= SP)
2746 *MARK = *SP; /* unwanted list, return last item */
8990e307 2747 else
3280af22 2748 *MARK = &PL_sv_undef;
a0d0e21e 2749 SP = MARK;
79072805 2750 }
a0d0e21e 2751 RETURN;
79072805
LW
2752}
2753
a0d0e21e 2754PP(pp_lslice)
79072805 2755{
4e35701f 2756 djSP;
3280af22
NIS
2757 SV **lastrelem = PL_stack_sp;
2758 SV **lastlelem = PL_stack_base + POPMARK;
2759 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2760 register SV **firstrelem = lastlelem + 1;
3280af22 2761 I32 arybase = PL_curcop->cop_arybase;
533c011a 2762 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2763 I32 is_something_there = lval;
79072805 2764
a0d0e21e
LW
2765 register I32 max = lastrelem - lastlelem;
2766 register SV **lelem;
2767 register I32 ix;
2768
2769 if (GIMME != G_ARRAY) {
748a9306
LW
2770 ix = SvIVx(*lastlelem);
2771 if (ix < 0)
2772 ix += max;
2773 else
2774 ix -= arybase;
a0d0e21e 2775 if (ix < 0 || ix >= max)
3280af22 2776 *firstlelem = &PL_sv_undef;
a0d0e21e
LW
2777 else
2778 *firstlelem = firstrelem[ix];
2779 SP = firstlelem;
2780 RETURN;
2781 }
2782
2783 if (max == 0) {
2784 SP = firstlelem - 1;
2785 RETURN;
2786 }
2787
2788 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2789 ix = SvIVx(*lelem);
c73bf8e3 2790 if (ix < 0)
a0d0e21e 2791 ix += max;
c73bf8e3 2792 else
748a9306 2793 ix -= arybase;
c73bf8e3
HS
2794 if (ix < 0 || ix >= max)
2795 *lelem = &PL_sv_undef;
2796 else {
2797 is_something_there = TRUE;
2798 if (!(*lelem = firstrelem[ix]))
3280af22 2799 *lelem = &PL_sv_undef;
748a9306 2800 }
79072805 2801 }
4633a7c4
LW
2802 if (is_something_there)
2803 SP = lastlelem;
2804 else
2805 SP = firstlelem - 1;
79072805
LW
2806 RETURN;
2807}
2808
a0d0e21e
LW
2809PP(pp_anonlist)
2810{
4e35701f 2811 djSP; dMARK; dORIGMARK;
a0d0e21e 2812 I32 items = SP - MARK;
44a8e56a 2813 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2814 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2815 XPUSHs(av);
a0d0e21e
LW
2816 RETURN;
2817}
2818
2819PP(pp_anonhash)
79072805 2820{
4e35701f 2821 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2822 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2823
2824 while (MARK < SP) {
2825 SV* key = *++MARK;
a0d0e21e
LW
2826 SV *val = NEWSV(46, 0);
2827 if (MARK < SP)
2828 sv_setsv(val, *++MARK);
599cee73 2829 else if (ckWARN(WARN_UNSAFE))
cea2e8a9 2830 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
f12c7020 2831 (void)hv_store_ent(hv,key,val,0);
79072805 2832 }
a0d0e21e
LW
2833 SP = ORIGMARK;
2834 XPUSHs((SV*)hv);
79072805
LW
2835 RETURN;
2836}
2837
a0d0e21e 2838PP(pp_splice)
79072805 2839{
4e35701f 2840 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2841 register AV *ary = (AV*)*++MARK;
2842 register SV **src;
2843 register SV **dst;
2844 register I32 i;
2845 register I32 offset;
2846 register I32 length;
2847 I32 newlen;
2848 I32 after;
2849 I32 diff;
2850 SV **tmparyval = 0;
93965878
NIS
2851 MAGIC *mg;
2852
33c27489
GS
2853 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2854 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2855 PUSHMARK(MARK);
8ec5e241 2856 PUTBACK;
a60c0954 2857 ENTER;
864dbfa3 2858 call_method("SPLICE",GIMME_V);
a60c0954 2859 LEAVE;
93965878
NIS
2860 SPAGAIN;
2861 RETURN;
2862 }
79072805 2863
a0d0e21e 2864 SP++;
79072805 2865
a0d0e21e 2866 if (++MARK < SP) {
84902520 2867 offset = i = SvIVx(*MARK);
a0d0e21e 2868 if (offset < 0)
93965878 2869 offset += AvFILLp(ary) + 1;
a0d0e21e 2870 else
3280af22 2871 offset -= PL_curcop->cop_arybase;
84902520 2872 if (offset < 0)
cea2e8a9 2873 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW
2874 if (++MARK < SP) {
2875 length = SvIVx(*MARK++);
48cdf507
GA
2876 if (length < 0) {
2877 length += AvFILLp(ary) - offset + 1;
2878 if (length < 0)
2879 length = 0;
2880 }
79072805
LW
2881 }
2882 else
a0d0e21e 2883 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2884 }
a0d0e21e
LW
2885 else {
2886 offset = 0;
2887 length = AvMAX(ary) + 1;
2888 }
93965878
NIS
2889 if (offset > AvFILLp(ary) + 1)
2890 offset = AvFILLp(ary) + 1;
2891 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW
2892 if (after < 0) { /* not that much array */
2893 length += after; /* offset+length now in array */
2894 after = 0;
2895 if (!AvALLOC(ary))
2896 av_extend(ary, 0);
2897 }
2898
2899 /* At this point, MARK .. SP-1 is our new LIST */
2900
2901 newlen = SP - MARK;
2902 diff = newlen - length;
13d7cbc1
GS
2903 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2904 av_reify(ary);
a0d0e21e
LW
2905
2906 if (diff < 0) { /* shrinking the area */
2907 if (newlen) {
2908 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2909 Copy(MARK, tmparyval, newlen, SV*);
79072805 2910 }
a0d0e21e
LW
2911
2912 MARK = ORIGMARK + 1;
2913 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2914 MEXTEND(MARK, length);
2915 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2916 if (AvREAL(ary)) {
bbce6d69 2917 EXTEND_MORTAL(length);
36477c24 2918 for (i = length, dst = MARK; i; i--) {
d689ffdd 2919 sv_2mortal(*dst); /* free them eventualy */
36477c24 2920 dst++;
2921 }
a0d0e21e
LW
2922 }
2923 MARK += length - 1;
79072805 2924 }
a0d0e21e
LW
2925 else {
2926 *MARK = AvARRAY(ary)[offset+length-1];
2927 if (AvREAL(ary)) {
d689ffdd 2928 sv_2mortal(*MARK);
a0d0e21e
LW
2929 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2930 SvREFCNT_dec(*dst++); /* free them now */
79072805 2931 }
a0d0e21e 2932 }
93965878 2933 AvFILLp(ary) += diff;
a0d0e21e
LW
2934
2935 /* pull up or down? */
2936
2937 if (offset < after) { /* easier to pull up */
2938 if (offset) { /* esp. if nothing to pull */
2939 src = &AvARRAY(ary)[offset-1];
2940 dst = src - diff; /* diff is negative */
2941 for (i = offset; i > 0; i--) /* can't trust Copy */
2942 *dst-- = *src--;
79072805 2943 }
a0d0e21e
LW
2944 dst = AvARRAY(ary);
2945 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2946 AvMAX(ary) += diff;
2947 }
2948 else {
2949 if (after) { /* anything to pull down? */
2950 src = AvARRAY(ary) + offset + length;
2951 dst = src + diff; /* diff is negative */
2952 Move(src, dst, after, SV*);
79072805 2953 }
93965878 2954 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW
2955 /* avoid later double free */
2956 }
2957 i = -diff;
2958 while (i)
3280af22 2959 dst[--i] = &PL_sv_undef;
a0d0e21e
LW
2960
2961 if (newlen) {
2962 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2963 newlen; newlen--) {
2964 *dst = NEWSV(46, 0);
2965 sv_setsv(*dst++, *src++);
79072805 2966 }
a0d0e21e
LW
2967 Safefree(tmparyval);
2968 }
2969 }
2970 else { /* no, expanding (or same) */
2971 if (length) {
2972 New(452, tmparyval, length, SV*); /* so remember deletion */
2973 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2974 }
2975
2976 if (diff > 0) { /* expanding */
2977
2978 /* push up or down? */
2979
2980 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2981 if (offset) {
2982 src = AvARRAY(ary);
2983 dst = src - diff;
2984 Move(src, dst, offset, SV*);
79072805 2985 }
a0d0e21e
LW
2986 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2987 AvMAX(ary) += diff;
93965878 2988 AvFILLp(ary) += diff;
79072805
LW
2989 }
2990 else {
93965878
NIS
2991 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2992 av_extend(ary, AvFILLp(ary) + diff);
2993 AvFILLp(ary) += diff;
a0d0e21e
LW
2994
2995 if (after) {
93965878 2996 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW
2997 src = dst - diff;
2998 for (i = after; i; i--) {
2999 *dst-- = *src--;
3000 }
79072805
LW
3001 }
3002 }
a0d0e21e
LW
3003 }
3004
3005 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3006 *dst = NEWSV(46, 0);
3007 sv_setsv(*dst++, *src++);
3008 }
3009 MARK = ORIGMARK + 1;
3010 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3011 if (length) {
3012 Copy(tmparyval, MARK, length, SV*);
3013 if (AvREAL(ary)) {
bbce6d69 3014 EXTEND_MORTAL(length);
36477c24 3015 for (i = length, dst = MARK; i; i--) {
d689ffdd 3016 sv_2mortal(*dst); /* free them eventualy */
36477c24 3017 dst++;
3018 }
79072805 3019 }
a0d0e21e 3020 Safefree(tmparyval);
79072805 3021 }
a0d0e21e
LW
3022 MARK += length - 1;
3023 }
3024 else if (length--) {
3025 *MARK = tmparyval[length];
3026 if (AvREAL(ary)) {
d689ffdd 3027 sv_2mortal(*MARK);
a0d0e21e
LW
3028 while (length-- > 0)
3029 SvREFCNT_dec(tmparyval[length]);
79072805 3030 }
a0d0e21e 3031 Safefree(tmparyval);
79072805 3032 }
a0d0e21e 3033 else
3280af22 3034 *MARK = &PL_sv_undef;
79072805 3035 }
a0d0e21e 3036 SP = MARK;
79072805
LW
3037 RETURN;
3038}
3039
a0d0e21e 3040PP(pp_push)
79072805 3041{
4e35701f 3042 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3043 register AV *ary = (AV*)*++MARK;
3280af22 3044 register SV *sv = &PL_sv_undef;
93965878 3045 MAGIC *mg;
79072805 3046
33c27489
GS
3047 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3048 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS
3049 PUSHMARK(MARK);
3050 PUTBACK;
a60c0954 3051 ENTER;
864dbfa3 3052 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3053 LEAVE;
93965878 3054 SPAGAIN;
93965878 3055 }
a60c0954
NIS
3056 else {
3057 /* Why no pre-extend of ary here ? */
3058 for (++MARK; MARK <= SP; MARK++) {
3059 sv = NEWSV(51, 0);
3060 if (*MARK)
3061 sv_setsv(sv, *MARK);
3062 av_push(ary, sv);
3063 }
79072805
LW
3064 }
3065 SP = ORIGMARK;
a0d0e21e 3066 PUSHi( AvFILL(ary) + 1 );
79072805
LW
3067 RETURN;
3068}
3069
a0d0e21e 3070PP(pp_pop)
79072805 3071{
4e35701f 3072 djSP;
a0d0e21e
LW
3073 AV *av = (AV*)POPs;
3074 SV *sv = av_pop(av);
d689ffdd 3075 if (AvREAL(av))
a0d0e21e
LW
3076 (void)sv_2mortal(sv);
3077 PUSHs(sv);
79072805 3078 RETURN;
79072805
LW
3079}
3080
a0d0e21e 3081PP(pp_shift)
79072805 3082{
4e35701f 3083 djSP;
a0d0e21e
LW
3084 AV *av = (AV*)POPs;
3085 SV *sv = av_shift(av);
79072805 3086 EXTEND(SP, 1);
a0d0e21e 3087 if (!sv)
79072805 3088 RETPUSHUNDEF;
d689ffdd 3089 if (AvREAL(av))
a0d0e21e
LW
3090 (void)sv_2mortal(sv);
3091 PUSHs(sv);
79072805 3092 RETURN;
79072805
LW
3093}
3094
a0d0e21e 3095PP(pp_unshift)
79072805 3096{
4e35701f 3097 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3098 register AV *ary = (AV*)*++MARK;
3099 register SV *sv;
3100 register I32 i = 0;
93965878
NIS
3101 MAGIC *mg;
3102
33c27489
GS
3103 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3104 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3105 PUSHMARK(MARK);
93965878 3106 PUTBACK;
a60c0954 3107 ENTER;
864dbfa3 3108 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3109 LEAVE;
93965878 3110 SPAGAIN;
93965878 3111 }
a60c0954
NIS
3112 else {
3113 av_unshift(ary, SP - MARK);
3114 while (MARK < SP) {
3115 sv = NEWSV(27, 0);
3116 sv_setsv(sv, *++MARK);
3117 (void)av_store(ary, i++, sv);
3118 }
79072805 3119 }
a0d0e21e
LW
3120 SP = ORIGMARK;
3121 PUSHi( AvFILL(ary) + 1 );
79072805 3122 RETURN;
79072805
LW
3123}
3124
a0d0e21e 3125PP(pp_reverse)
79072805 3126{
4e35701f 3127 djSP; dMARK;
a0d0e21e
LW
3128 register SV *tmp;
3129 SV **oldsp = SP;
79072805 3130
a0d0e21e
LW
3131 if (GIMME == G_ARRAY) {
3132 MARK++;
3133 while (MARK < SP) {
3134 tmp = *MARK;
3135 *MARK++ = *SP;
3136 *SP-- = tmp;
3137 }
dd58a1ab 3138 /* safe as long as stack cannot get extended in the above */
a0d0e21e 3139 SP = oldsp;
79072805
LW
3140 }
3141 else {
a0d0e21e
LW
3142 register char *up;
3143 register char *down;
3144 register I32 tmp;
3145 dTARGET;
3146 STRLEN len;
79072805 3147
a0d0e21e 3148 if (SP - MARK > 1)
3280af22 3149 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3150 else
54b9620d 3151 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW
3152 up = SvPV_force(TARG, len);
3153 if (len > 1) {
a0ed51b3 3154 if (IN_UTF8) { /* first reverse each character */
dfe13c55
GS
3155 U8* s = (U8*)SvPVX(TARG);
3156 U8* send = (U8*)(s + len);
a0ed51b3
LW
3157 while (s < send) {
3158 if (*s < 0x80) {
3159 s++;
3160 continue;
3161 }
3162 else {
dfe13c55 3163 up = (char*)s;
a0ed51b3 3164 s += UTF8SKIP(s);
dfe13c55 3165 down = (char*)(s - 1);
f248d071
GS
3166 if (s > send || !((*down & 0xc0) == 0x80)) {
3167 if (ckWARN_d(WARN_UTF8))
3168 Perl_warner(aTHX_ WARN_UTF8,
3169 "Malformed UTF-8 character");
a0ed51b3
LW
3170 break;
3171 }
3172 while (down > up) {
3173 tmp = *up;
3174 *up++ = *down;
3175 *down-- = tmp;
3176 }
3177 }
3178 }
3179 up = SvPVX(TARG);
3180 }
a0d0e21e
LW
3181 down = SvPVX(TARG) + len - 1;
3182 while (down > up) {
3183 tmp = *up;
3184 *up++ = *down;
3185 *down-- = tmp;
3186 }
3187 (void)SvPOK_only(TARG);
79072805 3188 }
a0d0e21e
LW
3189 SP = MARK + 1;
3190 SETTARG;
79072805 3191 }
a0d0e21e 3192 RETURN;
79072805
LW
3193}
3194
864dbfa3 3195STATIC SV *
cea2e8a9 3196S_mul128(pTHX_ SV *sv, U8 m)
55497cff 3197{
3198 STRLEN len;
3199 char *s = SvPV(sv, len);
3200 char *t;
3201 U32 i = 0;
3202
3203 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3204 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3205
09b7f37c 3206 sv_catsv(tmpNew, sv);
55497cff 3207 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3208 sv = tmpNew;
55497cff 3209 s = SvPV(sv, len);
3210 }
3211 t = s + len - 1;
3212 while (!*t) /* trailing '\0'? */
3213 t--;
3214 while (t > s) {
3215 i = ((*t - '0') << 7) + m;
3216 *(t--) = '0' + (i % 10);
3217 m = i / 10;
3218 }
3219 return (sv);
3220}
3221
a0d0e21e
LW
3222/* Explosives and implosives. */
3223
9d116dd7
JH
3224#if 'I' == 73 && 'J' == 74
3225/* On an ASCII/ISO kind of system */
ba1ac976 3226#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH
3227#else
3228/*
3229 Some other sort of character set - use memchr() so we don't match
3230 the null byte.
3231 */
80252599 3232#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH
3233#endif
3234
a0d0e21e 3235PP(pp_unpack)
79072805 3236{
4e35701f 3237 djSP;
a0d0e21e 3238 dPOPPOPssrl;
dd58a1ab 3239 I32 start_sp_offset = SP - PL_stack_base;
54310121 3240 I32 gimme = GIMME_V;
ed6116ce 3241 SV *sv;
a0d0e21e
LW
3242 STRLEN llen;
3243 STRLEN rlen;
3244 register char *pat = SvPV(left, llen);
3245 register char *s = SvPV(right, rlen);
3246 char *strend = s + rlen;
3247 char *strbeg = s;
3248 register char *patend = pat + llen;
3249 I32 datumtype;
3250 register I32 len;
3251 register I32 bits;
abdc5761 3252 register char *str;
79072805 3253
a0d0e21e
LW
3254 /* These must not be in registers: */
3255 I16 ashort;
3256 int aint;
3257 I32 along;
6b8eaf93 3258#ifdef HAS_QUAD
ecfc5424 3259 Quad_t aquad;
a0d0e21e
LW
3260#endif
3261 U16 aushort;
3262 unsigned int auint;
3263 U32 aulong;
6b8eaf93 3264#ifdef HAS_QUAD
e862df63 3265 Uquad_t auquad;
a0d0e21e
LW
3266#endif
3267 char *aptr;
3268 float afloat;
3269 double adouble;
3270 I32 checksum = 0;
3271 register U32 culong;
65202027 3272 NV cdouble;
fb73857a 3273 int commas = 0;
4b5b2118 3274 int star;
726ea183 3275#ifdef PERL_NATINT_PACK
ef54e1a4
JH
3276 int natint; /* native integer */
3277 int unatint; /* unsigned native integer */
726ea183 3278#endif
79072805 3279
54310121 3280 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW
3281 /*SUPPRESS 530*/
3282 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3283 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW
3284 patend++;
3285 while (isDIGIT(*patend) || *patend == '*')
3286 patend++;
3287 }
3288 else
3289 patend++;
79072805 3290 }
a0d0e21e
LW
3291 while (pat < patend) {
3292 reparse:
bbdab043 3293 datumtype = *pat++ & 0xFF;
726ea183 3294#ifdef PERL_NATINT_PACK
ef54e1a4 3295 natint = 0;
726ea183 3296#endif
bbdab043
CS
3297 if (isSPACE(datumtype))
3298 continue;
17f4a12d
IZ
3299 if (datumtype == '#') {
3300 while (pat < patend && *pat != '\n')
3301 pat++;
3302 continue;
3303 }
f61d411c 3304 if (*pat == '!') {
ef54e1a4
JH
3305 char *natstr = "sSiIlL";
3306
3307 if (strchr(natstr, datumtype)) {
726ea183 3308#ifdef PERL_NATINT_PACK
ef54e1a4 3309 natint = 1;
726ea183 3310#endif
ef54e1a4
JH
3311 pat++;
3312 }
3313 else
d470f89e 3314 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 3315 }
4b5b2118 3316 star = 0;
a0d0e21e
LW
3317 if (pat >= patend)
3318 len = 1;
3319 else if (*pat == '*') {
3320 len = strend - strbeg; /* long enough */
3321 pat++;
4b5b2118 3322 star = 1;
a0d0e21e
LW
3323 }
3324 else if (isDIGIT(*pat)) {
3325 len = *pat++ - '0';
06387354 3326 while (isDIGIT(*pat)) {
a0d0e21e 3327 len = (len * 10) + (*pat++ - '0');
06387354 3328 if (len < 0)
d470f89e 3329 DIE(aTHX_ "Repeat count in unpack overflows");
06387354 3330 }
a0d0e21e
LW
3331 }
3332 else
3333 len = (datumtype != '@');
4b5b2118 3334 redo_switch:
a0d0e21e
LW
3335 switch(datumtype) {
3336 default:
d470f89e 3337 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3338 case ',': /* grandfather in commas but with a warning */
599cee73 3339 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
d470f89e
GS
3340 Perl_warner(aTHX_ WARN_UNSAFE,
3341 "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3342 break;
a0d0e21e
LW
3343 case '%':
3344 if (len == 1 && pat[-1] != '1')
3345 len = 16;
3346 checksum = len;
3347 culong = 0;
3348 cdouble = 0;
3349 if (pat < patend)
3350 goto reparse;
3351 break;
3352 case '@':
3353 if (len > strend - strbeg)
cea2e8a9 3354 DIE(aTHX_ "@ outside of string");
a0d0e21e
LW
3355 s = strbeg + len;
3356 break;
3357 case 'X':
3358 if (len > s - strbeg)
cea2e8a9 3359 DIE(aTHX_ "X outside of string");
a0d0e21e
LW
3360 s -= len;
3361 break;
3362 case 'x':
3363 if (len > strend - s)
cea2e8a9 3364 DIE(aTHX_ "x outside of string");
a0d0e21e
LW
3365 s += len;
3366 break;
17f4a12d 3367 case '/':
dd58a1ab 3368 if (start_sp_offset >= SP - PL_stack_base)
17f4a12d 3369 DIE(aTHX_ "/ must follow a numeric type");
43192e07
IP
3370 datumtype = *pat++;
3371 if (*pat == '*')
3372 pat++; /* ignore '*' for compatibility with pack */
3373 if (isDIGIT(*pat))
17f4a12d 3374 DIE(aTHX_ "/ cannot take a count" );
43192e07 3375 len = POPi;
4b5b2118
GS
3376 star = 0;
3377 goto redo_switch;
a0d0e21e 3378 case 'A':
5a929a98 3379 case 'Z':
a0d0e21e
LW
3380 case 'a':
3381 if (len > strend - s)
3382 len = strend - s;
3383 if (checksum)
3384 goto uchar_checksum;
3385 sv = NEWSV(35, len);
3386 sv_setpvn(sv, s, len);
3387 s += len;
5a929a98 3388 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3389 aptr = s; /* borrow register */
5a929a98
VU
3390 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3391 s = SvPVX(sv);
3392 while (*s)
3393 s++;
3394 }
3395 else { /* 'A' strips both nulls and spaces */
3396 s = SvPVX(sv) + len - 1;
3397 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3398 s--;
3399 *++s = '\0';
3400 }
a0d0e21e
LW
3401 SvCUR_set(sv, s - SvPVX(sv));
3402 s = aptr; /* unborrow register */
3403 }
3404 XPUSHs(sv_2mortal(sv));
3405 break;
3406 case 'B':
3407 case 'b':
4b5b2118 3408 if (star || len > (strend - s) * 8)
a0d0e21e
LW
3409 len = (strend - s) * 8;
3410 if (checksum) {
80252599
GS
3411 if (!PL_bitcount) {
3412 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3413 for (bits = 1; bits < 256; bits++) {
80252599
GS
3414 if (bits & 1) PL_bitcount[bits]++;
3415 if (bits & 2) PL_bitcount[bits]++;
3416 if (bits & 4) PL_bitcount[bits]++;
3417 if (bits & 8) PL_bitcount[bits]++;
3418 if (bits & 16) PL_bitcount[bits]++;
3419 if (bits & 32) PL_bitcount[bits]++;
3420 if (bits & 64) PL_bitcount[bits]++;
3421 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW
3422 }
3423 }
3424 while (len >= 8) {
80252599 3425 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW
3426 len -= 8;
3427 }
3428 if (len) {
3429 bits = *s;
3430 if (datumtype == 'b') {
3431 while (len-- > 0) {
3432 if (bits & 1) culong++;
3433 bits >>= 1;
3434 }
3435 }
3436 else {
3437 while (len-- > 0) {
3438 if (bits & 128) culong++;
3439 bits <<= 1;
3440 }
3441 }
3442 }
79072805
LW
3443 break;
3444 }
a0d0e21e
LW
3445 sv = NEWSV(35, len + 1);
3446 SvCUR_set(sv, len);
3447 SvPOK_on(sv);
abdc5761 3448 str = SvPVX(sv);
a0d0e21e
LW
3449 if (datumtype == 'b') {
3450 aint = len;
3451 for (len = 0; len < aint; len++) {
3452 if (len & 7) /*SUPPRESS 595*/
3453 bits >>= 1;
3454 else
3455 bits = *s++;
abdc5761 3456 *str++ = '0' + (bits & 1);
a0d0e21e
LW
3457 }
3458 }
3459 else {
3460 aint = len;
3461 for (len = 0; len < aint; len++) {
3462 if (len & 7)
3463 bits <<= 1;
3464 else
3465 bits = *s++;
abdc5761 3466 *str++ = '0' + ((bits & 128) != 0);
a0d0e21e
LW
3467 }
3468 }
abdc5761 3469 *str = '\0';
a0d0e21e
LW
3470 XPUSHs(sv_2mortal(sv));
3471 break;
3472 case 'H':
3473 case 'h':
4b5b2118 3474 if (star || len > (strend - s) * 2)
a0d0e21e
LW
3475 len = (strend - s) * 2;
3476 sv = NEWSV(35, len + 1);
3477 SvCUR_set(sv, len);
3478 SvPOK_on(sv);
abdc5761 3479 str = SvPVX(sv);
a0d0e21e
LW
3480 if (datumtype == 'h') {
3481 aint = len;
3482 for (len = 0; len < aint; len++) {
3483 if (len & 1)
3484 bits >>= 4;
3485 else
3486 bits = *s++;
abdc5761 3487 *str++ = PL_hexdigit[bits & 15];
a0d0e21e
LW
3488 }
3489 }
3490 else {
3491 aint = len;
3492 for (len = 0; len < aint; len++) {
3493 if (len & 1)
3494 bits <<= 4;
3495 else
3496 bits = *s++;
abdc5761 3497 *str++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW
3498 }
3499 }
abdc5761 3500 *str = '\0';
a0d0e21e
LW
3501 XPUSHs(sv_2mortal(sv));
3502 break;
3503 case 'c':
3504 if (len > strend - s)
3505 len = strend - s;
3506 if (checksum) {
3507 while (len-- > 0) {
3508 aint = *s++;
3509 if (aint >= 128) /* fake up signed chars */
3510 aint -= 256;
3511 culong += aint;
3512 }
3513 }
3514 else {
3515 EXTEND(SP, len);
bbce6d69 3516 EXTEND_MORTAL(len);
a0d0e21e
LW
3517 while (len-- > 0) {
3518 aint = *s++;
3519 if (aint >= 128) /* fake up signed chars */
3520 aint -= 256;
3521 sv = NEWSV(36, 0);
1e422769 3522 sv_setiv(sv, (IV)aint);
a0d0e21e
LW
3523 PUSHs(sv_2mortal(sv));
3524 }
3525 }
3526 break;
3527 case 'C':
3528 if (len > strend - s)
3529 len = strend - s;
3530 if (checksum) {
3531 uchar_checksum:
3532 while (len-- > 0) {
3533 auint = *s++ & 255;
3534 culong += auint;
3535 }
3536 }
3537 else {
3538 EXTEND(SP, len);
bbce6d69 3539 EXTEND_MORTAL(len);
a0d0e21e
LW
3540 while (len-- > 0) {
3541 auint = *s++ & 255;
3542 sv = NEWSV(37, 0);
1e422769 3543 sv_setiv(sv, (IV)auint);
a0d0e21e
LW
3544 PUSHs(sv_2mortal(sv));
3545 }
3546 }
3547 break;
a0ed51b3
LW
3548 case 'U':
3549 if (len > strend - s)
3550 len = strend - s;
3551 if (checksum) {
3552 while (len-- > 0 && s < strend) {
dfe13c55 3553 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3 3554 s += along;
32d8b6e5 3555 if (checksum > 32)
65202027 3556 cdouble += (NV)auint;
32d8b6e5
GA
3557 else
3558 culong += auint;
a0ed51b3
LW
3559 }
3560 }
3561 else {
3562 EXTEND(SP, len);
3563 EXTEND_MORTAL(len);
3564 while (len-- > 0 && s < strend) {
dfe13c55 3565 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3
LW
3566 s += along;
3567 sv = NEWSV(37, 0);
bdeef251 3568 sv_setuv(sv, (UV)auint);
a0ed51b3
LW
3569 PUSHs(sv_2mortal(sv));
3570 }
3571 }
3572 break;
a0d0e21e 3573 case 's':
726ea183
JH
3574#if SHORTSIZE == SIZE16
3575 along = (strend - s) / SIZE16;
3576#else
ef54e1a4 3577 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
726ea183 3578#endif
a0d0e21e
LW
3579 if (len > along)
3580 len = along;
3581 if (checksum) {
726ea183 3582#if SHORTSIZE != SIZE16
ef54e1a4 3583 if (natint) {
bf9315bb 3584 short ashort;
ef54e1a4
JH
3585 while (len-- > 0) {
3586 COPYNN(s, &ashort, sizeof(short));
3587 s += sizeof(short);
3588 culong += ashort;
3589
3590 }
3591 }
726ea183
JH
3592 else
3593#endif
3594 {
ef54e1a4
JH
3595 while (len-- > 0) {
3596 COPY16(s, &ashort);
c67712b2
JH
3597#if SHORTSIZE > SIZE16
3598 if (ashort > 32767)
3599 ashort -= 65536;
3600#endif
ef54e1a4
JH
3601 s += SIZE16;
3602 culong += ashort;
3603 }
a0d0e21e
LW
3604 }
3605 }
3606 else {
3607 EXTEND(SP, len);
bbce6d69 3608 EXTEND_MORTAL(len);
726ea183 3609#if SHORTSIZE != SIZE16
ef54e1a4 3610 if (natint) {
bf9315bb 3611 short ashort;
ef54e1a4
JH
3612 while (len-- > 0) {
3613 COPYNN(s, &ashort, sizeof(short));
3614 s += sizeof(short);
3615 sv = NEWSV(38, 0);
3616 sv_setiv(sv, (IV)ashort);
3617 PUSHs(sv_2mortal(sv));
3618 }
3619 }
726ea183
JH
3620 else
3621#endif
3622 {
ef54e1a4
JH
3623 while (len-- > 0) {
3624 COPY16(s, &ashort);
c67712b2
JH
3625#if SHORTSIZE > SIZE16
3626 if (ashort > 32767)
3627 ashort -= 65536;
3628#endif
ef54e1a4
JH
3629 s += SIZE16;
3630 sv = NEWSV(38, 0);
3631 sv_setiv(sv, (IV)ashort);
3632 PUSHs(sv_2mortal(sv));
3633 }
a0d0e21e
LW
3634 }
3635 }
3636 break;
3637 case 'v':
3638 case 'n':
3639 case 'S':
726ea183
JH
3640#if SHORTSIZE == SIZE16
3641 along = (strend - s) / SIZE16;
3642#else
ef54e1a4
JH
3643 unatint = natint && datumtype == 'S';
3644 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
726ea183 3645#endif
a0d0e21e
LW
3646 if (len > along)
3647 len = along;
3648 if (checksum) {
726ea183 3649#if SHORTSIZE != SIZE16
ef54e1a4 3650 if (unatint) {
bf9315bb 3651 unsigned short aushort;
ef54e1a4
JH
3652 while (len-- > 0) {
3653 COPYNN(s, &aushort, sizeof(unsigned short));
3654 s += sizeof(unsigned short);
3655 culong += aushort;
3656 }
3657 }
726ea183
JH
3658 else
3659#endif
3660 {
ef54e1a4
JH
3661 while (len-- > 0) {
3662 COPY16(s, &aushort);
3663 s += SIZE16;
a0d0e21e 3664#ifdef HAS_NTOHS
ef54e1a4
JH
3665 if (datumtype == 'n')
3666 aushort = PerlSock_ntohs(aushort);
79072805 3667#endif
a0d0e21e 3668#ifdef HAS_VTOHS
ef54e1a4
JH
3669 if (datumtype == 'v')
3670 aushort = vtohs(aushort);
79072805 3671#endif
ef54e1a4
JH
3672 culong += aushort;
3673 }
a0d0e21e
LW
3674 }
3675 }
3676 else {
3677 EXTEND(SP, len);
bbce6d69 3678 EXTEND_MORTAL(len);
726ea183 3679#if SHORTSIZE != SIZE16
ef54e1a4 3680 if (unatint) {
bf9315bb 3681 unsigned short aushort;
ef54e1a4
JH
3682 while (len-- > 0) {
3683 COPYNN(s, &aushort, sizeof(unsigned short));
3684 s += sizeof(unsigned short);
3685 sv = NEWSV(39, 0);
726ea183 3686 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH
3687 PUSHs(sv_2mortal(sv));
3688 }
3689 }
726ea183
JH
3690 else
3691#endif
3692 {