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