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