This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[asperl] various changes to get asperl working under Borland
[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 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 38 */
39typedef int IBW;
40typedef unsigned UBW;
41
96e4d5b1 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 */
49#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
46fc3d4c 50# define BW_BITS 32
51# define BW_MASK ((1 << BW_BITS) - 1)
52# define BW_SIGN (1 << (BW_BITS - 1))
96e4d5b1 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
72 * the preprocessor.)
73 */
74#define SIZE16 2
75#define SIZE32 4
76
77#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
78# if BYTEORDER == 0x12345678
79# define OFF16(p) (char*)(p)
80# define OFF32(p) (char*)(p)
81# else
82# if BYTEORDER == 0x87654321
83# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
84# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
85# else
86 }}}} bad cray byte order
87# endif
88# endif
89# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
90# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
91# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
92# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
93#else
94# define COPY16(s,p) Copy(s, p, SIZE16, char)
95# define COPY32(s,p) Copy(s, p, SIZE32, char)
96# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
97# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
98#endif
99
76e3520e 100#ifndef PERL_OBJECT
71be2cbc 101static void doencodes _((SV* sv, char* s, I32 len));
93dc8474
CS		 102static SV* refto _((SV* sv));
103static U32 seed _((void));
76e3520e 104#endif
93dc8474
CS		 105
106static bool srand_called = FALSE;
79072805 107
a0d0e21e 108/* variations on pp_null */
79072805 109
8ac85365
NIS		 110#ifdef I_UNISTD
111#include <unistd.h>
112#endif
dfe9444c
AD		 113
114/* XXX I can't imagine anyone who doesn't have this actually _needs_
115 it, since pid_t is an integral type.
116 --AD 2/20/1998
117*/
118#ifdef NEED_GETPID_PROTO
119extern Pid_t getpid (void);
8ac85365
NIS		 120#endif
121
93a17b20
LW		 122PP(pp_stub)
123{
4e35701f 124 djSP;
54310121 125 if (GIMME_V == G_SCALAR)
93a17b20 126 XPUSHs(&sv_undef);
93a17b20
LW		 127 RETURN;
128}
129
79072805
LW		 130PP(pp_scalar)
131{
132 return NORMAL;
133}
134
135/* Pushy stuff. */
136
93a17b20
LW		 137PP(pp_padav)
138{
4e35701f 139 djSP; dTARGET;
a0d0e21e 140 if (op->op_private & OPpLVAL_INTRO)
8990e307 141 SAVECLEARSV(curpad[op->op_targ]);
85e6fe83 142 EXTEND(SP, 1);
a0d0e21e 143 if (op->op_flags & OPf_REF) {
85e6fe83 144 PUSHs(TARG);
93a17b20 145 RETURN;
85e6fe83
LW		 146 }
147 if (GIMME == G_ARRAY) {
148 I32 maxarg = AvFILL((AV*)TARG) + 1;
149 EXTEND(SP, maxarg);
93965878
NIS		 150 if (SvMAGICAL(TARG)) {
151 U32 i;
152 for (i=0; i < maxarg; i++) {
153 SV **svp = av_fetch((AV*)TARG, i, FALSE);
154 SP[i+1] = (svp) ? *svp : &sv_undef;
155 }
156 }
157 else {
158 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
159 }
85e6fe83
LW		 160 SP += maxarg;
161 }
162 else {
163 SV* sv = sv_newmortal();
164 I32 maxarg = AvFILL((AV*)TARG) + 1;
165 sv_setiv(sv, maxarg);
166 PUSHs(sv);
167 }
168 RETURN;
93a17b20
LW		 169}
170
171PP(pp_padhv)
172{
4e35701f 173 djSP; dTARGET;
54310121 174 I32 gimme;
175
93a17b20 176 XPUSHs(TARG);
a0d0e21e 177 if (op->op_private & OPpLVAL_INTRO)
8990e307 178 SAVECLEARSV(curpad[op->op_targ]);
a0d0e21e 179 if (op->op_flags & OPf_REF)
93a17b20 180 RETURN;
54310121 181 gimme = GIMME_V;
182 if (gimme == G_ARRAY) {
a0d0e21e 183 RETURNOP(do_kv(ARGS));
85e6fe83 184 }
54310121 185 else if (gimme == G_SCALAR) {
85e6fe83 186 SV* sv = sv_newmortal();
46fc3d4c 187 if (HvFILL((HV*)TARG))
188 sv_setpvf(sv, "%ld/%ld",
189 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW		 190 else
191 sv_setiv(sv, 0);
192 SETs(sv);
85e6fe83 193 }
54310121 194 RETURN;
93a17b20
LW		 195}
196
ed6116ce
LW		 197PP(pp_padany)
198{
199 DIE("NOT IMPL LINE %d",__LINE__);
200}
201
79072805
LW		 202/* Translations. */
203
204PP(pp_rv2gv)
205{
4e35701f 206 djSP; dTOPss;
8ec5e241 207
ed6116ce 208 if (SvROK(sv)) {
a0d0e21e 209 wasref:
ed6116ce 210 sv = SvRV(sv);
b1dadf13 211 if (SvTYPE(sv) == SVt_PVIO) {
212 GV *gv = (GV*) sv_newmortal();
213 gv_init(gv, 0, "", 0, 0);
214 GvIOp(gv) = (IO *)sv;
3e3baf6d 215 (void)SvREFCNT_inc(sv);
b1dadf13 216 sv = (SV*) gv;
217 } else if (SvTYPE(sv) != SVt_PVGV)
a0d0e21e 218 DIE("Not a GLOB reference");
79072805
LW		 219 }
220 else {
93a17b20 221 if (SvTYPE(sv) != SVt_PVGV) {
748a9306
LW		 222 char *sym;
223
a0d0e21e
LW		 224 if (SvGMAGICAL(sv)) {
225 mg_get(sv);
226 if (SvROK(sv))
227 goto wasref;
228 }
229 if (!SvOK(sv)) {
230 if (op->op_flags & OPf_REF ||
231 op->op_private & HINT_STRICT_REFS)
232 DIE(no_usym, "a symbol");
d83e6520
CS		 233 if (dowarn)
234 warn(warn_uninit);
a0d0e21e
LW		 235 RETSETUNDEF;
236 }
748a9306 237 sym = SvPV(sv, na);
85e6fe83 238 if (op->op_private & HINT_STRICT_REFS)
748a9306
LW		 239 DIE(no_symref, sym, "a symbol");
240 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
93a17b20 241 }
79072805 242 }
5f05dabc 243 if (op->op_private & OPpLVAL_INTRO)
244 save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
79072805
LW		 245 SETs(sv);
246 RETURN;
247}
248
79072805
LW		 249PP(pp_rv2sv)
250{
4e35701f 251 djSP; dTOPss;
79072805 252
ed6116ce 253 if (SvROK(sv)) {
a0d0e21e 254 wasref:
ed6116ce 255 sv = SvRV(sv);
79072805
LW		 256 switch (SvTYPE(sv)) {
257 case SVt_PVAV:
258 case SVt_PVHV:
259 case SVt_PVCV:
a0d0e21e 260 DIE("Not a SCALAR reference");
79072805
LW		 261 }
262 }
263 else {
f12c7020 264 GV *gv = (GV*)sv;
748a9306
LW		 265 char *sym;
266
463ee0b2 267 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 268 if (SvGMAGICAL(sv)) {
269 mg_get(sv);
270 if (SvROK(sv))
271 goto wasref;
272 }
273 if (!SvOK(sv)) {
274 if (op->op_flags & OPf_REF ||
275 op->op_private & HINT_STRICT_REFS)
276 DIE(no_usym, "a SCALAR");
d83e6520
CS		 277 if (dowarn)
278 warn(warn_uninit);
a0d0e21e
LW		 279 RETSETUNDEF;
280 }
748a9306 281 sym = SvPV(sv, na);
85e6fe83 282 if (op->op_private & HINT_STRICT_REFS)
748a9306 283 DIE(no_symref, sym, "a SCALAR");
f12c7020 284 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
463ee0b2
LW		 285 }
286 sv = GvSV(gv);
a0d0e21e
LW		 287 }
288 if (op->op_flags & OPf_MOD) {
289 if (op->op_private & OPpLVAL_INTRO)
290 sv = save_scalar((GV*)TOPs);
5f05dabc 291 else if (op->op_private & OPpDEREF)
68dc0745 292 vivify_ref(sv, op->op_private & OPpDEREF);
79072805 293 }
a0d0e21e 294 SETs(sv);
79072805
LW		 295 RETURN;
296}
297
298PP(pp_av2arylen)
299{
4e35701f 300 djSP;
79072805
LW		 301 AV *av = (AV*)TOPs;
302 SV *sv = AvARYLEN(av);
303 if (!sv) {
304 AvARYLEN(av) = sv = NEWSV(0,0);
305 sv_upgrade(sv, SVt_IV);
306 sv_magic(sv, (SV*)av, '#', Nullch, 0);
307 }
308 SETs(sv);
309 RETURN;
310}
311
a0d0e21e
LW		 312PP(pp_pos)
313{
4e35701f 314 djSP; dTARGET; dPOPss;
8ec5e241 315
a0d0e21e 316 if (op->op_flags & OPf_MOD) {
5f05dabc 317 if (SvTYPE(TARG) < SVt_PVLV) {
318 sv_upgrade(TARG, SVt_PVLV);
319 sv_magic(TARG, Nullsv, '.', Nullch, 0);
320 }
321
322 LvTYPE(TARG) = '.';
a0d0e21e
LW		 323 LvTARG(TARG) = sv;
324 PUSHs(TARG); /* no SvSETMAGIC */
325 RETURN;
326 }
327 else {
8ec5e241 328 MAGIC* mg;
a0d0e21e
LW		 329
330 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
331 mg = mg_find(sv, 'g');
565764a8
DL		 332 if (mg && mg->mg_len >= 0) {
333 PUSHi(mg->mg_len + curcop->cop_arybase);
a0d0e21e
LW		 334 RETURN;
335 }
336 }
337 RETPUSHUNDEF;
338 }
339}
340
79072805
LW		 341PP(pp_rv2cv)
342{
4e35701f 343 djSP;
79072805
LW		 344 GV *gv;
345 HV *stash;
8990e307 346
4633a7c4
LW		 347 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
348 /* (But not in defined().) */
349 CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
07055b4c
CS		 350 if (cv) {
351 if (CvCLONE(cv))
352 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
353 }
354 else
4633a7c4 355 cv = (CV*)&sv_undef;
79072805
LW		 356 SETs((SV*)cv);
357 RETURN;
358}
359
c07a80fd 360PP(pp_prototype)
361{
4e35701f 362 djSP;
c07a80fd 363 CV *cv;
364 HV *stash;
365 GV *gv;
366 SV *ret;
367
368 ret = &sv_undef;
b6c543e3
IZ		 369 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
370 char *s = SvPVX(TOPs);
371 if (strnEQ(s, "CORE::", 6)) {
372 int code;
373
374 code = keyword(s + 6, SvCUR(TOPs) - 6);
375 if (code < 0) { /* Overridable. */
376#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
377 int i = 0, n = 0, seen_question = 0;
378 I32 oa;
379 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
380
381 while (i < MAXO) { /* The slow way. */
382 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
383 goto found;
384 i++;
385 }
386 goto nonesuch; /* Should not happen... */
387 found:
388 oa = opargs[i] >> OASHIFT;
389 while (oa) {
390 if (oa & OA_OPTIONAL) {
391 seen_question = 1;
392 str[n++] = ';';
393 } else if (seen_question)
394 goto set; /* XXXX system, exec */
395 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
396 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
397 str[n++] = '\\';
398 }
399 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
400 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
401 oa = oa >> 4;
402 }
403 str[n++] = '\0';
404 ret = sv_2mortal(newSVpv(str, n - 1));
405 } else if (code) /* Non-Overridable */
406 goto set;
407 else { /* None such */
408 nonesuch:
409 croak("Cannot find an opnumber for \"%s\"", s+6);
410 }
411 }
412 }
c07a80fd 413 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 414 if (cv && SvPOK(cv))
415 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
b6c543e3 416 set:
c07a80fd 417 SETs(ret);
418 RETURN;
419}
420
a0d0e21e
LW		 421PP(pp_anoncode)
422{
4e35701f 423 djSP;
5f05dabc 424 CV* cv = (CV*)curpad[op->op_targ];
a5f75d66 425 if (CvCLONE(cv))
b355b4e0 426 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 427 EXTEND(SP,1);
748a9306 428 PUSHs((SV*)cv);
a0d0e21e
LW		 429 RETURN;
430}
431
432PP(pp_srefgen)
79072805 433{
4e35701f 434 djSP;
71be2cbc 435 *SP = refto(*SP);
79072805 436 RETURN;
8ec5e241 437}
a0d0e21e
LW		 438
439PP(pp_refgen)
440{
4e35701f 441 djSP; dMARK;
a0d0e21e
LW		 442 if (GIMME != G_ARRAY) {
443 MARK[1] = *SP;
444 SP = MARK + 1;
445 }
bbce6d69 446 EXTEND_MORTAL(SP - MARK);
71be2cbc 447 while (++MARK <= SP)
448 *MARK = refto(*MARK);
a0d0e21e 449 RETURN;
79072805
LW		 450}
451
76e3520e 452STATIC SV*
8ac85365 453refto(SV *sv)
71be2cbc 454{
455 SV* rv;
456
457 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
458 if (LvTARGLEN(sv))
68dc0745 459 vivify_defelem(sv);
460 if (!(sv = LvTARG(sv)))
461 sv = &sv_undef;
71be2cbc 462 }
463 else if (SvPADTMP(sv))
464 sv = newSVsv(sv);
465 else {
466 SvTEMP_off(sv);
467 (void)SvREFCNT_inc(sv);
468 }
469 rv = sv_newmortal();
470 sv_upgrade(rv, SVt_RV);
471 SvRV(rv) = sv;
472 SvROK_on(rv);
473 return rv;
474}
475
79072805
LW		 476PP(pp_ref)
477{
4e35701f 478 djSP; dTARGET;
463ee0b2 479 SV *sv;
79072805
LW		 480 char *pv;
481
a0d0e21e 482 sv = POPs;
f12c7020 483
484 if (sv && SvGMAGICAL(sv))
8ec5e241 485 mg_get(sv);
f12c7020 486
a0d0e21e 487 if (!sv || !SvROK(sv))
4633a7c4 488 RETPUSHNO;
79072805 489
ed6116ce 490 sv = SvRV(sv);
a0d0e21e 491 pv = sv_reftype(sv,TRUE);
463ee0b2 492 PUSHp(pv, strlen(pv));
79072805
LW		 493 RETURN;
494}
495
496PP(pp_bless)
497{
4e35701f 498 djSP;
463ee0b2 499 HV *stash;
79072805 500
463ee0b2
LW		 501 if (MAXARG == 1)
502 stash = curcop->cop_stash;
503 else
a0d0e21e
LW		 504 stash = gv_stashsv(POPs, TRUE);
505
5d3fdfeb 506 (void)sv_bless(TOPs, stash);
79072805
LW		 507 RETURN;
508}
509
fb73857a 510PP(pp_gelem)
511{
512 GV *gv;
513 SV *sv;
76e3520e 514 SV *tmpRef;
fb73857a 515 char *elem;
4e35701f 516 djSP;
fb73857a 517
518 sv = POPs;
519 elem = SvPV(sv, na);
520 gv = (GV*)POPs;
76e3520e 521 tmpRef = Nullsv;
fb73857a 522 sv = Nullsv;
523 switch (elem ? *elem : '\0')
524 {
525 case 'A':
526 if (strEQ(elem, "ARRAY"))
76e3520e 527 tmpRef = (SV*)GvAV(gv);
fb73857a 528 break;
529 case 'C':
530 if (strEQ(elem, "CODE"))
76e3520e 531 tmpRef = (SV*)GvCVu(gv);
fb73857a 532 break;
533 case 'F':
534 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 535 tmpRef = (SV*)GvIOp(gv);
fb73857a 536 break;
537 case 'G':
538 if (strEQ(elem, "GLOB"))
76e3520e 539 tmpRef = (SV*)gv;
fb73857a 540 break;
541 case 'H':
542 if (strEQ(elem, "HASH"))
76e3520e 543 tmpRef = (SV*)GvHV(gv);
fb73857a 544 break;
545 case 'I':
546 if (strEQ(elem, "IO"))
76e3520e 547 tmpRef = (SV*)GvIOp(gv);
fb73857a 548 break;
549 case 'N':
550 if (strEQ(elem, "NAME"))
551 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
552 break;
553 case 'P':
554 if (strEQ(elem, "PACKAGE"))
555 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
556 break;
557 case 'S':
558 if (strEQ(elem, "SCALAR"))
76e3520e 559 tmpRef = GvSV(gv);
fb73857a 560 break;
561 }
76e3520e
GS		 562 if (tmpRef)
563 sv = newRV(tmpRef);
fb73857a 564 if (sv)
565 sv_2mortal(sv);
566 else
567 sv = &sv_undef;
568 XPUSHs(sv);
569 RETURN;
570}
571
a0d0e21e 572/* Pattern matching */
79072805 573
a0d0e21e 574PP(pp_study)
79072805 575{
4e35701f 576 djSP; dPOPss;
c277df42 577 register UNOP *unop = cUNOP;
a0d0e21e
LW		 578 register unsigned char *s;
579 register I32 pos;
580 register I32 ch;
581 register I32 *sfirst;
582 register I32 *snext;
a0d0e21e
LW		 583 STRLEN len;
584
c277df42
IZ		 585 if(unop->op_first && unop->op_first->op_type == OP_PUSHRE) {
586 PMOP *pm = (PMOP *)unop->op_first;
587 SV *rv = sv_newmortal();
588 sv = newSVrv(rv, "Regexp");
589 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
590 RETURNX(PUSHs(rv));
591 }
592
1e422769 593 if (sv == lastscream) {
594 if (SvSCREAM(sv))
595 RETPUSHYES;
596 }
c07a80fd 597 else {
598 if (lastscream) {
599 SvSCREAM_off(lastscream);
600 SvREFCNT_dec(lastscream);
601 }
602 lastscream = SvREFCNT_inc(sv);
603 }
1e422769 604
605 s = (unsigned char*)(SvPV(sv, len));
606 pos = len;
607 if (pos <= 0)
608 RETPUSHNO;
a0d0e21e
LW		 609 if (pos > maxscream) {
610 if (maxscream < 0) {
611 maxscream = pos + 80;
612 New(301, screamfirst, 256, I32);
613 New(302, screamnext, maxscream, I32);
79072805
LW		 614 }
615 else {
a0d0e21e
LW		 616 maxscream = pos + pos / 4;
617 Renew(screamnext, maxscream, I32);
79072805 618 }
79072805 619 }
a0d0e21e
LW		 620
621 sfirst = screamfirst;
622 snext = screamnext;
623
624 if (!sfirst || !snext)
625 DIE("do_study: out of memory");
626
627 for (ch = 256; ch; --ch)
628 *sfirst++ = -1;
629 sfirst -= 256;
630
631 while (--pos >= 0) {
632 ch = s[pos];
633 if (sfirst[ch] >= 0)
634 snext[pos] = sfirst[ch] - pos;
635 else
636 snext[pos] = -pos;
637 sfirst[ch] = pos;
79072805
LW		 638 }
639
c07a80fd 640 SvSCREAM_on(sv);
464e2e8a 641 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 642 RETPUSHYES;
79072805
LW		 643}
644
a0d0e21e 645PP(pp_trans)
79072805 646{
4e35701f 647 djSP; dTARG;
a0d0e21e
LW		 648 SV *sv;
649
650 if (op->op_flags & OPf_STACKED)
651 sv = POPs;
79072805 652 else {
54b9620d 653 sv = DEFSV;
a0d0e21e 654 EXTEND(SP,1);
79072805 655 }
adbc6bb1 656 TARG = sv_newmortal();
a0d0e21e
LW		 657 PUSHi(do_trans(sv, op));
658 RETURN;
79072805
LW		 659}
660
a0d0e21e 661/* Lvalue operators. */
79072805 662
a0d0e21e
LW		 663PP(pp_schop)
664{
4e35701f 665 djSP; dTARGET;
a0d0e21e
LW		 666 do_chop(TARG, TOPs);
667 SETTARG;
668 RETURN;
79072805
LW		 669}
670
a0d0e21e 671PP(pp_chop)
79072805 672{
4e35701f 673 djSP; dMARK; dTARGET;
a0d0e21e
LW		 674 while (SP > MARK)
675 do_chop(TARG, POPs);
676 PUSHTARG;
677 RETURN;
79072805
LW		 678}
679
a0d0e21e 680PP(pp_schomp)
79072805 681{
4e35701f 682 djSP; dTARGET;
a0d0e21e
LW		 683 SETi(do_chomp(TOPs));
684 RETURN;
79072805
LW		 685}
686
a0d0e21e 687PP(pp_chomp)
79072805 688{
4e35701f 689 djSP; dMARK; dTARGET;
a0d0e21e 690 register I32 count = 0;
8ec5e241 691
a0d0e21e
LW		 692 while (SP > MARK)
693 count += do_chomp(POPs);
694 PUSHi(count);
695 RETURN;
79072805
LW		 696}
697
a0d0e21e 698PP(pp_defined)
463ee0b2 699{
4e35701f 700 djSP;
a0d0e21e
LW		 701 register SV* sv;
702
703 sv = POPs;
704 if (!sv || !SvANY(sv))
705 RETPUSHNO;
706 switch (SvTYPE(sv)) {
707 case SVt_PVAV:
fb73857a 708 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
a0d0e21e
LW		 709 RETPUSHYES;
710 break;
711 case SVt_PVHV:
fb73857a 712 if (HvARRAY(sv) || SvGMAGICAL(sv))
a0d0e21e
LW		 713 RETPUSHYES;
714 break;
715 case SVt_PVCV:
716 if (CvROOT(sv) || CvXSUB(sv))
717 RETPUSHYES;
718 break;
719 default:
720 if (SvGMAGICAL(sv))
721 mg_get(sv);
722 if (SvOK(sv))
723 RETPUSHYES;
724 }
725 RETPUSHNO;
463ee0b2
LW		 726}
727
a0d0e21e
LW		 728PP(pp_undef)
729{
4e35701f 730 djSP;
a0d0e21e
LW		 731 SV *sv;
732
774d564b 733 if (!op->op_private) {
734 EXTEND(SP, 1);
a0d0e21e 735 RETPUSHUNDEF;
774d564b 736 }
79072805 737
a0d0e21e
LW		 738 sv = POPs;
739 if (!sv)
740 RETPUSHUNDEF;
85e6fe83 741
a0d0e21e
LW		 742 if (SvTHINKFIRST(sv)) {
743 if (SvREADONLY(sv))
744 RETPUSHUNDEF;
745 if (SvROK(sv))
746 sv_unref(sv);
85e6fe83
LW		 747 }
748
a0d0e21e
LW		 749 switch (SvTYPE(sv)) {
750 case SVt_NULL:
751 break;
752 case SVt_PVAV:
753 av_undef((AV*)sv);
754 break;
755 case SVt_PVHV:
756 hv_undef((HV*)sv);
757 break;
758 case SVt_PVCV:
54310121 759 if (cv_const_sv((CV*)sv))
9607fc9c 760 warn("Constant subroutine %s undefined",
54310121 761 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 762 /* FALL THROUGH */
763 case SVt_PVFM:
09280a33
CS		 764 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
765 cv_undef((CV*)sv);
766 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
a0d0e21e 767 break;
8e07c86e 768 case SVt_PVGV:
44a8e56a 769 if (SvFAKE(sv))
770 sv_setsv(sv, &sv_undef);
771 break;
a0d0e21e 772 default:
1e422769 773 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW		 774 (void)SvOOK_off(sv);
775 Safefree(SvPVX(sv));
776 SvPV_set(sv, Nullch);
777 SvLEN_set(sv, 0);
a0d0e21e 778 }
4633a7c4
LW		 779 (void)SvOK_off(sv);
780 SvSETMAGIC(sv);
79072805 781 }
a0d0e21e
LW		 782
783 RETPUSHUNDEF;
79072805
LW		 784}
785
a0d0e21e 786PP(pp_predec)
79072805 787{
4e35701f 788 djSP;
68dc0745 789 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 790 croak(no_modify);
55497cff 791 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
792 SvIVX(TOPs) != IV_MIN)
793 {
748a9306 794 --SvIVX(TOPs);
55497cff 795 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 796 }
797 else
798 sv_dec(TOPs);
a0d0e21e
LW		 799 SvSETMAGIC(TOPs);
800 return NORMAL;
801}
79072805 802
a0d0e21e
LW		 803PP(pp_postinc)
804{
4e35701f 805 djSP; dTARGET;
68dc0745 806 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 807 croak(no_modify);
a0d0e21e 808 sv_setsv(TARG, TOPs);
55497cff 809 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
810 SvIVX(TOPs) != IV_MAX)
811 {
748a9306 812 ++SvIVX(TOPs);
55497cff 813 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 814 }
815 else
816 sv_inc(TOPs);
a0d0e21e
LW		 817 SvSETMAGIC(TOPs);
818 if (!SvOK(TARG))
819 sv_setiv(TARG, 0);
820 SETs(TARG);
821 return NORMAL;
822}
79072805 823
a0d0e21e
LW		 824PP(pp_postdec)
825{
4e35701f 826 djSP; dTARGET;
68dc0745 827 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
44a8e56a 828 croak(no_modify);
a0d0e21e 829 sv_setsv(TARG, TOPs);
55497cff 830 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
831 SvIVX(TOPs) != IV_MIN)
832 {
748a9306 833 --SvIVX(TOPs);
55497cff 834 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 835 }
836 else
837 sv_dec(TOPs);
a0d0e21e
LW		 838 SvSETMAGIC(TOPs);
839 SETs(TARG);
840 return NORMAL;
841}
79072805 842
a0d0e21e
LW		 843/* Ordinary operators. */
844
845PP(pp_pow)
846{
8ec5e241 847 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
a0d0e21e
LW		 848 {
849 dPOPTOPnnrl;
850 SETn( pow( left, right) );
851 RETURN;
93a17b20 852 }
a0d0e21e
LW		 853}
854
855PP(pp_multiply)
856{
8ec5e241 857 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 858 {
859 dPOPTOPnnrl;
860 SETn( left * right );
861 RETURN;
79072805 862 }
a0d0e21e
LW		 863}
864
865PP(pp_divide)
866{
8ec5e241 867 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e 868 {
77676ba1 869 dPOPPOPnnrl;
7a4c00b4 870 double value;
871 if (right == 0.0)
a0d0e21e
LW		 872 DIE("Illegal division by zero");
873#ifdef SLOPPYDIVIDE
874 /* insure that 20./5. == 4. */
875 {
7a4c00b4 876 IV k;
877 if ((double)I_V(left) == left &&
878 (double)I_V(right) == right &&
879 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e
LW		 880 value = k;
881 } else {
7a4c00b4 882 value = left / right;
79072805 883 }
a0d0e21e
LW		 884 }
885#else
7a4c00b4 886 value = left / right;
a0d0e21e
LW		 887#endif
888 PUSHn( value );
889 RETURN;
79072805 890 }
a0d0e21e
LW		 891}
892
893PP(pp_modulo)
894{
76e3520e 895 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 896 {
68dc0745 897 UV left;
898 UV right;
beb18505
CS		 899 bool left_neg;
900 bool right_neg;
68dc0745 901 UV ans;
a0d0e21e 902
68dc0745 903 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
904 IV i = SvIVX(POPs);
beb18505 905 right = (right_neg = (i < 0)) ? -i : i;
68dc0745 906 }
907 else {
908 double n = POPn;
beb18505 909 right = U_V((right_neg = (n < 0)) ? -n : n);
68dc0745 910 }
a0d0e21e 911
36477c24 912 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
68dc0745 913 IV i = SvIVX(POPs);
beb18505 914 left = (left_neg = (i < 0)) ? -i : i;
36477c24 915 }
a0d0e21e 916 else {
68dc0745 917 double n = POPn;
beb18505 918 left = U_V((left_neg = (n < 0)) ? -n : n);
a0d0e21e 919 }
68dc0745 920
921 if (!right)
922 DIE("Illegal modulus zero");
923
924 ans = left % right;
beb18505 925 if ((left_neg != right_neg) && ans)
68dc0745 926 ans = right - ans;
beb18505 927 if (right_neg) {
3e3baf6d
TB		 928 /* XXX may warn: unary minus operator applied to unsigned type */
929 /* could change -foo to be (~foo)+1 instead */
4e35701f
NIS		 930 if (ans <= ~((UV)IV_MAX)+1)
931 sv_setiv(TARG, ~ans+1);
beb18505
CS		 932 else
933 sv_setnv(TARG, -(double)ans);
934 }
935 else
936 sv_setuv(TARG, ans);
937 PUSHTARG;
a0d0e21e 938 RETURN;
79072805 939 }
a0d0e21e 940}
79072805 941
a0d0e21e
LW		 942PP(pp_repeat)
943{
4e35701f 944 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 945 {
a0d0e21e
LW		 946 register I32 count = POPi;
947 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
948 dMARK;
949 I32 items = SP - MARK;
950 I32 max;
79072805 951
a0d0e21e
LW		 952 max = items * count;
953 MEXTEND(MARK, max);
954 if (count > 1) {
955 while (SP > MARK) {
956 if (*SP)
957 SvTEMP_off((*SP));
958 SP--;
79072805 959 }
a0d0e21e
LW		 960 MARK++;
961 repeatcpy((char*)(MARK + items), (char*)MARK,
962 items * sizeof(SV*), count - 1);
963 SP += max;
79072805 964 }
a0d0e21e
LW		 965 else if (count <= 0)
966 SP -= items;
79072805 967 }
a0d0e21e
LW		 968 else { /* Note: mark already snarfed by pp_list */
969 SV *tmpstr;
970 STRLEN len;
971
972 tmpstr = POPs;
973 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
974 if (SvREADONLY(tmpstr) && curcop != &compiling)
975 DIE("Can't x= to readonly value");
976 if (SvROK(tmpstr))
977 sv_unref(tmpstr);
93a17b20 978 }
a0d0e21e
LW		 979 SvSetSV(TARG, tmpstr);
980 SvPV_force(TARG, len);
8ebc5c01 981 if (count != 1) {
982 if (count < 1)
983 SvCUR_set(TARG, 0);
984 else {
985 SvGROW(TARG, (count * len) + 1);
a0d0e21e 986 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 987 SvCUR(TARG) *= count;
7a4c00b4 988 }
a0d0e21e 989 *SvEND(TARG) = '\0';
a0d0e21e 990 }
8ebc5c01 991 (void)SvPOK_only(TARG);
a0d0e21e 992 PUSHTARG;
79072805 993 }
a0d0e21e 994 RETURN;
748a9306 995 }
a0d0e21e 996}
79072805 997
a0d0e21e
LW		 998PP(pp_subtract)
999{
8ec5e241 1000 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1001 {
7a4c00b4 1002 dPOPTOPnnrl_ul;
a0d0e21e
LW		 1003 SETn( left - right );
1004 RETURN;
79072805 1005 }
a0d0e21e 1006}
79072805 1007
a0d0e21e
LW		 1008PP(pp_left_shift)
1009{
8ec5e241 1010 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1011 {
36477c24 1012 IBW shift = POPi;
ff68c719 1013 if (op->op_private & HINT_INTEGER) {
36477c24 1014 IBW i = TOPi;
46fc3d4c 1015 i = BWi(i) << shift;
96e4d5b1 1016 SETi(BWi(i));
ff68c719 1017 }
1018 else {
36477c24 1019 UBW u = TOPu;
96e4d5b1 1020 u <<= shift;
1021 SETu(BWu(u));
ff68c719 1022 }
55497cff 1023 RETURN;
79072805 1024 }
a0d0e21e 1025}
79072805 1026
a0d0e21e
LW		 1027PP(pp_right_shift)
1028{
8ec5e241 1029 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1030 {
36477c24 1031 IBW shift = POPi;
ff68c719 1032 if (op->op_private & HINT_INTEGER) {
36477c24 1033 IBW i = TOPi;
46fc3d4c 1034 i = BWi(i) >> shift;
96e4d5b1 1035 SETi(BWi(i));
ff68c719 1036 }
1037 else {
36477c24 1038 UBW u = TOPu;
96e4d5b1 1039 u >>= shift;
1040 SETu(BWu(u));
ff68c719 1041 }
a0d0e21e 1042 RETURN;
93a17b20 1043 }
79072805
LW		 1044}
1045
a0d0e21e 1046PP(pp_lt)
79072805 1047{
8ec5e241 1048 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 1049 {
1050 dPOPnv;
54310121 1051 SETs(boolSV(TOPn < value));
a0d0e21e 1052 RETURN;
79072805 1053 }
a0d0e21e 1054}
79072805 1055
a0d0e21e
LW		 1056PP(pp_gt)
1057{
8ec5e241 1058 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 1059 {
1060 dPOPnv;
54310121 1061 SETs(boolSV(TOPn > value));
a0d0e21e 1062 RETURN;
79072805 1063 }
a0d0e21e
LW		 1064}
1065
1066PP(pp_le)
1067{
8ec5e241 1068 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 1069 {
1070 dPOPnv;
54310121 1071 SETs(boolSV(TOPn <= value));
a0d0e21e 1072 RETURN;
79072805 1073 }
a0d0e21e
LW		 1074}
1075
1076PP(pp_ge)
1077{
8ec5e241 1078 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 1079 {
1080 dPOPnv;
54310121 1081 SETs(boolSV(TOPn >= value));
a0d0e21e 1082 RETURN;
79072805 1083 }
a0d0e21e 1084}
79072805 1085
a0d0e21e
LW		 1086PP(pp_ne)
1087{
8ec5e241 1088 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 1089 {
1090 dPOPnv;
54310121 1091 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1092 RETURN;
1093 }
79072805
LW		 1094}
1095
a0d0e21e 1096PP(pp_ncmp)
79072805 1097{
8ec5e241 1098 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 1099 {
1100 dPOPTOPnnrl;
1101 I32 value;
79072805 1102
ff0cee69 1103 if (left == right)
a0d0e21e 1104 value = 0;
a0d0e21e
LW		 1105 else if (left < right)
1106 value = -1;
44a8e56a 1107 else if (left > right)
1108 value = 1;
1109 else {
1110 SETs(&sv_undef);
1111 RETURN;
1112 }
a0d0e21e
LW		 1113 SETi(value);
1114 RETURN;
79072805 1115 }
a0d0e21e 1116}
79072805 1117
a0d0e21e
LW		 1118PP(pp_slt)
1119{
8ec5e241 1120 djSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 1121 {
1122 dPOPTOPssrl;
bbce6d69 1123 int cmp = ((op->op_private & OPpLOCALE)
1124 ? sv_cmp_locale(left, right)
1125 : sv_cmp(left, right));
54310121 1126 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 1127 RETURN;
1128 }
79072805
LW		 1129}
1130
a0d0e21e 1131PP(pp_sgt)
79072805 1132{
8ec5e241 1133 djSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 1134 {
1135 dPOPTOPssrl;
bbce6d69 1136 int cmp = ((op->op_private & OPpLOCALE)
1137 ? sv_cmp_locale(left, right)
1138 : sv_cmp(left, right));
54310121 1139 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 1140 RETURN;
1141 }
1142}
79072805 1143
a0d0e21e
LW		 1144PP(pp_sle)
1145{
8ec5e241 1146 djSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 1147 {
1148 dPOPTOPssrl;
bbce6d69 1149 int cmp = ((op->op_private & OPpLOCALE)
1150 ? sv_cmp_locale(left, right)
1151 : sv_cmp(left, right));
54310121 1152 SETs(boolSV(cmp <= 0));
a0d0e21e 1153 RETURN;
79072805 1154 }
79072805
LW		 1155}
1156
a0d0e21e
LW		 1157PP(pp_sge)
1158{
8ec5e241 1159 djSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 1160 {
1161 dPOPTOPssrl;
bbce6d69 1162 int cmp = ((op->op_private & OPpLOCALE)
1163 ? sv_cmp_locale(left, right)
1164 : sv_cmp(left, right));
54310121 1165 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 1166 RETURN;
1167 }
1168}
79072805 1169
36477c24 1170PP(pp_seq)
1171{
8ec5e241 1172 djSP; tryAMAGICbinSET(seq,0);
36477c24 1173 {
1174 dPOPTOPssrl;
54310121 1175 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 1176 RETURN;
1177 }
1178}
79072805 1179
a0d0e21e 1180PP(pp_sne)
79072805 1181{
8ec5e241 1182 djSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 1183 {
1184 dPOPTOPssrl;
54310121 1185 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1186 RETURN;
463ee0b2 1187 }
79072805
LW		 1188}
1189
a0d0e21e 1190PP(pp_scmp)
79072805 1191{
4e35701f 1192 djSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 1193 {
1194 dPOPTOPssrl;
bbce6d69 1195 int cmp = ((op->op_private & OPpLOCALE)
1196 ? sv_cmp_locale(left, right)
1197 : sv_cmp(left, right));
1198 SETi( cmp );
a0d0e21e
LW		 1199 RETURN;
1200 }
1201}
79072805 1202
55497cff 1203PP(pp_bit_and)
1204{
8ec5e241 1205 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 1206 {
1207 dPOPTOPssrl;
4633a7c4 1208 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1209 if (op->op_private & HINT_INTEGER) {
8ec5e241 1210 IBW value = SvIV(left) & SvIV(right);
96e4d5b1 1211 SETi(BWi(value));
36477c24 1212 }
1213 else {
8ec5e241 1214 UBW value = SvUV(left) & SvUV(right);
96e4d5b1 1215 SETu(BWu(value));
36477c24 1216 }
a0d0e21e
LW		 1217 }
1218 else {
1219 do_vop(op->op_type, TARG, left, right);
1220 SETTARG;
1221 }
1222 RETURN;
1223 }
1224}
79072805 1225
a0d0e21e
LW		 1226PP(pp_bit_xor)
1227{
8ec5e241 1228 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 1229 {
1230 dPOPTOPssrl;
4633a7c4 1231 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1232 if (op->op_private & HINT_INTEGER) {
8ec5e241 1233 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
96e4d5b1 1234 SETi(BWi(value));
36477c24 1235 }
1236 else {
8ec5e241 1237 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
96e4d5b1 1238 SETu(BWu(value));
36477c24 1239 }
a0d0e21e
LW		 1240 }
1241 else {
1242 do_vop(op->op_type, TARG, left, right);
1243 SETTARG;
1244 }
1245 RETURN;
1246 }
1247}
79072805 1248
a0d0e21e
LW		 1249PP(pp_bit_or)
1250{
8ec5e241 1251 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 1252 {
1253 dPOPTOPssrl;
4633a7c4 1254 if (SvNIOKp(left) || SvNIOKp(right)) {
36477c24 1255 if (op->op_private & HINT_INTEGER) {
8ec5e241 1256 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
96e4d5b1 1257 SETi(BWi(value));
36477c24 1258 }
1259 else {
8ec5e241 1260 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
96e4d5b1 1261 SETu(BWu(value));
36477c24 1262 }
a0d0e21e
LW		 1263 }
1264 else {
1265 do_vop(op->op_type, TARG, left, right);
1266 SETTARG;
1267 }
1268 RETURN;
79072805 1269 }
a0d0e21e 1270}
79072805 1271
a0d0e21e
LW		 1272PP(pp_negate)
1273{
4e35701f 1274 djSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 1275 {
1276 dTOPss;
4633a7c4
LW		 1277 if (SvGMAGICAL(sv))
1278 mg_get(sv);
55497cff 1279 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1280 SETi(-SvIVX(sv));
1281 else if (SvNIOKp(sv))
a0d0e21e 1282 SETn(-SvNV(sv));
4633a7c4 1283 else if (SvPOKp(sv)) {
a0d0e21e
LW		 1284 STRLEN len;
1285 char *s = SvPV(sv, len);
bbce6d69 1286 if (isIDFIRST(*s)) {
a0d0e21e
LW		 1287 sv_setpvn(TARG, "-", 1);
1288 sv_catsv(TARG, sv);
79072805 1289 }
a0d0e21e
LW		 1290 else if (*s == '+' || *s == '-') {
1291 sv_setsv(TARG, sv);
1292 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805
LW		 1293 }
1294 else
a0d0e21e
LW		 1295 sv_setnv(TARG, -SvNV(sv));
1296 SETTARG;
79072805 1297 }
4633a7c4
LW		 1298 else
1299 SETn(-SvNV(sv));
79072805 1300 }
a0d0e21e 1301 RETURN;
79072805
LW		 1302}
1303
a0d0e21e 1304PP(pp_not)
79072805 1305{
a0d0e21e 1306#ifdef OVERLOAD
4e35701f 1307 djSP; tryAMAGICunSET(not);
a0d0e21e 1308#endif /* OVERLOAD */
54310121 1309 *stack_sp = boolSV(!SvTRUE(*stack_sp));
a0d0e21e 1310 return NORMAL;
79072805
LW		 1311}
1312
a0d0e21e 1313PP(pp_complement)
79072805 1314{
8ec5e241 1315 djSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 1316 {
1317 dTOPss;
4633a7c4 1318 if (SvNIOKp(sv)) {
36477c24 1319 if (op->op_private & HINT_INTEGER) {
1320 IBW value = ~SvIV(sv);
96e4d5b1 1321 SETi(BWi(value));
36477c24 1322 }
1323 else {
1324 UBW value = ~SvUV(sv);
96e4d5b1 1325 SETu(BWu(value));
36477c24 1326 }
a0d0e21e
LW		 1327 }
1328 else {
1329 register char *tmps;
1330 register long *tmpl;
55497cff 1331 register I32 anum;
a0d0e21e
LW		 1332 STRLEN len;
1333
1334 SvSetSV(TARG, sv);
1335 tmps = SvPV_force(TARG, len);
1336 anum = len;
1337#ifdef LIBERAL
1338 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1339 *tmps = ~*tmps;
1340 tmpl = (long*)tmps;
1341 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1342 *tmpl = ~*tmpl;
1343 tmps = (char*)tmpl;
1344#endif
1345 for ( ; anum > 0; anum--, tmps++)
1346 *tmps = ~*tmps;
1347
1348 SETs(TARG);
1349 }
1350 RETURN;
1351 }
79072805
LW		 1352}
1353
a0d0e21e
LW		 1354/* integer versions of some of the above */
1355
a0d0e21e 1356PP(pp_i_multiply)
79072805 1357{
8ec5e241 1358 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 1359 {
1360 dPOPTOPiirl;
1361 SETi( left * right );
1362 RETURN;
1363 }
79072805
LW		 1364}
1365
a0d0e21e 1366PP(pp_i_divide)
79072805 1367{
8ec5e241 1368 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 1369 {
1370 dPOPiv;
1371 if (value == 0)
1372 DIE("Illegal division by zero");
1373 value = POPi / value;
1374 PUSHi( value );
1375 RETURN;
1376 }
79072805
LW		 1377}
1378
a0d0e21e 1379PP(pp_i_modulo)
79072805 1380{
76e3520e 1381 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 1382 {
a0d0e21e 1383 dPOPTOPiirl;
aa306039
CS		 1384 if (!right)
1385 DIE("Illegal modulus zero");
a0d0e21e
LW		 1386 SETi( left % right );
1387 RETURN;
79072805 1388 }
79072805
LW		 1389}
1390
a0d0e21e 1391PP(pp_i_add)
79072805 1392{
8ec5e241 1393 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e
LW		 1394 {
1395 dPOPTOPiirl;
1396 SETi( left + right );
1397 RETURN;
79072805 1398 }
79072805
LW		 1399}
1400
a0d0e21e 1401PP(pp_i_subtract)
79072805 1402{
8ec5e241 1403 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e
LW		 1404 {
1405 dPOPTOPiirl;
1406 SETi( left - right );
1407 RETURN;
79072805 1408 }
79072805
LW		 1409}
1410
a0d0e21e 1411PP(pp_i_lt)
79072805 1412{
8ec5e241 1413 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 1414 {
1415 dPOPTOPiirl;
54310121 1416 SETs(boolSV(left < right));
a0d0e21e
LW		 1417 RETURN;
1418 }
79072805
LW		 1419}
1420
a0d0e21e 1421PP(pp_i_gt)
79072805 1422{
8ec5e241 1423 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 1424 {
1425 dPOPTOPiirl;
54310121 1426 SETs(boolSV(left > right));
a0d0e21e
LW		 1427 RETURN;
1428 }
79072805
LW		 1429}
1430
a0d0e21e 1431PP(pp_i_le)
79072805 1432{
8ec5e241 1433 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 1434 {
1435 dPOPTOPiirl;
54310121 1436 SETs(boolSV(left <= right));
a0d0e21e 1437 RETURN;
85e6fe83 1438 }
79072805
LW		 1439}
1440
a0d0e21e 1441PP(pp_i_ge)
79072805 1442{
8ec5e241 1443 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 1444 {
1445 dPOPTOPiirl;
54310121 1446 SETs(boolSV(left >= right));
a0d0e21e
LW		 1447 RETURN;
1448 }
79072805
LW		 1449}
1450
a0d0e21e 1451PP(pp_i_eq)
79072805 1452{
8ec5e241 1453 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 1454 {
1455 dPOPTOPiirl;
54310121 1456 SETs(boolSV(left == right));
a0d0e21e
LW		 1457 RETURN;
1458 }
79072805
LW		 1459}
1460
a0d0e21e 1461PP(pp_i_ne)
79072805 1462{
8ec5e241 1463 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 1464 {
1465 dPOPTOPiirl;
54310121 1466 SETs(boolSV(left != right));
a0d0e21e
LW		 1467 RETURN;
1468 }
79072805
LW		 1469}
1470
a0d0e21e 1471PP(pp_i_ncmp)
79072805 1472{
8ec5e241 1473 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 1474 {
1475 dPOPTOPiirl;
1476 I32 value;
79072805 1477
a0d0e21e 1478 if (left > right)
79072805 1479 value = 1;
a0d0e21e 1480 else if (left < right)
79072805 1481 value = -1;
a0d0e21e 1482 else
79072805 1483 value = 0;
a0d0e21e
LW		 1484 SETi(value);
1485 RETURN;
79072805 1486 }
85e6fe83
LW		 1487}
1488
1489PP(pp_i_negate)
1490{
4e35701f 1491 djSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 1492 SETi(-TOPi);
1493 RETURN;
1494}
1495
79072805
LW		 1496/* High falutin' math. */
1497
1498PP(pp_atan2)
1499{
8ec5e241 1500 djSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 1501 {
1502 dPOPTOPnnrl;
1503 SETn(atan2(left, right));
1504 RETURN;
1505 }
79072805
LW		 1506}
1507
1508PP(pp_sin)
1509{
4e35701f 1510 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e
LW		 1511 {
1512 double value;
1513 value = POPn;
1514 value = sin(value);
1515 XPUSHn(value);
1516 RETURN;
1517 }
79072805
LW		 1518}
1519
1520PP(pp_cos)
1521{
4e35701f 1522 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e
LW		 1523 {
1524 double value;
1525 value = POPn;
1526 value = cos(value);
1527 XPUSHn(value);
1528 RETURN;
1529 }
79072805
LW		 1530}
1531
1532PP(pp_rand)
1533{
4e35701f 1534 djSP; dTARGET;
79072805
LW		 1535 double value;
1536 if (MAXARG < 1)
1537 value = 1.0;
1538 else
1539 value = POPn;
1540 if (value == 0.0)
1541 value = 1.0;
93dc8474
CS		 1542 if (!srand_called) {
1543 (void)srand((unsigned)seed());
1544 srand_called = TRUE;
1545 }
79072805
LW		 1546#if RANDBITS == 31
1547 value = rand() * value / 2147483648.0;
1548#else
1549#if RANDBITS == 16
1550 value = rand() * value / 65536.0;
1551#else
1552#if RANDBITS == 15
1553 value = rand() * value / 32768.0;
1554#else
1555 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1556#endif
1557#endif
1558#endif
1559 XPUSHn(value);
1560 RETURN;
1561}
1562
1563PP(pp_srand)
1564{
4e35701f 1565 djSP;
93dc8474
CS		 1566 UV anum;
1567 if (MAXARG < 1)
1568 anum = seed();
79072805 1569 else
93dc8474
CS		 1570 anum = POPu;
1571 (void)srand((unsigned)anum);
1572 srand_called = TRUE;
79072805
LW		 1573 EXTEND(SP, 1);
1574 RETPUSHYES;
1575}
1576
76e3520e 1577STATIC U32
8ac85365 1578seed(void)
93dc8474 1579{
54310121 1580 /*
1581 * This is really just a quick hack which grabs various garbage
1582 * values. It really should be a real hash algorithm which
1583 * spreads the effect of every input bit onto every output bit,
1584 * if someone who knows about such tings would bother to write it.
1585 * Might be a good idea to add that function to CORE as well.
1586 * No numbers below come from careful analysis or anyting here,
1587 * except they are primes and SEED_C1 > 1E6 to get a full-width
1588 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1589 * probably be bigger too.
1590 */
1591#if RANDBITS > 16
1592# define SEED_C1 1000003
1593#define SEED_C4 73819
1594#else
1595# define SEED_C1 25747
1596#define SEED_C4 20639
1597#endif
1598#define SEED_C2 3
1599#define SEED_C3 269
1600#define SEED_C5 26107
1601
e858de61 1602 dTHR;
93dc8474 1603 U32 u;
f12c7020 1604#ifdef VMS
1605# include <starlet.h>
43c92808
HF		 1606 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1607 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474
CS		 1608 unsigned int when[2];
1609 _ckvmssts(sys$gettim(when));
54310121 1610 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1611#else
5f05dabc 1612# ifdef HAS_GETTIMEOFDAY
93dc8474
CS		 1613 struct timeval when;
1614 gettimeofday(&when,(struct timezone *) 0);
54310121 1615 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1616# else
93dc8474
CS		 1617 Time_t when;
1618 (void)time(&when);
54310121 1619 u = (U32)SEED_C1 * when;
f12c7020 1620# endif
1621#endif
54310121 1622 u += SEED_C3 * (U32)getpid();
1623 u += SEED_C4 * (U32)(UV)stack_sp;
1624#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1625 u += SEED_C5 * (U32)(UV)&when;
f12c7020 1626#endif
93dc8474 1627 return u;
79072805
LW		 1628}
1629
1630PP(pp_exp)
1631{
4e35701f 1632 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e
LW		 1633 {
1634 double value;
1635 value = POPn;
1636 value = exp(value);
1637 XPUSHn(value);
1638 RETURN;
1639 }
79072805
LW		 1640}
1641
1642PP(pp_log)
1643{
4e35701f 1644 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e
LW		 1645 {
1646 double value;
1647 value = POPn;
bbce6d69 1648 if (value <= 0.0) {
36477c24 1649 SET_NUMERIC_STANDARD();
2304df62 1650 DIE("Can't take log of %g", value);
bbce6d69 1651 }
a0d0e21e
LW		 1652 value = log(value);
1653 XPUSHn(value);
1654 RETURN;
1655 }
79072805
LW		 1656}
1657
1658PP(pp_sqrt)
1659{
4e35701f 1660 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e
LW		 1661 {
1662 double value;
1663 value = POPn;
bbce6d69 1664 if (value < 0.0) {
36477c24 1665 SET_NUMERIC_STANDARD();
2304df62 1666 DIE("Can't take sqrt of %g", value);
bbce6d69 1667 }
a0d0e21e
LW		 1668 value = sqrt(value);
1669 XPUSHn(value);
1670 RETURN;
1671 }
79072805
LW		 1672}
1673
1674PP(pp_int)
1675{
4e35701f 1676 djSP; dTARGET;
774d564b 1677 {
1678 double value = TOPn;
1679 IV iv;
1680
1681 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1682 iv = SvIVX(TOPs);
1683 SETi(iv);
1684 }
1685 else {
1686 if (value >= 0.0)
1687 (void)modf(value, &value);
1688 else {
1689 (void)modf(-value, &value);
1690 value = -value;
1691 }
1692 iv = I_V(value);
1693 if (iv == value)
1694 SETi(iv);
1695 else
1696 SETn(value);
1697 }
79072805 1698 }
79072805
LW		 1699 RETURN;
1700}
1701
463ee0b2
LW		 1702PP(pp_abs)
1703{
4e35701f 1704 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 1705 {
774d564b 1706 double value = TOPn;
1707 IV iv;
463ee0b2 1708
774d564b 1709 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1710 (iv = SvIVX(TOPs)) != IV_MIN) {
1711 if (iv < 0)
1712 iv = -iv;
1713 SETi(iv);
1714 }
1715 else {
1716 if (value < 0.0)
1717 value = -value;
1718 SETn(value);
1719 }
a0d0e21e 1720 }
774d564b 1721 RETURN;
463ee0b2
LW		 1722}
1723
79072805
LW		 1724PP(pp_hex)
1725{
4e35701f 1726 djSP; dTARGET;
79072805
LW		 1727 char *tmps;
1728 I32 argtype;
1729
a0d0e21e 1730 tmps = POPp;
55497cff 1731 XPUSHu(scan_hex(tmps, 99, &argtype));
79072805
LW		 1732 RETURN;
1733}
1734
1735PP(pp_oct)
1736{
4e35701f 1737 djSP; dTARGET;
55497cff 1738 UV value;
79072805
LW		 1739 I32 argtype;
1740 char *tmps;
1741
a0d0e21e 1742 tmps = POPp;
464e2e8a 1743 while (*tmps && isSPACE(*tmps))
1744 tmps++;
1745 if (*tmps == '0')
79072805
LW		 1746 tmps++;
1747 if (*tmps == 'x')
464e2e8a 1748 value = scan_hex(++tmps, 99, &argtype);
1749 else
1750 value = scan_oct(tmps, 99, &argtype);
55497cff 1751 XPUSHu(value);
79072805
LW		 1752 RETURN;
1753}
1754
1755/* String stuff. */
1756
1757PP(pp_length)
1758{
4e35701f 1759 djSP; dTARGET;
a0d0e21e 1760 SETi( sv_len(TOPs) );
79072805
LW		 1761 RETURN;
1762}
1763
1764PP(pp_substr)
1765{
4e35701f 1766 djSP; dTARGET;
79072805
LW		 1767 SV *sv;
1768 I32 len;
463ee0b2 1769 STRLEN curlen;
79072805
LW		 1770 I32 pos;
1771 I32 rem;
84902520 1772 I32 fail;
a0d0e21e 1773 I32 lvalue = op->op_flags & OPf_MOD;
79072805 1774 char *tmps;
a0d0e21e 1775 I32 arybase = curcop->cop_arybase;
79072805
LW		 1776
1777 if (MAXARG > 2)
1778 len = POPi;
84902520 1779 pos = POPi;
79072805 1780 sv = POPs;
a0d0e21e 1781 tmps = SvPV(sv, curlen);
84902520
TB		 1782 if (pos >= arybase) {
1783 pos -= arybase;
1784 rem = curlen-pos;
1785 fail = rem;
1786 if (MAXARG > 2) {
1787 if (len < 0) {
1788 rem += len;
1789 if (rem < 0)
1790 rem = 0;
1791 }
1792 else if (rem > len)
1793 rem = len;
1794 }
68dc0745 1795 }
84902520
TB		 1796 else {
1797 pos += curlen;
1798 if (MAXARG < 3)
1799 rem = curlen;
1800 else if (len >= 0) {
1801 rem = pos+len;
1802 if (rem > (I32)curlen)
1803 rem = curlen;
1804 }
1805 else {
1806 rem = curlen+len;
1807 if (rem < pos)
1808 rem = pos;
1809 }
1810 if (pos < 0)
1811 pos = 0;
1812 fail = rem;
1813 rem -= pos;
1814 }
1815 if (fail < 0) {
8ec5e241 1816 if (dowarn || lvalue)
2304df62
AD		 1817 warn("substr outside of string");
1818 RETPUSHUNDEF;
1819 }
79072805 1820 else {
79072805 1821 tmps += pos;
79072805
LW		 1822 sv_setpvn(TARG, tmps, rem);
1823 if (lvalue) { /* it's an lvalue! */
dedeecda 1824 if (!SvGMAGICAL(sv)) {
1825 if (SvROK(sv)) {
1826 SvPV_force(sv,na);
1827 if (dowarn)
1828 warn("Attempt to use reference as lvalue in substr");
1829 }
1830 if (SvOK(sv)) /* is it defined ? */
1831 (void)SvPOK_only(sv);
1832 else
1833 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1834 }
5f05dabc 1835
a0d0e21e
LW		 1836 if (SvTYPE(TARG) < SVt_PVLV) {
1837 sv_upgrade(TARG, SVt_PVLV);
1838 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 1839 }
a0d0e21e 1840
5f05dabc 1841 LvTYPE(TARG) = 'x';
79072805 1842 LvTARG(TARG) = sv;
a0d0e21e 1843 LvTARGOFF(TARG) = pos;
8ec5e241 1844 LvTARGLEN(TARG) = rem;
79072805
LW		 1845 }
1846 }
1847 PUSHs(TARG); /* avoid SvSETMAGIC here */
1848 RETURN;
1849}
1850
1851PP(pp_vec)
1852{
4e35701f 1853 djSP; dTARGET;
79072805
LW		 1854 register I32 size = POPi;
1855 register I32 offset = POPi;
1856 register SV *src = POPs;
a0d0e21e 1857 I32 lvalue = op->op_flags & OPf_MOD;
463ee0b2
LW		 1858 STRLEN srclen;
1859 unsigned char *s = (unsigned char*)SvPV(src, srclen);
79072805
LW		 1860 unsigned long retnum;
1861 I32 len;
1862
1863 offset *= size; /* turn into bit offset */
1864 len = (offset + size + 7) / 8;
1865 if (offset < 0 || size < 1)
1866 retnum = 0;
79072805 1867 else {
a0d0e21e
LW		 1868 if (lvalue) { /* it's an lvalue! */
1869 if (SvTYPE(TARG) < SVt_PVLV) {
1870 sv_upgrade(TARG, SVt_PVLV);
1871 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1872 }
1873
1874 LvTYPE(TARG) = 'v';
1875 LvTARG(TARG) = src;
8ec5e241
NIS		 1876 LvTARGOFF(TARG) = offset;
1877 LvTARGLEN(TARG) = size;
a0d0e21e 1878 }
93a17b20 1879 if (len > srclen) {
a0d0e21e
LW		 1880 if (size <= 8)
1881 retnum = 0;
1882 else {
1883 offset >>= 3;
748a9306
LW		 1884 if (size == 16) {
1885 if (offset >= srclen)
1886 retnum = 0;
a0d0e21e 1887 else
748a9306
LW		 1888 retnum = (unsigned long) s[offset] << 8;
1889 }
1890 else if (size == 32) {
1891 if (offset >= srclen)
1892 retnum = 0;
1893 else if (offset + 1 >= srclen)
a0d0e21e 1894 retnum = (unsigned long) s[offset] << 24;
748a9306
LW		 1895 else if (offset + 2 >= srclen)
1896 retnum = ((unsigned long) s[offset] << 24) +
1897 ((unsigned long) s[offset + 1] << 16);
1898 else
1899 retnum = ((unsigned long) s[offset] << 24) +
1900 ((unsigned long) s[offset + 1] << 16) +
1901 (s[offset + 2] << 8);
a0d0e21e
LW		 1902 }
1903 }
79072805 1904 }
a0d0e21e 1905 else if (size < 8)
79072805
LW		 1906 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1907 else {
1908 offset >>= 3;
1909 if (size == 8)
1910 retnum = s[offset];
1911 else if (size == 16)
1912 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1913 else if (size == 32)
1914 retnum = ((unsigned long) s[offset] << 24) +
1915 ((unsigned long) s[offset + 1] << 16) +
1916 (s[offset + 2] << 8) + s[offset+3];
1917 }
79072805
LW		 1918 }
1919
deb3007b 1920 sv_setuv(TARG, (UV)retnum);
79072805
LW		 1921 PUSHs(TARG);
1922 RETURN;
1923}
1924
1925PP(pp_index)
1926{
4e35701f 1927 djSP; dTARGET;
79072805
LW		 1928 SV *big;
1929 SV *little;
1930 I32 offset;
1931 I32 retval;
1932 char *tmps;
1933 char *tmps2;
463ee0b2 1934 STRLEN biglen;
a0d0e21e 1935 I32 arybase = curcop->cop_arybase;
79072805
LW		 1936
1937 if (MAXARG < 3)
1938 offset = 0;
1939 else
1940 offset = POPi - arybase;
1941 little = POPs;
1942 big = POPs;
463ee0b2 1943 tmps = SvPV(big, biglen);
79072805
LW		 1944 if (offset < 0)
1945 offset = 0;
93a17b20
LW		 1946 else if (offset > biglen)
1947 offset = biglen;
79072805 1948 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
93a17b20 1949 (unsigned char*)tmps + biglen, little)))
79072805
LW		 1950 retval = -1 + arybase;
1951 else
1952 retval = tmps2 - tmps + arybase;
1953 PUSHi(retval);
1954 RETURN;
1955}
1956
1957PP(pp_rindex)
1958{
4e35701f 1959 djSP; dTARGET;
79072805
LW		 1960 SV *big;
1961 SV *little;
463ee0b2
LW		 1962 STRLEN blen;
1963 STRLEN llen;
79072805
LW		 1964 SV *offstr;
1965 I32 offset;
1966 I32 retval;
1967 char *tmps;
1968 char *tmps2;
a0d0e21e 1969 I32 arybase = curcop->cop_arybase;
79072805 1970
a0d0e21e 1971 if (MAXARG >= 3)
79072805
LW		 1972 offstr = POPs;
1973 little = POPs;
1974 big = POPs;
463ee0b2
LW		 1975 tmps2 = SvPV(little, llen);
1976 tmps = SvPV(big, blen);
79072805 1977 if (MAXARG < 3)
463ee0b2 1978 offset = blen;
79072805 1979 else
463ee0b2 1980 offset = SvIV(offstr) - arybase + llen;
79072805
LW		 1981 if (offset < 0)
1982 offset = 0;
463ee0b2
LW		 1983 else if (offset > blen)
1984 offset = blen;
79072805 1985 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 1986 tmps2, tmps2 + llen)))
79072805
LW		 1987 retval = -1 + arybase;
1988 else
1989 retval = tmps2 - tmps + arybase;
1990 PUSHi(retval);
1991 RETURN;
1992}
1993
1994PP(pp_sprintf)
1995{
4e35701f 1996 djSP; dMARK; dORIGMARK; dTARGET;
36477c24 1997#ifdef USE_LOCALE_NUMERIC
bbce6d69 1998 if (op->op_private & OPpLOCALE)
36477c24 1999 SET_NUMERIC_LOCAL();
bbce6d69 2000 else
36477c24 2001 SET_NUMERIC_STANDARD();
2002#endif
79072805 2003 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2004 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 2005 SP = ORIGMARK;
2006 PUSHTARG;
2007 RETURN;
2008}
2009
79072805
LW		 2010PP(pp_ord)
2011{
4e35701f 2012 djSP; dTARGET;
79072805
LW		 2013 I32 value;
2014 char *tmps;
79072805 2015
79072805 2016#ifndef I286
a0d0e21e 2017 tmps = POPp;
79072805
LW		 2018 value = (I32) (*tmps & 255);
2019#else
a0d0e21e
LW		 2020 I32 anum;
2021 tmps = POPp;
79072805
LW		 2022 anum = (I32) *tmps;
2023 value = (I32) (anum & 255);
2024#endif
2025 XPUSHi(value);
2026 RETURN;
2027}
2028
463ee0b2
LW		 2029PP(pp_chr)
2030{
4e35701f 2031 djSP; dTARGET;
463ee0b2
LW		 2032 char *tmps;
2033
748a9306
LW		 2034 (void)SvUPGRADE(TARG,SVt_PV);
2035 SvGROW(TARG,2);
463ee0b2
LW		 2036 SvCUR_set(TARG, 1);
2037 tmps = SvPVX(TARG);
748a9306
LW		 2038 *tmps++ = POPi;
2039 *tmps = '\0';
a0d0e21e 2040 (void)SvPOK_only(TARG);
463ee0b2
LW		 2041 XPUSHs(TARG);
2042 RETURN;
2043}
2044
79072805
LW		 2045PP(pp_crypt)
2046{
4e35701f 2047 djSP; dTARGET; dPOPTOPssrl;
79072805 2048#ifdef HAS_CRYPT
a0d0e21e 2049 char *tmps = SvPV(left, na);
79072805 2050#ifdef FCRYPT
a0d0e21e 2051 sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
79072805 2052#else
a0d0e21e 2053 sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
79072805
LW		 2054#endif
2055#else
2056 DIE(
2057 "The crypt() function is unimplemented due to excessive paranoia.");
2058#endif
2059 SETs(TARG);
2060 RETURN;
2061}
2062
2063PP(pp_ucfirst)
2064{
4e35701f 2065 djSP;
79072805
LW		 2066 SV *sv = TOPs;
2067 register char *s;
2068
ed6116ce 2069 if (!SvPADTMP(sv)) {
79072805
LW		 2070 dTARGET;
2071 sv_setsv(TARG, sv);
2072 sv = TARG;
2073 SETs(sv);
2074 }
a0d0e21e 2075 s = SvPV_force(sv, na);
bbce6d69 2076 if (*s) {
2077 if (op->op_private & OPpLOCALE) {
2078 TAINT;
2079 SvTAINTED_on(sv);
2080 *s = toUPPER_LC(*s);
2081 }
2082 else
2083 *s = toUPPER(*s);
2084 }
79072805
LW		 2085
2086 RETURN;
2087}
2088
2089PP(pp_lcfirst)
2090{
4e35701f 2091 djSP;
79072805
LW		 2092 SV *sv = TOPs;
2093 register char *s;
2094
ed6116ce 2095 if (!SvPADTMP(sv)) {
79072805
LW		 2096 dTARGET;
2097 sv_setsv(TARG, sv);
2098 sv = TARG;
2099 SETs(sv);
2100 }
a0d0e21e 2101 s = SvPV_force(sv, na);
bbce6d69 2102 if (*s) {
2103 if (op->op_private & OPpLOCALE) {
2104 TAINT;
2105 SvTAINTED_on(sv);
2106 *s = toLOWER_LC(*s);
2107 }
2108 else
2109 *s = toLOWER(*s);
2110 }
79072805
LW		 2111
2112 SETs(sv);
2113 RETURN;
2114}
2115
2116PP(pp_uc)
2117{
4e35701f 2118 djSP;
79072805
LW		 2119 SV *sv = TOPs;
2120 register char *s;
463ee0b2 2121 STRLEN len;
79072805 2122
ed6116ce 2123 if (!SvPADTMP(sv)) {
79072805
LW		 2124 dTARGET;
2125 sv_setsv(TARG, sv);
2126 sv = TARG;
2127 SETs(sv);
2128 }
bbce6d69 2129
a0d0e21e 2130 s = SvPV_force(sv, len);
bbce6d69 2131 if (len) {
2132 register char *send = s + len;
2133
2134 if (op->op_private & OPpLOCALE) {
2135 TAINT;
2136 SvTAINTED_on(sv);
2137 for (; s < send; s++)
2138 *s = toUPPER_LC(*s);
2139 }
2140 else {
2141 for (; s < send; s++)
2142 *s = toUPPER(*s);
2143 }
79072805
LW		 2144 }
2145 RETURN;
2146}
2147
2148PP(pp_lc)
2149{
4e35701f 2150 djSP;
79072805
LW		 2151 SV *sv = TOPs;
2152 register char *s;
463ee0b2 2153 STRLEN len;
79072805 2154
ed6116ce 2155 if (!SvPADTMP(sv)) {
79072805
LW		 2156 dTARGET;
2157 sv_setsv(TARG, sv);
2158 sv = TARG;
2159 SETs(sv);
2160 }
bbce6d69 2161
a0d0e21e 2162 s = SvPV_force(sv, len);
bbce6d69 2163 if (len) {
2164 register char *send = s + len;
2165
2166 if (op->op_private & OPpLOCALE) {
2167 TAINT;
2168 SvTAINTED_on(sv);
2169 for (; s < send; s++)
2170 *s = toLOWER_LC(*s);
2171 }
2172 else {
2173 for (; s < send; s++)
2174 *s = toLOWER(*s);
2175 }
79072805
LW		 2176 }
2177 RETURN;
2178}
2179
a0d0e21e 2180PP(pp_quotemeta)
79072805 2181{
4e35701f 2182 djSP; dTARGET;
a0d0e21e
LW		 2183 SV *sv = TOPs;
2184 STRLEN len;
2185 register char *s = SvPV(sv,len);
2186 register char *d;
79072805 2187
a0d0e21e
LW		 2188 if (len) {
2189 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2190 SvGROW(TARG, (len * 2) + 1);
a0d0e21e
LW		 2191 d = SvPVX(TARG);
2192 while (len--) {
2193 if (!isALNUM(*s))
2194 *d++ = '\\';
2195 *d++ = *s++;
79072805 2196 }
a0d0e21e
LW		 2197 *d = '\0';
2198 SvCUR_set(TARG, d - SvPVX(TARG));
2199 (void)SvPOK_only(TARG);
79072805 2200 }
a0d0e21e
LW		 2201 else
2202 sv_setpvn(TARG, s, len);
2203 SETs(TARG);
79072805
LW		 2204 RETURN;
2205}
2206
a0d0e21e 2207/* Arrays. */
79072805 2208
a0d0e21e 2209PP(pp_aslice)
79072805 2210{
4e35701f 2211 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2212 register SV** svp;
2213 register AV* av = (AV*)POPs;
2214 register I32 lval = op->op_flags & OPf_MOD;
748a9306
LW		 2215 I32 arybase = curcop->cop_arybase;
2216 I32 elem;
79072805 2217
a0d0e21e 2218 if (SvTYPE(av) == SVt_PVAV) {
748a9306
LW		 2219 if (lval && op->op_private & OPpLVAL_INTRO) {
2220 I32 max = -1;
924508f0 2221 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 2222 elem = SvIVx(*svp);
2223 if (elem > max)
2224 max = elem;
2225 }
2226 if (max > AvMAX(av))
2227 av_extend(av, max);
2228 }
a0d0e21e 2229 while (++MARK <= SP) {
748a9306 2230 elem = SvIVx(*MARK);
a0d0e21e 2231
748a9306
LW		 2232 if (elem > 0)
2233 elem -= arybase;
a0d0e21e
LW		 2234 svp = av_fetch(av, elem, lval);
2235 if (lval) {
2236 if (!svp || *svp == &sv_undef)
2237 DIE(no_aelem, elem);
2238 if (op->op_private & OPpLVAL_INTRO)
161b7d16 2239 save_aelem(av, elem, svp);
79072805 2240 }
a0d0e21e 2241 *MARK = svp ? *svp : &sv_undef;
79072805
LW		 2242 }
2243 }
748a9306 2244 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 2245 MARK = ORIGMARK;
2246 *++MARK = *SP;
2247 SP = MARK;
2248 }
79072805
LW		 2249 RETURN;
2250}
2251
2252/* Associative arrays. */
2253
2254PP(pp_each)
2255{
4e35701f 2256 djSP; dTARGET;
79072805 2257 HV *hash = (HV*)POPs;
c07a80fd 2258 HE *entry;
54310121 2259 I32 gimme = GIMME_V;
c750a3ec 2260 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2261
c07a80fd 2262 PUTBACK;
c750a3ec
MB		 2263 /* might clobber stack_sp */
2264 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2265 SPAGAIN;
79072805 2266
79072805
LW		 2267 EXTEND(SP, 2);
2268 if (entry) {
54310121 2269 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2270 if (gimme == G_ARRAY) {
c07a80fd 2271 PUTBACK;
c750a3ec
MB		 2272 /* might clobber stack_sp */
2273 sv_setsv(TARG, realhv ?
2274 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
c07a80fd 2275 SPAGAIN;
8990e307 2276 PUSHs(TARG);
79072805 2277 }
79072805 2278 }
54310121 2279 else if (gimme == G_SCALAR)
79072805
LW		 2280 RETPUSHUNDEF;
2281
2282 RETURN;
2283}
2284
2285PP(pp_values)
2286{
2287 return do_kv(ARGS);
2288}
2289
2290PP(pp_keys)
2291{
2292 return do_kv(ARGS);
2293}
2294
2295PP(pp_delete)
2296{
4e35701f 2297 djSP;
54310121 2298 I32 gimme = GIMME_V;
2299 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2300 SV *sv;
5f05dabc 2301 HV *hv;
2302
2303 if (op->op_private & OPpSLICE) {
2304 dMARK; dORIGMARK;
97fcbf96 2305 U32 hvtype;
5f05dabc 2306 hv = (HV*)POPs;
97fcbf96 2307 hvtype = SvTYPE(hv);
5f05dabc 2308 while (++MARK <= SP) {
ae77835f
MB		 2309 if (hvtype == SVt_PVHV)
2310 sv = hv_delete_ent(hv, *MARK, discard, 0);
2311 else if (hvtype == SVt_PVAV)
2312 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2313 else
2314 DIE("Not a HASH reference");
5f05dabc 2315 *MARK = sv ? sv : &sv_undef;
2316 }
54310121 2317 if (discard)
2318 SP = ORIGMARK;
2319 else if (gimme == G_SCALAR) {
5f05dabc 2320 MARK = ORIGMARK;
2321 *++MARK = *SP;
2322 SP = MARK;
2323 }
2324 }
2325 else {
2326 SV *keysv = POPs;
2327 hv = (HV*)POPs;
97fcbf96
MB		 2328 if (SvTYPE(hv) == SVt_PVHV)
2329 sv = hv_delete_ent(hv, keysv, discard, 0);
2330 else if (SvTYPE(hv) == SVt_PVAV)
2331 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2332 else
5f05dabc 2333 DIE("Not a HASH reference");
5f05dabc 2334 if (!sv)
2335 sv = &sv_undef;
54310121 2336 if (!discard)
2337 PUSHs(sv);
79072805 2338 }
79072805
LW		 2339 RETURN;
2340}
2341
a0d0e21e 2342PP(pp_exists)
79072805 2343{
4e35701f 2344 djSP;
a0d0e21e
LW		 2345 SV *tmpsv = POPs;
2346 HV *hv = (HV*)POPs;
c750a3ec 2347 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2348 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec
MB		 2349 RETPUSHYES;
2350 } else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2351 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec
MB		 2352 RETPUSHYES;
2353 } else {
a0d0e21e
LW		 2354 DIE("Not a HASH reference");
2355 }
a0d0e21e
LW		 2356 RETPUSHNO;
2357}
79072805 2358
a0d0e21e
LW		 2359PP(pp_hslice)
2360{
4e35701f 2361 djSP; dMARK; dORIGMARK;
f12c7020 2362 register HE *he;
a0d0e21e
LW		 2363 register HV *hv = (HV*)POPs;
2364 register I32 lval = op->op_flags & OPf_MOD;
c750a3ec 2365 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2366
c750a3ec 2367 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2368 while (++MARK <= SP) {
f12c7020 2369 SV *keysv = *MARK;
ae77835f
MB		 2370 SV **svp;
2371 if (realhv) {
2372 he = hv_fetch_ent(hv, keysv, lval, 0);
2373 svp = he ? &HeVAL(he) : 0;
2374 } else {
97fcbf96 2375 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2376 }
a0d0e21e 2377 if (lval) {
f12c7020 2378 if (!he || HeVAL(he) == &sv_undef)
2379 DIE(no_helem, SvPV(keysv, na));
a0d0e21e 2380 if (op->op_private & OPpLVAL_INTRO)
161b7d16 2381 save_helem(hv, keysv, &HeVAL(he));
93a17b20 2382 }
f12c7020 2383 *MARK = he ? HeVAL(he) : &sv_undef;
79072805
LW		 2384 }
2385 }
a0d0e21e
LW		 2386 if (GIMME != G_ARRAY) {
2387 MARK = ORIGMARK;
2388 *++MARK = *SP;
2389 SP = MARK;
79072805 2390 }
a0d0e21e
LW		 2391 RETURN;
2392}
2393
2394/* List operators. */
2395
2396PP(pp_list)
2397{
4e35701f 2398 djSP; dMARK;
a0d0e21e
LW		 2399 if (GIMME != G_ARRAY) {
2400 if (++MARK <= SP)
2401 *MARK = *SP; /* unwanted list, return last item */
8990e307 2402 else
a0d0e21e
LW		 2403 *MARK = &sv_undef;
2404 SP = MARK;
79072805 2405 }
a0d0e21e 2406 RETURN;
79072805
LW		 2407}
2408
a0d0e21e 2409PP(pp_lslice)
79072805 2410{
4e35701f 2411 djSP;
a0d0e21e
LW		 2412 SV **lastrelem = stack_sp;
2413 SV **lastlelem = stack_base + POPMARK;
2414 SV **firstlelem = stack_base + POPMARK + 1;
2415 register SV **firstrelem = lastlelem + 1;
2416 I32 arybase = curcop->cop_arybase;
4633a7c4
LW		 2417 I32 lval = op->op_flags & OPf_MOD;
2418 I32 is_something_there = lval;
79072805 2419
a0d0e21e
LW		 2420 register I32 max = lastrelem - lastlelem;
2421 register SV **lelem;
2422 register I32 ix;
2423
2424 if (GIMME != G_ARRAY) {
748a9306
LW		 2425 ix = SvIVx(*lastlelem);
2426 if (ix < 0)
2427 ix += max;
2428 else
2429 ix -= arybase;
a0d0e21e
LW		 2430 if (ix < 0 || ix >= max)
2431 *firstlelem = &sv_undef;
2432 else
2433 *firstlelem = firstrelem[ix];
2434 SP = firstlelem;
2435 RETURN;
2436 }
2437
2438 if (max == 0) {
2439 SP = firstlelem - 1;
2440 RETURN;
2441 }
2442
2443 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2444 ix = SvIVx(*lelem);
a0d0e21e
LW		 2445 if (ix < 0) {
2446 ix += max;
2447 if (ix < 0)
2448 *lelem = &sv_undef;
2449 else if (!(*lelem = firstrelem[ix]))
2450 *lelem = &sv_undef;
79072805 2451 }
748a9306
LW		 2452 else {
2453 ix -= arybase;
2454 if (ix >= max || !(*lelem = firstrelem[ix]))
2455 *lelem = &sv_undef;
2456 }
ff0cee69 2457 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
4633a7c4 2458 is_something_there = TRUE;
79072805 2459 }
4633a7c4
LW		 2460 if (is_something_there)
2461 SP = lastlelem;
2462 else
2463 SP = firstlelem - 1;
79072805
LW		 2464 RETURN;
2465}
2466
a0d0e21e
LW		 2467PP(pp_anonlist)
2468{
4e35701f 2469 djSP; dMARK; dORIGMARK;
a0d0e21e 2470 I32 items = SP - MARK;
44a8e56a 2471 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2472 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2473 XPUSHs(av);
a0d0e21e
LW		 2474 RETURN;
2475}
2476
2477PP(pp_anonhash)
79072805 2478{
4e35701f 2479 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2480 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2481
2482 while (MARK < SP) {
2483 SV* key = *++MARK;
a0d0e21e
LW		 2484 SV *val = NEWSV(46, 0);
2485 if (MARK < SP)
2486 sv_setsv(val, *++MARK);
fb73857a 2487 else if (dowarn)
a0d0e21e 2488 warn("Odd number of elements in hash list");
f12c7020 2489 (void)hv_store_ent(hv,key,val,0);
79072805 2490 }
a0d0e21e
LW		 2491 SP = ORIGMARK;
2492 XPUSHs((SV*)hv);
79072805
LW		 2493 RETURN;
2494}
2495
a0d0e21e 2496PP(pp_splice)
79072805 2497{
4e35701f 2498 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2499 register AV *ary = (AV*)*++MARK;
2500 register SV **src;
2501 register SV **dst;
2502 register I32 i;
2503 register I32 offset;
2504 register I32 length;
2505 I32 newlen;
2506 I32 after;
2507 I32 diff;
2508 SV **tmparyval = 0;
93965878
NIS		 2509 MAGIC *mg;
2510
2511 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2512 *MARK-- = mg->mg_obj;
2513 PUSHMARK(MARK);
8ec5e241 2514 PUTBACK;
a60c0954 2515 ENTER;
93965878 2516 perl_call_method("SPLICE",GIMME_V);
a60c0954 2517 LEAVE;
93965878
NIS		 2518 SPAGAIN;
2519 RETURN;
2520 }
79072805 2521
a0d0e21e 2522 SP++;
79072805 2523
a0d0e21e 2524 if (++MARK < SP) {
84902520 2525 offset = i = SvIVx(*MARK);
a0d0e21e 2526 if (offset < 0)
93965878 2527 offset += AvFILLp(ary) + 1;
a0d0e21e
LW		 2528 else
2529 offset -= curcop->cop_arybase;
84902520
TB		 2530 if (offset < 0)
2531 DIE(no_aelem, i);
a0d0e21e
LW		 2532 if (++MARK < SP) {
2533 length = SvIVx(*MARK++);
2534 if (length < 0)
2535 length = 0;
79072805
LW		 2536 }
2537 else
a0d0e21e 2538 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2539 }
a0d0e21e
LW		 2540 else {
2541 offset = 0;
2542 length = AvMAX(ary) + 1;
2543 }
93965878
NIS		 2544 if (offset > AvFILLp(ary) + 1)
2545 offset = AvFILLp(ary) + 1;
2546 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 2547 if (after < 0) { /* not that much array */
2548 length += after; /* offset+length now in array */
2549 after = 0;
2550 if (!AvALLOC(ary))
2551 av_extend(ary, 0);
2552 }
2553
2554 /* At this point, MARK .. SP-1 is our new LIST */
2555
2556 newlen = SP - MARK;
2557 diff = newlen - length;
fb73857a 2558 if (newlen && !AvREAL(ary)) {
2559 if (AvREIFY(ary))
2560 av_reify(ary);
2561 else
2562 assert(AvREAL(ary)); /* would leak, so croak */
2563 }
a0d0e21e
LW		 2564
2565 if (diff < 0) { /* shrinking the area */
2566 if (newlen) {
2567 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2568 Copy(MARK, tmparyval, newlen, SV*);
79072805 2569 }
a0d0e21e
LW		 2570
2571 MARK = ORIGMARK + 1;
2572 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2573 MEXTEND(MARK, length);
2574 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2575 if (AvREAL(ary)) {
bbce6d69 2576 EXTEND_MORTAL(length);
36477c24 2577 for (i = length, dst = MARK; i; i--) {
2578 if (!SvIMMORTAL(*dst))
2579 sv_2mortal(*dst); /* free them eventualy */
2580 dst++;
2581 }
a0d0e21e
LW		 2582 }
2583 MARK += length - 1;
79072805 2584 }
a0d0e21e
LW		 2585 else {
2586 *MARK = AvARRAY(ary)[offset+length-1];
2587 if (AvREAL(ary)) {
36477c24 2588 if (!SvIMMORTAL(*MARK))
2589 sv_2mortal(*MARK);
a0d0e21e
LW		 2590 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2591 SvREFCNT_dec(*dst++); /* free them now */
79072805 2592 }
a0d0e21e 2593 }
93965878 2594 AvFILLp(ary) += diff;
a0d0e21e
LW		 2595
2596 /* pull up or down? */
2597
2598 if (offset < after) { /* easier to pull up */
2599 if (offset) { /* esp. if nothing to pull */
2600 src = &AvARRAY(ary)[offset-1];
2601 dst = src - diff; /* diff is negative */
2602 for (i = offset; i > 0; i--) /* can't trust Copy */
2603 *dst-- = *src--;
79072805 2604 }
a0d0e21e
LW		 2605 dst = AvARRAY(ary);
2606 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2607 AvMAX(ary) += diff;
2608 }
2609 else {
2610 if (after) { /* anything to pull down? */
2611 src = AvARRAY(ary) + offset + length;
2612 dst = src + diff; /* diff is negative */
2613 Move(src, dst, after, SV*);
79072805 2614 }
93965878 2615 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 2616 /* avoid later double free */
2617 }
2618 i = -diff;
2619 while (i)
2620 dst[--i] = &sv_undef;
2621
2622 if (newlen) {
2623 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2624 newlen; newlen--) {
2625 *dst = NEWSV(46, 0);
2626 sv_setsv(*dst++, *src++);
79072805 2627 }
a0d0e21e
LW		 2628 Safefree(tmparyval);
2629 }
2630 }
2631 else { /* no, expanding (or same) */
2632 if (length) {
2633 New(452, tmparyval, length, SV*); /* so remember deletion */
2634 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2635 }
2636
2637 if (diff > 0) { /* expanding */
2638
2639 /* push up or down? */
2640
2641 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2642 if (offset) {
2643 src = AvARRAY(ary);
2644 dst = src - diff;
2645 Move(src, dst, offset, SV*);
79072805 2646 }
a0d0e21e
LW		 2647 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2648 AvMAX(ary) += diff;
93965878 2649 AvFILLp(ary) += diff;
79072805
LW		 2650 }
2651 else {
93965878
NIS		 2652 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2653 av_extend(ary, AvFILLp(ary) + diff);
2654 AvFILLp(ary) += diff;
a0d0e21e
LW		 2655
2656 if (after) {
93965878 2657 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 2658 src = dst - diff;
2659 for (i = after; i; i--) {
2660 *dst-- = *src--;
2661 }
79072805
LW		 2662 }
2663 }
a0d0e21e
LW		 2664 }
2665
2666 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2667 *dst = NEWSV(46, 0);
2668 sv_setsv(*dst++, *src++);
2669 }
2670 MARK = ORIGMARK + 1;
2671 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2672 if (length) {
2673 Copy(tmparyval, MARK, length, SV*);
2674 if (AvREAL(ary)) {
bbce6d69 2675 EXTEND_MORTAL(length);
36477c24 2676 for (i = length, dst = MARK; i; i--) {
2677 if (!SvIMMORTAL(*dst))
2678 sv_2mortal(*dst); /* free them eventualy */
2679 dst++;
2680 }
79072805 2681 }
a0d0e21e 2682 Safefree(tmparyval);
79072805 2683 }
a0d0e21e
LW		 2684 MARK += length - 1;
2685 }
2686 else if (length--) {
2687 *MARK = tmparyval[length];
2688 if (AvREAL(ary)) {
36477c24 2689 if (!SvIMMORTAL(*MARK))
2690 sv_2mortal(*MARK);
a0d0e21e
LW		 2691 while (length-- > 0)
2692 SvREFCNT_dec(tmparyval[length]);
79072805 2693 }
a0d0e21e 2694 Safefree(tmparyval);
79072805 2695 }
a0d0e21e
LW		 2696 else
2697 *MARK = &sv_undef;
79072805 2698 }
a0d0e21e 2699 SP = MARK;
79072805
LW		 2700 RETURN;
2701}
2702
a0d0e21e 2703PP(pp_push)
79072805 2704{
4e35701f 2705 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 2706 register AV *ary = (AV*)*++MARK;
2707 register SV *sv = &sv_undef;
93965878 2708 MAGIC *mg;
79072805 2709
93965878
NIS		 2710 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2711 *MARK-- = mg->mg_obj;
2712 PUSHMARK(MARK);
2713 PUTBACK;
a60c0954
NIS		 2714 ENTER;
2715 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2716 LEAVE;
93965878 2717 SPAGAIN;
93965878 2718 }
a60c0954
NIS		 2719 else {
2720 /* Why no pre-extend of ary here ? */
2721 for (++MARK; MARK <= SP; MARK++) {
2722 sv = NEWSV(51, 0);
2723 if (*MARK)
2724 sv_setsv(sv, *MARK);
2725 av_push(ary, sv);
2726 }
79072805
LW		 2727 }
2728 SP = ORIGMARK;
a0d0e21e 2729 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 2730 RETURN;
2731}
2732
a0d0e21e 2733PP(pp_pop)
79072805 2734{
4e35701f 2735 djSP;
a0d0e21e
LW		 2736 AV *av = (AV*)POPs;
2737 SV *sv = av_pop(av);
36477c24 2738 if (!SvIMMORTAL(sv) && AvREAL(av))
a0d0e21e
LW		 2739 (void)sv_2mortal(sv);
2740 PUSHs(sv);
79072805 2741 RETURN;
79072805
LW		 2742}
2743
a0d0e21e 2744PP(pp_shift)
79072805 2745{
4e35701f 2746 djSP;
a0d0e21e
LW		 2747 AV *av = (AV*)POPs;
2748 SV *sv = av_shift(av);
79072805 2749 EXTEND(SP, 1);
a0d0e21e 2750 if (!sv)
79072805 2751 RETPUSHUNDEF;
36477c24 2752 if (!SvIMMORTAL(sv) && AvREAL(av))
a0d0e21e
LW		 2753 (void)sv_2mortal(sv);
2754 PUSHs(sv);
79072805 2755 RETURN;
79072805
LW		 2756}
2757
a0d0e21e 2758PP(pp_unshift)
79072805 2759{
4e35701f 2760 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 2761 register AV *ary = (AV*)*++MARK;
2762 register SV *sv;
2763 register I32 i = 0;
93965878
NIS		 2764 MAGIC *mg;
2765
8ec5e241 2766 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
93965878 2767 *MARK-- = mg->mg_obj;
7fd66d9d 2768 PUSHMARK(MARK);
93965878 2769 PUTBACK;
a60c0954
NIS		 2770 ENTER;
2771 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2772 LEAVE;
93965878 2773 SPAGAIN;
93965878 2774 }
a60c0954
NIS		 2775 else {
2776 av_unshift(ary, SP - MARK);
2777 while (MARK < SP) {
2778 sv = NEWSV(27, 0);
2779 sv_setsv(sv, *++MARK);
2780 (void)av_store(ary, i++, sv);
2781 }
79072805 2782 }
a0d0e21e
LW		 2783 SP = ORIGMARK;
2784 PUSHi( AvFILL(ary) + 1 );
79072805 2785 RETURN;
79072805
LW		 2786}
2787
a0d0e21e 2788PP(pp_reverse)
79072805 2789{
4e35701f 2790 djSP; dMARK;
a0d0e21e
LW		 2791 register SV *tmp;
2792 SV **oldsp = SP;
79072805 2793
a0d0e21e
LW		 2794 if (GIMME == G_ARRAY) {
2795 MARK++;
2796 while (MARK < SP) {
2797 tmp = *MARK;
2798 *MARK++ = *SP;
2799 *SP-- = tmp;
2800 }
2801 SP = oldsp;
79072805
LW		 2802 }
2803 else {
a0d0e21e
LW		 2804 register char *up;
2805 register char *down;
2806 register I32 tmp;
2807 dTARGET;
2808 STRLEN len;
79072805 2809
a0d0e21e
LW		 2810 if (SP - MARK > 1)
2811 do_join(TARG, &sv_no, MARK, SP);
2812 else
54b9620d 2813 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 2814 up = SvPV_force(TARG, len);
2815 if (len > 1) {
2816 down = SvPVX(TARG) + len - 1;
2817 while (down > up) {
2818 tmp = *up;
2819 *up++ = *down;
2820 *down-- = tmp;
2821 }
2822 (void)SvPOK_only(TARG);
79072805 2823 }
a0d0e21e
LW		 2824 SP = MARK + 1;
2825 SETTARG;
79072805 2826 }
a0d0e21e 2827 RETURN;
79072805
LW		 2828}
2829
76e3520e 2830STATIC SV *
8ac85365 2831mul128(SV *sv, U8 m)
55497cff 2832{
2833 STRLEN len;
2834 char *s = SvPV(sv, len);
2835 char *t;
2836 U32 i = 0;
2837
2838 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
8ac85365 2839 SV *New = newSVpv("0000000000", 10);
55497cff 2840
8ac85365 2841 sv_catsv(New, sv);
55497cff 2842 SvREFCNT_dec(sv); /* free old sv */
8ac85365 2843 sv = New;
55497cff 2844 s = SvPV(sv, len);
2845 }
2846 t = s + len - 1;
2847 while (!*t) /* trailing '\0'? */
2848 t--;
2849 while (t > s) {
2850 i = ((*t - '0') << 7) + m;
2851 *(t--) = '0' + (i % 10);
2852 m = i / 10;
2853 }
2854 return (sv);
2855}
2856
a0d0e21e
LW		 2857/* Explosives and implosives. */
2858
2859PP(pp_unpack)
79072805 2860{
4e35701f 2861 djSP;
a0d0e21e 2862 dPOPPOPssrl;
924508f0 2863 SV **oldsp = SP;
54310121 2864 I32 gimme = GIMME_V;
ed6116ce 2865 SV *sv;
a0d0e21e
LW		 2866 STRLEN llen;
2867 STRLEN rlen;
2868 register char *pat = SvPV(left, llen);
2869 register char *s = SvPV(right, rlen);
2870 char *strend = s + rlen;
2871 char *strbeg = s;
2872 register char *patend = pat + llen;
2873 I32 datumtype;
2874 register I32 len;
2875 register I32 bits;
79072805 2876
a0d0e21e
LW		 2877 /* These must not be in registers: */
2878 I16 ashort;
2879 int aint;
2880 I32 along;
ecfc5424
AD		 2881#ifdef HAS_QUAD
2882 Quad_t aquad;
a0d0e21e
LW		 2883#endif
2884 U16 aushort;
2885 unsigned int auint;
2886 U32 aulong;
ecfc5424
AD		 2887#ifdef HAS_QUAD
2888 unsigned Quad_t auquad;
a0d0e21e
LW		 2889#endif
2890 char *aptr;
2891 float afloat;
2892 double adouble;
2893 I32 checksum = 0;
2894 register U32 culong;
2895 double cdouble;
2896 static char* bitcount = 0;
fb73857a 2897 int commas = 0;
79072805 2898
54310121 2899 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 2900 /*SUPPRESS 530*/
2901 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
748a9306 2902 if (strchr("aAbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 2903 patend++;
2904 while (isDIGIT(*patend) || *patend == '*')
2905 patend++;
2906 }
2907 else
2908 patend++;
79072805 2909 }
a0d0e21e
LW		 2910 while (pat < patend) {
2911 reparse:
bbdab043
CS		 2912 datumtype = *pat++ & 0xFF;
2913 if (isSPACE(datumtype))
2914 continue;
a0d0e21e
LW		 2915 if (pat >= patend)
2916 len = 1;
2917 else if (*pat == '*') {
2918 len = strend - strbeg; /* long enough */
2919 pat++;
2920 }
2921 else if (isDIGIT(*pat)) {
2922 len = *pat++ - '0';
2923 while (isDIGIT(*pat))
2924 len = (len * 10) + (*pat++ - '0');
2925 }
2926 else
2927 len = (datumtype != '@');
2928 switch(datumtype) {
2929 default:
bbdab043 2930 croak("Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 2931 case ',': /* grandfather in commas but with a warning */
2932 if (commas++ == 0 && dowarn)
2933 warn("Invalid type in unpack: '%c'", (int)datumtype);
2934 break;
a0d0e21e
LW		 2935 case '%':
2936 if (len == 1 && pat[-1] != '1')
2937 len = 16;
2938 checksum = len;
2939 culong = 0;
2940 cdouble = 0;
2941 if (pat < patend)
2942 goto reparse;
2943 break;
2944 case '@':
2945 if (len > strend - strbeg)
2946 DIE("@ outside of string");
2947 s = strbeg + len;
2948 break;
2949 case 'X':
2950 if (len > s - strbeg)
2951 DIE("X outside of string");
2952 s -= len;
2953 break;
2954 case 'x':
2955 if (len > strend - s)
2956 DIE("x outside of string");
2957 s += len;
2958 break;
2959 case 'A':
2960 case 'a':
2961 if (len > strend - s)
2962 len = strend - s;
2963 if (checksum)
2964 goto uchar_checksum;
2965 sv = NEWSV(35, len);
2966 sv_setpvn(sv, s, len);
2967 s += len;
2968 if (datumtype == 'A') {
2969 aptr = s; /* borrow register */
2970 s = SvPVX(sv) + len - 1;
2971 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2972 s--;
2973 *++s = '\0';
2974 SvCUR_set(sv, s - SvPVX(sv));
2975 s = aptr; /* unborrow register */
2976 }
2977 XPUSHs(sv_2mortal(sv));
2978 break;
2979 case 'B':
2980 case 'b':
2981 if (pat[-1] == '*' || len > (strend - s) * 8)
2982 len = (strend - s) * 8;
2983 if (checksum) {
2984 if (!bitcount) {
2985 Newz(601, bitcount, 256, char);
2986 for (bits = 1; bits < 256; bits++) {
2987 if (bits & 1) bitcount[bits]++;
2988 if (bits & 2) bitcount[bits]++;
2989 if (bits & 4) bitcount[bits]++;
2990 if (bits & 8) bitcount[bits]++;
2991 if (bits & 16) bitcount[bits]++;
2992 if (bits & 32) bitcount[bits]++;
2993 if (bits & 64) bitcount[bits]++;
2994 if (bits & 128) bitcount[bits]++;
2995 }
2996 }
2997 while (len >= 8) {
2998 culong += bitcount[*(unsigned char*)s++];
2999 len -= 8;
3000 }
3001 if (len) {
3002 bits = *s;
3003 if (datumtype == 'b') {
3004 while (len-- > 0) {
3005 if (bits & 1) culong++;
3006 bits >>= 1;
3007 }
3008 }
3009 else {
3010 while (len-- > 0) {
3011 if (bits & 128) culong++;
3012 bits <<= 1;
3013 }
3014 }
3015 }
79072805
LW		 3016 break;
3017 }
a0d0e21e
LW		 3018 sv = NEWSV(35, len + 1);
3019 SvCUR_set(sv, len);
3020 SvPOK_on(sv);
3021 aptr = pat; /* borrow register */
3022 pat = SvPVX(sv);
3023 if (datumtype == 'b') {
3024 aint = len;
3025 for (len = 0; len < aint; len++) {
3026 if (len & 7) /*SUPPRESS 595*/
3027 bits >>= 1;
3028 else
3029 bits = *s++;
3030 *pat++ = '0' + (bits & 1);
3031 }
3032 }
3033 else {
3034 aint = len;
3035 for (len = 0; len < aint; len++) {
3036 if (len & 7)
3037 bits <<= 1;
3038 else
3039 bits = *s++;
3040 *pat++ = '0' + ((bits & 128) != 0);
3041 }
3042 }
3043 *pat = '\0';
3044 pat = aptr; /* unborrow register */
3045 XPUSHs(sv_2mortal(sv));
3046 break;
3047 case 'H':
3048 case 'h':
3049 if (pat[-1] == '*' || len > (strend - s) * 2)
3050 len = (strend - s) * 2;
3051 sv = NEWSV(35, len + 1);
3052 SvCUR_set(sv, len);
3053 SvPOK_on(sv);
3054 aptr = pat; /* borrow register */
3055 pat = SvPVX(sv);
3056 if (datumtype == 'h') {
3057 aint = len;
3058 for (len = 0; len < aint; len++) {
3059 if (len & 1)
3060 bits >>= 4;
3061 else
3062 bits = *s++;
3063 *pat++ = hexdigit[bits & 15];
3064 }
3065 }
3066 else {
3067 aint = len;
3068 for (len = 0; len < aint; len++) {
3069 if (len & 1)
3070 bits <<= 4;
3071 else
3072 bits = *s++;
3073 *pat++ = hexdigit[(bits >> 4) & 15];
3074 }
3075 }
3076 *pat = '\0';
3077 pat = aptr; /* unborrow register */
3078 XPUSHs(sv_2mortal(sv));
3079 break;
3080 case 'c':
3081 if (len > strend - s)
3082 len = strend - s;
3083 if (checksum) {
3084 while (len-- > 0) {
3085 aint = *s++;
3086 if (aint >= 128) /* fake up signed chars */
3087 aint -= 256;
3088 culong += aint;
3089 }
3090 }
3091 else {
3092 EXTEND(SP, len);
bbce6d69 3093 EXTEND_MORTAL(len);
a0d0e21e
LW		 3094 while (len-- > 0) {
3095 aint = *s++;
3096 if (aint >= 128) /* fake up signed chars */
3097 aint -= 256;
3098 sv = NEWSV(36, 0);
1e422769 3099 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3100 PUSHs(sv_2mortal(sv));
3101 }
3102 }
3103 break;
3104 case 'C':
3105 if (len > strend - s)
3106 len = strend - s;
3107 if (checksum) {
3108 uchar_checksum:
3109 while (len-- > 0) {
3110 auint = *s++ & 255;
3111 culong += auint;
3112 }
3113 }
3114 else {
3115 EXTEND(SP, len);
bbce6d69 3116 EXTEND_MORTAL(len);
a0d0e21e
LW		 3117 while (len-- > 0) {
3118 auint = *s++ & 255;
3119 sv = NEWSV(37, 0);
1e422769 3120 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3121 PUSHs(sv_2mortal(sv));
3122 }
3123 }
3124 break;
3125 case 's':
96e4d5b1 3126 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3127 if (len > along)
3128 len = along;
3129 if (checksum) {
3130 while (len-- > 0) {
96e4d5b1 3131 COPY16(s, &ashort);
3132 s += SIZE16;
a0d0e21e
LW		 3133 culong += ashort;
3134 }
3135 }
3136 else {
3137 EXTEND(SP, len);
bbce6d69 3138 EXTEND_MORTAL(len);
a0d0e21e 3139 while (len-- > 0) {
96e4d5b1 3140 COPY16(s, &ashort);
3141 s += SIZE16;
a0d0e21e 3142 sv = NEWSV(38, 0);
1e422769 3143 sv_setiv(sv, (IV)ashort);
a0d0e21e
LW		 3144 PUSHs(sv_2mortal(sv));
3145 }
3146 }
3147 break;
3148 case 'v':
3149 case 'n':
3150 case 'S':
96e4d5b1 3151 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3152 if (len > along)
3153 len = along;
3154 if (checksum) {
3155 while (len-- > 0) {
96e4d5b1 3156 COPY16(s, &aushort);
3157 s += SIZE16;
a0d0e21e
LW		 3158#ifdef HAS_NTOHS
3159 if (datumtype == 'n')
6ad3d225 3160 aushort = PerlSock_ntohs(aushort);
79072805 3161#endif
a0d0e21e
LW		 3162#ifdef HAS_VTOHS
3163 if (datumtype == 'v')
3164 aushort = vtohs(aushort);
79072805 3165#endif
a0d0e21e
LW		 3166 culong += aushort;
3167 }
3168 }
3169 else {
3170 EXTEND(SP, len);
bbce6d69 3171 EXTEND_MORTAL(len);
a0d0e21e 3172 while (len-- > 0) {
96e4d5b1 3173 COPY16(s, &aushort);
3174 s += SIZE16;
a0d0e21e
LW		 3175 sv = NEWSV(39, 0);
3176#ifdef HAS_NTOHS
3177 if (datumtype == 'n')
6ad3d225 3178 aushort = PerlSock_ntohs(aushort);
79072805 3179#endif
a0d0e21e
LW		 3180#ifdef HAS_VTOHS
3181 if (datumtype == 'v')
3182 aushort = vtohs(aushort);
79072805 3183#endif
1e422769 3184 sv_setiv(sv, (IV)aushort);
a0d0e21e
LW		 3185 PUSHs(sv_2mortal(sv));
3186 }
3187 }
3188 break;
3189 case 'i':
3190 along = (strend - s) / sizeof(int);
3191 if (len > along)
3192 len = along;
3193 if (checksum) {
3194 while (len-- > 0) {
3195 Copy(s, &aint, 1, int);
3196 s += sizeof(int);
3197 if (checksum > 32)
3198 cdouble += (double)aint;
3199 else
3200 culong += aint;
3201 }
3202 }
3203 else {
3204 EXTEND(SP, len);
bbce6d69 3205 EXTEND_MORTAL(len);
a0d0e21e
LW		 3206 while (len-- > 0) {
3207 Copy(s, &aint, 1, int);
3208 s += sizeof(int);
3209 sv = NEWSV(40, 0);
1e422769 3210 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3211 PUSHs(sv_2mortal(sv));
3212 }
3213 }
3214 break;
3215 case 'I':
3216 along = (strend - s) / sizeof(unsigned int);
3217 if (len > along)
3218 len = along;
3219 if (checksum) {
3220 while (len-- > 0) {
3221 Copy(s, &auint, 1, unsigned int);
3222 s += sizeof(unsigned int);
3223 if (checksum > 32)
3224 cdouble += (double)auint;
3225 else
3226 culong += auint;
3227 }
3228 }
3229 else {
3230 EXTEND(SP, len);
bbce6d69 3231 EXTEND_MORTAL(len);
a0d0e21e
LW		 3232 while (len-- > 0) {
3233 Copy(s, &auint, 1, unsigned int);
3234 s += sizeof(unsigned int);
3235 sv = NEWSV(41, 0);
1e422769 3236 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3237 PUSHs(sv_2mortal(sv));
3238 }
3239 }
3240 break;
3241 case 'l':
96e4d5b1 3242 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3243 if (len > along)
3244 len = along;
3245 if (checksum) {
3246 while (len-- > 0) {
96e4d5b1 3247 COPY32(s, &along);
3248 s += SIZE32;
a0d0e21e
LW		 3249 if (checksum > 32)
3250 cdouble += (double)along;
3251 else
3252 culong += along;
3253 }
3254 }
3255 else {
3256 EXTEND(SP, len);
bbce6d69 3257 EXTEND_MORTAL(len);
a0d0e21e 3258 while (len-- > 0) {
96e4d5b1 3259 COPY32(s, &along);
3260 s += SIZE32;
a0d0e21e 3261 sv = NEWSV(42, 0);
1e422769 3262 sv_setiv(sv, (IV)along);
a0d0e21e
LW		 3263 PUSHs(sv_2mortal(sv));
3264 }
79072805 3265 }
a0d0e21e
LW		 3266 break;
3267 case 'V':
3268 case 'N':
3269 case 'L':
96e4d5b1 3270 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3271 if (len > along)
3272 len = along;
3273 if (checksum) {
3274 while (len-- > 0) {
96e4d5b1 3275 COPY32(s, &aulong);
3276 s += SIZE32;
a0d0e21e
LW		 3277#ifdef HAS_NTOHL
3278 if (datumtype == 'N')
6ad3d225 3279 aulong = PerlSock_ntohl(aulong);
79072805 3280#endif
a0d0e21e
LW		 3281#ifdef HAS_VTOHL
3282 if (datumtype == 'V')
3283 aulong = vtohl(aulong);
79072805 3284#endif
a0d0e21e
LW		 3285 if (checksum > 32)
3286 cdouble += (double)aulong;
3287 else
3288 culong += aulong;
3289 }
3290 }
3291 else {
3292 EXTEND(SP, len);
bbce6d69 3293 EXTEND_MORTAL(len);
a0d0e21e 3294 while (len-- > 0) {
96e4d5b1 3295 COPY32(s, &aulong);
3296 s += SIZE32;
a0d0e21e
LW		 3297#ifdef HAS_NTOHL
3298 if (datumtype == 'N')
6ad3d225 3299 aulong = PerlSock_ntohl(aulong);
79072805 3300#endif
a0d0e21e
LW		 3301#ifdef HAS_VTOHL
3302 if (datumtype == 'V')
3303 aulong = vtohl(aulong);
79072805 3304#endif
1e422769 3305 sv = NEWSV(43, 0);
3306 sv_setuv(sv, (UV)aulong);
a0d0e21e
LW		 3307 PUSHs(sv_2mortal(sv));
3308 }
3309 }
3310 break;
3311 case 'p':
3312 along = (strend - s) / sizeof(char*);
3313 if (len > along)
3314 len = along;
3315 EXTEND(SP, len);
bbce6d69 3316 EXTEND_MORTAL(len);
a0d0e21e
LW		 3317 while (len-- > 0) {
3318 if (sizeof(char*) > strend - s)
3319 break;
3320 else {
3321 Copy(s, &aptr, 1, char*);
3322 s += sizeof(char*);
3323 }
3324 sv = NEWSV(44, 0);
3325 if (aptr)
3326 sv_setpv(sv, aptr);
3327 PUSHs(sv_2mortal(sv));
3328 }
3329 break;
def98dd4 3330 case 'w':
def98dd4 3331 EXTEND(SP, len);
bbce6d69 3332 EXTEND_MORTAL(len);
8ec5e241 3333 {
bbce6d69 3334 UV auv = 0;
3335 U32 bytes = 0;
3336
3337 while ((len > 0) && (s < strend)) {
3338 auv = (auv << 7) | (*s & 0x7f);
3339 if (!(*s++ & 0x80)) {
3340 bytes = 0;
3341 sv = NEWSV(40, 0);
3342 sv_setuv(sv, auv);
3343 PUSHs(sv_2mortal(sv));
3344 len--;
3345 auv = 0;
3346 }
3347 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 3348 char *t;
3349
fc36a67e 3350 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69 3351 while (s < strend) {
3352 sv = mul128(sv, *s & 0x7f);
3353 if (!(*s++ & 0x80)) {
3354 bytes = 0;
3355 break;
3356 }
3357 }
3358 t = SvPV(sv, na);
3359 while (*t == '0')
3360 t++;
3361 sv_chop(sv, t);
3362 PUSHs(sv_2mortal(sv));
3363 len--;
3364 auv = 0;
3365 }
3366 }
3367 if ((s >= strend) && bytes)
3368 croak("Unterminated compressed integer");
3369 }
def98dd4 3370 break;
a0d0e21e
LW		 3371 case 'P':
3372 EXTEND(SP, 1);
3373 if (sizeof(char*) > strend - s)
3374 break;
3375 else {
3376 Copy(s, &aptr, 1, char*);
3377 s += sizeof(char*);
3378 }
3379 sv = NEWSV(44, 0);
3380 if (aptr)
3381 sv_setpvn(sv, aptr, len);
3382 PUSHs(sv_2mortal(sv));
3383 break;
ecfc5424 3384#ifdef HAS_QUAD
a0d0e21e
LW		 3385 case 'q':
3386 EXTEND(SP, len);
bbce6d69 3387 EXTEND_MORTAL(len);
a0d0e21e 3388 while (len-- > 0) {
ecfc5424 3389 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 3390 aquad = 0;
3391 else {
ecfc5424
AD		 3392 Copy(s, &aquad, 1, Quad_t);
3393 s += sizeof(Quad_t);
a0d0e21e
LW		 3394 }
3395 sv = NEWSV(42, 0);
96e4d5b1 3396 if (aquad >= IV_MIN && aquad <= IV_MAX)
3397 sv_setiv(sv, (IV)aquad);
3398 else
3399 sv_setnv(sv, (double)aquad);
a0d0e21e
LW		 3400 PUSHs(sv_2mortal(sv));
3401 }
3402 break;
3403 case 'Q':
3404 EXTEND(SP, len);
bbce6d69 3405 EXTEND_MORTAL(len);
a0d0e21e 3406 while (len-- > 0) {
ecfc5424 3407 if (s + sizeof(unsigned Quad_t) > strend)
a0d0e21e
LW		 3408 auquad = 0;
3409 else {
ecfc5424
AD		 3410 Copy(s, &auquad, 1, unsigned Quad_t);
3411 s += sizeof(unsigned Quad_t);
a0d0e21e
LW		 3412 }
3413 sv = NEWSV(43, 0);
96e4d5b1 3414 if (aquad <= UV_MAX)
3415 sv_setuv(sv, (UV)auquad);
3416 else
3417 sv_setnv(sv, (double)auquad);
a0d0e21e
LW		 3418 PUSHs(sv_2mortal(sv));
3419 }
3420 break;
79072805 3421#endif
a0d0e21e
LW		 3422 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3423 case 'f':
3424 case 'F':
3425 along = (strend - s) / sizeof(float);
3426 if (len > along)
3427 len = along;
3428 if (checksum) {
3429 while (len-- > 0) {
3430 Copy(s, &afloat, 1, float);
3431 s += sizeof(float);
3432 cdouble += afloat;
3433 }
3434 }
3435 else {
3436 EXTEND(SP, len);
bbce6d69 3437 EXTEND_MORTAL(len);
a0d0e21e
LW		 3438 while (len-- > 0) {
3439 Copy(s, &afloat, 1, float);
3440 s += sizeof(float);
3441 sv = NEWSV(47, 0);
3442 sv_setnv(sv, (double)afloat);
3443 PUSHs(sv_2mortal(sv));
3444 }
3445 }
3446 break;
3447 case 'd':
3448 case 'D':
3449 along = (strend - s) / sizeof(double);
3450 if (len > along)
3451 len = along;
3452 if (checksum) {
3453 while (len-- > 0) {
3454 Copy(s, &adouble, 1, double);
3455 s += sizeof(double);
3456 cdouble += adouble;
3457 }
3458 }
3459 else {
3460 EXTEND(SP, len);
bbce6d69 3461 EXTEND_MORTAL(len);
a0d0e21e
LW		 3462 while (len-- > 0) {
3463 Copy(s, &adouble, 1, double);
3464 s += sizeof(double);
3465 sv = NEWSV(48, 0);
3466 sv_setnv(sv, (double)adouble);
3467 PUSHs(sv_2mortal(sv));
3468 }
3469 }
3470 break;
3471 case 'u':
3472 along = (strend - s) * 3 / 4;
3473 sv = NEWSV(42, along);
f12c7020 3474 if (along)
3475 SvPOK_on(sv);
a0d0e21e
LW		 3476 while (s < strend && *s > ' ' && *s < 'a') {
3477 I32 a, b, c, d;
3478 char hunk[4];
79072805 3479
a0d0e21e
LW		 3480 hunk[3] = '\0';
3481 len = (*s++ - ' ') & 077;
3482 while (len > 0) {
3483 if (s < strend && *s >= ' ')
3484 a = (*s++ - ' ') & 077;
3485 else
3486 a = 0;
3487 if (s < strend && *s >= ' ')
3488 b = (*s++ - ' ') & 077;
3489 else
3490 b = 0;
3491 if (s < strend && *s >= ' ')
3492 c = (*s++ - ' ') & 077;
3493 else
3494 c = 0;
3495 if (s < strend && *s >= ' ')
3496 d = (*s++ - ' ') & 077;
3497 else
3498 d = 0;
4e35701f
NIS		 3499 hunk[0] = (a << 2) | (b >> 4);
3500 hunk[1] = (b << 4) | (c >> 2);
3501 hunk[2] = (c << 6) | d;
3502 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW		 3503 len -= 3;
3504 }
3505 if (*s == '\n')
3506 s++;
3507 else if (s[1] == '\n') /* possible checksum byte */
3508 s += 2;
79072805 3509 }
a0d0e21e
LW		 3510 XPUSHs(sv_2mortal(sv));
3511 break;
79072805 3512 }
a0d0e21e
LW		 3513 if (checksum) {
3514 sv = NEWSV(42, 0);
3515 if (strchr("fFdD", datumtype) ||
3516 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3517 double trouble;
79072805 3518
a0d0e21e
LW		 3519 adouble = 1.0;
3520 while (checksum >= 16) {
3521 checksum -= 16;
3522 adouble *= 65536.0;
3523 }
3524 while (checksum >= 4) {
3525 checksum -= 4;
3526 adouble *= 16.0;
3527 }
3528 while (checksum--)
3529 adouble *= 2.0;
3530 along = (1 << checksum) - 1;
3531 while (cdouble < 0.0)
3532 cdouble += adouble;
3533 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3534 sv_setnv(sv, cdouble);
3535 }
3536 else {
3537 if (checksum < 32) {
96e4d5b1 3538 aulong = (1 << checksum) - 1;
3539 culong &= aulong;
a0d0e21e 3540 }
96e4d5b1 3541 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 3542 }
3543 XPUSHs(sv_2mortal(sv));
3544 checksum = 0;
79072805 3545 }
79072805 3546 }
924508f0 3547 if (SP == oldsp && gimme == G_SCALAR)
36477c24 3548 PUSHs(&sv_undef);
79072805 3549 RETURN;
79072805
LW		 3550}
3551
76e3520e 3552STATIC void
8ac85365 3553doencodes(register SV *sv, register char *s, register I32 len)
79072805 3554{
a0d0e21e 3555 char hunk[5];
79072805 3556
a0d0e21e
LW		 3557 *hunk = len + ' ';
3558 sv_catpvn(sv, hunk, 1);
3559 hunk[4] = '\0';
3560 while (len > 0) {
3561 hunk[0] = ' ' + (077 & (*s >> 2));
4e35701f
NIS		 3562 hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3563 hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
a0d0e21e
LW		 3564 hunk[3] = ' ' + (077 & (s[2] & 077));
3565 sv_catpvn(sv, hunk, 4);
3566 s += 3;
3567 len -= 3;
3568 }
3569 for (s = SvPVX(sv); *s; s++) {
3570 if (*s == ' ')
3571 *s = '`';
3572 }
3573 sv_catpvn(sv, "\n", 1);
79072805
LW		 3574}
3575
76e3520e 3576STATIC SV *
8ac85365 3577is_an_int(char *s, STRLEN l)
55497cff 3578{
3579 SV *result = newSVpv("", l);
3580 char *result_c = SvPV(result, na); /* convenience */
3581 char *out = result_c;
3582 bool skip = 1;
3583 bool ignore = 0;
3584
3585 while (*s) {
3586 switch (*s) {
3587 case ' ':
3588 break;
3589 case '+':
3590 if (!skip) {
3591 SvREFCNT_dec(result);
3592 return (NULL);
3593 }
3594 break;
3595 case '0':
3596 case '1':
3597 case '2':
3598 case '3':
3599 case '4':
3600 case '5':
3601 case '6':
3602 case '7':
3603 case '8':
3604 case '9':
3605 skip = 0;
3606 if (!ignore) {
3607 *(out++) = *s;
3608 }
3609 break;
3610 case '.':
3611 ignore = 1;
3612 break;
3613 default:
3614 SvREFCNT_dec(result);
3615 return (NULL);
3616 }
3617 s++;
3618 }
3619 *(out++) = '\0';
3620 SvCUR_set(result, out - result_c);
3621 return (result);
3622}
3623
76e3520e 3624STATIC int
61bb5906 3625div128(SV *pnum, bool *done)
8ac85365 3626 /* must be '\0' terminated */
8ec5e241 3627
55497cff 3628{
3629 STRLEN len;
3630 char *s = SvPV(pnum, len);
3631 int m = 0;
3632 int r = 0;
3633 char *t = s;
3634
3635 *done = 1;
3636 while (*t) {
3637 int i;
3638
3639 i = m * 10 + (*t - '0');
3640 m = i & 0x7F;
3641 r = (i >> 7); /* r < 10 */
3642 if (r) {
3643 *done = 0;
3644 }
3645 *(t++) = '0' + r;
3646 }
3647 *(t++) = '\0';
3648 SvCUR_set(pnum, (STRLEN) (t - s));
3649 return (m);
3650}
3651
3652
a0d0e21e 3653PP(pp_pack)
79072805 3654{
4e35701f 3655 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3656 register SV *cat = TARG;
3657 register I32 items;
3658 STRLEN fromlen;
3659 register char *pat = SvPVx(*++MARK, fromlen);
3660 register char *patend = pat + fromlen;
3661 register I32 len;
3662 I32 datumtype;
3663 SV *fromstr;
3664 /*SUPPRESS 442*/
3665 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3666 static char *space10 = " ";
79072805 3667
a0d0e21e
LW		 3668 /* These must not be in registers: */
3669 char achar;
3670 I16 ashort;
3671 int aint;
3672 unsigned int auint;
3673 I32 along;
3674 U32 aulong;
ecfc5424
AD		 3675#ifdef HAS_QUAD
3676 Quad_t aquad;
3677 unsigned Quad_t auquad;
79072805 3678#endif
a0d0e21e
LW		 3679 char *aptr;
3680 float afloat;
3681 double adouble;
fb73857a 3682 int commas = 0;
79072805 3683
a0d0e21e
LW		 3684 items = SP - MARK;
3685 MARK++;
3686 sv_setpvn(cat, "", 0);
3687 while (pat < patend) {
3688#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
bbdab043
CS		 3689 datumtype = *pat++ & 0xFF;
3690 if (isSPACE(datumtype))
3691 continue;
a0d0e21e
LW		 3692 if (*pat == '*') {
3693 len = strchr("@Xxu", datumtype) ? 0 : items;
3694 pat++;
3695 }
3696 else if (isDIGIT(*pat)) {
3697 len = *pat++ - '0';
3698 while (isDIGIT(*pat))
3699 len = (len * 10) + (*pat++ - '0');
3700 }
3701 else
3702 len = 1;
3703 switch(datumtype) {
3704 default:
bbdab043 3705 croak("Invalid type in pack: '%c'", (int)datumtype);
fb73857a 3706 case ',': /* grandfather in commas but with a warning */
3707 if (commas++ == 0 && dowarn)
3708 warn("Invalid type in pack: '%c'", (int)datumtype);
3709 break;
a0d0e21e
LW		 3710 case '%':
3711 DIE("%% may only be used in unpack");
3712 case '@':
3713 len -= SvCUR(cat);
3714 if (len > 0)
3715 goto grow;
3716 len = -len;
3717 if (len > 0)
3718 goto shrink;
3719 break;
3720 case 'X':
3721 shrink:
3722 if (SvCUR(cat) < len)
3723 DIE("X outside of string");
3724 SvCUR(cat) -= len;
3725 *SvEND(cat) = '\0';
3726 break;
3727 case 'x':
3728 grow:
3729 while (len >= 10) {
3730 sv_catpvn(cat, null10, 10);
3731 len -= 10;
3732 }
3733 sv_catpvn(cat, null10, len);
3734 break;
3735 case 'A':
3736 case 'a':
3737 fromstr = NEXTFROM;
3738 aptr = SvPV(fromstr, fromlen);
3739 if (pat[-1] == '*')
3740 len = fromlen;
3741 if (fromlen > len)
3742 sv_catpvn(cat, aptr, len);
3743 else {
3744 sv_catpvn(cat, aptr, fromlen);
3745 len -= fromlen;
3746 if (datumtype == 'A') {
3747 while (len >= 10) {
3748 sv_catpvn(cat, space10, 10);
3749 len -= 10;
3750 }
3751 sv_catpvn(cat, space10, len);
3752 }
3753 else {
3754 while (len >= 10) {
3755 sv_catpvn(cat, null10, 10);
3756 len -= 10;
3757 }
3758 sv_catpvn(cat, null10, len);
3759 }
3760 }
3761 break;
3762 case 'B':
3763 case 'b':
3764 {
3765 char *savepat = pat;
3766 I32 saveitems;
79072805 3767
a0d0e21e
LW		 3768 fromstr = NEXTFROM;
3769 saveitems = items;
3770 aptr = SvPV(fromstr, fromlen);
3771 if (pat[-1] == '*')
3772 len = fromlen;
3773 pat = aptr;
3774 aint = SvCUR(cat);
3775 SvCUR(cat) += (len+7)/8;
3776 SvGROW(cat, SvCUR(cat) + 1);
3777 aptr = SvPVX(cat) + aint;
3778 if (len > fromlen)
3779 len = fromlen;
3780 aint = len;
3781 items = 0;
3782 if (datumtype == 'B') {
3783 for (len = 0; len++ < aint;) {
3784 items |= *pat++ & 1;
3785 if (len & 7)
3786 items <<= 1;
3787 else {
3788 *aptr++ = items & 0xff;
3789 items = 0;
3790 }
3791 }
3792 }
3793 else {
3794 for (len = 0; len++ < aint;) {
3795 if (*pat++ & 1)
3796 items |= 128;
3797 if (len & 7)
3798 items >>= 1;
3799 else {
3800 *aptr++ = items & 0xff;
3801 items = 0;
3802 }
3803 }
3804 }
3805 if (aint & 7) {
3806 if (datumtype == 'B')
3807 items <<= 7 - (aint & 7);
3808 else
3809 items >>= 7 - (aint & 7);
3810 *aptr++ = items & 0xff;
3811 }
3812 pat = SvPVX(cat) + SvCUR(cat);
3813 while (aptr <= pat)
3814 *aptr++ = '\0';
79072805 3815
a0d0e21e
LW		 3816 pat = savepat;
3817 items = saveitems;
3818 }
3819 break;
3820 case 'H':
3821 case 'h':
3822 {
3823 char *savepat = pat;
3824 I32 saveitems;
79072805 3825
a0d0e21e
LW		 3826 fromstr = NEXTFROM;
3827 saveitems = items;
3828 aptr = SvPV(fromstr, fromlen);
3829 if (pat[-1] == '*')
3830 len = fromlen;
3831 pat = aptr;
3832 aint = SvCUR(cat);
3833 SvCUR(cat) += (len+1)/2;
3834 SvGROW(cat, SvCUR(cat) + 1);
3835 aptr = SvPVX(cat) + aint;
3836 if (len > fromlen)
3837 len = fromlen;
3838 aint = len;
3839 items = 0;
3840 if (datumtype == 'H') {
3841 for (len = 0; len++ < aint;) {
3842 if (isALPHA(*pat))
3843 items |= ((*pat++ & 15) + 9) & 15;
3844 else
3845 items |= *pat++ & 15;
3846 if (len & 1)
3847 items <<= 4;
3848 else {
3849 *aptr++ = items & 0xff;
3850 items = 0;
3851 }
3852 }
3853 }
3854 else {
3855 for (len = 0; len++ < aint;) {
3856 if (isALPHA(*pat))
3857 items |= (((*pat++ & 15) + 9) & 15) << 4;
3858 else
3859 items |= (*pat++ & 15) << 4;
3860 if (len & 1)
3861 items >>= 4;
3862 else {
3863 *aptr++ = items & 0xff;
3864 items = 0;
3865 }
3866 }
3867 }
3868 if (aint & 1)
3869 *aptr++ = items & 0xff;
3870 pat = SvPVX(cat) + SvCUR(cat);
3871 while (aptr <= pat)
3872 *aptr++ = '\0';
79072805 3873
a0d0e21e
LW		 3874 pat = savepat;
3875 items = saveitems;
3876 }
3877 break;
3878 case 'C':
3879 case 'c':
3880 while (len-- > 0) {
3881 fromstr = NEXTFROM;
3882 aint = SvIV(fromstr);
3883 achar = aint;
3884 sv_catpvn(cat, &achar, sizeof(char));
3885 }
3886 break;
3887 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3888 case 'f':
3889 case 'F':
3890 while (len-- > 0) {
3891 fromstr = NEXTFROM;
3892 afloat = (float)SvNV(fromstr);
3893 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3894 }
3895 break;
3896 case 'd':
3897 case 'D':
3898 while (len-- > 0) {
3899 fromstr = NEXTFROM;
3900 adouble = (double)SvNV(fromstr);
3901 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3902 }
3903 break;
3904 case 'n':
3905 while (len-- > 0) {
3906 fromstr = NEXTFROM;
3907 ashort = (I16)SvIV(fromstr);
3908#ifdef HAS_HTONS
6ad3d225 3909 ashort = PerlSock_htons(ashort);
79072805 3910#endif
96e4d5b1 3911 CAT16(cat, &ashort);
a0d0e21e
LW		 3912 }
3913 break;
3914 case 'v':
3915 while (len-- > 0) {
3916 fromstr = NEXTFROM;
3917 ashort = (I16)SvIV(fromstr);
3918#ifdef HAS_HTOVS
3919 ashort = htovs(ashort);
79072805 3920#endif
96e4d5b1 3921 CAT16(cat, &ashort);
a0d0e21e
LW		 3922 }
3923 break;
3924 case 'S':
3925 case 's':
3926 while (len-- > 0) {
3927 fromstr = NEXTFROM;
3928 ashort = (I16)SvIV(fromstr);
96e4d5b1 3929 CAT16(cat, &ashort);
a0d0e21e
LW		 3930 }
3931 break;
3932 case 'I':
3933 while (len-- > 0) {
3934 fromstr = NEXTFROM;
96e4d5b1 3935 auint = SvUV(fromstr);
a0d0e21e
LW		 3936 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3937 }
3938 break;
def98dd4
UP		 3939 case 'w':
3940 while (len-- > 0) {
bbce6d69 3941 fromstr = NEXTFROM;
3942 adouble = floor(SvNV(fromstr));
3943
3944 if (adouble < 0)
3945 croak("Cannot compress negative numbers");
3946
46fc3d4c 3947 if (
3948#ifdef BW_BITS
3949 adouble <= BW_MASK
3950#else
ef2d312d
TH		 3951#ifdef CXUX_BROKEN_CONSTANT_CONVERT
3952 adouble <= UV_MAX_cxux
3953#else
46fc3d4c 3954 adouble <= UV_MAX
3955#endif
ef2d312d 3956#endif
46fc3d4c 3957 )
3958 {
bbce6d69 3959 char buf[1 + sizeof(UV)];
3960 char *in = buf + sizeof(buf);
3961 UV auv = U_V(adouble);;
3962
3963 do {
3964 *--in = (auv & 0x7f) | 0x80;
3965 auv >>= 7;
3966 } while (auv);
3967 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3968 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3969 }
3970 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
3971 char *from, *result, *in;
3972 SV *norm;
3973 STRLEN len;
3974 bool done;
8ec5e241 3975
bbce6d69 3976 /* Copy string and check for compliance */
3977 from = SvPV(fromstr, len);
3978 if ((norm = is_an_int(from, len)) == NULL)
3979 croak("can compress only unsigned integer");
3980
3981 New('w', result, len, char);
3982 in = result + len;
3983 done = FALSE;
3984 while (!done)
3985 *--in = div128(norm, &done) | 0x80;
3986 result[len - 1] &= 0x7F; /* clear continue bit */
3987 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 3988 Safefree(result);
bbce6d69 3989 SvREFCNT_dec(norm); /* free norm */
def98dd4 3990 }
bbce6d69 3991 else if (SvNOKp(fromstr)) {
3992 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
3993 char *in = buf + sizeof(buf);
3994
3995 do {
3996 double next = floor(adouble / 128);
3997 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
3998 if (--in < buf) /* this cannot happen ;-) */
3999 croak ("Cannot compress integer");
4000 adouble = next;
4001 } while (adouble > 0);
4002 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4003 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4004 }
4005 else
4006 croak("Cannot compress non integer");
4007 }
def98dd4 4008 break;
a0d0e21e
LW		 4009 case 'i':
4010 while (len-- > 0) {
4011 fromstr = NEXTFROM;
4012 aint = SvIV(fromstr);
4013 sv_catpvn(cat, (char*)&aint, sizeof(int));
4014 }
4015 break;
4016 case 'N':
4017 while (len-- > 0) {
4018 fromstr = NEXTFROM;
96e4d5b1 4019 aulong = SvUV(fromstr);
a0d0e21e 4020#ifdef HAS_HTONL
6ad3d225 4021 aulong = PerlSock_htonl(aulong);
79072805 4022#endif
96e4d5b1 4023 CAT32(cat, &aulong);
a0d0e21e
LW		 4024 }
4025 break;
4026 case 'V':
4027 while (len-- > 0) {
4028 fromstr = NEXTFROM;
96e4d5b1 4029 aulong = SvUV(fromstr);
a0d0e21e
LW		 4030#ifdef HAS_HTOVL
4031 aulong = htovl(aulong);
79072805 4032#endif
96e4d5b1 4033 CAT32(cat, &aulong);
a0d0e21e
LW		 4034 }
4035 break;
4036 case 'L':
4037 while (len-- > 0) {
4038 fromstr = NEXTFROM;
96e4d5b1 4039 aulong = SvUV(fromstr);
4040 CAT32(cat, &aulong);
a0d0e21e
LW		 4041 }
4042 break;
4043 case 'l':
4044 while (len-- > 0) {
4045 fromstr = NEXTFROM;
4046 along = SvIV(fromstr);
96e4d5b1 4047 CAT32(cat, &along);
a0d0e21e
LW		 4048 }
4049 break;
ecfc5424 4050#ifdef HAS_QUAD
a0d0e21e
LW		 4051 case 'Q':
4052 while (len-- > 0) {
4053 fromstr = NEXTFROM;
ecfc5424
AD		 4054 auquad = (unsigned Quad_t)SvIV(fromstr);
4055 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
a0d0e21e
LW		 4056 }
4057 break;
4058 case 'q':
4059 while (len-- > 0) {
4060 fromstr = NEXTFROM;
ecfc5424
AD		 4061 aquad = (Quad_t)SvIV(fromstr);
4062 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 4063 }
4064 break;
ecfc5424 4065#endif /* HAS_QUAD */
a0d0e21e
LW		 4066 case 'P':
4067 len = 1; /* assume SV is correct length */
4068 /* FALL THROUGH */
4069 case 'p':
4070 while (len-- > 0) {
4071 fromstr = NEXTFROM;
72dbcb4b 4072 if (fromstr == &sv_undef)
84902520 4073 aptr = NULL;
72dbcb4b 4074 else {
84902520
TB		 4075 /* XXX better yet, could spirit away the string to
4076 * a safe spot and hang on to it until the result
4077 * of pack() (and all copies of the result) are
4078 * gone.
4079 */
4080 if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4081 warn("Attempt to pack pointer to temporary value");
4082 if (SvPOK(fromstr) || SvNIOK(fromstr))
4083 aptr = SvPV(fromstr,na);
4084 else
4085 aptr = SvPV_force(fromstr,na);
72dbcb4b 4086 }
a0d0e21e
LW		 4087 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4088 }
4089 break;
4090 case 'u':
4091 fromstr = NEXTFROM;
4092 aptr = SvPV(fromstr, fromlen);
4093 SvGROW(cat, fromlen * 4 / 3);
4094 if (len <= 1)
4095 len = 45;
4096 else
4097 len = len / 3 * 3;
4098 while (fromlen > 0) {
4099 I32 todo;
79072805 4100
a0d0e21e
LW		 4101 if (fromlen > len)
4102 todo = len;
4103 else
4104 todo = fromlen;
4105 doencodes(cat, aptr, todo);
4106 fromlen -= todo;
4107 aptr += todo;
4108 }
4109 break;
4110 }
4111 }
4112 SvSETMAGIC(cat);
4113 SP = ORIGMARK;
4114 PUSHs(cat);
4115 RETURN;
79072805 4116}
a0d0e21e 4117#undef NEXTFROM
79072805 4118
8ec5e241 4119
a0d0e21e 4120PP(pp_split)
79072805 4121{
4e35701f 4122 djSP; dTARG;
a0d0e21e
LW		 4123 AV *ary;
4124 register I32 limit = POPi; /* note, negative is forever */
4125 SV *sv = POPs;
4126 STRLEN len;
4127 register char *s = SvPV(sv, len);
4128 char *strend = s + len;
44a8e56a 4129 register PMOP *pm;
ac4c12e7 4130 register REGEXP *prx;
a0d0e21e
LW		 4131 register SV *dstr;
4132 register char *m;
4133 I32 iters = 0;
4134 I32 maxiters = (strend - s) + 10;
4135 I32 i;
4136 char *orig;
4137 I32 origlimit = limit;
4138 I32 realarray = 0;
4139 I32 base;
f12c7020 4140 AV *oldstack = curstack;
54310121 4141 I32 gimme = GIMME_V;
c07a80fd 4142 I32 oldsave = savestack_ix;
8ec5e241
NIS		 4143 I32 make_mortal = 1;
4144 MAGIC *mg = (MAGIC *) NULL;
79072805 4145
44a8e56a 4146#ifdef DEBUGGING
4147 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4148#else
4149 pm = (PMOP*)POPs;
4150#endif
a0d0e21e
LW		 4151 if (!pm || !s)
4152 DIE("panic: do_split");
ac4c12e7 4153 prx = pm->op_pmregexp;
bbce6d69 4154
4155 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4156 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4157
a0d0e21e
LW		 4158 if (pm->op_pmreplroot)
4159 ary = GvAVn((GV*)pm->op_pmreplroot);
4160 else if (gimme != G_ARRAY)
6d4ff0d2
MB		 4161#ifdef USE_THREADS
4162 ary = (AV*)curpad[0];
4163#else
a0d0e21e 4164 ary = GvAVn(defgv);
6d4ff0d2 4165#endif /* USE_THREADS */
79072805 4166 else
a0d0e21e
LW		 4167 ary = Nullav;
4168 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4169 realarray = 1;
8ec5e241 4170 PUTBACK;
a0d0e21e
LW		 4171 av_extend(ary,0);
4172 av_clear(ary);
8ec5e241
NIS		 4173 SPAGAIN;
4174 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4175 PUSHMARK(SP);
4176 XPUSHs(mg->mg_obj);
4177 }
4178 else {
1c0b011c
NIS		 4179 if (!AvREAL(ary)) {
4180 AvREAL_on(ary);
4181 for (i = AvFILLp(ary); i >= 0; i--)
4182 AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
4183 }
4184 /* temporarily switch stacks */
4185 SWITCHSTACK(curstack, ary);
8ec5e241 4186 make_mortal = 0;
1c0b011c 4187 }
79072805 4188 }
a0d0e21e
LW		 4189 base = SP - stack_base;
4190 orig = s;
4191 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4192 if (pm->op_pmflags & PMf_LOCALE) {
4193 while (isSPACE_LC(*s))
4194 s++;
4195 }
4196 else {
4197 while (isSPACE(*s))
4198 s++;
4199 }
a0d0e21e 4200 }
c07a80fd 4201 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4202 SAVEINT(multiline);
4203 multiline = pm->op_pmflags & PMf_MULTILINE;
4204 }
4205
a0d0e21e
LW		 4206 if (!limit)
4207 limit = maxiters + 2;
4208 if (pm->op_pmflags & PMf_WHITE) {
4209 while (--limit) {
bbce6d69 4210 m = s;
4211 while (m < strend &&
4212 !((pm->op_pmflags & PMf_LOCALE)
4213 ? isSPACE_LC(*m) : isSPACE(*m)))
4214 ++m;
a0d0e21e
LW		 4215 if (m >= strend)
4216 break;
bbce6d69 4217
a0d0e21e
LW		 4218 dstr = NEWSV(30, m-s);
4219 sv_setpvn(dstr, s, m-s);
8ec5e241 4220 if (make_mortal)
a0d0e21e
LW		 4221 sv_2mortal(dstr);
4222 XPUSHs(dstr);
bbce6d69 4223
4224 s = m + 1;
4225 while (s < strend &&
4226 ((pm->op_pmflags & PMf_LOCALE)
4227 ? isSPACE_LC(*s) : isSPACE(*s)))
4228 ++s;
79072805
LW		 4229 }
4230 }
ac4c12e7 4231 else if (strEQ("^", prx->precomp)) {
a0d0e21e
LW		 4232 while (--limit) {
4233 /*SUPPRESS 530*/
4234 for (m = s; m < strend && *m != '\n'; m++) ;
4235 m++;
4236 if (m >= strend)
4237 break;
4238 dstr = NEWSV(30, m-s);
4239 sv_setpvn(dstr, s, m-s);
8ec5e241 4240 if (make_mortal)
a0d0e21e
LW		 4241 sv_2mortal(dstr);
4242 XPUSHs(dstr);
4243 s = m;
4244 }
4245 }
ac4c12e7
GS		 4246 else if (prx->check_substr && !prx->nparens
4247 && (prx->reganch & ROPT_CHECK_ALL)
4248 && !(prx->reganch & ROPT_ANCH)) {
4249 i = SvCUR(prx->check_substr);
4250 if (i == 1 && !SvTAIL(prx->check_substr)) {
4251 i = *SvPVX(prx->check_substr);
a0d0e21e 4252 while (--limit) {
bbce6d69 4253 /*SUPPRESS 530*/
4254 for (m = s; m < strend && *m != i; m++) ;
a0d0e21e
LW		 4255 if (m >= strend)
4256 break;
4257 dstr = NEWSV(30, m-s);
4258 sv_setpvn(dstr, s, m-s);
8ec5e241 4259 if (make_mortal)
a0d0e21e
LW		 4260 sv_2mortal(dstr);
4261 XPUSHs(dstr);
4262 s = m + 1;
4263 }
4264 }
4265 else {
4266#ifndef lint
4267 while (s < strend && --limit &&
4268 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
ac4c12e7 4269 prx->check_substr)) )
79072805 4270#endif
a0d0e21e
LW		 4271 {
4272 dstr = NEWSV(31, m-s);
4273 sv_setpvn(dstr, s, m-s);
8ec5e241 4274 if (make_mortal)
a0d0e21e
LW		 4275 sv_2mortal(dstr);
4276 XPUSHs(dstr);
4277 s = m + i;
4278 }
463ee0b2 4279 }
463ee0b2 4280 }
a0d0e21e 4281 else {
ac4c12e7 4282 maxiters += (strend - s) * prx->nparens;
a0d0e21e 4283 while (s < strend && --limit &&
ac4c12e7 4284 regexec_flags(prx, s, strend, orig, 1, Nullsv, NULL, 0))
bbce6d69 4285 {
ac4c12e7
GS		 4286 TAINT_IF(RX_MATCH_TAINTED(prx));
4287 if (prx->subbase
4288 && prx->subbase != orig) {
a0d0e21e
LW		 4289 m = s;
4290 s = orig;
ac4c12e7 4291 orig = prx->subbase;
a0d0e21e
LW		 4292 s = orig + (m - s);
4293 strend = s + (strend - m);
4294 }
ac4c12e7 4295 m = prx->startp[0];
a0d0e21e
LW		 4296 dstr = NEWSV(32, m-s);
4297 sv_setpvn(dstr, s, m-s);
8ec5e241 4298 if (make_mortal)
a0d0e21e
LW		 4299 sv_2mortal(dstr);
4300 XPUSHs(dstr);
ac4c12e7
GS		 4301 if (prx->nparens) {
4302 for (i = 1; i <= prx->nparens; i++) {
4303 s = prx->startp[i];
4304 m = prx->endp[i];
748a9306
LW		 4305 if (m && s) {
4306 dstr = NEWSV(33, m-s);
4307 sv_setpvn(dstr, s, m-s);
4308 }
4309 else
4310 dstr = NEWSV(33, 0);
8ec5e241 4311 if (make_mortal)
a0d0e21e
LW		 4312 sv_2mortal(dstr);
4313 XPUSHs(dstr);
4314 }
4315 }
ac4c12e7 4316 s = prx->endp[0];
a0d0e21e 4317 }
79072805 4318 }
8ec5e241 4319
c07a80fd 4320 LEAVE_SCOPE(oldsave);
a0d0e21e
LW		 4321 iters = (SP - stack_base) - base;
4322 if (iters > maxiters)
4323 DIE("Split loop");
8ec5e241 4324
a0d0e21e
LW		 4325 /* keep field after final delim? */
4326 if (s < strend || (iters && origlimit)) {
4327 dstr = NEWSV(34, strend-s);
4328 sv_setpvn(dstr, s, strend-s);
8ec5e241 4329 if (make_mortal)
a0d0e21e
LW		 4330 sv_2mortal(dstr);
4331 XPUSHs(dstr);
4332 iters++;
79072805 4333 }
a0d0e21e 4334 else if (!origlimit) {
b1dadf13 4335 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 4336 iters--, SP--;
4337 }
8ec5e241 4338
a0d0e21e 4339 if (realarray) {
8ec5e241 4340 if (!mg) {
1c0b011c
NIS		 4341 SWITCHSTACK(ary, oldstack);
4342 if (SvSMAGICAL(ary)) {
4343 PUTBACK;
4344 mg_set((SV*)ary);
4345 SPAGAIN;
4346 }
4347 if (gimme == G_ARRAY) {
4348 EXTEND(SP, iters);
4349 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4350 SP += iters;
4351 RETURN;
4352 }
8ec5e241 4353 }
1c0b011c 4354 else {
fb73857a 4355 PUTBACK;
8ec5e241
NIS		 4356 ENTER;
4357 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4358 LEAVE;
fb73857a 4359 SPAGAIN;
8ec5e241
NIS		 4360 if (gimme == G_ARRAY) {
4361 /* EXTEND should not be needed - we just popped them */
4362 EXTEND(SP, iters);
4363 for (i=0; i < iters; i++) {
4364 SV **svp = av_fetch(ary, i, FALSE);
4365 PUSHs((svp) ? *svp : &sv_undef);
4366 }
1c0b011c
NIS		 4367 RETURN;
4368 }
a0d0e21e
LW		 4369 }
4370 }
4371 else {
4372 if (gimme == G_ARRAY)
4373 RETURN;
4374 }
4375 if (iters || !pm->op_pmreplroot) {
4376 GETTARGET;
4377 PUSHi(iters);
4378 RETURN;
4379 }
4380 RETPUSHUNDEF;
79072805 4381}
85e6fe83 4382
c0329465 4383#ifdef USE_THREADS
77a005ab 4384void
8ac85365 4385unlock_condpair(void *svv)
c0329465
MB		 4386{
4387 dTHR;
4388 MAGIC *mg = mg_find((SV*)svv, 'm');
8ec5e241 4389
c0329465
MB		 4390 if (!mg)
4391 croak("panic: unlock_condpair unlocking non-mutex");
4392 MUTEX_LOCK(MgMUTEXP(mg));
4393 if (MgOWNER(mg) != thr)
4394 croak("panic: unlock_condpair unlocking mutex that we don't own");
4395 MgOWNER(mg) = 0;
4396 COND_SIGNAL(MgOWNERCONDP(mg));
bc1f4c86
MB		 4397 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4398 (unsigned long)thr, (unsigned long)svv);)
c0329465
MB		 4399 MUTEX_UNLOCK(MgMUTEXP(mg));
4400}
4401#endif /* USE_THREADS */
4402
4403PP(pp_lock)
4404{
4e35701f 4405 djSP;
c0329465 4406 dTOPss;
e55aaa0e
MB		 4407 SV *retsv = sv;
4408#ifdef USE_THREADS
c0329465 4409 MAGIC *mg;
8ec5e241 4410
c0329465
MB		 4411 if (SvROK(sv))
4412 sv = SvRV(sv);
4413
4414 mg = condpair_magic(sv);
4415 MUTEX_LOCK(MgMUTEXP(mg));
4416 if (MgOWNER(mg) == thr)
4417 MUTEX_UNLOCK(MgMUTEXP(mg));
4418 else {
4419 while (MgOWNER(mg))
4420 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4421 MgOWNER(mg) = thr;
bc1f4c86
MB		 4422 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4423 (unsigned long)thr, (unsigned long)sv);)
c0329465 4424 MUTEX_UNLOCK(MgMUTEXP(mg));
e55aaa0e 4425 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
c0329465
MB		 4426 save_destructor(unlock_condpair, sv);
4427 }
4428#endif /* USE_THREADS */
e55aaa0e
MB		 4429 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4430 || SvTYPE(retsv) == SVt_PVCV) {
4431 retsv = refto(retsv);
4432 }
4433 SETs(retsv);
c0329465
MB		 4434 RETURN;
4435}
a863c7d1 4436
2faa37cc 4437PP(pp_threadsv)
a863c7d1 4438{
12f917ad 4439 djSP;
57d3b86d 4440#ifdef USE_THREADS
924508f0 4441 EXTEND(SP, 1);
554b3eca 4442 if (op->op_private & OPpLVAL_INTRO)
54b9620d 4443 PUSHs(*save_threadsv(op->op_targ));
554b3eca 4444 else
940cb80d 4445 PUSHs(THREADSV(op->op_targ));
fdb47d66 4446 RETURN;
a863c7d1 4447#else
2faa37cc 4448 DIE("tried to access per-thread data in non-threaded perl");
a863c7d1 4449#endif /* USE_THREADS */
a863c7d1 4450}
Unnamed repository; edit this file 'description' to name the repository.