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