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