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