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