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