This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix for unpack('u') failures on OS/390
[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
9d116dd7
JH
2911static const char uuemap[] =
2912 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
2913static char uudmap[256]; /* Initialised on first use */
2914#if 'I' == 73 && 'J' == 74
2915/* On an ASCII/ISO kind of system */
ba1ac976 2916#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH
2917#else
2918/*
2919 Some other sort of character set - use memchr() so we don't match
2920 the null byte.
2921 */
ba1ac976 2922#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
9d116dd7
JH
2923#endif
2924
a0d0e21e 2925PP(pp_unpack)
79072805 2926{
4e35701f 2927 djSP;
a0d0e21e 2928 dPOPPOPssrl;
924508f0 2929 SV **oldsp = SP;
54310121 2930 I32 gimme = GIMME_V;
ed6116ce 2931 SV *sv;
a0d0e21e
LW
2932 STRLEN llen;
2933 STRLEN rlen;
2934 register char *pat = SvPV(left, llen);
2935 register char *s = SvPV(right, rlen);
2936 char *strend = s + rlen;
2937 char *strbeg = s;
2938 register char *patend = pat + llen;
2939 I32 datumtype;
2940 register I32 len;
2941 register I32 bits;
79072805 2942
a0d0e21e
LW
2943 /* These must not be in registers: */
2944 I16 ashort;
2945 int aint;
2946 I32 along;
ecfc5424
AD
2947#ifdef HAS_QUAD
2948 Quad_t aquad;
a0d0e21e
LW
2949#endif
2950 U16 aushort;
2951 unsigned int auint;
2952 U32 aulong;
ecfc5424
AD
2953#ifdef HAS_QUAD
2954 unsigned Quad_t auquad;
a0d0e21e
LW
2955#endif
2956 char *aptr;
2957 float afloat;
2958 double adouble;
2959 I32 checksum = 0;
2960 register U32 culong;
2961 double cdouble;
2962 static char* bitcount = 0;
fb73857a 2963 int commas = 0;
79072805 2964
54310121 2965 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW
2966 /*SUPPRESS 530*/
2967 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
748a9306 2968 if (strchr("aAbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW
2969 patend++;
2970 while (isDIGIT(*patend) || *patend == '*')
2971 patend++;
2972 }
2973 else
2974 patend++;
79072805 2975 }
a0d0e21e
LW
2976 while (pat < patend) {
2977 reparse:
bbdab043
CS
2978 datumtype = *pat++ & 0xFF;
2979 if (isSPACE(datumtype))
2980 continue;
a0d0e21e
LW
2981 if (pat >= patend)
2982 len = 1;
2983 else if (*pat == '*') {
2984 len = strend - strbeg; /* long enough */
2985 pat++;
2986 }
2987 else if (isDIGIT(*pat)) {
2988 len = *pat++ - '0';
2989 while (isDIGIT(*pat))
2990 len = (len * 10) + (*pat++ - '0');
2991 }
2992 else
2993 len = (datumtype != '@');
2994 switch(datumtype) {
2995 default:
bbdab043 2996 croak("Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 2997 case ',': /* grandfather in commas but with a warning */
3280af22 2998 if (commas++ == 0 && PL_dowarn)
fb73857a
PP
2999 warn("Invalid type in unpack: '%c'", (int)datumtype);
3000 break;
a0d0e21e
LW
3001 case '%':
3002 if (len == 1 && pat[-1] != '1')
3003 len = 16;
3004 checksum = len;
3005 culong = 0;
3006 cdouble = 0;
3007 if (pat < patend)
3008 goto reparse;
3009 break;
3010 case '@':
3011 if (len > strend - strbeg)
3012 DIE("@ outside of string");
3013 s = strbeg + len;
3014 break;
3015 case 'X':
3016 if (len > s - strbeg)
3017 DIE("X outside of string");
3018 s -= len;
3019 break;
3020 case 'x':
3021 if (len > strend - s)
3022 DIE("x outside of string");
3023 s += len;
3024 break;
3025 case 'A':
3026 case 'a':
3027 if (len > strend - s)
3028 len = strend - s;
3029 if (checksum)
3030 goto uchar_checksum;
3031 sv = NEWSV(35, len);
3032 sv_setpvn(sv, s, len);
3033 s += len;
3034 if (datumtype == 'A') {
3035 aptr = s; /* borrow register */
3036 s = SvPVX(sv) + len - 1;
3037 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3038 s--;
3039 *++s = '\0';
3040 SvCUR_set(sv, s - SvPVX(sv));
3041 s = aptr; /* unborrow register */
3042 }
3043 XPUSHs(sv_2mortal(sv));
3044 break;
3045 case 'B':
3046 case 'b':
3047 if (pat[-1] == '*' || len > (strend - s) * 8)
3048 len = (strend - s) * 8;
3049 if (checksum) {
3050 if (!bitcount) {
3051 Newz(601, bitcount, 256, char);
3052 for (bits = 1; bits < 256; bits++) {
3053 if (bits & 1) bitcount[bits]++;
3054 if (bits & 2) bitcount[bits]++;
3055 if (bits & 4) bitcount[bits]++;
3056 if (bits & 8) bitcount[bits]++;
3057 if (bits & 16) bitcount[bits]++;
3058 if (bits & 32) bitcount[bits]++;
3059 if (bits & 64) bitcount[bits]++;
3060 if (bits & 128) bitcount[bits]++;
3061 }
3062 }
3063 while (len >= 8) {
3064 culong += bitcount[*(unsigned char*)s++];
3065 len -= 8;
3066 }
3067 if (len) {
3068 bits = *s;
3069 if (datumtype == 'b') {
3070 while (len-- > 0) {
3071 if (bits & 1) culong++;
3072 bits >>= 1;
3073 }
3074 }
3075 else {
3076 while (len-- > 0) {
3077 if (bits & 128) culong++;
3078 bits <<= 1;
3079 }
3080 }
3081 }
79072805
LW
3082 break;
3083 }
a0d0e21e
LW
3084 sv = NEWSV(35, len + 1);
3085 SvCUR_set(sv, len);
3086 SvPOK_on(sv);
3087 aptr = pat; /* borrow register */
3088 pat = SvPVX(sv);
3089 if (datumtype == 'b') {
3090 aint = len;
3091 for (len = 0; len < aint; len++) {
3092 if (len & 7) /*SUPPRESS 595*/
3093 bits >>= 1;
3094 else
3095 bits = *s++;
3096 *pat++ = '0' + (bits & 1);
3097 }
3098 }
3099 else {
3100 aint = len;
3101 for (len = 0; len < aint; len++) {
3102 if (len & 7)
3103 bits <<= 1;
3104 else
3105 bits = *s++;
3106 *pat++ = '0' + ((bits & 128) != 0);
3107 }
3108 }
3109 *pat = '\0';
3110 pat = aptr; /* unborrow register */
3111 XPUSHs(sv_2mortal(sv));
3112 break;
3113 case 'H':
3114 case 'h':
3115 if (pat[-1] == '*' || len > (strend - s) * 2)
3116 len = (strend - s) * 2;
3117 sv = NEWSV(35, len + 1);
3118 SvCUR_set(sv, len);
3119 SvPOK_on(sv);
3120 aptr = pat; /* borrow register */
3121 pat = SvPVX(sv);
3122 if (datumtype == 'h') {
3123 aint = len;
3124 for (len = 0; len < aint; len++) {
3125 if (len & 1)
3126 bits >>= 4;
3127 else
3128 bits = *s++;
3280af22 3129 *pat++ = PL_hexdigit[bits & 15];
a0d0e21e
LW
3130 }
3131 }
3132 else {
3133 aint = len;
3134 for (len = 0; len < aint; len++) {
3135 if (len & 1)
3136 bits <<= 4;
3137 else
3138 bits = *s++;
3280af22 3139 *pat++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW
3140 }
3141 }
3142 *pat = '\0';
3143 pat = aptr; /* unborrow register */
3144 XPUSHs(sv_2mortal(sv));
3145 break;
3146 case 'c':
3147 if (len > strend - s)
3148 len = strend - s;
3149 if (checksum) {
3150 while (len-- > 0) {
3151 aint = *s++;
3152 if (aint >= 128) /* fake up signed chars */
3153 aint -= 256;
3154 culong += aint;
3155 }
3156 }
3157 else {
3158 EXTEND(SP, len);
bbce6d69 3159 EXTEND_MORTAL(len);
a0d0e21e
LW
3160 while (len-- > 0) {
3161 aint = *s++;
3162 if (aint >= 128) /* fake up signed chars */
3163 aint -= 256;
3164 sv = NEWSV(36, 0);
1e422769 3165 sv_setiv(sv, (IV)aint);
a0d0e21e
LW
3166 PUSHs(sv_2mortal(sv));
3167 }
3168 }
3169 break;
3170 case 'C':
3171 if (len > strend - s)
3172 len = strend - s;
3173 if (checksum) {
3174 uchar_checksum:
3175 while (len-- > 0) {
3176 auint = *s++ & 255;
3177 culong += auint;
3178 }
3179 }
3180 else {
3181 EXTEND(SP, len);
bbce6d69 3182 EXTEND_MORTAL(len);
a0d0e21e
LW
3183 while (len-- > 0) {
3184 auint = *s++ & 255;
3185 sv = NEWSV(37, 0);
1e422769 3186 sv_setiv(sv, (IV)auint);
a0d0e21e
LW
3187 PUSHs(sv_2mortal(sv));
3188 }
3189 }
3190 break;
3191 case 's':
96e4d5b1 3192 along = (strend - s) / SIZE16;
a0d0e21e
LW
3193 if (len > along)
3194 len = along;
3195 if (checksum) {
3196 while (len-- > 0) {
96e4d5b1
PP
3197 COPY16(s, &ashort);
3198 s += SIZE16;
a0d0e21e
LW
3199 culong += ashort;
3200 }
3201 }
3202 else {
3203 EXTEND(SP, len);
bbce6d69 3204 EXTEND_MORTAL(len);
a0d0e21e 3205 while (len-- > 0) {
96e4d5b1
PP
3206 COPY16(s, &ashort);
3207 s += SIZE16;
a0d0e21e 3208 sv = NEWSV(38, 0);
1e422769 3209 sv_setiv(sv, (IV)ashort);
a0d0e21e
LW
3210 PUSHs(sv_2mortal(sv));
3211 }
3212 }
3213 break;
3214 case 'v':
3215 case 'n':
3216 case 'S':
96e4d5b1 3217 along = (strend - s) / SIZE16;
a0d0e21e
LW
3218 if (len > along)
3219 len = along;
3220 if (checksum) {
3221 while (len-- > 0) {
96e4d5b1
PP
3222 COPY16(s, &aushort);
3223 s += SIZE16;
a0d0e21e
LW
3224#ifdef HAS_NTOHS
3225 if (datumtype == 'n')
6ad3d225 3226 aushort = PerlSock_ntohs(aushort);
79072805 3227#endif
a0d0e21e
LW
3228#ifdef HAS_VTOHS
3229 if (datumtype == 'v')
3230 aushort = vtohs(aushort);
79072805 3231#endif
a0d0e21e
LW
3232 culong += aushort;
3233 }
3234 }
3235 else {
3236 EXTEND(SP, len);
bbce6d69 3237 EXTEND_MORTAL(len);
a0d0e21e 3238 while (len-- > 0) {
96e4d5b1
PP
3239 COPY16(s, &aushort);
3240 s += SIZE16;
a0d0e21e
LW
3241 sv = NEWSV(39, 0);
3242#ifdef HAS_NTOHS
3243 if (datumtype == 'n')
6ad3d225 3244 aushort = PerlSock_ntohs(aushort);
79072805 3245#endif
a0d0e21e
LW
3246#ifdef HAS_VTOHS
3247 if (datumtype == 'v')
3248 aushort = vtohs(aushort);
79072805 3249#endif
1e422769 3250 sv_setiv(sv, (IV)aushort);
a0d0e21e
LW
3251 PUSHs(sv_2mortal(sv));
3252 }
3253 }
3254 break;
3255 case 'i':
3256 along = (strend - s) / sizeof(int);
3257 if (len > along)
3258 len = along;
3259 if (checksum) {
3260 while (len-- > 0) {
3261 Copy(s, &aint, 1, int);
3262 s += sizeof(int);
3263 if (checksum > 32)
3264 cdouble += (double)aint;
3265 else
3266 culong += aint;
3267 }
3268 }
3269 else {
3270 EXTEND(SP, len);
bbce6d69 3271 EXTEND_MORTAL(len);
a0d0e21e
LW
3272 while (len-- > 0) {
3273 Copy(s, &aint, 1, int);
3274 s += sizeof(int);
3275 sv = NEWSV(40, 0);
20408e3c
GS
3276#ifdef __osf__
3277 /* Without the dummy below unpack("i", pack("i",-1))
3278 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3279 * cc with optimization turned on */
3280 (aint) ?
3281 sv_setiv(sv, (IV)aint) :
3282#endif
1e422769 3283 sv_setiv(sv, (IV)aint);
a0d0e21e
LW
3284 PUSHs(sv_2mortal(sv));
3285 }
3286 }
3287 break;
3288 case 'I':
3289 along = (strend - s) / sizeof(unsigned int);
3290 if (len > along)
3291 len = along;
3292 if (checksum) {
3293 while (len-- > 0) {
3294 Copy(s, &auint, 1, unsigned int);
3295 s += sizeof(unsigned int);
3296 if (checksum > 32)
3297 cdouble += (double)auint;
3298 else
3299 culong += auint;
3300 }
3301 }
3302 else {
3303 EXTEND(SP, len);
bbce6d69 3304 EXTEND_MORTAL(len);
a0d0e21e
LW
3305 while (len-- > 0) {
3306 Copy(s, &auint, 1, unsigned int);
3307 s += sizeof(unsigned int);
3308 sv = NEWSV(41, 0);
1e422769 3309 sv_setuv(sv, (UV)auint);
a0d0e21e
LW
3310 PUSHs(sv_2mortal(sv));
3311 }
3312 }
3313 break;
3314 case 'l':
96e4d5b1 3315 along = (strend - s) / SIZE32;
a0d0e21e
LW
3316 if (len > along)
3317 len = along;
3318 if (checksum) {
3319 while (len-- > 0) {
96e4d5b1
PP
3320 COPY32(s, &along);
3321 s += SIZE32;
a0d0e21e
LW
3322 if (checksum > 32)
3323 cdouble += (double)along;
3324 else
3325 culong += along;
3326 }
3327 }
3328 else {
3329 EXTEND(SP, len);
bbce6d69 3330 EXTEND_MORTAL(len);
a0d0e21e 3331 while (len-- > 0) {
96e4d5b1
PP
3332 COPY32(s, &along);
3333 s += SIZE32;
a0d0e21e 3334 sv = NEWSV(42, 0);
1e422769 3335 sv_setiv(sv, (IV)along);
a0d0e21e
LW
3336 PUSHs(sv_2mortal(sv));
3337 }
79072805 3338 }
a0d0e21e
LW
3339 break;
3340 case 'V':
3341 case 'N':
3342 case 'L':
96e4d5b1 3343 along = (strend - s) / SIZE32;
a0d0e21e
LW
3344 if (len > along)
3345 len = along;
3346 if (checksum) {
3347 while (len-- > 0) {
96e4d5b1
PP
3348 COPY32(s, &aulong);
3349 s += SIZE32;
a0d0e21e
LW
3350#ifdef HAS_NTOHL
3351 if (datumtype == 'N')
6ad3d225 3352 aulong = PerlSock_ntohl(aulong);
79072805 3353#endif
a0d0e21e
LW
3354#ifdef HAS_VTOHL
3355 if (datumtype == 'V')
3356 aulong = vtohl(aulong);
79072805 3357#endif
a0d0e21e
LW
3358 if (checksum > 32)
3359 cdouble += (double)aulong;
3360 else
3361 culong += aulong;
3362 }
3363 }
3364 else {
3365 EXTEND(SP, len);
bbce6d69 3366 EXTEND_MORTAL(len);
a0d0e21e 3367 while (len-- > 0) {
96e4d5b1
PP
3368 COPY32(s, &aulong);
3369 s += SIZE32;
a0d0e21e
LW
3370#ifdef HAS_NTOHL
3371 if (datumtype == 'N')
6ad3d225 3372 aulong = PerlSock_ntohl(aulong);
79072805 3373#endif
a0d0e21e
LW
3374#ifdef HAS_VTOHL
3375 if (datumtype == 'V')
3376 aulong = vtohl(aulong);
79072805 3377#endif
1e422769
PP
3378 sv = NEWSV(43, 0);
3379 sv_setuv(sv, (UV)aulong);
a0d0e21e
LW
3380 PUSHs(sv_2mortal(sv));
3381 }
3382 }
3383 break;
3384 case 'p':
3385 along = (strend - s) / sizeof(char*);
3386 if (len > along)
3387 len = along;
3388 EXTEND(SP, len);
bbce6d69 3389 EXTEND_MORTAL(len);
a0d0e21e
LW
3390 while (len-- > 0) {
3391 if (sizeof(char*) > strend - s)
3392 break;
3393 else {
3394 Copy(s, &aptr, 1, char*);
3395 s += sizeof(char*);
3396 }
3397 sv = NEWSV(44, 0);
3398 if (aptr)
3399 sv_setpv(sv, aptr);
3400 PUSHs(sv_2mortal(sv));
3401 }
3402 break;
def98dd4 3403 case 'w':
def98dd4 3404 EXTEND(SP, len);
bbce6d69 3405 EXTEND_MORTAL(len);
8ec5e241 3406 {
bbce6d69
PP
3407 UV auv = 0;
3408 U32 bytes = 0;
3409
3410 while ((len > 0) && (s < strend)) {
3411 auv = (auv << 7) | (*s & 0x7f);
3412 if (!(*s++ & 0x80)) {
3413 bytes = 0;
3414 sv = NEWSV(40, 0);
3415 sv_setuv(sv, auv);
3416 PUSHs(sv_2mortal(sv));
3417 len--;
3418 auv = 0;
3419 }
3420 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69
PP
3421 char *t;
3422
fc36a67e 3423 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69
PP
3424 while (s < strend) {
3425 sv = mul128(sv, *s & 0x7f);
3426 if (!(*s++ & 0x80)) {
3427 bytes = 0;
3428 break;
3429 }
3430 }
3280af22 3431 t = SvPV(sv, PL_na);
bbce6d69
PP
3432 while (*t == '0')
3433 t++;
3434 sv_chop(sv, t);
3435 PUSHs(sv_2mortal(sv));
3436 len--;
3437 auv = 0;
3438 }
3439 }
3440 if ((s >= strend) && bytes)
3441 croak("Unterminated compressed integer");
3442 }
def98dd4 3443 break;
a0d0e21e
LW
3444 case 'P':
3445 EXTEND(SP, 1);
3446 if (sizeof(char*) > strend - s)
3447 break;
3448 else {
3449 Copy(s, &aptr, 1, char*);
3450 s += sizeof(char*);
3451 }
3452 sv = NEWSV(44, 0);
3453 if (aptr)
3454 sv_setpvn(sv, aptr, len);
3455 PUSHs(sv_2mortal(sv));
3456 break;
ecfc5424 3457#ifdef HAS_QUAD
a0d0e21e 3458 case 'q':
d4217c7e
JH
3459 along = (strend - s) / sizeof(Quad_t);
3460 if (len > along)
3461 len = along;
a0d0e21e 3462 EXTEND(SP, len);
bbce6d69 3463 EXTEND_MORTAL(len);
a0d0e21e 3464 while (len-- > 0) {
ecfc5424 3465 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW
3466 aquad = 0;
3467 else {
ecfc5424
AD
3468 Copy(s, &aquad, 1, Quad_t);
3469 s += sizeof(Quad_t);
a0d0e21e
LW
3470 }
3471 sv = NEWSV(42, 0);
96e4d5b1
PP
3472 if (aquad >= IV_MIN && aquad <= IV_MAX)
3473 sv_setiv(sv, (IV)aquad);
3474 else
3475 sv_setnv(sv, (double)aquad);
a0d0e21e
LW
3476 PUSHs(sv_2mortal(sv));
3477 }
3478 break;
3479 case 'Q':
d4217c7e
JH
3480 along = (strend - s) / sizeof(Quad_t);
3481 if (len > along)
3482 len = along;
a0d0e21e 3483 EXTEND(SP, len);
bbce6d69 3484 EXTEND_MORTAL(len);
a0d0e21e 3485 while (len-- > 0) {
ecfc5424 3486 if (s + sizeof(unsigned Quad_t) > strend)
a0d0e21e
LW
3487 auquad = 0;
3488 else {
ecfc5424
AD
3489 Copy(s, &auquad, 1, unsigned Quad_t);
3490 s += sizeof(unsigned Quad_t);
a0d0e21e
LW
3491 }
3492 sv = NEWSV(43, 0);
27612d38 3493 if (auquad <= UV_MAX)
96e4d5b1
PP
3494 sv_setuv(sv, (UV)auquad);
3495 else
3496 sv_setnv(sv, (double)auquad);
a0d0e21e
LW
3497 PUSHs(sv_2mortal(sv));
3498 }
3499 break;
79072805 3500#endif
a0d0e21e
LW
3501 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3502 case 'f':
3503 case 'F':
3504 along = (strend - s) / sizeof(float);
3505 if (len > along)
3506 len = along;
3507 if (checksum) {
3508 while (len-- > 0) {
3509 Copy(s, &afloat, 1, float);
3510 s += sizeof(float);
3511 cdouble += afloat;
3512 }
3513 }
3514 else {
3515 EXTEND(SP, len);
bbce6d69 3516 EXTEND_MORTAL(len);
a0d0e21e
LW
3517 while (len-- > 0) {
3518 Copy(s, &afloat, 1, float);
3519 s += sizeof(float);
3520 sv = NEWSV(47, 0);
3521 sv_setnv(sv, (double)afloat);
3522 PUSHs(sv_2mortal(sv));
3523 }
3524 }
3525 break;
3526 case 'd':
3527 case 'D':
3528 along = (strend - s) / sizeof(double);
3529 if (len > along)
3530 len = along;
3531 if (checksum) {
3532 while (len-- > 0) {
3533 Copy(s, &adouble, 1, double);
3534 s += sizeof(double);
3535 cdouble += adouble;
3536 }
3537 }
3538 else {
3539 EXTEND(SP, len);
bbce6d69 3540 EXTEND_MORTAL(len);
a0d0e21e
LW
3541 while (len-- > 0) {
3542 Copy(s, &adouble, 1, double);
3543 s += sizeof(double);
3544 sv = NEWSV(48, 0);
3545 sv_setnv(sv, (double)adouble);
3546 PUSHs(sv_2mortal(sv));
3547 }
3548 }
3549 break;
3550 case 'u':
9d116dd7
JH
3551 /* MKS:
3552 * Initialise the decode mapping. By using a table driven
3553 * algorithm, the code will be character-set independent
3554 * (and just as fast as doing character arithmetic)
3555 */
3556 if (uudmap['M'] == 0) {
3557 int i;
3558
3559 for (i = 0; i < sizeof(uuemap); i += 1)
3560 uudmap[uuemap[i]] = i;
3561 /*
3562 * Because ' ' and '`' map to the same value,
3563 * we need to decode them both the same.
3564 */
3565 uudmap[' '] = 0;
3566 }
3567
a0d0e21e
LW
3568 along = (strend - s) * 3 / 4;
3569 sv = NEWSV(42, along);
f12c7020
PP
3570 if (along)
3571 SvPOK_on(sv);
9d116dd7 3572 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
a0d0e21e
LW
3573 I32 a, b, c, d;
3574 char hunk[4];
79072805 3575
a0d0e21e 3576 hunk[3] = '\0';
409b62f3 3577 len = uudmap[*s++] & 077;
a0d0e21e 3578 while (len > 0) {
9d116dd7
JH
3579 if (s < strend && ISUUCHAR(*s))
3580 a = uudmap[*s++] & 077;
3581 else
3582 a = 0;
3583 if (s < strend && ISUUCHAR(*s))
3584 b = uudmap[*s++] & 077;
3585 else
3586 b = 0;
3587 if (s < strend && ISUUCHAR(*s))
3588 c = uudmap[*s++] & 077;
3589 else
3590 c = 0;
3591 if (s < strend && ISUUCHAR(*s))
3592 d = uudmap[*s++] & 077;
a0d0e21e
LW
3593 else
3594 d = 0;
4e35701f
NIS
3595 hunk[0] = (a << 2) | (b >> 4);
3596 hunk[1] = (b << 4) | (c >> 2);
3597 hunk[2] = (c << 6) | d;
3598 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW
3599 len -= 3;
3600 }
3601 if (*s == '\n')
3602 s++;
3603 else if (s[1] == '\n') /* possible checksum byte */
3604 s += 2;
79072805 3605 }
a0d0e21e
LW
3606 XPUSHs(sv_2mortal(sv));
3607 break;
79072805 3608 }
a0d0e21e
LW
3609 if (checksum) {
3610 sv = NEWSV(42, 0);
3611 if (strchr("fFdD", datumtype) ||
3612 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3613 double trouble;
79072805 3614
a0d0e21e
LW
3615 adouble = 1.0;
3616 while (checksum >= 16) {
3617 checksum -= 16;
3618 adouble *= 65536.0;
3619 }
3620 while (checksum >= 4) {
3621 checksum -= 4;
3622 adouble *= 16.0;
3623 }
3624 while (checksum--)
3625 adouble *= 2.0;
3626 along = (1 << checksum) - 1;
3627 while (cdouble < 0.0)
3628 cdouble += adouble;
3629 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3630 sv_setnv(sv, cdouble);
3631 }
3632 else {
3633 if (checksum < 32) {
96e4d5b1
PP
3634 aulong = (1 << checksum) - 1;
3635 culong &= aulong;
a0d0e21e 3636 }
96e4d5b1 3637 sv_setuv(sv, (UV)culong);
a0d0e21e
LW
3638 }
3639 XPUSHs(sv_2mortal(sv));
3640 checksum = 0;
79072805 3641 }
79072805 3642 }
924508f0 3643 if (SP == oldsp && gimme == G_SCALAR)
3280af22 3644 PUSHs(&PL_sv_undef);
79072805 3645 RETURN;
79072805
LW
3646}
3647
76e3520e 3648STATIC void
8ac85365 3649doencodes(register SV *sv, register char *s, register I32 len)
79072805 3650{
a0d0e21e 3651 char hunk[5];
79072805 3652
9d116dd7 3653 *hunk = uuemap[len];
a0d0e21e
LW
3654 sv_catpvn(sv, hunk, 1);
3655 hunk[4] = '\0';
f264d472 3656 while (len > 2) {
9d116dd7 3657 hunk[0] = uuemap[(077 & (*s >> 2))];
d38acd6c
GS
3658 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3659 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
9d116dd7 3660 hunk[3] = uuemap[(077 & (s[2] & 077))];
a0d0e21e
LW
3661 sv_catpvn(sv, hunk, 4);
3662 s += 3;
3663 len -= 3;
3664 }
f264d472
GS
3665 if (len > 0) {
3666 char r = (len > 1 ? s[1] : '\0');
3667 hunk[0] = uuemap[(077 & (*s >> 2))];
d38acd6c 3668 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
f264d472
GS
3669 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3670 hunk[3] = uuemap[0];
3671 sv_catpvn(sv, hunk, 4);
3672 }
a0d0e21e 3673 sv_catpvn(sv, "\n", 1);
79072805
LW
3674}
3675
76e3520e 3676STATIC SV *
8ac85365 3677is_an_int(char *s, STRLEN l)
55497cff
PP
3678{
3679 SV *result = newSVpv("", l);
3280af22 3680 char *result_c = SvPV(result, PL_na); /* convenience */
55497cff
PP
3681 char *out = result_c;
3682 bool skip = 1;
3683 bool ignore = 0;
3684
3685 while (*s) {
3686 switch (*s) {
3687 case ' ':
3688 break;
3689 case '+':
3690 if (!skip) {
3691 SvREFCNT_dec(result);
3692 return (NULL);
3693 }
3694 break;
3695 case '0':
3696 case '1':
3697 case '2':
3698 case '3':
3699 case '4':
3700 case '5':
3701 case '6':
3702 case '7':
3703 case '8':
3704 case '9':
3705 skip = 0;
3706 if (!ignore) {
3707 *(out++) = *s;
3708 }
3709 break;
3710 case '.':
3711 ignore = 1;
3712 break;
3713 default:
3714 SvREFCNT_dec(result);
3715 return (NULL);
3716 }
3717 s++;
3718 }
3719 *(out++) = '\0';
3720 SvCUR_set(result, out - result_c);
3721 return (result);
3722}
3723
76e3520e 3724STATIC int
61bb5906 3725div128(SV *pnum, bool *done)
8ac85365 3726 /* must be '\0' terminated */
8ec5e241 3727
55497cff
PP
3728{
3729 STRLEN len;
3730 char *s = SvPV(pnum, len);
3731 int m = 0;
3732 int r = 0;
3733 char *t = s;
3734
3735 *done = 1;
3736 while (*t) {
3737 int i;
3738
3739 i = m * 10 + (*t - '0');
3740 m = i & 0x7F;
3741 r = (i >> 7); /* r < 10 */
3742 if (r) {
3743 *done = 0;
3744 }
3745 *(t++) = '0' + r;
3746 }
3747 *(t++) = '\0';
3748 SvCUR_set(pnum, (STRLEN) (t - s));
3749 return (m);
3750}
3751
3752
a0d0e21e 3753PP(pp_pack)
79072805 3754{
4e35701f 3755 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3756 register SV *cat = TARG;
3757 register I32 items;
3758 STRLEN fromlen;
3759 register char *pat = SvPVx(*++MARK, fromlen);
3760 register char *patend = pat + fromlen;
3761 register I32 len;
3762 I32 datumtype;
3763 SV *fromstr;
3764 /*SUPPRESS 442*/