This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
missed a file
[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
PP
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
PP
39 */
40typedef int IBW;
41typedef unsigned UBW;
42
96e4d5b1
PP
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
PP
51# define BW_BITS 32
52# define BW_MASK ((1 << BW_BITS) - 1)
53# define BW_SIGN (1 << (BW_BITS - 1))
96e4d5b1
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
187 gimme = GIMME_V;
188 if (gimme == G_ARRAY) {
a0d0e21e 189 RETURNOP(do_kv(ARGS));
85e6fe83 190 }
54310121 191 else if (gimme == G_SCALAR) {
85e6fe83 192 SV* sv = sv_newmortal();
46fc3d4c
PP
193 if (HvFILL((HV*)TARG))
194 sv_setpvf(sv, "%ld/%ld",
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{
205 DIE("NOT IMPL LINE %d",__LINE__);
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
PP
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)
a0d0e21e 227 DIE("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)
22c35a8c 260 DIE(PL_no_usym, "a symbol");
599cee73 261 if (ckWARN(WARN_UNINITIALIZED))
22c35a8c 262 warner(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)
275 DIE(PL_no_symref, sym, "a symbol");
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:
a0d0e21e 299 DIE("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)
22c35a8c 316 DIE(PL_no_usym, "a SCALAR");
599cee73 317 if (ckWARN(WARN_UNINITIALIZED))
22c35a8c 318 warner(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)
331 DIE(PL_no_symref, sym, "a SCALAR");
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
PP
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
PP
416PP(pp_prototype)
417{
4e35701f 418 djSP;
c07a80fd
PP
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:
3f4520fe 470 croak("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
PP
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
PP
513 while (++MARK <= SP)
514 *MARK = refto(*MARK);
a0d0e21e 515 RETURN;
79072805
LW
516}
517
76e3520e 518STATIC SV*
864dbfa3 519refto(pTHX_ SV *sv)
71be2cbc
PP
520{
521 SV* rv;
522
523 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
524 if (LvTARGLEN(sv))
68dc0745
PP
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
PP
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
PP
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
PM
575 if (ckWARN(WARN_UNSAFE) && len == 0)
576 warner(WARN_UNSAFE,
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
PP
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
PP
598 sv = Nullsv;
599 switch (elem ? *elem : '\0')
600 {
601 case 'A':
602 if (strEQ(elem, "ARRAY"))
76e3520e 603 tmpRef = (SV*)GvAV(gv);
fb73857a
PP
604 break;
605 case 'C':
606 if (strEQ(elem, "CODE"))
76e3520e 607 tmpRef = (SV*)GvCVu(gv);
fb73857a
PP
608 break;
609 case 'F':
610 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 611 tmpRef = (SV*)GvIOp(gv);
fb73857a
PP
612 break;
613 case 'G':
614 if (strEQ(elem, "GLOB"))
76e3520e 615 tmpRef = (SV*)gv;
fb73857a
PP
616 break;
617 case 'H':
618 if (strEQ(elem, "HASH"))
76e3520e 619 tmpRef = (SV*)GvHV(gv);
fb73857a
PP
620 break;
621 case 'I':
622 if (strEQ(elem, "IO"))
76e3520e 623 tmpRef = (SV*)GvIOp(gv);
fb73857a
PP
624 break;
625 case 'N':
626 if (strEQ(elem, "NAME"))
79cb57f6 627 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a
PP
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
PP
636 break;
637 }
76e3520e
GS
638 if (tmpRef)
639 sv = newRV(tmpRef);
fb73857a
PP
640 if (sv)
641 sv_2mortal(sv);
642 else
3280af22 643 sv = &PL_sv_undef;
fb73857a
PP
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
PP
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
PP
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)
692 DIE("do_study: out of memory");
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
PM
822 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
823 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
54310121 824 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c
PP
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)
22c35a8c 866 croak(PL_no_modify);
25da4f38 867 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
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)
22c35a8c 883 croak(PL_no_modify);
a0d0e21e 884 sv_setsv(TARG, TOPs);
25da4f38 885 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
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)
22c35a8c 904 croak(PL_no_modify);
a0d0e21e 905 sv_setsv(TARG, TOPs);
25da4f38 906 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
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;
7a4c00b4
PP
946 double value;
947 if (right == 0.0)
a0d0e21e
LW
948 DIE("Illegal division by zero");
949#ifdef SLOPPYDIVIDE
950 /* insure that 20./5. == 4. */
951 {
7a4c00b4
PP
952 IV k;
953 if ((double)I_V(left) == left &&
954 (double)I_V(right) == right &&
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;
979 double dright;
980 double dleft;
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
IZ
1009 if (use_double) {
1010 double dans;
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)
1035 DIE("Illegal modulus zero");
1036
1037 dans = fmod(dleft, dright);
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)
1049 DIE("Illegal modulus zero");
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
1060 sv_setnv(TARG, -(double)ans);
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
PP
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
PP
1139 }
1140 else {
36477c24 1141 UBW u = TOPu;
96e4d5b1
PP
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
PP
1158 }
1159 else {
36477c24 1160 UBW u = TOPu;
96e4d5b1
PP
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
PP
1229 else if (left > right)
1230 value = 1;
1231 else {
3280af22 1232 SETs(&PL_sv_undef);
44a8e56a
PP
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
PP
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
PP
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
PP
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
PP
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
PP
1292PP(pp_seq)
1293{
8ec5e241 1294 djSP; tryAMAGICbinSET(seq,0);
36477c24
PP
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
PP
1318 ? sv_cmp_locale(left, right)
1319 : sv_cmp(left, right));
1320 SETi( cmp );
a0d0e21e
LW
1321 RETURN;
1322 }
1323}
79072805 1324
55497cff
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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)
1496 DIE("Illegal division by zero");
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
CS
1508 if (!right)
1509 DIE("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;
1627 SETn(atan2(left, right));
1628 RETURN;
1629 }
79072805
LW
1630}
1631
1632PP(pp_sin)
1633{
4e35701f 1634 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e
LW
1635 {
1636 double value;
1637 value = POPn;
1638 value = sin(value);
1639 XPUSHn(value);
1640 RETURN;
1641 }
79072805
LW
1642}
1643
1644PP(pp_cos)
1645{
4e35701f 1646 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e
LW
1647 {
1648 double value;
1649 value = POPn;
1650 value = cos(value);
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;
79072805
LW
1674 double value;
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
864dbfa3 1705seed(pTHX)
93dc8474 1706{
54310121
PP
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
PP
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
PP
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
PP
1776# endif
1777#endif
54310121 1778 u += SEED_C3 * (U32)getpid();
3280af22 1779 u += SEED_C4 * (U32)(UV)PL_stack_sp;
54310121
PP
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
LW
1789 {
1790 double value;
1791 value = POPn;
1792 value = exp(value);
1793 XPUSHn(value);
1794 RETURN;
1795 }
79072805
LW
1796}
1797
1798PP(pp_log)
1799{
4e35701f 1800 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e
LW
1801 {
1802 double value;
1803 value = POPn;
bbce6d69 1804 if (value <= 0.0) {
36477c24 1805 SET_NUMERIC_STANDARD();
2304df62 1806 DIE("Can't take log of %g", value);
bbce6d69 1807 }
a0d0e21e
LW
1808 value = log(value);
1809 XPUSHn(value);
1810 RETURN;
1811 }
79072805
LW
1812}
1813
1814PP(pp_sqrt)
1815{
4e35701f 1816 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e
LW
1817 {
1818 double value;
1819 value = POPn;
bbce6d69 1820 if (value < 0.0) {
36477c24 1821 SET_NUMERIC_STANDARD();
2304df62 1822 DIE("Can't take sqrt of %g", value);
bbce6d69 1823 }
a0d0e21e
LW
1824 value = sqrt(value);
1825 XPUSHn(value);
1826 RETURN;
1827 }
79072805
LW
1828}
1829
1830PP(pp_int)
1831{
4e35701f 1832 djSP; dTARGET;
774d564b
PP
1833 {
1834 double value = TOPn;
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)
1843 (void)modf(value, &value);
1844 else {
1845 (void)modf(-value, &value);
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 {
774d564b
PP
1862 double value = TOPn;
1863 IV iv;
463ee0b2 1864
774d564b
PP
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
PP
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
PP
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
PM
2002 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2003 warner(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
PP
2012 if (!SvGMAGICAL(sv)) {
2013 if (SvROK(sv)) {
2d8e6c8d
GS
2014 STRLEN n_a;
2015 SvPV_force(sv,n_a);
599cee73
PM
2016 if (ckWARN(WARN_SUBSTR))
2017 warner(WARN_SUBSTR,
2018 "Attempt to use reference as lvalue in substr");
dedeecda
PP
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;
36477c24 2207#ifdef USE_LOCALE_NUMERIC
533c011a 2208 if (PL_op->op_private & OPpLOCALE)
36477c24 2209 SET_NUMERIC_LOCAL();
bbce6d69 2210 else
36477c24
PP
2211 SET_NUMERIC_STANDARD();
2212#endif
79072805 2213 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2214 TAINT_IF(SvTAINTED(TARG));
79072805
LW
2215 SP = ORIGMARK;
2216 PUSHTARG;
2217 RETURN;
2218}
2219
79072805
LW
2220PP(pp_ord)
2221{
4e35701f 2222 djSP; dTARGET;
bdeef251 2223 UV value;
2d8e6c8d
GS
2224 STRLEN n_a;
2225 U8 *tmps = (U8*)POPpx;
a0ed51b3 2226 I32 retlen;
79072805 2227
a0ed51b3 2228 if (IN_UTF8 && (*tmps & 0x80))
bdeef251 2229 value = utf8_to_uv(tmps, &retlen);
a0ed51b3 2230 else
bdeef251
GA
2231 value = (UV)(*tmps & 255);
2232 XPUSHu(value);
79072805
LW
2233 RETURN;
2234}
2235
463ee0b2
LW
2236PP(pp_chr)
2237{
4e35701f 2238 djSP; dTARGET;
463ee0b2 2239 char *tmps;
3b9be786 2240 U32 value = POPu;
463ee0b2 2241
748a9306 2242 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3
LW
2243
2244 if (IN_UTF8 && value >= 128) {
2245 SvGROW(TARG,8);
2246 tmps = SvPVX(TARG);
dfe13c55 2247 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
a0ed51b3
LW
2248 SvCUR_set(TARG, tmps - SvPVX(TARG));
2249 *tmps = '\0';
2250 (void)SvPOK_only(TARG);
2251 XPUSHs(TARG);
2252 RETURN;
2253 }
2254
748a9306 2255 SvGROW(TARG,2);
463ee0b2
LW
2256 SvCUR_set(TARG, 1);
2257 tmps = SvPVX(TARG);
a0ed51b3 2258 *tmps++ = value;
748a9306 2259 *tmps = '\0';
a0d0e21e 2260 (void)SvPOK_only(TARG);
463ee0b2
LW
2261 XPUSHs(TARG);
2262 RETURN;
2263}
2264
79072805
LW
2265PP(pp_crypt)
2266{
4e35701f 2267 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2268 STRLEN n_a;
79072805 2269#ifdef HAS_CRYPT
2d8e6c8d 2270 char *tmps = SvPV(left, n_a);
79072805 2271#ifdef FCRYPT
2d8e6c8d 2272 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2273#else
2d8e6c8d 2274 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW
2275#endif
2276#else
2277 DIE(
2278 "The crypt() function is unimplemented due to excessive paranoia.");
2279#endif
2280 SETs(TARG);
2281 RETURN;
2282}
2283
2284PP(pp_ucfirst)
2285{
4e35701f 2286 djSP;
79072805 2287 SV *sv = TOPs;
a0ed51b3
LW
2288 register U8 *s;
2289 STRLEN slen;
2290
dfe13c55 2291 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3
LW
2292 I32 ulen;
2293 U8 tmpbuf[10];
2294 U8 *tend;
2295 UV uv = utf8_to_uv(s, &ulen);
2296
2297 if (PL_op->op_private & OPpLOCALE) {
2298 TAINT;
2299 SvTAINTED_on(sv);
2300 uv = toTITLE_LC_uni(uv);
2301 }
2302 else
2303 uv = toTITLE_utf8(s);
2304
2305 tend = uv_to_utf8(tmpbuf, uv);
2306
2307 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2308 dTARGET;
dfe13c55
GS
2309 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2310 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
a0ed51b3
LW
2311 SETs(TARG);
2312 }
2313 else {
dfe13c55 2314 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2315 Copy(tmpbuf, s, ulen, U8);
2316 }
2317 RETURN;
2318 }
79072805 2319
ed6116ce 2320 if (!SvPADTMP(sv)) {
79072805
LW
2321 dTARGET;
2322 sv_setsv(TARG, sv);
2323 sv = TARG;
2324 SETs(sv);
2325 }
2d8e6c8d 2326 s = (U8*)SvPV_force(sv, slen);
bbce6d69 2327 if (*s) {
533c011a 2328 if (PL_op->op_private & OPpLOCALE) {
bbce6d69
PP
2329 TAINT;
2330 SvTAINTED_on(sv);
2331 *s = toUPPER_LC(*s);
2332 }
2333 else
2334 *s = toUPPER(*s);
2335 }
79072805
LW
2336
2337 RETURN;
2338}
2339
2340PP(pp_lcfirst)
2341{
4e35701f 2342 djSP;
79072805 2343 SV *sv = TOPs;
a0ed51b3
LW
2344 register U8 *s;
2345 STRLEN slen;
2346
dfe13c55 2347 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3
LW
2348 I32 ulen;
2349 U8 tmpbuf[10];
2350 U8 *tend;
2351 UV uv = utf8_to_uv(s, &ulen);
2352
2353 if (PL_op->op_private & OPpLOCALE) {
2354 TAINT;
2355 SvTAINTED_on(sv);
2356 uv = toLOWER_LC_uni(uv);
2357 }
2358 else
2359 uv = toLOWER_utf8(s);
2360
2361 tend = uv_to_utf8(tmpbuf, uv);
2362
2363 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2364 dTARGET;
dfe13c55
GS
2365 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2366 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
a0ed51b3
LW
2367 SETs(TARG);
2368 }
2369 else {
dfe13c55 2370 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2371 Copy(tmpbuf, s, ulen, U8);
2372 }
2373 RETURN;
2374 }
79072805 2375
ed6116ce 2376 if (!SvPADTMP(sv)) {
79072805
LW
2377 dTARGET;
2378 sv_setsv(TARG, sv);
2379 sv = TARG;
2380 SETs(sv);
2381 }
2d8e6c8d 2382 s = (U8*)SvPV_force(sv, slen);
bbce6d69 2383 if (*s) {
533c011a 2384 if (PL_op->op_private & OPpLOCALE) {
bbce6d69
PP
2385 TAINT;
2386 SvTAINTED_on(sv);
2387 *s = toLOWER_LC(*s);
2388 }
2389 else
2390 *s = toLOWER(*s);
2391 }
79072805
LW
2392
2393 SETs(sv);
2394 RETURN;
2395}
2396
2397PP(pp_uc)
2398{
4e35701f 2399 djSP;
79072805 2400 SV *sv = TOPs;
a0ed51b3 2401 register U8 *s;
463ee0b2 2402 STRLEN len;
79072805 2403
a0ed51b3
LW
2404 if (IN_UTF8) {
2405 dTARGET;
2406 I32 ulen;
2407 register U8 *d;
2408 U8 *send;
2409
dfe13c55 2410 s = (U8*)SvPV(sv,len);
a5a20234
LW
2411 if (!len) {
2412 sv_setpvn(TARG, "", 0);
2413 SETs(TARG);
a0ed51b3 2414 RETURN;
a5a20234 2415 }
a0ed51b3
LW
2416
2417 (void)SvUPGRADE(TARG, SVt_PV);
2418 SvGROW(TARG, (len * 2) + 1);
2419 (void)SvPOK_only(TARG);
dfe13c55 2420 d = (U8*)SvPVX(TARG);
a0ed51b3
LW
2421 send = s + len;
2422 if (PL_op->op_private & OPpLOCALE) {
2423 TAINT;
2424 SvTAINTED_on(TARG);
2425 while (s < send) {
2426 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2427 s += ulen;
2428 }
2429 }
2430 else {
2431 while (s < send) {
2432 d = uv_to_utf8(d, toUPPER_utf8( s ));
2433 s += UTF8SKIP(s);
2434 }
2435 }
2436 *d = '\0';
2437 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2438 SETs(TARG);
2439 RETURN;
2440 }
2441
ed6116ce 2442 if (!SvPADTMP(sv)) {
79072805
LW
2443 dTARGET;
2444 sv_setsv(TARG, sv);
2445 sv = TARG;
2446 SETs(sv);
2447 }
bbce6d69 2448
dfe13c55 2449 s = (U8*)SvPV_force(sv, len);
bbce6d69 2450 if (len) {
a0ed51b3 2451 register U8 *send = s + len;
bbce6d69 2452
533c011a 2453 if (PL_op->op_private & OPpLOCALE) {
bbce6d69
PP
2454 TAINT;
2455 SvTAINTED_on(sv);
2456 for (; s < send; s++)
2457 *s = toUPPER_LC(*s);
2458 }
2459 else {
2460 for (; s < send; s++)
2461 *s = toUPPER(*s);
2462 }
79072805
LW
2463 }
2464 RETURN;
2465}
2466
2467PP(pp_lc)
2468{
4e35701f 2469 djSP;
79072805 2470 SV *sv = TOPs;
a0ed51b3 2471 register U8 *s;
463ee0b2 2472 STRLEN len;
79072805 2473
a0ed51b3
LW
2474 if (IN_UTF8) {
2475 dTARGET;
2476 I32 ulen;
2477 register U8 *d;
2478 U8 *send;
2479
dfe13c55 2480 s = (U8*)SvPV(sv,len);
a5a20234
LW
2481 if (!len) {
2482 sv_setpvn(TARG, "", 0);
2483 SETs(TARG);
a0ed51b3 2484 RETURN;
a5a20234 2485 }
a0ed51b3
LW
2486
2487 (void)SvUPGRADE(TARG, SVt_PV);
2488 SvGROW(TARG, (len * 2) + 1);
2489 (void)SvPOK_only(TARG);
dfe13c55 2490 d = (U8*)SvPVX(TARG);
a0ed51b3
LW
2491 send = s + len;
2492 if (PL_op->op_private & OPpLOCALE) {
2493 TAINT;
2494 SvTAINTED_on(TARG);
2495 while (s < send) {
2496 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2497 s += ulen;
2498 }
2499 }
2500 else {
2501 while (s < send) {
2502 d = uv_to_utf8(d, toLOWER_utf8(s));
2503 s += UTF8SKIP(s);
2504 }
2505 }
2506 *d = '\0';
2507 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2508 SETs(TARG);
2509 RETURN;
2510 }
2511
ed6116ce 2512 if (!SvPADTMP(sv)) {
79072805
LW
2513 dTARGET;
2514 sv_setsv(TARG, sv);
2515 sv = TARG;
2516 SETs(sv);
2517 }
bbce6d69 2518
dfe13c55 2519 s = (U8*)SvPV_force(sv, len);
bbce6d69 2520 if (len) {
a0ed51b3 2521 register U8 *send = s + len;
bbce6d69 2522
533c011a 2523 if (PL_op->op_private & OPpLOCALE) {
bbce6d69
PP
2524 TAINT;
2525 SvTAINTED_on(sv);
2526 for (; s < send; s++)
2527 *s = toLOWER_LC(*s);
2528 }
2529 else {
2530 for (; s < send; s++)
2531 *s = toLOWER(*s);
2532 }
79072805
LW
2533 }
2534 RETURN;
2535}
2536
a0d0e21e 2537PP(pp_quotemeta)
79072805 2538{
4e35701f 2539 djSP; dTARGET;
a0d0e21e
LW
2540 SV *sv = TOPs;
2541 STRLEN len;
2542 register char *s = SvPV(sv,len);
2543 register char *d;
79072805 2544
a0d0e21e
LW
2545 if (len) {
2546 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2547 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 2548 d = SvPVX(TARG);
0dd2cdef
LW
2549 if (IN_UTF8) {
2550 while (len) {
2551 if (*s & 0x80) {
2552 STRLEN ulen = UTF8SKIP(s);
2553 if (ulen > len)
2554 ulen = len;
2555 len -= ulen;
2556 while (ulen--)
2557 *d++ = *s++;
2558 }
2559 else {
2560 if (!isALNUM(*s))
2561 *d++ = '\\';
2562 *d++ = *s++;
2563 len--;
2564 }
2565 }
2566 }
2567 else {
2568 while (len--) {
2569 if (!isALNUM(*s))
2570 *d++ = '\\';
2571 *d++ = *s++;
2572 }
79072805 2573 }
a0d0e21e
LW
2574 *d = '\0';
2575 SvCUR_set(TARG, d - SvPVX(TARG));
2576 (void)SvPOK_only(TARG);
79072805 2577 }
a0d0e21e
LW
2578 else
2579 sv_setpvn(TARG, s, len);
2580 SETs(TARG);
79072805
LW
2581 RETURN;
2582}
2583
a0d0e21e 2584/* Arrays. */
79072805 2585
a0d0e21e 2586PP(pp_aslice)
79072805 2587{
4e35701f 2588 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2589 register SV** svp;
2590 register AV* av = (AV*)POPs;
533c011a 2591 register I32 lval = PL_op->op_flags & OPf_MOD;
3280af22 2592 I32 arybase = PL_curcop->cop_arybase;
748a9306 2593 I32 elem;
79072805 2594
a0d0e21e 2595 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2596 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2597 I32 max = -1;
924508f0 2598 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW
2599 elem = SvIVx(*svp);
2600 if (elem > max)
2601 max = elem;
2602 }
2603 if (max > AvMAX(av))
2604 av_extend(av, max);
2605 }
a0d0e21e 2606 while (++MARK <= SP) {
748a9306 2607 elem = SvIVx(*MARK);
a0d0e21e 2608
748a9306
LW
2609 if (elem > 0)
2610 elem -= arybase;
a0d0e21e
LW
2611 svp = av_fetch(av, elem, lval);
2612 if (lval) {
3280af22 2613 if (!svp || *svp == &PL_sv_undef)
22c35a8c 2614 DIE(PL_no_aelem, elem);
533c011a 2615 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2616 save_aelem(av, elem, svp);
79072805 2617 }
3280af22 2618 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2619 }
2620 }
748a9306 2621 if (GIMME != G_ARRAY) {
a0d0e21e
LW
2622 MARK = ORIGMARK;
2623 *++MARK = *SP;
2624 SP = MARK;
2625 }
79072805
LW
2626 RETURN;
2627}
2628
2629/* Associative arrays. */
2630
2631PP(pp_each)
2632{
4e35701f 2633 djSP; dTARGET;
79072805 2634 HV *hash = (HV*)POPs;
c07a80fd 2635 HE *entry;
54310121 2636 I32 gimme = GIMME_V;
c750a3ec 2637 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2638
c07a80fd 2639 PUTBACK;
c750a3ec
MB
2640 /* might clobber stack_sp */
2641 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2642 SPAGAIN;
79072805 2643
79072805
LW
2644 EXTEND(SP, 2);
2645 if (entry) {
54310121
PP
2646 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2647 if (gimme == G_ARRAY) {
c07a80fd 2648 PUTBACK;
c750a3ec
MB
2649 /* might clobber stack_sp */
2650 sv_setsv(TARG, realhv ?
2651 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
c07a80fd 2652 SPAGAIN;
8990e307 2653 PUSHs(TARG);
79072805 2654 }
79072805 2655 }
54310121 2656 else if (gimme == G_SCALAR)
79072805
LW
2657 RETPUSHUNDEF;
2658
2659 RETURN;
2660}
2661
2662PP(pp_values)
2663{
2664 return do_kv(ARGS);
2665}
2666
2667PP(pp_keys)
2668{
2669 return do_kv(ARGS);
2670}
2671
2672PP(pp_delete)
2673{
4e35701f 2674 djSP;
54310121
PP
2675 I32 gimme = GIMME_V;
2676 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2677 SV *sv;
5f05dabc
PP
2678 HV *hv;
2679
533c011a 2680 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2681 dMARK; dORIGMARK;
97fcbf96 2682 U32 hvtype;
5f05dabc 2683 hv = (HV*)POPs;
97fcbf96 2684 hvtype = SvTYPE(hv);
5f05dabc 2685 while (++MARK <= SP) {
ae77835f
MB
2686 if (hvtype == SVt_PVHV)
2687 sv = hv_delete_ent(hv, *MARK, discard, 0);
ae77835f
MB
2688 else
2689 DIE("Not a HASH reference");
3280af22 2690 *MARK = sv ? sv : &PL_sv_undef;
5f05dabc 2691 }
54310121
PP
2692 if (discard)
2693 SP = ORIGMARK;
2694 else if (gimme == G_SCALAR) {
5f05dabc
PP
2695 MARK = ORIGMARK;
2696 *++MARK = *SP;
2697 SP = MARK;
2698 }
2699 }
2700 else {
2701 SV *keysv = POPs;
2702 hv = (HV*)POPs;
97fcbf96
MB
2703 if (SvTYPE(hv) == SVt_PVHV)
2704 sv = hv_delete_ent(hv, keysv, discard, 0);
97fcbf96 2705 else
5f05dabc 2706 DIE("Not a HASH reference");
5f05dabc 2707 if (!sv)
3280af22 2708 sv = &PL_sv_undef;
54310121
PP
2709 if (!discard)
2710 PUSHs(sv);
79072805 2711 }
79072805
LW
2712 RETURN;
2713}
2714
a0d0e21e 2715PP(pp_exists)
79072805 2716{
4e35701f 2717 djSP;
a0d0e21e
LW
2718 SV *tmpsv = POPs;
2719 HV *hv = (HV*)POPs;
c750a3ec 2720 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2721 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2722 RETPUSHYES;
ef54e1a4
JH
2723 }
2724 else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2725 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec 2726 RETPUSHYES;
ef54e1a4
JH
2727 }
2728 else {
a0d0e21e
LW
2729 DIE("Not a HASH reference");
2730 }
a0d0e21e
LW
2731 RETPUSHNO;
2732}
79072805 2733
a0d0e21e
LW
2734PP(pp_hslice)
2735{
4e35701f 2736 djSP; dMARK; dORIGMARK;
a0d0e21e 2737 register HV *hv = (HV*)POPs;
533c011a 2738 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2739 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2740
0ebe0038
SM
2741 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2742 DIE("Can't localize pseudo-hash element");
2743
c750a3ec 2744 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2745 while (++MARK <= SP) {
f12c7020 2746 SV *keysv = *MARK;
ae77835f
MB
2747 SV **svp;
2748 if (realhv) {
800e9ae0 2749 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2750 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH
2751 }
2752 else {
97fcbf96 2753 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2754 }
a0d0e21e 2755 if (lval) {
2d8e6c8d
GS
2756 if (!svp || *svp == &PL_sv_undef) {
2757 STRLEN n_a;
2758 DIE(PL_no_helem, SvPV(keysv, n_a));
2759 }
533c011a 2760 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2761 save_helem(hv, keysv, svp);
93a17b20 2762 }
3280af22 2763 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2764 }
2765 }
a0d0e21e
LW
2766 if (GIMME != G_ARRAY) {
2767 MARK = ORIGMARK;
2768 *++MARK = *SP;
2769 SP = MARK;
79072805 2770 }
a0d0e21e
LW
2771 RETURN;
2772}
2773
2774/* List operators. */
2775
2776PP(pp_list)
2777{
4e35701f 2778 djSP; dMARK;
a0d0e21e
LW
2779 if (GIMME != G_ARRAY) {
2780 if (++MARK <= SP)
2781 *MARK = *SP; /* unwanted list, return last item */
8990e307 2782 else
3280af22 2783 *MARK = &PL_sv_undef;
a0d0e21e 2784 SP = MARK;
79072805 2785 }
a0d0e21e 2786 RETURN;
79072805
LW
2787}
2788
a0d0e21e 2789PP(pp_lslice)
79072805 2790{
4e35701f 2791 djSP;
3280af22
NIS
2792 SV **lastrelem = PL_stack_sp;
2793 SV **lastlelem = PL_stack_base + POPMARK;
2794 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2795 register SV **firstrelem = lastlelem + 1;
3280af22 2796 I32 arybase = PL_curcop->cop_arybase;
533c011a 2797 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2798 I32 is_something_there = lval;
79072805 2799
a0d0e21e
LW
2800 register I32 max = lastrelem - lastlelem;
2801 register SV **lelem;
2802 register I32 ix;
2803
2804 if (GIMME != G_ARRAY) {
748a9306
LW
2805 ix = SvIVx(*lastlelem);
2806 if (ix < 0)
2807 ix += max;
2808 else
2809 ix -= arybase;
a0d0e21e 2810 if (ix < 0 || ix >= max)
3280af22 2811 *firstlelem = &PL_sv_undef;
a0d0e21e
LW
2812 else
2813 *firstlelem = firstrelem[ix];
2814 SP = firstlelem;
2815 RETURN;
2816 }
2817
2818 if (max == 0) {
2819 SP = firstlelem - 1;
2820 RETURN;
2821 }
2822
2823 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2824 ix = SvIVx(*lelem);
c73bf8e3 2825 if (ix < 0)
a0d0e21e 2826 ix += max;
c73bf8e3 2827 else
748a9306 2828 ix -= arybase;
c73bf8e3
HS
2829 if (ix < 0 || ix >= max)
2830 *lelem = &PL_sv_undef;
2831 else {
2832 is_something_there = TRUE;
2833 if (!(*lelem = firstrelem[ix]))
3280af22 2834 *lelem = &PL_sv_undef;
748a9306 2835 }
79072805 2836 }
4633a7c4
LW
2837 if (is_something_there)
2838 SP = lastlelem;
2839 else
2840 SP = firstlelem - 1;
79072805
LW
2841 RETURN;
2842}
2843
a0d0e21e
LW
2844PP(pp_anonlist)
2845{
4e35701f 2846 djSP; dMARK; dORIGMARK;
a0d0e21e 2847 I32 items = SP - MARK;
44a8e56a
PP
2848 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2849 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2850 XPUSHs(av);
a0d0e21e
LW
2851 RETURN;
2852}
2853
2854PP(pp_anonhash)
79072805 2855{
4e35701f 2856 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2857 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2858
2859 while (MARK < SP) {
2860 SV* key = *++MARK;
a0d0e21e
LW
2861 SV *val = NEWSV(46, 0);
2862 if (MARK < SP)
2863 sv_setsv(val, *++MARK);
599cee73
PM
2864 else if (ckWARN(WARN_UNSAFE))
2865 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
f12c7020 2866 (void)hv_store_ent(hv,key,val,0);
79072805 2867 }
a0d0e21e
LW
2868 SP = ORIGMARK;
2869 XPUSHs((SV*)hv);
79072805
LW
2870 RETURN;
2871}
2872
a0d0e21e 2873PP(pp_splice)
79072805 2874{
4e35701f 2875 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2876 register AV *ary = (AV*)*++MARK;
2877 register SV **src;
2878 register SV **dst;
2879 register I32 i;
2880 register I32 offset;
2881 register I32 length;
2882 I32 newlen;
2883 I32 after;
2884 I32 diff;
2885 SV **tmparyval = 0;
93965878
NIS
2886 MAGIC *mg;
2887
33c27489
GS
2888 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2889 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2890 PUSHMARK(MARK);
8ec5e241 2891 PUTBACK;
a60c0954 2892 ENTER;
864dbfa3 2893 call_method("SPLICE",GIMME_V);
a60c0954 2894 LEAVE;
93965878
NIS
2895 SPAGAIN;
2896 RETURN;
2897 }
79072805 2898
a0d0e21e 2899 SP++;
79072805 2900
a0d0e21e 2901 if (++MARK < SP) {
84902520 2902 offset = i = SvIVx(*MARK);
a0d0e21e 2903 if (offset < 0)
93965878 2904 offset += AvFILLp(ary) + 1;
a0d0e21e 2905 else
3280af22 2906 offset -= PL_curcop->cop_arybase;
84902520 2907 if (offset < 0)
22c35a8c 2908 DIE(PL_no_aelem, i);
a0d0e21e
LW
2909 if (++MARK < SP) {
2910 length = SvIVx(*MARK++);
48cdf507
GA
2911 if (length < 0) {
2912 length += AvFILLp(ary) - offset + 1;
2913 if (length < 0)
2914 length = 0;
2915 }
79072805
LW
2916 }
2917 else
a0d0e21e 2918 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2919 }
a0d0e21e
LW
2920 else {
2921 offset = 0;
2922 length = AvMAX(ary) + 1;
2923 }
93965878
NIS
2924 if (offset > AvFILLp(ary) + 1)
2925 offset = AvFILLp(ary) + 1;
2926 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW
2927 if (after < 0) { /* not that much array */
2928 length += after; /* offset+length now in array */
2929 after = 0;
2930 if (!AvALLOC(ary))
2931 av_extend(ary, 0);
2932 }
2933
2934 /* At this point, MARK .. SP-1 is our new LIST */
2935
2936 newlen = SP - MARK;
2937 diff = newlen - length;
13d7cbc1
GS
2938 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2939 av_reify(ary);
a0d0e21e
LW
2940
2941 if (diff < 0) { /* shrinking the area */
2942 if (newlen) {
2943 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2944 Copy(MARK, tmparyval, newlen, SV*);
79072805 2945 }
a0d0e21e
LW
2946
2947 MARK = ORIGMARK + 1;
2948 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2949 MEXTEND(MARK, length);
2950 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2951 if (AvREAL(ary)) {
bbce6d69 2952 EXTEND_MORTAL(length);
36477c24 2953 for (i = length, dst = MARK; i; i--) {
d689ffdd 2954 sv_2mortal(*dst); /* free them eventualy */
36477c24
PP
2955 dst++;
2956 }
a0d0e21e
LW
2957 }
2958 MARK += length - 1;
79072805 2959 }
a0d0e21e
LW
2960 else {
2961 *MARK = AvARRAY(ary)[offset+length-1];
2962 if (AvREAL(ary)) {
d689ffdd 2963 sv_2mortal(*MARK);
a0d0e21e
LW
2964 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2965 SvREFCNT_dec(*dst++); /* free them now */
79072805 2966 }
a0d0e21e 2967 }
93965878 2968 AvFILLp(ary) += diff;
a0d0e21e
LW
2969
2970 /* pull up or down? */
2971
2972 if (offset < after) { /* easier to pull up */
2973 if (offset) { /* esp. if nothing to pull */
2974 src = &AvARRAY(ary)[offset-1];
2975 dst = src - diff; /* diff is negative */
2976 for (i = offset; i > 0; i--) /* can't trust Copy */
2977 *dst-- = *src--;
79072805 2978 }
a0d0e21e
LW
2979 dst = AvARRAY(ary);
2980 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2981 AvMAX(ary) += diff;
2982 }
2983 else {
2984 if (after) { /* anything to pull down? */
2985 src = AvARRAY(ary) + offset + length;
2986 dst = src + diff; /* diff is negative */
2987 Move(src, dst, after, SV*);
79072805 2988 }
93965878 2989 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW
2990 /* avoid later double free */
2991 }
2992 i = -diff;
2993 while (i)
3280af22 2994 dst[--i] = &PL_sv_undef;
a0d0e21e
LW
2995
2996 if (newlen) {
2997 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2998 newlen; newlen--) {
2999 *dst = NEWSV(46, 0);
3000 sv_setsv(*dst++, *src++);
79072805 3001 }
a0d0e21e
LW
3002 Safefree(tmparyval);
3003 }
3004 }
3005 else { /* no, expanding (or same) */
3006 if (length) {
3007 New(452, tmparyval, length, SV*); /* so remember deletion */
3008 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3009 }
3010
3011 if (diff > 0) { /* expanding */
3012
3013 /* push up or down? */
3014
3015 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3016 if (offset) {
3017 src = AvARRAY(ary);
3018 dst = src - diff;
3019 Move(src, dst, offset, SV*);
79072805 3020 }
a0d0e21e
LW
3021 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3022 AvMAX(ary) += diff;
93965878 3023 AvFILLp(ary) += diff;
79072805
LW
3024 }
3025 else {
93965878
NIS
3026 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3027 av_extend(ary, AvFILLp(ary) + diff);
3028 AvFILLp(ary) += diff;
a0d0e21e
LW
3029
3030 if (after) {
93965878 3031 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW
3032 src = dst - diff;
3033 for (i = after; i; i--) {
3034 *dst-- = *src--;
3035 }
79072805
LW
3036 }
3037 }
a0d0e21e
LW
3038 }
3039
3040 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3041 *dst = NEWSV(46, 0);
3042 sv_setsv(*dst++, *src++);
3043 }
3044 MARK = ORIGMARK + 1;
3045 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3046 if (length) {
3047 Copy(tmparyval, MARK, length, SV*);
3048 if (AvREAL(ary)) {
bbce6d69 3049 EXTEND_MORTAL(length);
36477c24 3050 for (i = length, dst = MARK; i; i--) {
d689ffdd 3051 sv_2mortal(*dst); /* free them eventualy */
36477c24
PP
3052 dst++;
3053 }
79072805 3054 }
a0d0e21e 3055 Safefree(tmparyval);
79072805 3056 }
a0d0e21e
LW
3057 MARK += length - 1;
3058 }
3059 else if (length--) {
3060 *MARK = tmparyval[length];
3061 if (AvREAL(ary)) {
d689ffdd 3062 sv_2mortal(*MARK);
a0d0e21e
LW
3063 while (length-- > 0)
3064 SvREFCNT_dec(tmparyval[length]);
79072805 3065 }
a0d0e21e 3066 Safefree(tmparyval);
79072805 3067 }
a0d0e21e 3068 else
3280af22 3069 *MARK = &PL_sv_undef;
79072805 3070 }
a0d0e21e 3071 SP = MARK;
79072805
LW
3072 RETURN;
3073}
3074
a0d0e21e 3075PP(pp_push)
79072805 3076{
4e35701f 3077 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3078 register AV *ary = (AV*)*++MARK;
3280af22 3079 register SV *sv = &PL_sv_undef;
93965878 3080 MAGIC *mg;
79072805 3081
33c27489
GS
3082 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3083 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS
3084 PUSHMARK(MARK);
3085 PUTBACK;
a60c0954 3086 ENTER;
864dbfa3 3087 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3088 LEAVE;
93965878 3089 SPAGAIN;
93965878 3090 }
a60c0954
NIS
3091 else {
3092 /* Why no pre-extend of ary here ? */
3093 for (++MARK; MARK <= SP; MARK++) {
3094 sv = NEWSV(51, 0);
3095 if (*MARK)
3096 sv_setsv(sv, *MARK);
3097 av_push(ary, sv);
3098 }
79072805
LW
3099 }
3100 SP = ORIGMARK;
a0d0e21e 3101 PUSHi( AvFILL(ary) + 1 );
79072805
LW
3102 RETURN;
3103}
3104
a0d0e21e 3105PP(pp_pop)
79072805 3106{
4e35701f 3107 djSP;
a0d0e21e
LW
3108 AV *av = (AV*)POPs;
3109 SV *sv = av_pop(av);
d689ffdd 3110 if (AvREAL(av))
a0d0e21e
LW
3111 (void)sv_2mortal(sv);
3112 PUSHs(sv);
79072805 3113 RETURN;
79072805
LW
3114}
3115
a0d0e21e 3116PP(pp_shift)
79072805 3117{
4e35701f 3118 djSP;
a0d0e21e
LW
3119 AV *av = (AV*)POPs;
3120 SV *sv = av_shift(av);
79072805 3121 EXTEND(SP, 1);
a0d0e21e 3122 if (!sv)
79072805 3123 RETPUSHUNDEF;
d689ffdd 3124 if (AvREAL(av))
a0d0e21e
LW
3125 (void)sv_2mortal(sv);
3126 PUSHs(sv);
79072805 3127 RETURN;
79072805
LW
3128}
3129
a0d0e21e 3130PP(pp_unshift)
79072805 3131{
4e35701f 3132 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3133 register AV *ary = (AV*)*++MARK;
3134 register SV *sv;
3135 register I32 i = 0;
93965878
NIS
3136 MAGIC *mg;
3137
33c27489
GS
3138 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3139 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3140 PUSHMARK(MARK);
93965878 3141 PUTBACK;
a60c0954 3142 ENTER;
864dbfa3 3143 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3144 LEAVE;
93965878 3145 SPAGAIN;
93965878 3146 }
a60c0954
NIS
3147 else {
3148 av_unshift(ary, SP - MARK);
3149 while (MARK < SP) {
3150 sv = NEWSV(27, 0);
3151 sv_setsv(sv, *++MARK);
3152 (void)av_store(ary, i++, sv);
3153 }
79072805 3154 }
a0d0e21e
LW
3155 SP = ORIGMARK;
3156 PUSHi( AvFILL(ary) + 1 );
79072805 3157 RETURN;
79072805
LW
3158}
3159
a0d0e21e 3160PP(pp_reverse)
79072805 3161{
4e35701f 3162 djSP; dMARK;
a0d0e21e
LW
3163 register SV *tmp;
3164 SV **oldsp = SP;
79072805 3165
a0d0e21e
LW
3166 if (GIMME == G_ARRAY) {
3167 MARK++;
3168 while (MARK < SP) {
3169 tmp = *MARK;
3170 *MARK++ = *SP;
3171 *SP-- = tmp;
3172 }
3173 SP = oldsp;
79072805
LW
3174 }
3175 else {
a0d0e21e
LW
3176 register char *up;
3177 register char *down;
3178 register I32 tmp;
3179 dTARGET;
3180 STRLEN len;
79072805 3181
a0d0e21e 3182 if (SP - MARK > 1)
3280af22 3183 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3184 else
54b9620d 3185 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW
3186 up = SvPV_force(TARG, len);
3187 if (len > 1) {
a0ed51b3 3188 if (IN_UTF8) { /* first reverse each character */
dfe13c55
GS
3189 U8* s = (U8*)SvPVX(TARG);
3190 U8* send = (U8*)(s + len);
a0ed51b3
LW
3191 while (s < send) {
3192 if (*s < 0x80) {
3193 s++;
3194 continue;
3195 }
3196 else {
dfe13c55 3197 up = (char*)s;
a0ed51b3 3198 s += UTF8SKIP(s);
dfe13c55 3199 down = (char*)(s - 1);
a0ed51b3
LW
3200 if (s > send || !((*down & 0xc0) == 0x80)) {
3201 warn("Malformed UTF-8 character");
3202 break;
3203 }
3204 while (down > up) {
3205 tmp = *up;
3206 *up++ = *down;
3207 *down-- = tmp;
3208 }
3209 }
3210 }
3211 up = SvPVX(TARG);
3212 }
a0d0e21e
LW
3213 down = SvPVX(TARG) + len - 1;
3214 while (down > up) {
3215 tmp = *up;
3216 *up++ = *down;
3217 *down-- = tmp;
3218 }
3219 (void)SvPOK_only(TARG);
79072805 3220 }
a0d0e21e
LW
3221 SP = MARK + 1;
3222 SETTARG;
79072805 3223 }
a0d0e21e 3224 RETURN;
79072805
LW
3225}
3226
864dbfa3
GS
3227STATIC SV *
3228mul128(pTHX_ SV *sv, U8 m)
55497cff
PP
3229{
3230 STRLEN len;
3231 char *s = SvPV(sv, len);
3232 char *t;
3233 U32 i = 0;
3234
3235 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3236 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3237
09b7f37c 3238 sv_catsv(tmpNew, sv);
55497cff 3239 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3240 sv = tmpNew;
55497cff
PP
3241 s = SvPV(sv, len);
3242 }
3243 t = s + len - 1;
3244 while (!*t) /* trailing '\0'? */
3245 t--;
3246 while (t > s) {
3247 i = ((*t - '0') << 7) + m;
3248 *(t--) = '0' + (i % 10);
3249 m = i / 10;
3250 }
3251 return (sv);
3252}
3253
a0d0e21e
LW
3254/* Explosives and implosives. */
3255
9d116dd7
JH
3256#if 'I' == 73 && 'J' == 74
3257/* On an ASCII/ISO kind of system */
ba1ac976 3258#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH
3259#else
3260/*
3261 Some other sort of character set - use memchr() so we don't match
3262 the null byte.
3263 */
80252599 3264#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH
3265#endif
3266
a0d0e21e 3267PP(pp_unpack)
79072805 3268{
4e35701f 3269 djSP;
a0d0e21e 3270 dPOPPOPssrl;
924508f0 3271 SV **oldsp = SP;
54310121 3272 I32 gimme = GIMME_V;
ed6116ce 3273 SV *sv;
a0d0e21e
LW
3274 STRLEN llen;
3275 STRLEN rlen;
3276 register char *pat = SvPV(left, llen);
3277 register char *s = SvPV(right, rlen);
3278 char *strend = s + rlen;
3279 char *strbeg = s;
3280 register char *patend = pat + llen;
3281 I32 datumtype;
3282 register I32 len;
3283 register I32 bits;
79072805 3284
a0d0e21e
LW
3285 /* These must not be in registers: */
3286 I16 ashort;
3287 int aint;
3288 I32 along;
ecfc5424
AD
3289#ifdef HAS_QUAD
3290 Quad_t aquad;
a0d0e21e
LW
3291#endif
3292 U16 aushort;
3293 unsigned int auint;
3294 U32 aulong;
ecfc5424 3295#ifdef HAS_QUAD
e862df63 3296 Uquad_t auquad;
a0d0e21e
LW
3297#endif
3298 char *aptr;
3299 float afloat;
3300 double adouble;
3301 I32 checksum = 0;
3302 register U32 culong;
3303 double cdouble;
fb73857a 3304 int commas = 0;
726ea183 3305#ifdef PERL_NATINT_PACK
ef54e1a4
JH
3306 int natint; /* native integer */
3307 int unatint; /* unsigned native integer */
726ea183 3308#endif
79072805 3309
54310121 3310 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW
3311 /*SUPPRESS 530*/
3312 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3313 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW
3314 patend++;
3315 while (isDIGIT(*patend) || *patend == '*')
3316 patend++;
3317 }
3318 else
3319 patend++;
79072805 3320 }
a0d0e21e
LW
3321 while (pat < patend) {
3322 reparse:
bbdab043 3323 datumtype = *pat++ & 0xFF;
726ea183 3324#ifdef PERL_NATINT_PACK
ef54e1a4 3325 natint = 0;
726ea183 3326#endif
bbdab043
CS
3327 if (isSPACE(datumtype))
3328 continue;
f61d411c 3329 if (*pat == '!') {
ef54e1a4
JH
3330 char *natstr = "sSiIlL";
3331
3332 if (strchr(natstr, datumtype)) {
726ea183 3333#ifdef PERL_NATINT_PACK
ef54e1a4 3334 natint = 1;
726ea183 3335#endif
ef54e1a4
JH
3336 pat++;
3337 }
3338 else
f61d411c 3339 croak("'!' allowed only after types %s", natstr);
ef54e1a4 3340 }
a0d0e21e
LW
3341 if (pat >= patend)
3342 len = 1;
3343 else if (*pat == '*') {
3344 len = strend - strbeg; /* long enough */
3345 pat++;
3346 }
3347 else if (isDIGIT(*pat)) {
3348 len = *pat++ - '0';
3349 while (isDIGIT(*pat))
3350 len = (len * 10) + (*pat++ - '0');
3351 }
3352 else
3353 len = (datumtype != '@');
3354 switch(datumtype) {
3355 default:
bbdab043 3356 croak("Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3357 case ',': /* grandfather in commas but with a warning */
599cee73
PM
3358 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3359 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3360 break;
a0d0e21e
LW
3361 case '%':
3362 if (len == 1 && pat[-1] != '1')
3363 len = 16;
3364 checksum = len;
3365 culong = 0;
3366 cdouble = 0;
3367 if (pat < patend)
3368 goto reparse;
3369 break;
3370 case '@':
3371 if (len > strend - strbeg)
3372 DIE("@ outside of string");
3373 s = strbeg + len;
3374 break;
3375 case 'X':
3376 if (len > s - strbeg)
3377 DIE("X outside of string");
3378 s -= len;
3379 break;
3380 case 'x':
3381 if (len > strend - s)
3382 DIE("x outside of string");
3383 s += len;
3384 break;
3385 case 'A':
5a929a98 3386 case 'Z':
a0d0e21e
LW
3387 case 'a':
3388 if (len > strend - s)
3389 len = strend - s;
3390 if (checksum)
3391 goto uchar_checksum;
3392 sv = NEWSV(35, len);
3393 sv_setpvn(sv, s, len);
3394 s += len;
5a929a98 3395 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3396 aptr = s; /* borrow register */
5a929a98
VU
3397 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3398 s = SvPVX(sv);
3399 while (*s)
3400 s++;
3401 }
3402 else { /* 'A' strips both nulls and spaces */
3403 s = SvPVX(sv) + len - 1;
3404 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3405 s--;
3406 *++s = '\0';
3407 }
a0d0e21e
LW
3408 SvCUR_set(sv, s - SvPVX(sv));
3409 s = aptr; /* unborrow register */
3410 }
3411 XPUSHs(sv_2mortal(sv));
3412 break;
3413 case 'B':
3414 case 'b':
3415 if (pat[-1] == '*' || len > (strend - s) * 8)
3416 len = (strend - s) * 8;
3417 if (checksum) {
80252599
GS
3418 if (!PL_bitcount) {
3419 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3420 for (bits = 1; bits < 256; bits++) {
80252599
GS
3421 if (bits & 1) PL_bitcount[bits]++;
3422 if (bits & 2) PL_bitcount[bits]++;
3423 if (bits & 4) PL_bitcount[bits]++;
3424 if (bits & 8) PL_bitcount[bits]++;
3425 if (bits & 16) PL_bitcount[bits]++;
3426 if (bits & 32) PL_bitcount[bits]++;
3427 if (bits & 64) PL_bitcount[bits]++;
3428 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW
3429 }
3430 }
3431 while (len >= 8) {
80252599 3432 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW
3433 len -= 8;
3434 }
3435 if (len) {
3436 bits = *s;
3437 if (datumtype == 'b') {
3438 while (len-- > 0) {
3439 if (bits & 1) culong++;
3440 bits >>= 1;
3441 }
3442 }
3443 else {
3444 while (len-- > 0) {
3445 if (bits & 128) culong++;
3446 bits <<= 1;
3447 }
3448 }
3449 }
79072805
LW
3450 break;
3451 }
a0d0e21e
LW
3452 sv = NEWSV(35, len + 1);
3453 SvCUR_set(sv, len);
3454 SvPOK_on(sv);
3455 aptr = pat; /* borrow register */
3456 pat = SvPVX(sv);
3457 if (datumtype == 'b') {
3458 aint = len;
3459 for (len = 0; len < aint; len++) {
3460 if (len & 7) /*SUPPRESS 595*/
3461 bits >>= 1;
3462 else
3463 bits = *s++;
3464 *pat++ = '0' + (bits & 1);
3465 }
3466 }
3467 else {
3468 aint = len;
3469 for (len = 0; len < aint; len++) {
3470 if (len & 7)
3471 bits <<= 1;
3472 else
3473 bits = *s++;
3474 *pat++ = '0' + ((bits & 128) != 0);
3475 }
3476 }
3477 *pat = '\0';
3478 pat = aptr; /* unborrow register */
3479 XPUSHs(sv_2mortal(sv));
3480 break;
3481 case 'H':
3482 case 'h':
3483 if (pat[-1] == '*' || len > (strend - s) * 2)
3484 len = (strend - s) * 2;
3485 sv = NEWSV(35, len + 1);
3486 SvCUR_set(sv, len);
3487 SvPOK_on(sv);
3488 aptr = pat; /* borrow register */
3489 pat = SvPVX(sv);
3490 if (datumtype == 'h') {
3491 aint = len;
3492 for (len = 0; len < aint; len++) {
3493 if (len & 1)
3494 bits >>= 4;
3495 else
3496 bits = *s++;
3280af22 3497 *pat++ = PL_hexdigit[bits & 15];
a0d0e21e
LW
3498 }
3499 }
3500 else {
3501 aint = len;
3502 for (len = 0; len < aint; len++) {
3503 if (len & 1)
3504 bits <<= 4;
3505 else
3506 bits = *s++;
3280af22 3507 *pat++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW
3508 }
3509 }
3510 *pat = '\0';
3511 pat = aptr; /* unborrow register */
3512 XPUSHs(sv_2mortal(sv));
3513 break;
3514 case 'c':
3515 if (len > strend - s)
3516 len = strend - s;
3517 if (checksum) {
3518 while (len-- > 0) {
3519 aint = *s++;
3520 if (aint >= 128) /* fake up signed chars */
3521 aint -= 256;
3522 culong += aint;
3523 }
3524 }
3525 else {
3526 EXTEND(SP, len);
bbce6d69 3527 EXTEND_MORTAL(len);
a0d0e21e
LW
3528 while (len-- > 0) {
3529 aint = *s++;
3530 if (aint >= 128) /* fake up signed chars */
3531 aint -= 256;
3532 sv = NEWSV(36, 0);
1e422769 3533 sv_setiv(sv, (IV)aint);
a0d0e21e
LW
3534 PUSHs(sv_2mortal(sv));
3535 }
3536 }
3537 break;
3538 case 'C':
3539 if (len > strend - s)
3540 len = strend - s;
3541 if (checksum) {
3542 uchar_checksum:
3543 while (len-- > 0) {
3544 auint = *s++ & 255;
3545 culong += auint;
3546 }
3547 }
3548 else {
3549 EXTEND(SP, len);
bbce6d69 3550 EXTEND_MORTAL(len);
a0d0e21e
LW
3551 while (len-- > 0) {
3552 auint = *s++ & 255;
3553 sv = NEWSV(37, 0);
1e422769 3554 sv_setiv(sv, (IV)auint);
a0d0e21e
LW
3555 PUSHs(sv_2mortal(sv));
3556 }
3557 }
3558 break;
a0ed51b3
LW
3559 case 'U':
3560 if (len > strend - s)
3561 len = strend - s;
3562 if (checksum) {
3563 while (len-- > 0 && s < strend) {
dfe13c55 3564 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3 3565 s += along;
32d8b6e5
GA
3566 if (checksum > 32)
3567 cdouble += (double)auint;
3568 else
3569 culong += auint;
a0ed51b3
LW
3570 }
3571 }
3572 else {
3573 EXTEND(SP, len);
3574 EXTEND_MORTAL(len);
3575 while (len-- > 0 && s < strend) {
dfe13c55 3576 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3
LW
3577 s += along;
3578 sv = NEWSV(37, 0);
bdeef251 3579 sv_setuv(sv, (UV)auint);
a0ed51b3
LW
3580 PUSHs(sv_2mortal(sv));
3581 }
3582 }
3583 break;
a0d0e21e 3584 case 's':
726ea183
JH
3585#if SHORTSIZE == SIZE16
3586 along = (strend - s) / SIZE16;
3587#else
ef54e1a4 3588 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
726ea183 3589#endif
a0d0e21e
LW
3590 if (len > along)
3591 len = along;
3592 if (checksum) {
726ea183 3593#if SHORTSIZE != SIZE16
ef54e1a4
JH
3594 if (natint) {
3595 while (len-- > 0) {
3596 COPYNN(s, &ashort, sizeof(short));
3597 s += sizeof(short);
3598 culong += ashort;
3599
3600 }
3601 }
726ea183
JH
3602 else
3603#endif
3604 {
ef54e1a4
JH
3605 while (len-- > 0) {
3606 COPY16(s, &ashort);
c67712b2
JH
3607#if SHORTSIZE > SIZE16
3608 if (ashort > 32767)
3609 ashort -= 65536;
3610#endif
ef54e1a4
JH
3611 s += SIZE16;
3612 culong += ashort;
3613 }
a0d0e21e
LW
3614 }
3615 }
3616 else {
3617 EXTEND(SP, len);
bbce6d69 3618 EXTEND_MORTAL(len);
726ea183 3619#if SHORTSIZE != SIZE16
ef54e1a4
JH
3620 if (natint) {
3621 while (len-- > 0) {
3622 COPYNN(s, &ashort, sizeof(short));
3623 s += sizeof(short);
3624 sv = NEWSV(38, 0);
3625 sv_setiv(sv, (IV)ashort);
3626 PUSHs(sv_2mortal(sv));
3627 }
3628 }
726ea183
JH
3629 else
3630#endif
3631 {
ef54e1a4
JH
3632 while (len-- > 0) {
3633 COPY16(s, &ashort);
c67712b2
JH
3634#if SHORTSIZE > SIZE16
3635 if (ashort > 32767)
3636 ashort -= 65536;
3637#endif
ef54e1a4
JH
3638 s += SIZE16;
3639 sv = NEWSV(38, 0);
3640 sv_setiv(sv, (IV)ashort);
3641 PUSHs(sv_2mortal(sv));
3642 }
a0d0e21e
LW
3643 }
3644 }
3645 break;
3646 case 'v':
3647 case 'n':
3648 case 'S':
726ea183
JH
3649#if SHORTSIZE == SIZE16
3650 along = (strend - s) / SIZE16;
3651#else
ef54e1a4
JH
3652 unatint = natint && datumtype == 'S';
3653 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
726ea183 3654#endif
a0d0e21e
LW
3655 if (len > along)
3656 len = along;
3657 if (checksum) {
726ea183 3658#if SHORTSIZE != SIZE16
ef54e1a4
JH
3659 if (unatint) {
3660 while (len-- > 0) {
3661 COPYNN(s, &aushort, sizeof(unsigned short));
3662 s += sizeof(unsigned short);
3663 culong += aushort;
3664 }
3665 }
726ea183
JH
3666 else
3667#endif
3668 {
ef54e1a4
JH
3669 while (len-- > 0) {
3670 COPY16(s, &aushort);
3671 s += SIZE16;
a0d0e21e 3672#ifdef HAS_NTOHS
ef54e1a4
JH
3673 if (datumtype == 'n')
3674 aushort = PerlSock_ntohs(aushort);
79072805 3675#endif
a0d0e21e 3676#ifdef HAS_VTOHS
ef54e1a4
JH
3677 if (datumtype == 'v')
3678 aushort = vtohs(aushort);
79072805 3679#endif
ef54e1a4
JH
3680 culong += aushort;
3681 }
a0d0e21e
LW
3682 }
3683 }
3684 else {
3685 EXTEND(SP, len);
bbce6d69 3686 EXTEND_MORTAL(len);
726ea183 3687#if SHORTSIZE != SIZE16
ef54e1a4
JH
3688 if (unatint) {
3689 while (len-- > 0) {
3690 COPYNN(s, &aushort, sizeof(unsigned short));
3691 s += sizeof(unsigned short);
3692 sv = NEWSV(39, 0);
726ea183 3693 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH
3694 PUSHs(sv_2mortal(sv));
3695 }
3696 }
726ea183
JH
3697 else
3698#endif
3699 {
ef54e1a4
JH
3700 while (len-- > 0) {
3701 COPY16(s, &aushort);
3702 s += SIZE16;
3703 sv = NEWSV(39, 0);
a0d0e21e 3704#ifdef HAS_NTOHS
ef54e1a4
JH
3705 if (datumtype == 'n')
3706 aushort = PerlSock_ntohs(aushort);
79072805 3707#endif
a0d0e21e 3708#ifdef HAS_VTOHS
ef54e1a4
JH
3709 if (datumtype == 'v')
3710 aushort = vtohs(aushort);
79072805 3711#endif
726ea183 3712 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH
3713 PUSHs(sv_2mortal(sv));
3714 }
a0d0e21e
LW
3715 }
3716 }
3717 break;
3718 case 'i':
3719 along = (strend - s) / sizeof(int);
3720 if (len > along)
3721 len = along;
3722 if (checksum) {
3723 while (len-- > 0) {
3724 Copy(s, &aint, 1, int);
3725 s += sizeof(int);
3726 if (checksum > 32)
3727 cdouble += (double)aint;
3728 else
3729 culong += aint;
3730 }
3731 }
3732 else {
3733 EXTEND(SP, len);
bbce6d69 3734 EXTEND_MORTAL(len);
a0d0e21e
LW
3735 while (len-- > 0) {
3736 Copy(s, &aint, 1, int);
3737 s += sizeof(int);
3738 sv = NEWSV(40, 0);
20408e3c
GS
3739#ifdef __osf__
3740 /* Without the dummy below unpack("i", pack("i",-1))
3741 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
13476c87
JH
3742 * cc with optimization turned on.
3743 *
3744 * The bug was detected in
3745 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)