This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
integrate change#2159 from mainline
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805 4 *
a0d0e21e
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
79072805 7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
13 */
79072805
LW		 14
15#include "EXTERN.h"
16#include "perl.h"
17
36477c24 18/*
ef2d312d
TH		 19 * The compiler on Concurrent CX/UX systems has a subtle bug which only
20 * seems to show up when compiling pp.c - it generates the wrong double
21 * precision constant value for (double)UV_MAX when used inline in the body
22 * of the code below, so this makes a static variable up front (which the
23 * compiler seems to get correct) and uses it in place of UV_MAX below.
24 */
25#ifdef CXUX_BROKEN_CONSTANT_CONVERT
26static double UV_MAX_cxux = ((double)UV_MAX);
8ec5e241 27#endif
ef2d312d
TH		 28
29/*
36477c24 30 * Types used in bitwise operations.
31 *
32 * Normally we'd just use IV and UV. However, some hardware and
33 * software combinations (e.g. Alpha and current OSF/1) don't have a
34 * floating-point type to use for NV that has adequate bits to fully
35 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
36 *
96e4d5b1 37 * It just so happens that "int" is the right size almost everywhere.
36477c24 38 */
39typedef int IBW;
40typedef unsigned UBW;
41
96e4d5b1 42/*
43 * Mask used after bitwise operations.
44 *
45 * There is at least one realm (Cray word machines) that doesn't
46 * have an integral type (except char) small enough to be represented
47 * in a double without loss; that is, it has no 32-bit type.
48 */
6ee623d5 49#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
46fc3d4c 50# define BW_BITS 32
51# define BW_MASK ((1 << BW_BITS) - 1)
52# define BW_SIGN (1 << (BW_BITS - 1))
96e4d5b1 53# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
54# define BWu(u) ((u) & BW_MASK)
55#else
56# define BWi(i) (i)
57# define BWu(u) (u)
58#endif
59
60/*
61 * Offset for integer pack/unpack.
62 *
63 * On architectures where I16 and I32 aren't really 16 and 32 bits,
64 * which for now are all Crays, pack and unpack have to play games.
65 */
66
67/*
68 * These values are required for portability of pack() output.
69 * If they're not right on your machine, then pack() and unpack()
70 * wouldn't work right anyway; you'll need to apply the Cray hack.
71 * (I'd like to check them with #if, but you can't use sizeof() in
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 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 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 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 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 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 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 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 368PP(pp_prototype)
369{
4e35701f 370 djSP;
c07a80fd 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 422 if (cv && SvPOK(cv))
423 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
b6c543e3 424 set:
c07a80fd 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 460 while (++MARK <= SP)
461 *MARK = refto(*MARK);
a0d0e21e 462 RETURN;
79072805
LW		 463}
464
76e3520e 465STATIC SV*
8ac85365 466refto(SV *sv)
71be2cbc 467{
468 SV* rv;
469
470 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
471 if (LvTARGLEN(sv))
68dc0745 472 vivify_defelem(sv);
473 if (!(sv = LvTARG(sv)))
3280af22 474 sv = &PL_sv_undef;
71be2cbc 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 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 529PP(pp_gelem)
530{
531 GV *gv;
532 SV *sv;
76e3520e 533 SV *tmpRef;
fb73857a 534 char *elem;
4e35701f 535 djSP;
fb73857a 536
537 sv = POPs;
3280af22 538 elem = SvPV(sv, PL_na);
fb73857a 539 gv = (GV*)POPs;
76e3520e 540 tmpRef = Nullsv;
fb73857a 541 sv = Nullsv;
542 switch (elem ? *elem : '\0')
543 {
544 case 'A':
545 if (strEQ(elem, "ARRAY"))
76e3520e 546 tmpRef = (SV*)GvAV(gv);
fb73857a 547 break;
548 case 'C':
549 if (strEQ(elem, "CODE"))
76e3520e 550 tmpRef = (SV*)GvCVu(gv);
fb73857a 551 break;
552 case 'F':
553 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 554 tmpRef = (SV*)GvIOp(gv);
fb73857a 555 break;
556 case 'G':
557 if (strEQ(elem, "GLOB"))
76e3520e 558 tmpRef = (SV*)gv;
fb73857a 559 break;
560 case 'H':
561 if (strEQ(elem, "HASH"))
76e3520e 562 tmpRef = (SV*)GvHV(gv);
fb73857a 563 break;
564 case 'I':
565 if (strEQ(elem, "IO"))
76e3520e 566 tmpRef = (SV*)GvIOp(gv);
fb73857a 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 579 break;
580 }
76e3520e
GS		 581 if (tmpRef)
582 sv = newRV(tmpRef);
fb73857a 583 if (sv)
584 sv_2mortal(sv);
585 else
3280af22 586 sv = &PL_sv_undef;
fb73857a 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 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 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 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 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 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 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 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 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 918 UV left;
919 UV right;
beb18505
CS		 920 bool left_neg;
921 bool right_neg;
68dc0745 922 UV ans;
a0d0e21e 923
68dc0745 924 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
925 IV i = SvIVX(POPs);
beb18505 926 right = (right_neg = (i < 0)) ? -i : i;
68dc0745 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 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 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 1038 }
1039 else {
36477c24 1040 UBW u = TOPu;
96e4d5b1 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 1057 }
1058 else {
36477c24 1059 UBW u = TOPu;
96e4d5b1 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 1128 else if (left > right)
1129 value = 1;
1130 else {
3280af22 1131 SETs(&PL_sv_undef);
44a8e56a 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 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 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 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 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 1191PP(pp_seq)
1192{
8ec5e241 1193 djSP; tryAMAGICbinSET(seq,0);
36477c24 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 1217 ? sv_cmp_locale(left, right)
1218 : sv_cmp(left, right));
1219 SETi( cmp );
a0d0e21e
LW		 1220 RETURN;
1221 }
1222}
79072805 1223
55497cff 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 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 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 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 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 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 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;
365db942
RS		 1637#ifndef PERL_NO_DEV_RANDOM
1638 int fd;
1639#endif
93dc8474 1640 U32 u;
f12c7020 1641#ifdef VMS
1642# include <starlet.h>
43c92808
HF		 1643 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1644 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 1645 unsigned int when[2];
365db942
RS		 1646#else
1647# ifdef HAS_GETTIMEOFDAY
1648 struct timeval when;
1649# else
1650 Time_t when;
1651# endif
1652#endif
1653
1654/* This test is an escape hatch, this symbol isn't set by Configure. */
1655#ifndef PERL_NO_DEV_RANDOM
1656#ifndef PERL_RANDOM_DEVICE
1657 /* /dev/random isn't used by default because reads from it will block
1658 * if there isn't enough entropy available. You can compile with
1659 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1660 * is enough real entropy to fill the seed. */
1661# define PERL_RANDOM_DEVICE "/dev/urandom"
1662#endif
1663 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1664 if (fd != -1) {
1665 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1666 u = 0;
1667 PerlLIO_close(fd);
1668 if (u)
1669 return u;
1670 }
1671#endif
1672
1673#ifdef VMS
93dc8474 1674 _ckvmssts(sys$gettim(when));
54310121 1675 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1676#else
5f05dabc 1677# ifdef HAS_GETTIMEOFDAY
93dc8474 1678 gettimeofday(&when,(struct timezone *) 0);
54310121 1679 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1680# else
93dc8474 1681 (void)time(&when);
54310121 1682 u = (U32)SEED_C1 * when;
f12c7020 1683# endif
1684#endif
54310121 1685 u += SEED_C3 * (U32)getpid();
3280af22 1686 u += SEED_C4 * (U32)(UV)PL_stack_sp;
54310121 1687#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1688 u += SEED_C5 * (U32)(UV)&when;
f12c7020 1689#endif
93dc8474 1690 return u;
79072805
LW		 1691}
1692
1693PP(pp_exp)
1694{
4e35701f 1695 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e
LW		 1696 {
1697 double value;
1698 value = POPn;
1699 value = exp(value);
1700 XPUSHn(value);
1701 RETURN;
1702 }
79072805
LW		 1703}
1704
1705PP(pp_log)
1706{
4e35701f 1707 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e
LW		 1708 {
1709 double value;
1710 value = POPn;
bbce6d69 1711 if (value <= 0.0) {
36477c24 1712 SET_NUMERIC_STANDARD();
2304df62 1713 DIE("Can't take log of %g", value);
bbce6d69 1714 }
a0d0e21e
LW		 1715 value = log(value);
1716 XPUSHn(value);
1717 RETURN;
1718 }
79072805
LW		 1719}
1720
1721PP(pp_sqrt)
1722{
4e35701f 1723 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e
LW		 1724 {
1725 double value;
1726 value = POPn;
bbce6d69 1727 if (value < 0.0) {
36477c24 1728 SET_NUMERIC_STANDARD();
2304df62 1729 DIE("Can't take sqrt of %g", value);
bbce6d69 1730 }
a0d0e21e
LW		 1731 value = sqrt(value);
1732 XPUSHn(value);
1733 RETURN;
1734 }
79072805
LW		 1735}
1736
1737PP(pp_int)
1738{
4e35701f 1739 djSP; dTARGET;
774d564b 1740 {
1741 double value = TOPn;
1742 IV iv;
1743
1744 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1745 iv = SvIVX(TOPs);
1746 SETi(iv);
1747 }
1748 else {
1749 if (value >= 0.0)
1750 (void)modf(value, &value);
1751 else {
1752 (void)modf(-value, &value);
1753 value = -value;
1754 }
1755 iv = I_V(value);
1756 if (iv == value)
1757 SETi(iv);
1758 else
1759 SETn(value);
1760 }
79072805 1761 }
79072805
LW		 1762 RETURN;
1763}
1764
463ee0b2
LW		 1765PP(pp_abs)
1766{
4e35701f 1767 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 1768 {
774d564b 1769 double value = TOPn;
1770 IV iv;
463ee0b2 1771
774d564b 1772 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1773 (iv = SvIVX(TOPs)) != IV_MIN) {
1774 if (iv < 0)
1775 iv = -iv;
1776 SETi(iv);
1777 }
1778 else {
1779 if (value < 0.0)
1780 value = -value;
1781 SETn(value);
1782 }
a0d0e21e 1783 }
774d564b 1784 RETURN;
463ee0b2
LW		 1785}
1786
79072805
LW		 1787PP(pp_hex)
1788{
4e35701f 1789 djSP; dTARGET;
79072805
LW		 1790 char *tmps;
1791 I32 argtype;
1792
a0d0e21e 1793 tmps = POPp;
55497cff 1794 XPUSHu(scan_hex(tmps, 99, &argtype));
79072805
LW		 1795 RETURN;
1796}
1797
1798PP(pp_oct)
1799{
4e35701f 1800 djSP; dTARGET;
55497cff 1801 UV value;
79072805
LW		 1802 I32 argtype;
1803 char *tmps;
1804
a0d0e21e 1805 tmps = POPp;
464e2e8a 1806 while (*tmps && isSPACE(*tmps))
1807 tmps++;
1808 if (*tmps == '0')
79072805
LW		 1809 tmps++;
1810 if (*tmps == 'x')
464e2e8a 1811 value = scan_hex(++tmps, 99, &argtype);
1812 else
1813 value = scan_oct(tmps, 99, &argtype);
55497cff 1814 XPUSHu(value);
79072805
LW		 1815 RETURN;
1816}
1817
1818/* String stuff. */
1819
1820PP(pp_length)
1821{
4e35701f 1822 djSP; dTARGET;
a0d0e21e 1823 SETi( sv_len(TOPs) );
79072805
LW		 1824 RETURN;
1825}
1826
1827PP(pp_substr)
1828{
4e35701f 1829 djSP; dTARGET;
79072805
LW		 1830 SV *sv;
1831 I32 len;
463ee0b2 1832 STRLEN curlen;
79072805
LW		 1833 I32 pos;
1834 I32 rem;
84902520 1835 I32 fail;
533c011a 1836 I32 lvalue = PL_op->op_flags & OPf_MOD;
79072805 1837 char *tmps;
3280af22 1838 I32 arybase = PL_curcop->cop_arybase;
7b8d334a
GS		 1839 char *repl = 0;
1840 STRLEN repl_len;
79072805 1841
20408e3c 1842 SvTAINTED_off(TARG); /* decontaminate */
5d82c453
GA		 1843 if (MAXARG > 2) {
1844 if (MAXARG > 3) {
1845 sv = POPs;
1846 repl = SvPV(sv, repl_len);
7b8d334a 1847 }
79072805 1848 len = POPi;
5d82c453 1849 }
84902520 1850 pos = POPi;
79072805 1851 sv = POPs;
849ca7ee 1852 PUTBACK;
a0d0e21e 1853 tmps = SvPV(sv, curlen);
84902520
TB		 1854 if (pos >= arybase) {
1855 pos -= arybase;
1856 rem = curlen-pos;
1857 fail = rem;
5d82c453
GA		 1858 if (MAXARG > 2) {
1859 if (len < 0) {
1860 rem += len;
1861 if (rem < 0)
1862 rem = 0;
1863 }
1864 else if (rem > len)
1865 rem = len;
1866 }
68dc0745 1867 }
84902520 1868 else {
5d82c453
GA		 1869 pos += curlen;
1870 if (MAXARG < 3)
1871 rem = curlen;
1872 else if (len >= 0) {
1873 rem = pos+len;
1874 if (rem > (I32)curlen)
1875 rem = curlen;
1876 }
1877 else {
1878 rem = curlen+len;
1879 if (rem < pos)
1880 rem = pos;
1881 }
1882 if (pos < 0)
1883 pos = 0;
1884 fail = rem;
1885 rem -= pos;
84902520
TB		 1886 }
1887 if (fail < 0) {
3280af22 1888 if (PL_dowarn || lvalue || repl)
2304df62
AD		 1889 warn("substr outside of string");
1890 RETPUSHUNDEF;
1891 }
79072805 1892 else {
79072805 1893 tmps += pos;
79072805
LW		 1894 sv_setpvn(TARG, tmps, rem);
1895 if (lvalue) { /* it's an lvalue! */
dedeecda 1896 if (!SvGMAGICAL(sv)) {
1897 if (SvROK(sv)) {
3280af22
NIS		 1898 SvPV_force(sv,PL_na);
1899 if (PL_dowarn)
dedeecda 1900 warn("Attempt to use reference as lvalue in substr");
1901 }
1902 if (SvOK(sv)) /* is it defined ? */
1903 (void)SvPOK_only(sv);
1904 else
1905 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1906 }
5f05dabc 1907
a0d0e21e
LW		 1908 if (SvTYPE(TARG) < SVt_PVLV) {
1909 sv_upgrade(TARG, SVt_PVLV);
1910 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 1911 }
a0d0e21e 1912
5f05dabc 1913 LvTYPE(TARG) = 'x';
6ff81951
GS		 1914 if (LvTARG(TARG) != sv) {
1915 if (LvTARG(TARG))
1916 SvREFCNT_dec(LvTARG(TARG));
1917 LvTARG(TARG) = SvREFCNT_inc(sv);
1918 }
a0d0e21e 1919 LvTARGOFF(TARG) = pos;
8ec5e241 1920 LvTARGLEN(TARG) = rem;
79072805 1921 }
5d82c453 1922 else if (repl)
7b8d334a 1923 sv_insert(sv, pos, rem, repl, repl_len);
79072805 1924 }
849ca7ee 1925 SPAGAIN;
79072805
LW		 1926 PUSHs(TARG); /* avoid SvSETMAGIC here */
1927 RETURN;
1928}
1929
1930PP(pp_vec)
1931{
4e35701f 1932 djSP; dTARGET;
79072805
LW		 1933 register I32 size = POPi;
1934 register I32 offset = POPi;
1935 register SV *src = POPs;
533c011a 1936 I32 lvalue = PL_op->op_flags & OPf_MOD;
463ee0b2
LW		 1937 STRLEN srclen;
1938 unsigned char *s = (unsigned char*)SvPV(src, srclen);
79072805
LW		 1939 unsigned long retnum;
1940 I32 len;
1941
20408e3c 1942 SvTAINTED_off(TARG); /* decontaminate */
79072805
LW		 1943 offset *= size; /* turn into bit offset */
1944 len = (offset + size + 7) / 8;
1945 if (offset < 0 || size < 1)
1946 retnum = 0;
79072805 1947 else {
a0d0e21e
LW		 1948 if (lvalue) { /* it's an lvalue! */
1949 if (SvTYPE(TARG) < SVt_PVLV) {
1950 sv_upgrade(TARG, SVt_PVLV);
1951 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1952 }
1953
1954 LvTYPE(TARG) = 'v';
6ff81951
GS		 1955 if (LvTARG(TARG) != src) {
1956 if (LvTARG(TARG))
1957 SvREFCNT_dec(LvTARG(TARG));
1958 LvTARG(TARG) = SvREFCNT_inc(src);
1959 }
8ec5e241
NIS		 1960 LvTARGOFF(TARG) = offset;
1961 LvTARGLEN(TARG) = size;
a0d0e21e 1962 }
93a17b20 1963 if (len > srclen) {
a0d0e21e
LW		 1964 if (size <= 8)
1965 retnum = 0;
1966 else {
1967 offset >>= 3;
748a9306
LW		 1968 if (size == 16) {
1969 if (offset >= srclen)
1970 retnum = 0;
a0d0e21e 1971 else
748a9306
LW		 1972 retnum = (unsigned long) s[offset] << 8;
1973 }
1974 else if (size == 32) {
1975 if (offset >= srclen)
1976 retnum = 0;
1977 else if (offset + 1 >= srclen)
a0d0e21e 1978 retnum = (unsigned long) s[offset] << 24;
748a9306
LW		 1979 else if (offset + 2 >= srclen)
1980 retnum = ((unsigned long) s[offset] << 24) +
1981 ((unsigned long) s[offset + 1] << 16);
1982 else
1983 retnum = ((unsigned long) s[offset] << 24) +
1984 ((unsigned long) s[offset + 1] << 16) +
1985 (s[offset + 2] << 8);
a0d0e21e
LW		 1986 }
1987 }
79072805 1988 }
a0d0e21e 1989 else if (size < 8)
79072805
LW		 1990 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1991 else {
1992 offset >>= 3;
1993 if (size == 8)
1994 retnum = s[offset];
1995 else if (size == 16)
1996 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1997 else if (size == 32)
1998 retnum = ((unsigned long) s[offset] << 24) +
1999 ((unsigned long) s[offset + 1] << 16) +
2000 (s[offset + 2] << 8) + s[offset+3];
2001 }
79072805
LW		 2002 }
2003
deb3007b 2004 sv_setuv(TARG, (UV)retnum);
79072805
LW		 2005 PUSHs(TARG);
2006 RETURN;
2007}
2008
2009PP(pp_index)
2010{
4e35701f 2011 djSP; dTARGET;
79072805
LW		 2012 SV *big;
2013 SV *little;
2014 I32 offset;
2015 I32 retval;
2016 char *tmps;
2017 char *tmps2;
463ee0b2 2018 STRLEN biglen;
3280af22 2019 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 2020
2021 if (MAXARG < 3)
2022 offset = 0;
2023 else
2024 offset = POPi - arybase;
2025 little = POPs;
2026 big = POPs;
463ee0b2 2027 tmps = SvPV(big, biglen);
79072805
LW		 2028 if (offset < 0)
2029 offset = 0;
93a17b20
LW		 2030 else if (offset > biglen)
2031 offset = biglen;
79072805 2032 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2033 (unsigned char*)tmps + biglen, little, 0)))
79072805
LW		 2034 retval = -1 + arybase;
2035 else
2036 retval = tmps2 - tmps + arybase;
2037 PUSHi(retval);
2038 RETURN;
2039}
2040
2041PP(pp_rindex)
2042{
4e35701f 2043 djSP; dTARGET;
79072805
LW		 2044 SV *big;
2045 SV *little;
463ee0b2
LW		 2046 STRLEN blen;
2047 STRLEN llen;
79072805
LW		 2048 SV *offstr;
2049 I32 offset;
2050 I32 retval;
2051 char *tmps;
2052 char *tmps2;
3280af22 2053 I32 arybase = PL_curcop->cop_arybase;
79072805 2054
a0d0e21e 2055 if (MAXARG >= 3)
79072805
LW		 2056 offstr = POPs;
2057 little = POPs;
2058 big = POPs;
463ee0b2
LW		 2059 tmps2 = SvPV(little, llen);
2060 tmps = SvPV(big, blen);
79072805 2061 if (MAXARG < 3)
463ee0b2 2062 offset = blen;
79072805 2063 else
463ee0b2 2064 offset = SvIV(offstr) - arybase + llen;
79072805
LW		 2065 if (offset < 0)
2066 offset = 0;
463ee0b2
LW		 2067 else if (offset > blen)
2068 offset = blen;
79072805 2069 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2070 tmps2, tmps2 + llen)))
79072805
LW		 2071 retval = -1 + arybase;
2072 else
2073 retval = tmps2 - tmps + arybase;
2074 PUSHi(retval);
2075 RETURN;
2076}
2077
2078PP(pp_sprintf)
2079{
4e35701f 2080 djSP; dMARK; dORIGMARK; dTARGET;
36477c24 2081#ifdef USE_LOCALE_NUMERIC
533c011a 2082 if (PL_op->op_private & OPpLOCALE)
36477c24 2083 SET_NUMERIC_LOCAL();
bbce6d69 2084 else
36477c24 2085 SET_NUMERIC_STANDARD();
2086#endif
79072805 2087 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2088 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 2089 SP = ORIGMARK;
2090 PUSHTARG;
2091 RETURN;
2092}
2093
79072805
LW		 2094PP(pp_ord)
2095{
4e35701f 2096 djSP; dTARGET;
79072805
LW		 2097 I32 value;
2098 char *tmps;
79072805 2099
79072805 2100#ifndef I286
a0d0e21e 2101 tmps = POPp;
79072805
LW		 2102 value = (I32) (*tmps & 255);
2103#else
a0d0e21e
LW		 2104 I32 anum;
2105 tmps = POPp;
79072805
LW		 2106 anum = (I32) *tmps;
2107 value = (I32) (anum & 255);
2108#endif
2109 XPUSHi(value);
2110 RETURN;
2111}
2112
463ee0b2
LW		 2113PP(pp_chr)
2114{
4e35701f 2115 djSP; dTARGET;
463ee0b2
LW		 2116 char *tmps;
2117
748a9306
LW		 2118 (void)SvUPGRADE(TARG,SVt_PV);
2119 SvGROW(TARG,2);
463ee0b2
LW		 2120 SvCUR_set(TARG, 1);
2121 tmps = SvPVX(TARG);
748a9306
LW		 2122 *tmps++ = POPi;
2123 *tmps = '\0';
a0d0e21e 2124 (void)SvPOK_only(TARG);
463ee0b2
LW		 2125 XPUSHs(TARG);
2126 RETURN;
2127}
2128
79072805
LW		 2129PP(pp_crypt)
2130{
4e35701f 2131 djSP; dTARGET; dPOPTOPssrl;
79072805 2132#ifdef HAS_CRYPT
3280af22 2133 char *tmps = SvPV(left, PL_na);
79072805 2134#ifdef FCRYPT
6b88bc9c 2135 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
79072805 2136#else
ff95b63e 2137 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
79072805
LW		 2138#endif
2139#else
2140 DIE(
2141 "The crypt() function is unimplemented due to excessive paranoia.");
2142#endif
2143 SETs(TARG);
2144 RETURN;
2145}
2146
2147PP(pp_ucfirst)
2148{
4e35701f 2149 djSP;
79072805
LW		 2150 SV *sv = TOPs;
2151 register char *s;
2152
ed6116ce 2153 if (!SvPADTMP(sv)) {
79072805
LW		 2154 dTARGET;
2155 sv_setsv(TARG, sv);
2156 sv = TARG;
2157 SETs(sv);
2158 }
3280af22 2159 s = SvPV_force(sv, PL_na);
bbce6d69 2160 if (*s) {
533c011a 2161 if (PL_op->op_private & OPpLOCALE) {
bbce6d69 2162 TAINT;
2163 SvTAINTED_on(sv);
2164 *s = toUPPER_LC(*s);
2165 }
2166 else
2167 *s = toUPPER(*s);
2168 }
79072805
LW		 2169
2170 RETURN;
2171}
2172
2173PP(pp_lcfirst)
2174{
4e35701f 2175 djSP;
79072805
LW		 2176 SV *sv = TOPs;
2177 register char *s;
2178
ed6116ce 2179 if (!SvPADTMP(sv)) {
79072805
LW		 2180 dTARGET;
2181 sv_setsv(TARG, sv);
2182 sv = TARG;
2183 SETs(sv);
2184 }
3280af22 2185 s = SvPV_force(sv, PL_na);
bbce6d69 2186 if (*s) {
533c011a 2187 if (PL_op->op_private & OPpLOCALE) {
bbce6d69 2188 TAINT;
2189 SvTAINTED_on(sv);
2190 *s = toLOWER_LC(*s);
2191 }
2192 else
2193 *s = toLOWER(*s);
2194 }
79072805
LW		 2195
2196 SETs(sv);
2197 RETURN;
2198}
2199
2200PP(pp_uc)
2201{
4e35701f 2202 djSP;
79072805
LW		 2203 SV *sv = TOPs;
2204 register char *s;
463ee0b2 2205 STRLEN len;
79072805 2206
ed6116ce 2207 if (!SvPADTMP(sv)) {
79072805
LW		 2208 dTARGET;
2209 sv_setsv(TARG, sv);
2210 sv = TARG;
2211 SETs(sv);
2212 }
bbce6d69 2213
a0d0e21e 2214 s = SvPV_force(sv, len);
bbce6d69 2215 if (len) {
2216 register char *send = s + len;
2217
533c011a 2218 if (PL_op->op_private & OPpLOCALE) {
bbce6d69 2219 TAINT;
2220 SvTAINTED_on(sv);
2221 for (; s < send; s++)
2222 *s = toUPPER_LC(*s);
2223 }
2224 else {
2225 for (; s < send; s++)
2226 *s = toUPPER(*s);
2227 }
79072805
LW		 2228 }
2229 RETURN;
2230}
2231
2232PP(pp_lc)
2233{
4e35701f 2234 djSP;
79072805
LW		 2235 SV *sv = TOPs;
2236 register char *s;
463ee0b2 2237 STRLEN len;
79072805 2238
ed6116ce 2239 if (!SvPADTMP(sv)) {
79072805
LW		 2240 dTARGET;
2241 sv_setsv(TARG, sv);
2242 sv = TARG;
2243 SETs(sv);
2244 }
bbce6d69 2245
a0d0e21e 2246 s = SvPV_force(sv, len);
bbce6d69 2247 if (len) {
2248 register char *send = s + len;
2249
533c011a 2250 if (PL_op->op_private & OPpLOCALE) {
bbce6d69 2251 TAINT;
2252 SvTAINTED_on(sv);
2253 for (; s < send; s++)
2254 *s = toLOWER_LC(*s);
2255 }
2256 else {
2257 for (; s < send; s++)
2258 *s = toLOWER(*s);
2259 }
79072805
LW		 2260 }
2261 RETURN;
2262}
2263
a0d0e21e 2264PP(pp_quotemeta)
79072805 2265{
4e35701f 2266 djSP; dTARGET;
a0d0e21e
LW		 2267 SV *sv = TOPs;
2268 STRLEN len;
2269 register char *s = SvPV(sv,len);
2270 register char *d;
79072805 2271
a0d0e21e
LW		 2272 if (len) {
2273 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2274 SvGROW(TARG, (len * 2) + 1);
a0d0e21e
LW		 2275 d = SvPVX(TARG);
2276 while (len--) {
2277 if (!isALNUM(*s))
2278 *d++ = '\\';
2279 *d++ = *s++;
79072805 2280 }
a0d0e21e
LW		 2281 *d = '\0';
2282 SvCUR_set(TARG, d - SvPVX(TARG));
2283 (void)SvPOK_only(TARG);
79072805 2284 }
a0d0e21e
LW		 2285 else
2286 sv_setpvn(TARG, s, len);
2287 SETs(TARG);
79072805
LW		 2288 RETURN;
2289}
2290
a0d0e21e 2291/* Arrays. */
79072805 2292
a0d0e21e 2293PP(pp_aslice)
79072805 2294{
4e35701f 2295 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2296 register SV** svp;
2297 register AV* av = (AV*)POPs;
533c011a 2298 register I32 lval = PL_op->op_flags & OPf_MOD;
3280af22 2299 I32 arybase = PL_curcop->cop_arybase;
748a9306 2300 I32 elem;
79072805 2301
a0d0e21e 2302 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2303 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2304 I32 max = -1;
924508f0 2305 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 2306 elem = SvIVx(*svp);
2307 if (elem > max)
2308 max = elem;
2309 }
2310 if (max > AvMAX(av))
2311 av_extend(av, max);
2312 }
a0d0e21e 2313 while (++MARK <= SP) {
748a9306 2314 elem = SvIVx(*MARK);
a0d0e21e 2315
748a9306
LW		 2316 if (elem > 0)
2317 elem -= arybase;
a0d0e21e
LW		 2318 svp = av_fetch(av, elem, lval);
2319 if (lval) {
3280af22 2320 if (!svp || *svp == &PL_sv_undef)
a0d0e21e 2321 DIE(no_aelem, elem);
533c011a 2322 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2323 save_aelem(av, elem, svp);
79072805 2324 }
3280af22 2325 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2326 }
2327 }
748a9306 2328 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 2329 MARK = ORIGMARK;
2330 *++MARK = *SP;
2331 SP = MARK;
2332 }
79072805
LW		 2333 RETURN;
2334}
2335
2336/* Associative arrays. */
2337
2338PP(pp_each)
2339{
4e35701f 2340 djSP; dTARGET;
79072805 2341 HV *hash = (HV*)POPs;
c07a80fd 2342 HE *entry;
54310121 2343 I32 gimme = GIMME_V;
c750a3ec 2344 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2345
c07a80fd 2346 PUTBACK;
c750a3ec
MB		 2347 /* might clobber stack_sp */
2348 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2349 SPAGAIN;
79072805 2350
79072805
LW		 2351 EXTEND(SP, 2);
2352 if (entry) {
54310121 2353 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2354 if (gimme == G_ARRAY) {
c07a80fd 2355 PUTBACK;
c750a3ec
MB		 2356 /* might clobber stack_sp */
2357 sv_setsv(TARG, realhv ?
2358 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
c07a80fd 2359 SPAGAIN;
8990e307 2360 PUSHs(TARG);
79072805 2361 }
79072805 2362 }
54310121 2363 else if (gimme == G_SCALAR)
79072805
LW		 2364 RETPUSHUNDEF;
2365
2366 RETURN;
2367}
2368
2369PP(pp_values)
2370{
2371 return do_kv(ARGS);
2372}
2373
2374PP(pp_keys)
2375{
2376 return do_kv(ARGS);
2377}
2378
2379PP(pp_delete)
2380{
4e35701f 2381 djSP;
54310121 2382 I32 gimme = GIMME_V;
2383 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2384 SV *sv;
5f05dabc 2385 HV *hv;
2386
533c011a 2387 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2388 dMARK; dORIGMARK;
97fcbf96 2389 U32 hvtype;
5f05dabc 2390 hv = (HV*)POPs;
97fcbf96 2391 hvtype = SvTYPE(hv);
5f05dabc 2392 while (++MARK <= SP) {
ae77835f
MB		 2393 if (hvtype == SVt_PVHV)
2394 sv = hv_delete_ent(hv, *MARK, discard, 0);
ae77835f
MB		 2395 else
2396 DIE("Not a HASH reference");
3280af22 2397 *MARK = sv ? sv : &PL_sv_undef;
5f05dabc 2398 }
54310121 2399 if (discard)
2400 SP = ORIGMARK;
2401 else if (gimme == G_SCALAR) {
5f05dabc 2402 MARK = ORIGMARK;
2403 *++MARK = *SP;
2404 SP = MARK;
2405 }
2406 }
2407 else {
2408 SV *keysv = POPs;
2409 hv = (HV*)POPs;
97fcbf96
MB		 2410 if (SvTYPE(hv) == SVt_PVHV)
2411 sv = hv_delete_ent(hv, keysv, discard, 0);
97fcbf96 2412 else
5f05dabc 2413 DIE("Not a HASH reference");
5f05dabc 2414 if (!sv)
3280af22 2415 sv = &PL_sv_undef;
54310121 2416 if (!discard)
2417 PUSHs(sv);
79072805 2418 }
79072805
LW		 2419 RETURN;
2420}
2421
a0d0e21e 2422PP(pp_exists)
79072805 2423{
4e35701f 2424 djSP;
a0d0e21e
LW		 2425 SV *tmpsv = POPs;
2426 HV *hv = (HV*)POPs;
c750a3ec 2427 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2428 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec
MB		 2429 RETPUSHYES;
2430 } else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2431 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec
MB		 2432 RETPUSHYES;
2433 } else {
a0d0e21e
LW		 2434 DIE("Not a HASH reference");
2435 }
a0d0e21e
LW		 2436 RETPUSHNO;
2437}
79072805 2438
a0d0e21e
LW		 2439PP(pp_hslice)
2440{
4e35701f 2441 djSP; dMARK; dORIGMARK;
a0d0e21e 2442 register HV *hv = (HV*)POPs;
533c011a 2443 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2444 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2445
0ebe0038
SM		 2446 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2447 DIE("Can't localize pseudo-hash element");
2448
c750a3ec 2449 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2450 while (++MARK <= SP) {
f12c7020 2451 SV *keysv = *MARK;
ae77835f
MB		 2452 SV **svp;
2453 if (realhv) {
800e9ae0 2454 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f
MB		 2455 svp = he ? &HeVAL(he) : 0;
2456 } else {
97fcbf96 2457 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2458 }
a0d0e21e 2459 if (lval) {
3280af22
NIS		 2460 if (!svp || *svp == &PL_sv_undef)
2461 DIE(no_helem, SvPV(keysv, PL_na));
533c011a 2462 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2463 save_helem(hv, keysv, svp);
93a17b20 2464 }
3280af22 2465 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2466 }
2467 }
a0d0e21e
LW		 2468 if (GIMME != G_ARRAY) {
2469 MARK = ORIGMARK;
2470 *++MARK = *SP;
2471 SP = MARK;
79072805 2472 }
a0d0e21e
LW		 2473 RETURN;
2474}
2475
2476/* List operators. */
2477
2478PP(pp_list)
2479{
4e35701f 2480 djSP; dMARK;
a0d0e21e
LW		 2481 if (GIMME != G_ARRAY) {
2482 if (++MARK <= SP)
2483 *MARK = *SP; /* unwanted list, return last item */
8990e307 2484 else
3280af22 2485 *MARK = &PL_sv_undef;
a0d0e21e 2486 SP = MARK;
79072805 2487 }
a0d0e21e 2488 RETURN;
79072805
LW		 2489}
2490
a0d0e21e 2491PP(pp_lslice)
79072805 2492{
4e35701f 2493 djSP;
3280af22
NIS		 2494 SV **lastrelem = PL_stack_sp;
2495 SV **lastlelem = PL_stack_base + POPMARK;
2496 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2497 register SV **firstrelem = lastlelem + 1;
3280af22 2498 I32 arybase = PL_curcop->cop_arybase;
533c011a 2499 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2500 I32 is_something_there = lval;
79072805 2501
a0d0e21e
LW		 2502 register I32 max = lastrelem - lastlelem;
2503 register SV **lelem;
2504 register I32 ix;
2505
2506 if (GIMME != G_ARRAY) {
748a9306
LW		 2507 ix = SvIVx(*lastlelem);
2508 if (ix < 0)
2509 ix += max;
2510 else
2511 ix -= arybase;
a0d0e21e 2512 if (ix < 0 || ix >= max)
3280af22 2513 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 2514 else
2515 *firstlelem = firstrelem[ix];
2516 SP = firstlelem;
2517 RETURN;
2518 }
2519
2520 if (max == 0) {
2521 SP = firstlelem - 1;
2522 RETURN;
2523 }
2524
2525 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2526 ix = SvIVx(*lelem);
a0d0e21e
LW		 2527 if (ix < 0) {
2528 ix += max;
2529 if (ix < 0)
3280af22 2530 *lelem = &PL_sv_undef;
a0d0e21e 2531 else if (!(*lelem = firstrelem[ix]))
3280af22 2532 *lelem = &PL_sv_undef;
79072805 2533 }
748a9306
LW		 2534 else {
2535 ix -= arybase;
2536 if (ix >= max || !(*lelem = firstrelem[ix]))
3280af22 2537 *lelem = &PL_sv_undef;
748a9306 2538 }
ff0cee69 2539 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
4633a7c4 2540 is_something_there = TRUE;
79072805 2541 }
4633a7c4
LW		 2542 if (is_something_there)
2543 SP = lastlelem;
2544 else
2545 SP = firstlelem - 1;
79072805
LW		 2546 RETURN;
2547}
2548
a0d0e21e
LW		 2549PP(pp_anonlist)
2550{
4e35701f 2551 djSP; dMARK; dORIGMARK;
a0d0e21e 2552 I32 items = SP - MARK;
44a8e56a 2553 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2554 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2555 XPUSHs(av);
a0d0e21e
LW		 2556 RETURN;
2557}
2558
2559PP(pp_anonhash)
79072805 2560{
4e35701f 2561 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2562 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2563
2564 while (MARK < SP) {
2565 SV* key = *++MARK;
a0d0e21e
LW		 2566 SV *val = NEWSV(46, 0);
2567 if (MARK < SP)
2568 sv_setsv(val, *++MARK);
3280af22 2569 else if (PL_dowarn)
1930e939 2570 warn("Odd number of elements in hash assignment");
f12c7020 2571 (void)hv_store_ent(hv,key,val,0);
79072805 2572 }
a0d0e21e
LW		 2573 SP = ORIGMARK;
2574 XPUSHs((SV*)hv);
79072805
LW		 2575 RETURN;
2576}
2577
a0d0e21e 2578PP(pp_splice)
79072805 2579{
4e35701f 2580 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2581 register AV *ary = (AV*)*++MARK;
2582 register SV **src;
2583 register SV **dst;
2584 register I32 i;
2585 register I32 offset;
2586 register I32 length;
2587 I32 newlen;
2588 I32 after;
2589 I32 diff;
2590 SV **tmparyval = 0;
93965878
NIS		 2591 MAGIC *mg;
2592
ece095e7
CS		 2593 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2594 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2595 PUSHMARK(MARK);
8ec5e241 2596 PUTBACK;
a60c0954 2597 ENTER;
93965878 2598 perl_call_method("SPLICE",GIMME_V);
a60c0954 2599 LEAVE;
93965878
NIS		 2600 SPAGAIN;
2601 RETURN;
2602 }
79072805 2603
a0d0e21e 2604 SP++;
79072805 2605
a0d0e21e 2606 if (++MARK < SP) {
84902520 2607 offset = i = SvIVx(*MARK);
a0d0e21e 2608 if (offset < 0)
93965878 2609 offset += AvFILLp(ary) + 1;
a0d0e21e 2610 else
3280af22 2611 offset -= PL_curcop->cop_arybase;
84902520
TB		 2612 if (offset < 0)
2613 DIE(no_aelem, i);
a0d0e21e
LW		 2614 if (++MARK < SP) {
2615 length = SvIVx(*MARK++);
48cdf507
GA		 2616 if (length < 0) {
2617 length += AvFILLp(ary) - offset + 1;
2618 if (length < 0)
2619 length = 0;
2620 }
79072805
LW		 2621 }
2622 else
a0d0e21e 2623 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2624 }
a0d0e21e
LW		 2625 else {
2626 offset = 0;
2627 length = AvMAX(ary) + 1;
2628 }
93965878
NIS		 2629 if (offset > AvFILLp(ary) + 1)
2630 offset = AvFILLp(ary) + 1;
2631 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 2632 if (after < 0) { /* not that much array */
2633 length += after; /* offset+length now in array */
2634 after = 0;
2635 if (!AvALLOC(ary))
2636 av_extend(ary, 0);
2637 }
2638
2639 /* At this point, MARK .. SP-1 is our new LIST */
2640
2641 newlen = SP - MARK;
2642 diff = newlen - length;
fb73857a 2643 if (newlen && !AvREAL(ary)) {
2644 if (AvREIFY(ary))
2645 av_reify(ary);
2646 else
2647 assert(AvREAL(ary)); /* would leak, so croak */
2648 }
a0d0e21e
LW		 2649
2650 if (diff < 0) { /* shrinking the area */
2651 if (newlen) {
2652 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2653 Copy(MARK, tmparyval, newlen, SV*);
79072805 2654 }
a0d0e21e
LW		 2655
2656 MARK = ORIGMARK + 1;
2657 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2658 MEXTEND(MARK, length);
2659 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2660 if (AvREAL(ary)) {
bbce6d69 2661 EXTEND_MORTAL(length);
36477c24 2662 for (i = length, dst = MARK; i; i--) {
d689ffdd 2663 sv_2mortal(*dst); /* free them eventualy */
36477c24 2664 dst++;
2665 }
a0d0e21e
LW		 2666 }
2667 MARK += length - 1;
79072805 2668 }
a0d0e21e
LW		 2669 else {
2670 *MARK = AvARRAY(ary)[offset+length-1];
2671 if (AvREAL(ary)) {
d689ffdd 2672 sv_2mortal(*MARK);
a0d0e21e
LW		 2673 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2674 SvREFCNT_dec(*dst++); /* free them now */
79072805 2675 }
a0d0e21e 2676 }
93965878 2677 AvFILLp(ary) += diff;
a0d0e21e
LW		 2678
2679 /* pull up or down? */
2680
2681 if (offset < after) { /* easier to pull up */
2682 if (offset) { /* esp. if nothing to pull */
2683 src = &AvARRAY(ary)[offset-1];
2684 dst = src - diff; /* diff is negative */
2685 for (i = offset; i > 0; i--) /* can't trust Copy */
2686 *dst-- = *src--;
79072805 2687 }
a0d0e21e
LW		 2688 dst = AvARRAY(ary);
2689 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2690 AvMAX(ary) += diff;
2691 }
2692 else {
2693 if (after) { /* anything to pull down? */
2694 src = AvARRAY(ary) + offset + length;
2695 dst = src + diff; /* diff is negative */
2696 Move(src, dst, after, SV*);
79072805 2697 }
93965878 2698 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 2699 /* avoid later double free */
2700 }
2701 i = -diff;
2702 while (i)
3280af22 2703 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 2704
2705 if (newlen) {
2706 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2707 newlen; newlen--) {
2708 *dst = NEWSV(46, 0);
2709 sv_setsv(*dst++, *src++);
79072805 2710 }
a0d0e21e
LW		 2711 Safefree(tmparyval);
2712 }
2713 }
2714 else { /* no, expanding (or same) */
2715 if (length) {
2716 New(452, tmparyval, length, SV*); /* so remember deletion */
2717 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2718 }
2719
2720 if (diff > 0) { /* expanding */
2721
2722 /* push up or down? */
2723
2724 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2725 if (offset) {
2726 src = AvARRAY(ary);
2727 dst = src - diff;
2728 Move(src, dst, offset, SV*);
79072805 2729 }
a0d0e21e
LW		 2730 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2731 AvMAX(ary) += diff;
93965878 2732 AvFILLp(ary) += diff;
79072805
LW		 2733 }
2734 else {
93965878
NIS		 2735 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2736 av_extend(ary, AvFILLp(ary) + diff);
2737 AvFILLp(ary) += diff;
a0d0e21e
LW		 2738
2739 if (after) {
93965878 2740 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 2741 src = dst - diff;
2742 for (i = after; i; i--) {
2743 *dst-- = *src--;
2744 }
79072805
LW		 2745 }
2746 }
a0d0e21e
LW		 2747 }
2748
2749 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2750 *dst = NEWSV(46, 0);
2751 sv_setsv(*dst++, *src++);
2752 }
2753 MARK = ORIGMARK + 1;
2754 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2755 if (length) {
2756 Copy(tmparyval, MARK, length, SV*);
2757 if (AvREAL(ary)) {
bbce6d69 2758 EXTEND_MORTAL(length);
36477c24 2759 for (i = length, dst = MARK; i; i--) {
d689ffdd 2760 sv_2mortal(*dst); /* free them eventualy */
36477c24 2761 dst++;
2762 }
79072805 2763 }
a0d0e21e 2764 Safefree(tmparyval);
79072805 2765 }
a0d0e21e
LW		 2766 MARK += length - 1;
2767 }
2768 else if (length--) {
2769 *MARK = tmparyval[length];
2770 if (AvREAL(ary)) {
d689ffdd 2771 sv_2mortal(*MARK);
a0d0e21e
LW		 2772 while (length-- > 0)
2773 SvREFCNT_dec(tmparyval[length]);
79072805 2774 }
a0d0e21e 2775 Safefree(tmparyval);
79072805 2776 }
a0d0e21e 2777 else
3280af22 2778 *MARK = &PL_sv_undef;
79072805 2779 }
a0d0e21e 2780 SP = MARK;
79072805
LW		 2781 RETURN;
2782}
2783
a0d0e21e 2784PP(pp_push)
79072805 2785{
4e35701f 2786 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 2787 register AV *ary = (AV*)*++MARK;
3280af22 2788 register SV *sv = &PL_sv_undef;
93965878 2789 MAGIC *mg;
79072805 2790
ece095e7
CS		 2791 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2792 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 2793 PUSHMARK(MARK);
2794 PUTBACK;
a60c0954
NIS		 2795 ENTER;
2796 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2797 LEAVE;
93965878 2798 SPAGAIN;
93965878 2799 }
a60c0954
NIS		 2800 else {
2801 /* Why no pre-extend of ary here ? */
2802 for (++MARK; MARK <= SP; MARK++) {
2803 sv = NEWSV(51, 0);
2804 if (*MARK)
2805 sv_setsv(sv, *MARK);
2806 av_push(ary, sv);
2807 }
79072805
LW		 2808 }
2809 SP = ORIGMARK;
a0d0e21e 2810 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 2811 RETURN;
2812}
2813
a0d0e21e 2814PP(pp_pop)
79072805 2815{
4e35701f 2816 djSP;
a0d0e21e
LW		 2817 AV *av = (AV*)POPs;
2818 SV *sv = av_pop(av);
d689ffdd 2819 if (AvREAL(av))
a0d0e21e
LW		 2820 (void)sv_2mortal(sv);
2821 PUSHs(sv);
79072805 2822 RETURN;
79072805
LW		 2823}
2824
a0d0e21e 2825PP(pp_shift)
79072805 2826{
4e35701f 2827 djSP;
a0d0e21e
LW		 2828 AV *av = (AV*)POPs;
2829 SV *sv = av_shift(av);
79072805 2830 EXTEND(SP, 1);
a0d0e21e 2831 if (!sv)
79072805 2832 RETPUSHUNDEF;
d689ffdd 2833 if (AvREAL(av))
a0d0e21e
LW		 2834 (void)sv_2mortal(sv);
2835 PUSHs(sv);
79072805 2836 RETURN;
79072805
LW		 2837}
2838
a0d0e21e 2839PP(pp_unshift)
79072805 2840{
4e35701f 2841 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 2842 register AV *ary = (AV*)*++MARK;
2843 register SV *sv;
2844 register I32 i = 0;
93965878
NIS		 2845 MAGIC *mg;
2846
ece095e7
CS		 2847 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2848 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 2849 PUSHMARK(MARK);
93965878 2850 PUTBACK;
a60c0954
NIS		 2851 ENTER;
2852 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2853 LEAVE;
93965878 2854 SPAGAIN;
93965878 2855 }
a60c0954
NIS		 2856 else {
2857 av_unshift(ary, SP - MARK);
2858 while (MARK < SP) {
2859 sv = NEWSV(27, 0);
2860 sv_setsv(sv, *++MARK);
2861 (void)av_store(ary, i++, sv);
2862 }
79072805 2863 }
a0d0e21e
LW		 2864 SP = ORIGMARK;
2865 PUSHi( AvFILL(ary) + 1 );
79072805 2866 RETURN;
79072805
LW		 2867}
2868
a0d0e21e 2869PP(pp_reverse)
79072805 2870{
4e35701f 2871 djSP; dMARK;
a0d0e21e
LW		 2872 register SV *tmp;
2873 SV **oldsp = SP;
79072805 2874
a0d0e21e
LW		 2875 if (GIMME == G_ARRAY) {
2876 MARK++;
2877 while (MARK < SP) {
2878 tmp = *MARK;
2879 *MARK++ = *SP;
2880 *SP-- = tmp;
2881 }
2882 SP = oldsp;
79072805
LW		 2883 }
2884 else {
a0d0e21e
LW		 2885 register char *up;
2886 register char *down;
2887 register I32 tmp;
2888 dTARGET;
2889 STRLEN len;
79072805 2890
a0d0e21e 2891 if (SP - MARK > 1)
3280af22 2892 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 2893 else
54b9620d 2894 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 2895 up = SvPV_force(TARG, len);
2896 if (len > 1) {
2897 down = SvPVX(TARG) + len - 1;
2898 while (down > up) {
2899 tmp = *up;
2900 *up++ = *down;
2901 *down-- = tmp;
2902 }
2903 (void)SvPOK_only(TARG);
79072805 2904 }
a0d0e21e
LW		 2905 SP = MARK + 1;
2906 SETTARG;
79072805 2907 }
a0d0e21e 2908 RETURN;
79072805
LW		 2909}
2910
76e3520e 2911STATIC SV *
8ac85365 2912mul128(SV *sv, U8 m)
55497cff 2913{
2914 STRLEN len;
2915 char *s = SvPV(sv, len);
2916 char *t;
2917 U32 i = 0;
2918
2919 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
09b7f37c 2920 SV *tmpNew = newSVpv("0000000000", 10);
55497cff 2921
09b7f37c 2922 sv_catsv(tmpNew, sv);
55497cff 2923 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 2924 sv = tmpNew;
55497cff 2925 s = SvPV(sv, len);
2926 }
2927 t = s + len - 1;
2928 while (!*t) /* trailing '\0'? */
2929 t--;
2930 while (t > s) {
2931 i = ((*t - '0') << 7) + m;
2932 *(t--) = '0' + (i % 10);
2933 m = i / 10;
2934 }
2935 return (sv);
2936}
2937
a0d0e21e
LW		 2938/* Explosives and implosives. */
2939
9d116dd7
JH		 2940static const char uuemap[] =
2941 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
2942static char uudmap[256]; /* Initialised on first use */
2943#if 'I' == 73 && 'J' == 74
2944/* On an ASCII/ISO kind of system */
ba1ac976 2945#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH		 2946#else
2947/*
2948 Some other sort of character set - use memchr() so we don't match
2949 the null byte.
2950 */
ba1ac976 2951#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
9d116dd7
JH		 2952#endif
2953
a0d0e21e 2954PP(pp_unpack)
79072805 2955{
4e35701f 2956 djSP;
a0d0e21e 2957 dPOPPOPssrl;
924508f0 2958 SV **oldsp = SP;
54310121 2959 I32 gimme = GIMME_V;
ed6116ce 2960 SV *sv;
a0d0e21e
LW		 2961 STRLEN llen;
2962 STRLEN rlen;
2963 register char *pat = SvPV(left, llen);
2964 register char *s = SvPV(right, rlen);
2965 char *strend = s + rlen;
2966 char *strbeg = s;
2967 register char *patend = pat + llen;
2968 I32 datumtype;
2969 register I32 len;
2970 register I32 bits;
79072805 2971
a0d0e21e
LW		 2972 /* These must not be in registers: */
2973 I16 ashort;
2974 int aint;
2975 I32 along;
ecfc5424
AD		 2976#ifdef HAS_QUAD
2977 Quad_t aquad;
a0d0e21e
LW		 2978#endif
2979 U16 aushort;
2980 unsigned int auint;
2981 U32 aulong;
ecfc5424
AD		 2982#ifdef HAS_QUAD
2983 unsigned Quad_t auquad;
a0d0e21e
LW		 2984#endif
2985 char *aptr;
2986 float afloat;
2987 double adouble;
2988 I32 checksum = 0;
2989 register U32 culong;
2990 double cdouble;
2991 static char* bitcount = 0;
fb73857a 2992 int commas = 0;
79072805 2993
54310121 2994 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 2995 /*SUPPRESS 530*/
2996 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
748a9306 2997 if (strchr("aAbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 2998 patend++;
2999 while (isDIGIT(*patend) || *patend == '*')
3000 patend++;
3001 }
3002 else
3003 patend++;
79072805 3004 }
a0d0e21e
LW		 3005 while (pat < patend) {
3006 reparse:
bbdab043
CS		 3007 datumtype = *pat++ & 0xFF;
3008 if (isSPACE(datumtype))
3009 continue;
a0d0e21e
LW		 3010 if (pat >= patend)
3011 len = 1;
3012 else if (*pat == '*') {
3013 len = strend - strbeg; /* long enough */
3014 pat++;
3015 }
3016 else if (isDIGIT(*pat)) {
3017 len = *pat++ - '0';
3018 while (isDIGIT(*pat))
3019 len = (len * 10) + (*pat++ - '0');
3020 }
3021 else
3022 len = (datumtype != '@');
3023 switch(datumtype) {
3024 default:
bbdab043 3025 croak("Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3026 case ',': /* grandfather in commas but with a warning */
3280af22 3027 if (commas++ == 0 && PL_dowarn)
fb73857a 3028 warn("Invalid type in unpack: '%c'", (int)datumtype);
3029 break;
a0d0e21e
LW		 3030 case '%':
3031 if (len == 1 && pat[-1] != '1')
3032 len = 16;
3033 checksum = len;
3034 culong = 0;
3035 cdouble = 0;
3036 if (pat < patend)
3037 goto reparse;
3038 break;
3039 case '@':
3040 if (len > strend - strbeg)
3041 DIE("@ outside of string");
3042 s = strbeg + len;
3043 break;
3044 case 'X':
3045 if (len > s - strbeg)
3046 DIE("X outside of string");
3047 s -= len;
3048 break;
3049 case 'x':
3050 if (len > strend - s)
3051 DIE("x outside of string");
3052 s += len;
3053 break;
3054 case 'A':
3055 case 'a':
3056 if (len > strend - s)
3057 len = strend - s;
3058 if (checksum)
3059 goto uchar_checksum;
3060 sv = NEWSV(35, len);
3061 sv_setpvn(sv, s, len);
3062 s += len;
3063 if (datumtype == 'A') {
3064 aptr = s; /* borrow register */
3065 s = SvPVX(sv) + len - 1;
3066 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3067 s--;
3068 *++s = '\0';
3069 SvCUR_set(sv, s - SvPVX(sv));
3070 s = aptr; /* unborrow register */
3071 }
3072 XPUSHs(sv_2mortal(sv));
3073 break;
3074 case 'B':
3075 case 'b':
3076 if (pat[-1] == '*' || len > (strend - s) * 8)
3077 len = (strend - s) * 8;
3078 if (checksum) {
3079 if (!bitcount) {
3080 Newz(601, bitcount, 256, char);
3081 for (bits = 1; bits < 256; bits++) {
3082 if (bits & 1) bitcount[bits]++;
3083 if (bits & 2) bitcount[bits]++;
3084 if (bits & 4) bitcount[bits]++;
3085 if (bits & 8) bitcount[bits]++;
3086 if (bits & 16) bitcount[bits]++;
3087 if (bits & 32) bitcount[bits]++;
3088 if (bits & 64) bitcount[bits]++;
3089 if (bits & 128) bitcount[bits]++;
3090 }
3091 }
3092 while (len >= 8) {
3093 culong += bitcount[*(unsigned char*)s++];
3094 len -= 8;
3095 }
3096 if (len) {
3097 bits = *s;
3098 if (datumtype == 'b') {
3099 while (len-- > 0) {
3100 if (bits & 1) culong++;
3101 bits >>= 1;
3102 }
3103 }
3104 else {
3105 while (len-- > 0) {
3106 if (bits & 128) culong++;
3107 bits <<= 1;
3108 }
3109 }
3110 }
79072805
LW		 3111 break;
3112 }
a0d0e21e
LW		 3113 sv = NEWSV(35, len + 1);
3114 SvCUR_set(sv, len);
3115 SvPOK_on(sv);
3116 aptr = pat; /* borrow register */
3117 pat = SvPVX(sv);
3118 if (datumtype == 'b') {
3119 aint = len;
3120 for (len = 0; len < aint; len++) {
3121 if (len & 7) /*SUPPRESS 595*/
3122 bits >>= 1;
3123 else
3124 bits = *s++;
3125 *pat++ = '0' + (bits & 1);
3126 }
3127 }
3128 else {
3129 aint = len;
3130 for (len = 0; len < aint; len++) {
3131 if (len & 7)
3132 bits <<= 1;
3133 else
3134 bits = *s++;
3135 *pat++ = '0' + ((bits & 128) != 0);
3136 }
3137 }
3138 *pat = '\0';
3139 pat = aptr; /* unborrow register */
3140 XPUSHs(sv_2mortal(sv));
3141 break;
3142 case 'H':
3143 case 'h':
3144 if (pat[-1] == '*' || len > (strend - s) * 2)
3145 len = (strend - s) * 2;
3146 sv = NEWSV(35, len + 1);
3147 SvCUR_set(sv, len);
3148 SvPOK_on(sv);
3149 aptr = pat; /* borrow register */
3150 pat = SvPVX(sv);
3151 if (datumtype == 'h') {
3152 aint = len;
3153 for (len = 0; len < aint; len++) {
3154 if (len & 1)
3155 bits >>= 4;
3156 else
3157 bits = *s++;
3280af22 3158 *pat++ = PL_hexdigit[bits & 15];
a0d0e21e
LW		 3159 }
3160 }
3161 else {
3162 aint = len;
3163 for (len = 0; len < aint; len++) {
3164 if (len & 1)
3165 bits <<= 4;
3166 else
3167 bits = *s++;
3280af22 3168 *pat++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW		 3169 }
3170 }
3171 *pat = '\0';
3172 pat = aptr; /* unborrow register */
3173 XPUSHs(sv_2mortal(sv));
3174 break;
3175 case 'c':
3176 if (len > strend - s)
3177 len = strend - s;
3178 if (checksum) {
3179 while (len-- > 0) {
3180 aint = *s++;
3181 if (aint >= 128) /* fake up signed chars */
3182 aint -= 256;
3183 culong += aint;
3184 }
3185 }
3186 else {
3187 EXTEND(SP, len);
bbce6d69 3188 EXTEND_MORTAL(len);
a0d0e21e
LW		 3189 while (len-- > 0) {
3190 aint = *s++;
3191 if (aint >= 128) /* fake up signed chars */
3192 aint -= 256;
3193 sv = NEWSV(36, 0);
1e422769 3194 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3195 PUSHs(sv_2mortal(sv));
3196 }
3197 }
3198 break;
3199 case 'C':
3200 if (len > strend - s)
3201 len = strend - s;
3202 if (checksum) {
3203 uchar_checksum:
3204 while (len-- > 0) {
3205 auint = *s++ & 255;
3206 culong += auint;
3207 }
3208 }
3209 else {
3210 EXTEND(SP, len);
bbce6d69 3211 EXTEND_MORTAL(len);
a0d0e21e
LW		 3212 while (len-- > 0) {
3213 auint = *s++ & 255;
3214 sv = NEWSV(37, 0);
1e422769 3215 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3216 PUSHs(sv_2mortal(sv));
3217 }
3218 }
3219 break;
3220 case 's':
96e4d5b1 3221 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3222 if (len > along)
3223 len = along;
3224 if (checksum) {
3225 while (len-- > 0) {
96e4d5b1 3226 COPY16(s, &ashort);
3227 s += SIZE16;
a0d0e21e
LW		 3228 culong += ashort;
3229 }
3230 }
3231 else {
3232 EXTEND(SP, len);
bbce6d69 3233 EXTEND_MORTAL(len);
a0d0e21e 3234 while (len-- > 0) {
96e4d5b1 3235 COPY16(s, &ashort);
3236 s += SIZE16;
a0d0e21e 3237 sv = NEWSV(38, 0);
1e422769 3238 sv_setiv(sv, (IV)ashort);
a0d0e21e
LW		 3239 PUSHs(sv_2mortal(sv));
3240 }
3241 }
3242 break;
3243 case 'v':
3244 case 'n':
3245 case 'S':
96e4d5b1 3246 along = (strend - s) / SIZE16;
a0d0e21e
LW		 3247 if (len > along)
3248 len = along;
3249 if (checksum) {
3250 while (len-- > 0) {
96e4d5b1 3251 COPY16(s, &aushort);
3252 s += SIZE16;
a0d0e21e
LW		 3253#ifdef HAS_NTOHS
3254 if (datumtype == 'n')
6ad3d225 3255 aushort = PerlSock_ntohs(aushort);
79072805 3256#endif
a0d0e21e
LW		 3257#ifdef HAS_VTOHS
3258 if (datumtype == 'v')
3259 aushort = vtohs(aushort);
79072805 3260#endif
a0d0e21e
LW		 3261 culong += aushort;
3262 }
3263 }
3264 else {
3265 EXTEND(SP, len);
bbce6d69 3266 EXTEND_MORTAL(len);
a0d0e21e 3267 while (len-- > 0) {
96e4d5b1 3268 COPY16(s, &aushort);
3269 s += SIZE16;
a0d0e21e
LW		 3270 sv = NEWSV(39, 0);
3271#ifdef HAS_NTOHS
3272 if (datumtype == 'n')
6ad3d225 3273 aushort = PerlSock_ntohs(aushort);
79072805 3274#endif
a0d0e21e
LW		 3275#ifdef HAS_VTOHS
3276 if (datumtype == 'v')
3277 aushort = vtohs(aushort);
79072805 3278#endif
1e422769 3279 sv_setiv(sv, (IV)aushort);
a0d0e21e
LW		 3280 PUSHs(sv_2mortal(sv));
3281 }
3282 }
3283 break;
3284 case 'i':
3285 along = (strend - s) / sizeof(int);
3286 if (len > along)
3287 len = along;
3288 if (checksum) {
3289 while (len-- > 0) {
3290 Copy(s, &aint, 1, int);
3291 s += sizeof(int);
3292 if (checksum > 32)
3293 cdouble += (double)aint;
3294 else
3295 culong += aint;
3296 }
3297 }
3298 else {
3299 EXTEND(SP, len);
bbce6d69 3300 EXTEND_MORTAL(len);
a0d0e21e
LW		 3301 while (len-- > 0) {
3302 Copy(s, &aint, 1, int);
3303 s += sizeof(int);
3304 sv = NEWSV(40, 0);
20408e3c
GS		 3305#ifdef __osf__
3306 /* Without the dummy below unpack("i", pack("i",-1))
3307 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3308 * cc with optimization turned on */
3309 (aint) ?
3310 sv_setiv(sv, (IV)aint) :
3311#endif
1e422769 3312 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3313 PUSHs(sv_2mortal(sv));
3314 }
3315 }
3316 break;
3317 case 'I':
3318 along = (strend - s) / sizeof(unsigned int);
3319 if (len > along)
3320 len = along;
3321 if (checksum) {
3322 while (len-- > 0) {
3323 Copy(s, &auint, 1, unsigned int);
3324 s += sizeof(unsigned int);
3325 if (checksum > 32)
3326 cdouble += (double)auint;
3327 else
3328 culong += auint;
3329 }
3330 }
3331 else {
3332 EXTEND(SP, len);
bbce6d69 3333 EXTEND_MORTAL(len);
a0d0e21e
LW		 3334 while (len-- > 0) {
3335 Copy(s, &auint, 1, unsigned int);
3336 s += sizeof(unsigned int);
3337 sv = NEWSV(41, 0);
1e422769 3338 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3339 PUSHs(sv_2mortal(sv));
3340 }
3341 }
3342 break;
3343 case 'l':
96e4d5b1 3344 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3345 if (len > along)
3346 len = along;
3347 if (checksum) {
3348 while (len-- > 0) {
96e4d5b1 3349 COPY32(s, &along);
3350 s += SIZE32;
a0d0e21e
LW		 3351 if (checksum > 32)
3352 cdouble += (double)along;
3353 else
3354 culong += along;
3355 }
3356 }
3357 else {
3358 EXTEND(SP, len);
bbce6d69 3359 EXTEND_MORTAL(len);
a0d0e21e 3360 while (len-- > 0) {
96e4d5b1 3361 COPY32(s, &along);
3362 s += SIZE32;
a0d0e21e 3363 sv = NEWSV(42, 0);
1e422769 3364 sv_setiv(sv, (IV)along);
a0d0e21e
LW		 3365 PUSHs(sv_2mortal(sv));
3366 }
79072805 3367 }
a0d0e21e
LW		 3368 break;
3369 case 'V':
3370 case 'N':
3371 case 'L':
96e4d5b1 3372 along = (strend - s) / SIZE32;
a0d0e21e
LW		 3373 if (len > along)
3374 len = along;
3375 if (checksum) {
3376 while (len-- > 0) {
96e4d5b1 3377 COPY32(s, &aulong);
3378 s += SIZE32;
a0d0e21e
LW		 3379#ifdef HAS_NTOHL
3380 if (datumtype == 'N')
6ad3d225 3381 aulong = PerlSock_ntohl(aulong);
79072805 3382#endif
a0d0e21e
LW		 3383#ifdef HAS_VTOHL
3384 if (datumtype == 'V')
3385 aulong = vtohl(aulong);
79072805 3386#endif
a0d0e21e
LW		 3387 if (checksum > 32)
3388 cdouble += (double)aulong;
3389 else
3390 culong += aulong;
3391 }
3392 }
3393 else {
3394 EXTEND(SP, len);
bbce6d69 3395 EXTEND_MORTAL(len);
a0d0e21e 3396 while (len-- > 0) {
96e4d5b1 3397 COPY32(s, &aulong);
3398 s += SIZE32;
a0d0e21e
LW		 3399#ifdef HAS_NTOHL
3400 if (datumtype == 'N')
6ad3d225 3401 aulong = PerlSock_ntohl(aulong);
79072805 3402#endif
a0d0e21e
LW		 3403#ifdef HAS_VTOHL
3404 if (datumtype == 'V')
3405 aulong = vtohl(aulong);
79072805 3406#endif
1e422769 3407 sv = NEWSV(43, 0);
3408 sv_setuv(sv, (UV)aulong);
a0d0e21e
LW		 3409 PUSHs(sv_2mortal(sv));
3410 }
3411 }
3412 break;
3413 case 'p':
3414 along = (strend - s) / sizeof(char*);
3415 if (len > along)
3416 len = along;
3417 EXTEND(SP, len);
bbce6d69 3418 EXTEND_MORTAL(len);
a0d0e21e
LW		 3419 while (len-- > 0) {
3420 if (sizeof(char*) > strend - s)
3421 break;
3422 else {
3423 Copy(s, &aptr, 1, char*);
3424 s += sizeof(char*);
3425 }
3426 sv = NEWSV(44, 0);
3427 if (aptr)
3428 sv_setpv(sv, aptr);
3429 PUSHs(sv_2mortal(sv));
3430 }
3431 break;
def98dd4 3432 case 'w':
def98dd4 3433 EXTEND(SP, len);
bbce6d69 3434 EXTEND_MORTAL(len);
8ec5e241 3435 {
bbce6d69 3436 UV auv = 0;
3437 U32 bytes = 0;
3438
3439 while ((len > 0) && (s < strend)) {
3440 auv = (auv << 7) | (*s & 0x7f);
3441 if (!(*s++ & 0x80)) {
3442 bytes = 0;
3443 sv = NEWSV(40, 0);
3444 sv_setuv(sv, auv);
3445 PUSHs(sv_2mortal(sv));
3446 len--;
3447 auv = 0;
3448 }
3449 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 3450 char *t;
3451
fc36a67e 3452 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69 3453 while (s < strend) {
3454 sv = mul128(sv, *s & 0x7f);
3455 if (!(*s++ & 0x80)) {
3456 bytes = 0;
3457 break;
3458 }
3459 }
3280af22 3460 t = SvPV(sv, PL_na);
bbce6d69 3461 while (*t == '0')
3462 t++;
3463 sv_chop(sv, t);
3464 PUSHs(sv_2mortal(sv));
3465 len--;
3466 auv = 0;
3467 }
3468 }
3469 if ((s >= strend) && bytes)
3470 croak("Unterminated compressed integer");
3471 }
def98dd4 3472 break;
a0d0e21e
LW		 3473 case 'P':
3474 EXTEND(SP, 1);
3475 if (sizeof(char*) > strend - s)
3476 break;
3477 else {
3478 Copy(s, &aptr, 1, char*);
3479 s += sizeof(char*);
3480 }
3481 sv = NEWSV(44, 0);
3482 if (aptr)
3483 sv_setpvn(sv, aptr, len);
3484 PUSHs(sv_2mortal(sv));
3485 break;
ecfc5424 3486#ifdef HAS_QUAD
a0d0e21e 3487 case 'q':
d4217c7e
JH		 3488 along = (strend - s) / sizeof(Quad_t);
3489 if (len > along)
3490 len = along;
a0d0e21e 3491 EXTEND(SP, len);
bbce6d69 3492 EXTEND_MORTAL(len);
a0d0e21e 3493 while (len-- > 0) {
ecfc5424 3494 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 3495 aquad = 0;
3496 else {
ecfc5424
AD		 3497 Copy(s, &aquad, 1, Quad_t);
3498 s += sizeof(Quad_t);
a0d0e21e
LW		 3499 }
3500 sv = NEWSV(42, 0);
96e4d5b1 3501 if (aquad >= IV_MIN && aquad <= IV_MAX)
3502 sv_setiv(sv, (IV)aquad);
3503 else
3504 sv_setnv(sv, (double)aquad);
a0d0e21e
LW		 3505 PUSHs(sv_2mortal(sv));
3506 }
3507 break;
3508 case 'Q':
d4217c7e
JH		 3509 along = (strend - s) / sizeof(Quad_t);
3510 if (len > along)
3511 len = along;
a0d0e21e 3512 EXTEND(SP, len);
bbce6d69 3513 EXTEND_MORTAL(len);
a0d0e21e 3514 while (len-- > 0) {
ecfc5424 3515 if (s + sizeof(unsigned Quad_t) > strend)
a0d0e21e
LW		 3516 auquad = 0;
3517 else {
ecfc5424
AD		 3518 Copy(s, &auquad, 1, unsigned Quad_t);
3519 s += sizeof(unsigned Quad_t);
a0d0e21e
LW		 3520 }
3521 sv = NEWSV(43, 0);
27612d38 3522 if (auquad <= UV_MAX)
96e4d5b1 3523 sv_setuv(sv, (UV)auquad);
3524 else
3525 sv_setnv(sv, (double)auquad);
a0d0e21e
LW		 3526 PUSHs(sv_2mortal(sv));
3527 }
3528 break;
79072805 3529#endif
a0d0e21e
LW		 3530 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3531 case 'f':
3532 case 'F':
3533 along = (strend - s) / sizeof(float);
3534 if (len > along)
3535 len = along;
3536 if (checksum) {
3537 while (len-- > 0) {
3538 Copy(s, &afloat, 1, float);
3539 s += sizeof(float);
3540 cdouble += afloat;
3541 }
3542 }
3543 else {
3544 EXTEND(SP, len);
bbce6d69 3545 EXTEND_MORTAL(len);
a0d0e21e
LW		 3546 while (len-- > 0) {
3547 Copy(s, &afloat, 1, float);
3548 s += sizeof(float);
3549 sv = NEWSV(47, 0);
3550 sv_setnv(sv, (double)afloat);
3551 PUSHs(sv_2mortal(sv));
3552 }
3553 }
3554 break;
3555 case 'd':
3556 case 'D':
3557 along = (strend - s) / sizeof(double);
3558 if (len > along)
3559 len = along;
3560 if (checksum) {
3561 while (len-- > 0) {
3562 Copy(s, &adouble, 1, double);
3563 s += sizeof(double);
3564 cdouble += adouble;
3565 }
3566 }
3567 else {
3568 EXTEND(SP, len);
bbce6d69 3569 EXTEND_MORTAL(len);
a0d0e21e
LW		 3570 while (len-- > 0) {
3571 Copy(s, &adouble, 1, double);
3572 s += sizeof(double);
3573 sv = NEWSV(48, 0);
3574 sv_setnv(sv, (double)adouble);
3575 PUSHs(sv_2mortal(sv));
3576 }
3577 }
3578 break;
3579 case 'u':
9d116dd7
JH		 3580 /* MKS:
3581 * Initialise the decode mapping. By using a table driven
3582 * algorithm, the code will be character-set independent
3583 * (and just as fast as doing character arithmetic)
3584 */
3585 if (uudmap['M'] == 0) {
3586 int i;
3587
3588 for (i = 0; i < sizeof(uuemap); i += 1)
3589 uudmap[uuemap[i]] = i;
3590 /*
3591 * Because ' ' and '`' map to the same value,
3592 * we need to decode them both the same.
3593 */
3594 uudmap[' '] = 0;
3595 }
3596
a0d0e21e
LW		 3597 along = (strend - s) * 3 / 4;
3598 sv = NEWSV(42, along);
f12c7020 3599 if (along)
3600 SvPOK_on(sv);
9d116dd7 3601 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
a0d0e21e
LW		 3602 I32 a, b, c, d;
3603 char hunk[4];
79072805 3604
a0d0e21e 3605 hunk[3] = '\0';
409b62f3 3606 len = uudmap[*s++] & 077;
a0d0e21e 3607 while (len > 0) {
9d116dd7
JH		 3608 if (s < strend && ISUUCHAR(*s))
3609 a = uudmap[*s++] & 077;
3610 else
3611 a = 0;
3612 if (s < strend && ISUUCHAR(*s))
3613 b = uudmap[*s++] & 077;
3614 else
3615 b = 0;
3616 if (s < strend && ISUUCHAR(*s))
3617 c = uudmap[*s++] & 077;
3618 else
3619 c = 0;
3620 if (s < strend && ISUUCHAR(*s))
3621 d = uudmap[*s++] & 077;
a0d0e21e
LW		 3622 else
3623 d = 0;
4e35701f
NIS		 3624 hunk[0] = (a << 2) | (b >> 4);
3625 hunk[1] = (b << 4) | (c >> 2);
3626 hunk[2] = (c << 6) | d;
3627 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW		 3628 len -= 3;
3629 }
3630 if (*s == '\n')
3631 s++;
3632 else if (s[1] == '\n') /* possible checksum byte */
3633 s += 2;
79072805 3634 }
a0d0e21e
LW		 3635 XPUSHs(sv_2mortal(sv));
3636 break;
79072805 3637 }
a0d0e21e
LW		 3638 if (checksum) {
3639 sv = NEWSV(42, 0);
3640 if (strchr("fFdD", datumtype) ||
3641 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3642 double trouble;
79072805 3643
a0d0e21e
LW		 3644 adouble = 1.0;
3645 while (checksum >= 16) {
3646 checksum -= 16;
3647 adouble *= 65536.0;
3648 }
3649 while (checksum >= 4) {
3650 checksum -= 4;
3651 adouble *= 16.0;
3652 }
3653 while (checksum--)
3654 adouble *= 2.0;
3655 along = (1 << checksum) - 1;
3656 while (cdouble < 0.0)
3657 cdouble += adouble;
3658 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3659 sv_setnv(sv, cdouble);
3660 }
3661 else {
3662 if (checksum < 32) {
96e4d5b1 3663 aulong = (1 << checksum) - 1;
3664 culong &= aulong;
a0d0e21e 3665 }
96e4d5b1 3666 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 3667 }
3668 XPUSHs(sv_2mortal(sv));
3669 checksum = 0;
79072805 3670 }
79072805 3671 }
924508f0 3672 if (SP == oldsp && gimme == G_SCALAR)
3280af22 3673 PUSHs(&PL_sv_undef);
79072805 3674 RETURN;
79072805
LW		 3675}
3676
76e3520e 3677STATIC void
8ac85365 3678doencodes(register SV *sv, register char *s, register I32 len)
79072805 3679{
a0d0e21e 3680 char hunk[5];
79072805 3681
9d116dd7 3682 *hunk = uuemap[len];
a0d0e21e
LW		 3683 sv_catpvn(sv, hunk, 1);
3684 hunk[4] = '\0';
f264d472 3685 while (len > 2) {
9d116dd7 3686 hunk[0] = uuemap[(077 & (*s >> 2))];
d38acd6c
GS		 3687 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3688 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
9d116dd7 3689 hunk[3] = uuemap[(077 & (s[2] & 077))];
a0d0e21e
LW		 3690 sv_catpvn(sv, hunk, 4);
3691 s += 3;
3692 len -= 3;
3693 }
f264d472
GS		 3694 if (len > 0) {
3695 char r = (len > 1 ? s[1] : '\0');
3696 hunk[0] = uuemap[(077 & (*s >> 2))];
d38acd6c 3697 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
f264d472
GS		 3698 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3699 hunk[3] = uuemap[0];
3700 sv_catpvn(sv, hunk, 4);
3701 }
a0d0e21e 3702 sv_catpvn(sv, "\n", 1);
79072805
LW		 3703}
3704
76e3520e 3705STATIC SV *
8ac85365 3706is_an_int(char *s, STRLEN l)
55497cff 3707{
3708 SV *result = newSVpv("", l);
3280af22 3709 char *result_c = SvPV(result, PL_na); /* convenience */
55497cff 3710 char *out = result_c;
3711 bool skip = 1;
3712 bool ignore = 0;
3713
3714 while (*s) {
3715 switch (*s) {
3716 case ' ':
3717 break;
3718 case '+':
3719 if (!skip) {
3720 SvREFCNT_dec(result);
3721 return (NULL);
3722 }
3723 break;
3724 case '0':
3725 case '1':
3726 case '2':
3727 case '3':
3728 case '4':
3729 case '5':
3730 case '6':
3731 case '7':
3732 case '8':
3733 case '9':
3734 skip = 0;
3735 if (!ignore) {
3736 *(out++) = *s;
3737 }
3738 break;
3739 case '.':
3740 ignore = 1;
3741 break;
3742 default:
3743 SvREFCNT_dec(result);
3744 return (NULL);
3745 }
3746 s++;
3747 }
3748 *(out++) = '\0';
3749 SvCUR_set(result, out - result_c);
3750 return (result);
3751}
3752
76e3520e 3753STATIC int
61bb5906 3754div128(SV *pnum, bool *done)
8ac85365 3755 /* must be '\0' terminated */
8ec5e241 3756
55497cff 3757{
3758 STRLEN len;
3759 char *s = SvPV(pnum, len);
3760 int m = 0;
3761 int r = 0;
3762 char *t = s;
3763
3764 *done = 1;
3765 while (*t) {
3766 int i;
3767
3768 i = m * 10 + (*t - '0');
3769 m = i & 0x7F;
3770 r = (i >> 7); /* r < 10 */
3771 if (r) {
3772 *done = 0;
3773 }
3774 *(t++) = '0' + r;
3775 }
3776 *(t++) = '\0';
3777 SvCUR_set(pnum, (STRLEN) (t - s));
3778 return (m);
3779}
3780
3781
a0d0e21e 3782PP(pp_pack)
79072805 3783{
4e35701f 3784 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3785 register SV *cat = TARG;
3786 register I32 items;
3787 STRLEN fromlen;
3788 register char *pat = SvPVx(*++MARK, fromlen);
3789 register char *patend = pat + fromlen;
3790 register I32 len;
3791 I32 datumtype;
3792 SV *fromstr;
3793 /*SUPPRESS 442*/
3794 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3795 static char *space10 = " ";
79072805 3796
a0d0e21e
LW		 3797 /* These must not be in registers: */
3798 char achar;
3799 I16 ashort;
3800 int aint;
3801 unsigned int auint;
3802 I32 along;
3803 U32 aulong;
ecfc5424
AD		 3804#ifdef HAS_QUAD
3805 Quad_t aquad;
3806 unsigned Quad_t auquad;
79072805 3807#endif
a0d0e21e
LW		 3808 char *aptr;
3809 float afloat;
3810 double adouble;
fb73857a 3811 int commas = 0;
79072805 3812
a0d0e21e
LW		 3813 items = SP - MARK;
3814 MARK++;
3815 sv_setpvn(cat, "", 0);
3816 while (pat < patend) {
3280af22 3817#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
bbdab043
CS		 3818 datumtype = *pat++ & 0xFF;
3819 if (isSPACE(datumtype))
3820 continue;
a0d0e21e
LW		 3821 if (*pat == '*') {
3822 len = strchr("@Xxu", datumtype) ? 0 : items;
3823 pat++;
3824 }
3825 else if (isDIGIT(*pat)) {
3826 len = *pat++ - '0';
3827 while (isDIGIT(*pat))
3828 len = (len * 10) + (*pat++ - '0');
3829 }
3830 else
3831 len = 1;
3832 switch(datumtype) {
3833 default:
bbdab043 3834 croak("Invalid type in pack: '%c'", (int)datumtype);
fb73857a 3835 case ',': /* grandfather in commas but with a warning */
3280af22 3836 if (commas++ == 0 && PL_dowarn)
fb73857a 3837 warn("Invalid type in pack: '%c'", (int)datumtype);
3838 break;
a0d0e21e
LW		 3839 case '%':
3840 DIE("%% may only be used in unpack");
3841 case '@':
3842 len -= SvCUR(cat);
3843 if (len > 0)
3844 goto grow;
3845 len = -len;
3846 if (len > 0)
3847 goto shrink;
3848 break;
3849 case 'X':
3850 shrink:
3851 if (SvCUR(cat) < len)
3852 DIE("X outside of string");
3853 SvCUR(cat) -= len;
3854 *SvEND(cat) = '\0';
3855 break;
3856 case 'x':
3857 grow:
3858 while (len >= 10) {
3859 sv_catpvn(cat, null10, 10);
3860 len -= 10;
3861 }
3862 sv_catpvn(cat, null10, len);
3863 break;
3864 case 'A':
3865 case 'a':
3866 fromstr = NEXTFROM;
3867 aptr = SvPV(fromstr, fromlen);
3868 if (pat[-1] == '*')
3869 len = fromlen;
3870 if (fromlen > len)
3871 sv_catpvn(cat, aptr, len);
3872 else {
3873 sv_catpvn(cat, aptr, fromlen);
3874 len -= fromlen;
3875 if (datumtype == 'A') {
3876 while (len >= 10) {
3877 sv_catpvn(cat, space10, 10);
3878 len -= 10;
3879 }
3880 sv_catpvn(cat, space10, len);
3881 }
3882 else {
3883 while (len >= 10) {
3884 sv_catpvn(cat, null10, 10);
3885 len -= 10;
3886 }
3887 sv_catpvn(cat, null10, len);
3888 }
3889 }
3890 break;
3891 case 'B':
3892 case 'b':
3893 {
3894 char *savepat = pat;
3895 I32 saveitems;
79072805 3896
a0d0e21e
LW		 3897 fromstr = NEXTFROM;
3898 saveitems = items;
3899 aptr = SvPV(fromstr, fromlen);
3900 if (pat[-1] == '*')
3901 len = fromlen;
3902 pat = aptr;
3903 aint = SvCUR(cat);
3904 SvCUR(cat) += (len+7)/8;
3905 SvGROW(cat, SvCUR(cat) + 1);
3906 aptr = SvPVX(cat) + aint;
3907 if (len > fromlen)
3908 len = fromlen;
3909 aint = len;
3910 items = 0;
3911 if (datumtype == 'B') {
3912 for (len = 0; len++ < aint;) {
3913 items |= *pat++ & 1;
3914 if (len & 7)
3915 items <<= 1;
3916 else {
3917 *aptr++ = items & 0xff;
3918 items = 0;
3919 }
3920 }
3921 }
3922 else {
3923 for (len = 0; len++ < aint;) {
3924 if (*pat++ & 1)
3925 items |= 128;
3926 if (len & 7)
3927 items >>= 1;
3928 else {
3929 *aptr++ = items & 0xff;
3930 items = 0;
3931 }
3932 }
3933 }
3934 if (aint & 7) {
3935 if (datumtype == 'B')
3936 items <<= 7 - (aint & 7);
3937 else
3938 items >>= 7 - (aint & 7);
3939 *aptr++ = items & 0xff;
3940 }
3941 pat = SvPVX(cat) + SvCUR(cat);
3942 while (aptr <= pat)
3943 *aptr++ = '\0';
79072805 3944
a0d0e21e
LW		 3945 pat = savepat;
3946 items = saveitems;
3947 }
3948 break;
3949 case 'H':
3950 case 'h':
3951 {
3952 char *savepat = pat;
3953 I32 saveitems;
79072805 3954
a0d0e21e
LW		 3955 fromstr = NEXTFROM;
3956 saveitems = items;
3957 aptr = SvPV(fromstr, fromlen);
3958 if (pat[-1] == '*')
3959 len = fromlen;
3960 pat = aptr;
3961 aint = SvCUR(cat);
3962 SvCUR(cat) += (len+1)/2;
3963 SvGROW(cat, SvCUR(cat) + 1);
3964 aptr = SvPVX(cat) + aint;
3965 if (len > fromlen)
3966 len = fromlen;
3967 aint = len;
3968 items = 0;
3969 if (datumtype == 'H') {
3970 for (len = 0; len++ < aint;) {
3971 if (isALPHA(*pat))
3972 items |= ((*pat++ & 15) + 9) & 15;
3973 else
3974 items |= *pat++ & 15;
3975 if (len & 1)
3976 items <<= 4;
3977 else {
3978 *aptr++ = items & 0xff;
3979 items = 0;
3980 }
3981 }
3982 }
3983 else {
3984 for (len = 0; len++ < aint;) {
3985 if (isALPHA(*pat))
3986 items |= (((*pat++ & 15) + 9) & 15) << 4;
3987 else
3988 items |= (*pat++ & 15) << 4;
3989 if (len & 1)
3990 items >>= 4;
3991 else {
3992 *aptr++ = items & 0xff;
3993 items = 0;
3994 }
3995 }
3996 }
3997 if (aint & 1)
3998 *aptr++ = items & 0xff;
3999 pat = SvPVX(cat) + SvCUR(cat);
4000 while (aptr <= pat)
4001 *aptr++ = '\0';
79072805 4002
a0d0e21e
LW		 4003 pat = savepat;
4004 items = saveitems;
4005 }
4006 break;
4007 case 'C':
4008 case 'c':
4009 while (len-- > 0) {
4010 fromstr = NEXTFROM;
4011 aint = SvIV(fromstr);
4012 achar = aint;
4013 sv_catpvn(cat, &achar, sizeof(char));
4014 }
4015 break;
4016 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4017 case 'f':
4018 case 'F':
4019 while (len-- > 0) {
4020 fromstr = NEXTFROM;
4021 afloat = (float)SvNV(fromstr);
4022 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4023 }
4024 break;
4025 case 'd':
4026 case 'D':
4027 while (len-- > 0) {
4028 fromstr = NEXTFROM;
4029 adouble = (double)SvNV(fromstr);
4030 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4031 }
4032 break;
4033 case 'n':
4034 while (len-- > 0) {
4035 fromstr = NEXTFROM;
4036 ashort = (I16)SvIV(fromstr);
4037#ifdef HAS_HTONS
6ad3d225 4038 ashort = PerlSock_htons(ashort);
79072805 4039#endif
96e4d5b1 4040 CAT16(cat, &ashort);
a0d0e21e
LW		 4041 }
4042 break;
4043 case 'v':
4044 while (len-- > 0) {
4045 fromstr = NEXTFROM;
4046 ashort = (I16)SvIV(fromstr);
4047#ifdef HAS_HTOVS
4048 ashort = htovs(ashort);
79072805 4049#endif
96e4d5b1 4050 CAT16(cat, &ashort);
a0d0e21e
LW		 4051 }
4052 break;
4053 case 'S':
4054 case 's':
4055 while (len-- > 0) {
4056 fromstr = NEXTFROM;
4057 ashort = (I16)SvIV(fromstr);
96e4d5b1 4058 CAT16(cat, &ashort);
a0d0e21e
LW		 4059 }
4060 break;
4061 case 'I':
4062 while (len-- > 0) {
4063 fromstr = NEXTFROM;
96e4d5b1 4064 auint = SvUV(fromstr);
a0d0e21e
LW		 4065 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4066 }
4067 break;
def98dd4
UP		 4068 case 'w':
4069 while (len-- > 0) {
bbce6d69 4070 fromstr = NEXTFROM;
4071 adouble = floor(SvNV(fromstr));
4072
4073 if (adouble < 0)
4074 croak("Cannot compress negative numbers");
4075
46fc3d4c 4076 if (
4077#ifdef BW_BITS
4078 adouble <= BW_MASK
4079#else
ef2d312d
TH		 4080#ifdef CXUX_BROKEN_CONSTANT_CONVERT
4081 adouble <= UV_MAX_cxux
4082#else
46fc3d4c 4083 adouble <= UV_MAX
4084#endif
ef2d312d 4085#endif
46fc3d4c 4086 )
4087 {
bbce6d69 4088 char buf[1 + sizeof(UV)];
4089 char *in = buf + sizeof(buf);
4090 UV auv = U_V(adouble);;
4091
4092 do {
4093 *--in = (auv & 0x7f) | 0x80;
4094 auv >>= 7;
4095 } while (auv);
4096 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4097 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4098 }
4099 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4100 char *from, *result, *in;
4101 SV *norm;
4102 STRLEN len;
4103 bool done;
8ec5e241 4104
bbce6d69 4105 /* Copy string and check for compliance */
4106 from = SvPV(fromstr, len);
4107 if ((norm = is_an_int(from, len)) == NULL)
4108 croak("can compress only unsigned integer");
4109
4110 New('w', result, len, char);
4111 in = result + len;
4112 done = FALSE;
4113 while (!done)
4114 *--in = div128(norm, &done) | 0x80;
4115 result[len - 1] &= 0x7F; /* clear continue bit */
4116 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 4117 Safefree(result);
bbce6d69 4118 SvREFCNT_dec(norm); /* free norm */
def98dd4 4119 }
bbce6d69 4120 else if (SvNOKp(fromstr)) {
4121 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4122 char *in = buf + sizeof(buf);
4123
4124 do {
4125 double next = floor(adouble / 128);
4126 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4127 if (--in < buf) /* this cannot happen ;-) */
4128 croak ("Cannot compress integer");
4129 adouble = next;
4130 } while (adouble > 0);
4131 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4132 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4133 }
4134 else
4135 croak("Cannot compress non integer");
4136 }
def98dd4 4137 break;
a0d0e21e
LW		 4138 case 'i':
4139 while (len-- > 0) {
4140 fromstr = NEXTFROM;
4141 aint = SvIV(fromstr);
4142 sv_catpvn(cat, (char*)&aint, sizeof(int));
4143 }
4144 break;
4145 case 'N':
4146 while (len-- > 0) {
4147 fromstr = NEXTFROM;
96e4d5b1 4148 aulong = SvUV(fromstr);
a0d0e21e 4149#ifdef HAS_HTONL
6ad3d225 4150 aulong = PerlSock_htonl(aulong);
79072805 4151#endif
96e4d5b1 4152 CAT32(cat, &aulong);
a0d0e21e
LW		 4153 }
4154 break;
4155 case 'V':
4156 while (len-- > 0) {
4157 fromstr = NEXTFROM;
96e4d5b1 4158 aulong = SvUV(fromstr);
a0d0e21e
LW		 4159#ifdef HAS_HTOVL
4160 aulong = htovl(aulong);
79072805 4161#endif
96e4d5b1 4162 CAT32(cat, &aulong);
a0d0e21e
LW		 4163 }
4164 break;
4165 case 'L':
4166 while (len-- > 0) {
4167 fromstr = NEXTFROM;
96e4d5b1 4168 aulong = SvUV(fromstr);
4169 CAT32(cat, &aulong);
a0d0e21e
LW		 4170 }
4171 break;
4172 case 'l':
4173 while (len-- > 0) {
4174 fromstr = NEXTFROM;
4175 along = SvIV(fromstr);
96e4d5b1 4176 CAT32(cat, &along);
a0d0e21e
LW		 4177 }
4178 break;
ecfc5424 4179#ifdef HAS_QUAD
a0d0e21e
LW		 4180 case 'Q':
4181 while (len-- > 0) {
4182 fromstr = NEXTFROM;
ecfc5424
AD		 4183 auquad = (unsigned Quad_t)SvIV(fromstr);
4184 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
a0d0e21e
LW		 4185 }
4186 break;
4187 case 'q':
4188 while (len-- > 0) {
4189 fromstr = NEXTFROM;
ecfc5424
AD		 4190 aquad = (Quad_t)SvIV(fromstr);
4191 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 4192 }
4193 break;
ecfc5424 4194#endif /* HAS_QUAD */
a0d0e21e
LW		 4195 case 'P':
4196 len = 1; /* assume SV is correct length */
4197 /* FALL THROUGH */
4198 case 'p':
4199 while (len-- > 0) {
4200 fromstr = NEXTFROM;
3280af22 4201 if (fromstr == &PL_sv_undef)
84902520 4202 aptr = NULL;
72dbcb4b 4203 else {
84902520
TB		 4204 /* XXX better yet, could spirit away the string to
4205 * a safe spot and hang on to it until the result
4206 * of pack() (and all copies of the result) are
4207 * gone.
4208 */
3280af22 4209 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
84902520
TB		 4210 warn("Attempt to pack pointer to temporary value");
4211 if (SvPOK(fromstr) || SvNIOK(fromstr))
3280af22 4212 aptr = SvPV(fromstr,PL_na);
84902520 4213 else
3280af22 4214 aptr = SvPV_force(fromstr,PL_na);
72dbcb4b 4215 }
a0d0e21e
LW		 4216 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4217 }
4218 break;
4219 case 'u':
4220 fromstr = NEXTFROM;
4221 aptr = SvPV(fromstr, fromlen);
4222 SvGROW(cat, fromlen * 4 / 3);
4223 if (len <= 1)
4224 len = 45;
4225 else
4226 len = len / 3 * 3;
4227 while (fromlen > 0) {
4228 I32 todo;
79072805 4229
a0d0e21e
LW		 4230 if (fromlen > len)
4231 todo = len;
4232 else
4233 todo = fromlen;
4234 doencodes(cat, aptr, todo);
4235 fromlen -= todo;
4236 aptr += todo;
4237 }
4238 break;
4239 }
4240 }
4241 SvSETMAGIC(cat);
4242 SP = ORIGMARK;
4243 PUSHs(cat);
4244 RETURN;
79072805 4245}
a0d0e21e 4246#undef NEXTFROM
79072805 4247
8ec5e241 4248
a0d0e21e 4249PP(pp_split)
79072805 4250{
4e35701f 4251 djSP; dTARG;
a0d0e21e
LW		 4252 AV *ary;
4253 register I32 limit = POPi; /* note, negative is forever */
4254 SV *sv = POPs;
4255 STRLEN len;
4256 register char *s = SvPV(sv, len);
4257 char *strend = s + len;
44a8e56a 4258 register PMOP *pm;
d9f97599 4259 register REGEXP *rx;
a0d0e21e
LW		 4260 register SV *dstr;
4261 register char *m;
4262 I32 iters = 0;
4263 I32 maxiters = (strend - s) + 10;
4264 I32 i;
4265 char *orig;
4266 I32 origlimit = limit;
4267 I32 realarray = 0;
4268 I32 base;
3280af22 4269 AV *oldstack = PL_curstack;
54310121 4270 I32 gimme = GIMME_V;
3280af22 4271 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4272 I32 make_mortal = 1;
4273 MAGIC *mg = (MAGIC *) NULL;
79072805 4274
44a8e56a 4275#ifdef DEBUGGING
4276 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4277#else
4278 pm = (PMOP*)POPs;
4279#endif
a0d0e21e
LW		 4280 if (!pm || !s)
4281 DIE("panic: do_split");
d9f97599 4282 rx = pm->op_pmregexp;
bbce6d69 4283
4284 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4285 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4286
a0d0e21e
LW		 4287 if (pm->op_pmreplroot)
4288 ary = GvAVn((GV*)pm->op_pmreplroot);
4289 else if (gimme != G_ARRAY)
6d4ff0d2 4290#ifdef USE_THREADS
533c011a 4291 ary = (AV*)PL_curpad[0];
6d4ff0d2 4292#else
3280af22 4293 ary = GvAVn(PL_defgv);
6d4ff0d2 4294#endif /* USE_THREADS */
79072805 4295 else
a0d0e21e
LW		 4296 ary = Nullav;
4297 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4298 realarray = 1;
8ec5e241 4299 PUTBACK;
a0d0e21e
LW		 4300 av_extend(ary,0);
4301 av_clear(ary);
8ec5e241 4302 SPAGAIN;
ece095e7 4303 if (mg = SvTIED_mg((SV*)ary, 'P')) {
8ec5e241 4304 PUSHMARK(SP);
ece095e7 4305 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4306 }
4307 else {
1c0b011c
NIS		 4308 if (!AvREAL(ary)) {
4309 AvREAL_on(ary);
4310 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4311 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4312 }
4313 /* temporarily switch stacks */
3280af22 4314 SWITCHSTACK(PL_curstack, ary);
8ec5e241 4315 make_mortal = 0;
1c0b011c 4316 }
79072805 4317 }
3280af22 4318 base = SP - PL_stack_base;
a0d0e21e
LW		 4319 orig = s;
4320 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4321 if (pm->op_pmflags & PMf_LOCALE) {
4322 while (isSPACE_LC(*s))
4323 s++;
4324 }
4325 else {
4326 while (isSPACE(*s))
4327 s++;
4328 }
a0d0e21e 4329 }
c07a80fd 4330 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 4331 SAVEINT(PL_multiline);
4332 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4333 }
4334
a0d0e21e
LW		 4335 if (!limit)
4336 limit = maxiters + 2;
4337 if (pm->op_pmflags & PMf_WHITE) {
4338 while (--limit) {
bbce6d69 4339 m = s;
4340 while (m < strend &&
4341 !((pm->op_pmflags & PMf_LOCALE)
4342 ? isSPACE_LC(*m) : isSPACE(*m)))
4343 ++m;
a0d0e21e
LW		 4344 if (m >= strend)
4345 break;
bbce6d69 4346
a0d0e21e
LW		 4347 dstr = NEWSV(30, m-s);
4348 sv_setpvn(dstr, s, m-s);
8ec5e241 4349 if (make_mortal)
a0d0e21e
LW		 4350 sv_2mortal(dstr);
4351 XPUSHs(dstr);
bbce6d69 4352
4353 s = m + 1;
4354 while (s < strend &&
4355 ((pm->op_pmflags & PMf_LOCALE)
4356 ? isSPACE_LC(*s) : isSPACE(*s)))
4357 ++s;
79072805
LW		 4358 }
4359 }
d9f97599 4360 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4361 while (--limit) {
4362 /*SUPPRESS 530*/
4363 for (m = s; m < strend && *m != '\n'; m++) ;
4364 m++;
4365 if (m >= strend)
4366 break;
4367 dstr = NEWSV(30, m-s);
4368 sv_setpvn(dstr, s, m-s);
8ec5e241 4369 if (make_mortal)
a0d0e21e
LW		 4370 sv_2mortal(dstr);
4371 XPUSHs(dstr);
4372 s = m;
4373 }
4374 }
d9f97599
GS		 4375 else if (rx->check_substr && !rx->nparens
4376 && (rx->reganch & ROPT_CHECK_ALL)
4377 && !(rx->reganch & ROPT_ANCH)) {
4378 i = SvCUR(rx->check_substr);
4379 if (i == 1 && !SvTAIL(rx->check_substr)) {
4380 i = *SvPVX(rx->check_substr);
a0d0e21e 4381 while (--limit) {
bbce6d69 4382 /*SUPPRESS 530*/
4383 for (m = s; m < strend && *m != i; m++) ;
a0d0e21e
LW		 4384 if (m >= strend)
4385 break;
4386 dstr = NEWSV(30, m-s);
4387 sv_setpvn(dstr, s, m-s);
8ec5e241 4388 if (make_mortal)
a0d0e21e
LW		 4389 sv_2mortal(dstr);
4390 XPUSHs(dstr);
4391 s = m + 1;
4392 }
4393 }
4394 else {
4395#ifndef lint
4396 while (s < strend && --limit &&
4397 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
411d5715 4398 rx->check_substr, 0)) )
79072805 4399#endif
a0d0e21e
LW		 4400 {
4401 dstr = NEWSV(31, m-s);
4402 sv_setpvn(dstr, s, m-s);
8ec5e241 4403 if (make_mortal)
a0d0e21e
LW		 4404 sv_2mortal(dstr);
4405 XPUSHs(dstr);
4406 s = m + i;
4407 }
463ee0b2 4408 }
463ee0b2 4409 }
a0d0e21e 4410 else {
d9f97599 4411 maxiters += (strend - s) * rx->nparens;
a0d0e21e 4412 while (s < strend && --limit &&
15e52e56 4413 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
bbce6d69 4414 {
d9f97599
GS		 4415 TAINT_IF(RX_MATCH_TAINTED(rx));
4416 if (rx->subbase
4417 && rx->subbase != orig) {
a0d0e21e
LW		 4418 m = s;
4419 s = orig;
d9f97599 4420 orig = rx->subbase;
a0d0e21e
LW		 4421 s = orig + (m - s);
4422 strend = s + (strend - m);
4423 }
d9f97599 4424 m = rx->startp[0];
a0d0e21e
LW		 4425 dstr = NEWSV(32, m-s);
4426 sv_setpvn(dstr, s, m-s);
8ec5e241 4427 if (make_mortal)
a0d0e21e
LW		 4428 sv_2mortal(dstr);
4429 XPUSHs(dstr);
d9f97599
GS		 4430 if (rx->nparens) {
4431 for (i = 1; i <= rx->nparens; i++) {
4432 s = rx->startp[i];
4433 m = rx->endp[i];
748a9306
LW		 4434 if (m && s) {
4435 dstr = NEWSV(33, m-s);
4436 sv_setpvn(dstr, s, m-s);
4437 }
4438 else
4439 dstr = NEWSV(33, 0);
8ec5e241 4440 if (make_mortal)
a0d0e21e
LW		 4441 sv_2mortal(dstr);
4442 XPUSHs(dstr);
4443 }
4444 }
d9f97599 4445 s = rx->endp[0];
a0d0e21e 4446 }
79072805 4447 }
8ec5e241 4448
c07a80fd 4449 LEAVE_SCOPE(oldsave);
3280af22 4450 iters = (SP - PL_stack_base) - base;
a0d0e21e
LW		 4451 if (iters > maxiters)
4452 DIE("Split loop");
8ec5e241 4453
a0d0e21e
LW		 4454 /* keep field after final delim? */
4455 if (s < strend || (iters && origlimit)) {
4456 dstr = NEWSV(34, strend-s);
4457 sv_setpvn(dstr, s, strend-s);
8ec5e241 4458 if (make_mortal)
a0d0e21e
LW		 4459 sv_2mortal(dstr);
4460 XPUSHs(dstr);
4461 iters++;
79072805 4462 }
a0d0e21e 4463 else if (!origlimit) {
b1dadf13 4464 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 4465 iters--, SP--;
4466 }
8ec5e241 4467
a0d0e21e 4468 if (realarray) {
8ec5e241 4469 if (!mg) {
1c0b011c
NIS		 4470 SWITCHSTACK(ary, oldstack);
4471 if (SvSMAGICAL(ary)) {
4472 PUTBACK;
4473 mg_set((SV*)ary);
4474 SPAGAIN;
4475 }
4476 if (gimme == G_ARRAY) {
4477 EXTEND(SP, iters);
4478 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4479 SP += iters;
4480 RETURN;
4481 }
8ec5e241 4482 }
1c0b011c 4483 else {
fb73857a 4484 PUTBACK;
8ec5e241
NIS		 4485 ENTER;
4486 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4487 LEAVE;
fb73857a 4488 SPAGAIN;
8ec5e241
NIS		 4489 if (gimme == G_ARRAY) {
4490 /* EXTEND should not be needed - we just popped them */
4491 EXTEND(SP, iters);
4492 for (i=0; i < iters; i++) {
4493 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4494 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4495 }
1c0b011c
NIS		 4496 RETURN;
4497 }
a0d0e21e
LW		 4498 }
4499 }
4500 else {
4501 if (gimme == G_ARRAY)
4502 RETURN;
4503 }
4504 if (iters || !pm->op_pmreplroot) {
4505 GETTARGET;
4506 PUSHi(iters);
4507 RETURN;
4508 }
4509 RETPUSHUNDEF;
79072805 4510}
85e6fe83 4511
c0329465 4512#ifdef USE_THREADS
77a005ab 4513void
8ac85365 4514unlock_condpair(void *svv)
c0329465
MB		 4515{
4516 dTHR;
4517 MAGIC *mg = mg_find((SV*)svv, 'm');
8ec5e241 4518
c0329465
MB		 4519 if (!mg)
4520 croak("panic: unlock_condpair unlocking non-mutex");
4521 MUTEX_LOCK(MgMUTEXP(mg));
4522 if (MgOWNER(mg) != thr)
4523 croak("panic: unlock_condpair unlocking mutex that we don't own");
4524 MgOWNER(mg) = 0;
4525 COND_SIGNAL(MgOWNERCONDP(mg));
8b73bbec 4526 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
bc1f4c86 4527 (unsigned long)thr, (unsigned long)svv);)
c0329465
MB		 4528 MUTEX_UNLOCK(MgMUTEXP(mg));
4529}
4530#endif /* USE_THREADS */
4531
4532PP(pp_lock)
4533{
4e35701f 4534 djSP;
c0329465 4535 dTOPss;
e55aaa0e
MB		 4536 SV *retsv = sv;
4537#ifdef USE_THREADS
c0329465 4538 MAGIC *mg;
8ec5e241 4539
c0329465
MB		 4540 if (SvROK(sv))
4541 sv = SvRV(sv);
4542
4543 mg = condpair_magic(sv);
4544 MUTEX_LOCK(MgMUTEXP(mg));
4545 if (MgOWNER(mg) == thr)
4546 MUTEX_UNLOCK(MgMUTEXP(mg));
4547 else {
4548 while (MgOWNER(mg))
4549 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4550 MgOWNER(mg) = thr;
8b73bbec 4551 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
bc1f4c86 4552 (unsigned long)thr, (unsigned long)sv);)
c0329465
MB		 4553 MUTEX_UNLOCK(MgMUTEXP(mg));
4554 save_destructor(unlock_condpair, sv);
4555 }
4556#endif /* USE_THREADS */
e55aaa0e
MB		 4557 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4558 || SvTYPE(retsv) == SVt_PVCV) {
4559 retsv = refto(retsv);
4560 }
4561 SETs(retsv);
c0329465
MB		 4562 RETURN;
4563}
a863c7d1 4564
2faa37cc 4565PP(pp_threadsv)
a863c7d1 4566{
12f917ad 4567 djSP;
57d3b86d 4568#ifdef USE_THREADS
924508f0 4569 EXTEND(SP, 1);
533c011a
NIS		 4570 if (PL_op->op_private & OPpLVAL_INTRO)
4571 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 4572 else
533c011a 4573 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 4574 RETURN;
a863c7d1 4575#else
2faa37cc 4576 DIE("tried to access per-thread data in non-threaded perl");
a863c7d1 4577#endif /* USE_THREADS */
a863c7d1 4578}
Unnamed repository; edit this file 'description' to name the repository.