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