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