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