This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to match new home of Pod::Functions.
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
a0d0e21e 3 * Copyright (c) 1991-1994, 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
a0d0e21e 18static void doencodes _((SV *sv, char *s, I32 len));
79072805 19
a0d0e21e 20/* variations on pp_null */
79072805 21
93a17b20
LW
22PP(pp_stub)
23{
24 dSP;
25 if (GIMME != G_ARRAY) {
26 XPUSHs(&sv_undef);
27 }
28 RETURN;
29}
30
79072805
LW
31PP(pp_scalar)
32{
33 return NORMAL;
34}
35
36/* Pushy stuff. */
37
93a17b20
LW
38PP(pp_padav)
39{
40 dSP; dTARGET;
a0d0e21e 41 if (op->op_private & OPpLVAL_INTRO)
8990e307 42 SAVECLEARSV(curpad[op->op_targ]);
85e6fe83 43 EXTEND(SP, 1);
a0d0e21e 44 if (op->op_flags & OPf_REF) {
85e6fe83 45 PUSHs(TARG);
93a17b20 46 RETURN;
85e6fe83
LW
47 }
48 if (GIMME == G_ARRAY) {
49 I32 maxarg = AvFILL((AV*)TARG) + 1;
50 EXTEND(SP, maxarg);
51 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
52 SP += maxarg;
53 }
54 else {
55 SV* sv = sv_newmortal();
56 I32 maxarg = AvFILL((AV*)TARG) + 1;
57 sv_setiv(sv, maxarg);
58 PUSHs(sv);
59 }
60 RETURN;
93a17b20
LW
61}
62
63PP(pp_padhv)
64{
65 dSP; dTARGET;
66 XPUSHs(TARG);
a0d0e21e 67 if (op->op_private & OPpLVAL_INTRO)
8990e307 68 SAVECLEARSV(curpad[op->op_targ]);
a0d0e21e 69 if (op->op_flags & OPf_REF)
93a17b20 70 RETURN;
85e6fe83 71 if (GIMME == G_ARRAY) { /* array wanted */
a0d0e21e 72 RETURNOP(do_kv(ARGS));
85e6fe83
LW
73 }
74 else {
75 SV* sv = sv_newmortal();
76 if (HvFILL((HV*)TARG)) {
77 sprintf(buf, "%d/%d", HvFILL((HV*)TARG), HvMAX((HV*)TARG)+1);
78 sv_setpv(sv, buf);
79 }
80 else
81 sv_setiv(sv, 0);
82 SETs(sv);
83 RETURN;
84 }
93a17b20
LW
85}
86
ed6116ce
LW
87PP(pp_padany)
88{
89 DIE("NOT IMPL LINE %d",__LINE__);
90}
91
79072805
LW
92/* Translations. */
93
94PP(pp_rv2gv)
95{
96 dSP; dTOPss;
a0d0e21e 97
ed6116ce 98 if (SvROK(sv)) {
a0d0e21e 99 wasref:
ed6116ce 100 sv = SvRV(sv);
79072805 101 if (SvTYPE(sv) != SVt_PVGV)
a0d0e21e 102 DIE("Not a GLOB reference");
79072805
LW
103 }
104 else {
93a17b20 105 if (SvTYPE(sv) != SVt_PVGV) {
748a9306
LW
106 char *sym;
107
a0d0e21e
LW
108 if (SvGMAGICAL(sv)) {
109 mg_get(sv);
110 if (SvROK(sv))
111 goto wasref;
112 }
113 if (!SvOK(sv)) {
114 if (op->op_flags & OPf_REF ||
115 op->op_private & HINT_STRICT_REFS)
116 DIE(no_usym, "a symbol");
117 RETSETUNDEF;
118 }
748a9306 119 sym = SvPV(sv, na);
85e6fe83 120 if (op->op_private & HINT_STRICT_REFS)
748a9306
LW
121 DIE(no_symref, sym, "a symbol");
122 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
93a17b20 123 }
79072805 124 }
a0d0e21e 125 if (op->op_private & OPpLVAL_INTRO) {
79072805
LW
126 GP *ogp = GvGP(sv);
127
128 SSCHECK(3);
4633a7c4 129 SSPUSHPTR(SvREFCNT_inc(sv));
79072805
LW
130 SSPUSHPTR(ogp);
131 SSPUSHINT(SAVEt_GP);
132
a0d0e21e 133 if (op->op_flags & OPf_SPECIAL) {
79072805 134 GvGP(sv)->gp_refcnt++; /* will soon be assigned */
a0d0e21e
LW
135 GvFLAGS(sv) |= GVf_INTRO;
136 }
79072805
LW
137 else {
138 GP *gp;
139 Newz(602,gp, 1, GP);
140 GvGP(sv) = gp;
141 GvREFCNT(sv) = 1;
142 GvSV(sv) = NEWSV(72,0);
143 GvLINE(sv) = curcop->cop_line;
144 GvEGV(sv) = sv;
145 }
146 }
147 SETs(sv);
148 RETURN;
149}
150
79072805
LW
151PP(pp_rv2sv)
152{
153 dSP; dTOPss;
154
ed6116ce 155 if (SvROK(sv)) {
a0d0e21e 156 wasref:
ed6116ce 157 sv = SvRV(sv);
79072805
LW
158 switch (SvTYPE(sv)) {
159 case SVt_PVAV:
160 case SVt_PVHV:
161 case SVt_PVCV:
a0d0e21e 162 DIE("Not a SCALAR reference");
79072805
LW
163 }
164 }
165 else {
463ee0b2 166 GV *gv = sv;
748a9306
LW
167 char *sym;
168
463ee0b2 169 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW
170 if (SvGMAGICAL(sv)) {
171 mg_get(sv);
172 if (SvROK(sv))
173 goto wasref;
174 }
175 if (!SvOK(sv)) {
176 if (op->op_flags & OPf_REF ||
177 op->op_private & HINT_STRICT_REFS)
178 DIE(no_usym, "a SCALAR");
179 RETSETUNDEF;
180 }
748a9306 181 sym = SvPV(sv, na);
85e6fe83 182 if (op->op_private & HINT_STRICT_REFS)
748a9306
LW
183 DIE(no_symref, sym, "a SCALAR");
184 gv = (SV*)gv_fetchpv(sym, TRUE, SVt_PV);
463ee0b2
LW
185 }
186 sv = GvSV(gv);
a0d0e21e
LW
187 }
188 if (op->op_flags & OPf_MOD) {
189 if (op->op_private & OPpLVAL_INTRO)
190 sv = save_scalar((GV*)TOPs);
191 else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) {
192 if (SvGMAGICAL(sv))
193 mg_get(sv);
194 if (!SvOK(sv)) {
4633a7c4
LW
195 if (SvREADONLY(sv))
196 croak(no_modify);
a0d0e21e
LW
197 (void)SvUPGRADE(sv, SVt_RV);
198 SvRV(sv) = (op->op_private & OPpDEREF_HV ?
199 (SV*)newHV() : (SV*)newAV());
85e6fe83 200 SvROK_on(sv);
a0d0e21e 201 SvSETMAGIC(sv);
85e6fe83 202 }
93a17b20 203 }
79072805 204 }
a0d0e21e 205 SETs(sv);
79072805
LW
206 RETURN;
207}
208
209PP(pp_av2arylen)
210{
211 dSP;
212 AV *av = (AV*)TOPs;
213 SV *sv = AvARYLEN(av);
214 if (!sv) {
215 AvARYLEN(av) = sv = NEWSV(0,0);
216 sv_upgrade(sv, SVt_IV);
217 sv_magic(sv, (SV*)av, '#', Nullch, 0);
218 }
219 SETs(sv);
220 RETURN;
221}
222
a0d0e21e
LW
223PP(pp_pos)
224{
225 dSP; dTARGET; dPOPss;
226
227 if (op->op_flags & OPf_MOD) {
228 LvTYPE(TARG) = '<';
229 LvTARG(TARG) = sv;
230 PUSHs(TARG); /* no SvSETMAGIC */
231 RETURN;
232 }
233 else {
234 MAGIC* mg;
235
236 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
237 mg = mg_find(sv, 'g');
238 if (mg && mg->mg_len >= 0) {
239 PUSHi(mg->mg_len + curcop->cop_arybase);
240 RETURN;
241 }
242 }
243 RETPUSHUNDEF;
244 }
245}
246
79072805
LW
247PP(pp_rv2cv)
248{
249 dSP;
79072805
LW
250 GV *gv;
251 HV *stash;
8990e307 252
4633a7c4
LW
253 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
254 /* (But not in defined().) */
255 CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
79072805 256
4633a7c4
LW
257 if (!cv)
258 cv = (CV*)&sv_undef;
79072805
LW
259 SETs((SV*)cv);
260 RETURN;
261}
262
c07a80fd
PP
263PP(pp_prototype)
264{
265 dSP;
266 CV *cv;
267 HV *stash;
268 GV *gv;
269 SV *ret;
270
271 ret = &sv_undef;
272 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
273 if (cv && SvPOK(cv)) {
274 char *p = SvPVX(cv);
275 ret = sv_2mortal(newSVpv(p ? p : "", SvLEN(cv)));
276 }
277 SETs(ret);
278 RETURN;
279}
280
a0d0e21e
LW
281PP(pp_anoncode)
282{
283 dSP;
748a9306
LW
284 CV* cv = (CV*)cSVOP->op_sv;
285 EXTEND(SP,1);
286
287 if (SvFLAGS(cv) & SVpcv_CLONE) {
b355b4e0 288 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
748a9306
LW
289 }
290
291 PUSHs((SV*)cv);
a0d0e21e
LW
292 RETURN;
293}
294
295PP(pp_srefgen)
79072805
LW
296{
297 dSP; dTOPss;
298 SV* rv;
8990e307 299 rv = sv_newmortal();
ed6116ce 300 sv_upgrade(rv, SVt_RV);
a0d0e21e
LW
301 if (SvPADTMP(sv))
302 sv = newSVsv(sv);
303 else {
304 SvTEMP_off(sv);
305 (void)SvREFCNT_inc(sv);
306 }
307 SvRV(rv) = sv;
ed6116ce 308 SvROK_on(rv);
79072805
LW
309 SETs(rv);
310 RETURN;
a0d0e21e
LW
311}
312
313PP(pp_refgen)
314{
315 dSP; dMARK;
316 SV* sv;
317 SV* rv;
318 if (GIMME != G_ARRAY) {
319 MARK[1] = *SP;
320 SP = MARK + 1;
321 }
322 while (MARK < SP) {
323 sv = *++MARK;
324 rv = sv_newmortal();
325 sv_upgrade(rv, SVt_RV);
326 if (SvPADTMP(sv))
327 sv = newSVsv(sv);
328 else {
329 SvTEMP_off(sv);
330 (void)SvREFCNT_inc(sv);
331 }
332 SvRV(rv) = sv;
333 SvROK_on(rv);
334 *MARK = rv;
335 }
336 RETURN;
79072805
LW
337}
338
339PP(pp_ref)
340{
463ee0b2
LW
341 dSP; dTARGET;
342 SV *sv;
79072805
LW
343 char *pv;
344
a0d0e21e
LW
345 sv = POPs;
346 if (!sv || !SvROK(sv))
4633a7c4 347 RETPUSHNO;
79072805 348
ed6116ce 349 sv = SvRV(sv);
a0d0e21e 350 pv = sv_reftype(sv,TRUE);
463ee0b2 351 PUSHp(pv, strlen(pv));
79072805
LW
352 RETURN;
353}
354
355PP(pp_bless)
356{
463ee0b2 357 dSP;
463ee0b2 358 HV *stash;
79072805 359
463ee0b2
LW
360 if (MAXARG == 1)
361 stash = curcop->cop_stash;
362 else
a0d0e21e
LW
363 stash = gv_stashsv(POPs, TRUE);
364
365 (void)sv_bless(TOPs, stash);
79072805
LW
366 RETURN;
367}
368
a0d0e21e 369/* Pattern matching */
79072805 370
a0d0e21e 371PP(pp_study)
79072805 372{
c07a80fd 373 dSP; dPOPss;
a0d0e21e
LW
374 register unsigned char *s;
375 register I32 pos;
376 register I32 ch;
377 register I32 *sfirst;
378 register I32 *snext;
379 I32 retval;
380 STRLEN len;
381
c07a80fd 382 s = (unsigned char*)(SvPV(sv, len));
a0d0e21e 383 pos = len;
c07a80fd
PP
384 if (sv == lastscream)
385 SvSCREAM_off(sv);
386 else {
387 if (lastscream) {
388 SvSCREAM_off(lastscream);
389 SvREFCNT_dec(lastscream);
390 }
391 lastscream = SvREFCNT_inc(sv);
392 }
a0d0e21e
LW
393 if (pos <= 0) {
394 retval = 0;
395 goto ret;
396 }
397 if (pos > maxscream) {
398 if (maxscream < 0) {
399 maxscream = pos + 80;
400 New(301, screamfirst, 256, I32);
401 New(302, screamnext, maxscream, I32);
79072805
LW
402 }
403 else {
a0d0e21e
LW
404 maxscream = pos + pos / 4;
405 Renew(screamnext, maxscream, I32);
79072805 406 }
79072805 407 }
a0d0e21e
LW
408
409 sfirst = screamfirst;
410 snext = screamnext;
411
412 if (!sfirst || !snext)
413 DIE("do_study: out of memory");
414
415 for (ch = 256; ch; --ch)
416 *sfirst++ = -1;
417 sfirst -= 256;
418
419 while (--pos >= 0) {
420 ch = s[pos];
421 if (sfirst[ch] >= 0)
422 snext[pos] = sfirst[ch] - pos;
423 else
424 snext[pos] = -pos;
425 sfirst[ch] = pos;
426
427 /* If there were any case insensitive searches, we must assume they
428 * all are. This speeds up insensitive searches much more than
429 * it slows down sensitive ones.
430 */
431 if (sawi)
432 sfirst[fold[ch]] = pos;
79072805
LW
433 }
434
c07a80fd 435 SvSCREAM_on(sv);
a0d0e21e
LW
436 retval = 1;
437 ret:
438 XPUSHs(sv_2mortal(newSViv((I32)retval)));
79072805
LW
439 RETURN;
440}
441
a0d0e21e 442PP(pp_trans)
79072805 443{
a0d0e21e
LW
444 dSP; dTARG;
445 SV *sv;
446
447 if (op->op_flags & OPf_STACKED)
448 sv = POPs;
79072805 449 else {
a0d0e21e
LW
450 sv = GvSV(defgv);
451 EXTEND(SP,1);
79072805 452 }
adbc6bb1 453 TARG = sv_newmortal();
a0d0e21e
LW
454 PUSHi(do_trans(sv, op));
455 RETURN;
79072805
LW
456}
457
a0d0e21e 458/* Lvalue operators. */
79072805 459
a0d0e21e
LW
460PP(pp_schop)
461{
462 dSP; dTARGET;
463 do_chop(TARG, TOPs);
464 SETTARG;
465 RETURN;
79072805
LW
466}
467
a0d0e21e 468PP(pp_chop)
79072805 469{
a0d0e21e
LW
470 dSP; dMARK; dTARGET;
471 while (SP > MARK)
472 do_chop(TARG, POPs);
473 PUSHTARG;
474 RETURN;
79072805
LW
475}
476
a0d0e21e 477PP(pp_schomp)
79072805 478{
a0d0e21e
LW
479 dSP; dTARGET;
480 SETi(do_chomp(TOPs));
481 RETURN;
79072805
LW
482}
483
a0d0e21e 484PP(pp_chomp)
79072805 485{
a0d0e21e
LW
486 dSP; dMARK; dTARGET;
487 register I32 count = 0;
488
489 while (SP > MARK)
490 count += do_chomp(POPs);
491 PUSHi(count);
492 RETURN;
79072805
LW
493}
494
a0d0e21e 495PP(pp_defined)
463ee0b2 496{
a0d0e21e
LW
497 dSP;
498 register SV* sv;
499
500 sv = POPs;
501 if (!sv || !SvANY(sv))
502 RETPUSHNO;
503 switch (SvTYPE(sv)) {
504 case SVt_PVAV:
8e07c86e 505 if (AvMAX(sv) >= 0 || SvRMAGICAL(sv))
a0d0e21e
LW
506 RETPUSHYES;
507 break;
508 case SVt_PVHV:
8e07c86e 509 if (HvARRAY(sv) || SvRMAGICAL(sv))
a0d0e21e
LW
510 RETPUSHYES;
511 break;
512 case SVt_PVCV:
513 if (CvROOT(sv) || CvXSUB(sv))
514 RETPUSHYES;
515 break;
516 default:
517 if (SvGMAGICAL(sv))
518 mg_get(sv);
519 if (SvOK(sv))
520 RETPUSHYES;
521 }
522 RETPUSHNO;
463ee0b2
LW
523}
524
a0d0e21e
LW
525PP(pp_undef)
526{
79072805 527 dSP;
a0d0e21e
LW
528 SV *sv;
529
530 if (!op->op_private)
531 RETPUSHUNDEF;
79072805 532
a0d0e21e
LW
533 sv = POPs;
534 if (!sv)
535 RETPUSHUNDEF;
85e6fe83 536
a0d0e21e
LW
537 if (SvTHINKFIRST(sv)) {
538 if (SvREADONLY(sv))
539 RETPUSHUNDEF;
540 if (SvROK(sv))
541 sv_unref(sv);
85e6fe83
LW
542 }
543
a0d0e21e
LW
544 switch (SvTYPE(sv)) {
545 case SVt_NULL:
546 break;
547 case SVt_PVAV:
548 av_undef((AV*)sv);
549 break;
550 case SVt_PVHV:
551 hv_undef((HV*)sv);
552 break;
553 case SVt_PVCV:
554 cv_undef((CV*)sv);
555 sub_generation++;
556 break;
8e07c86e
AD
557 case SVt_PVGV:
558 if (SvFAKE(sv)) {
559 sv_setsv(sv, &sv_undef);
560 break;
561 }
a0d0e21e 562 default:
4633a7c4
LW
563 if (SvPOK(sv) && SvLEN(sv)) {
564 (void)SvOOK_off(sv);
565 Safefree(SvPVX(sv));
566 SvPV_set(sv, Nullch);
567 SvLEN_set(sv, 0);
a0d0e21e 568 }
4633a7c4
LW
569 (void)SvOK_off(sv);
570 SvSETMAGIC(sv);
79072805 571 }
a0d0e21e
LW
572
573 RETPUSHUNDEF;
79072805
LW
574}
575
a0d0e21e 576PP(pp_predec)
79072805 577{
a0d0e21e 578 dSP;
748a9306
LW
579 if (SvIOK(TOPs)) {
580 --SvIVX(TOPs);
581 SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
582 }
583 else
584 sv_dec(TOPs);
a0d0e21e
LW
585 SvSETMAGIC(TOPs);
586 return NORMAL;
587}
79072805 588
a0d0e21e
LW
589PP(pp_postinc)
590{
591 dSP; dTARGET;
592 sv_setsv(TARG, TOPs);
748a9306
LW
593 if (SvIOK(TOPs)) {
594 ++SvIVX(TOPs);
595 SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
596 }
597 else
598 sv_inc(TOPs);
a0d0e21e
LW
599 SvSETMAGIC(TOPs);
600 if (!SvOK(TARG))
601 sv_setiv(TARG, 0);
602 SETs(TARG);
603 return NORMAL;
604}
79072805 605
a0d0e21e
LW
606PP(pp_postdec)
607{
608 dSP; dTARGET;
609 sv_setsv(TARG, TOPs);
748a9306
LW
610 if (SvIOK(TOPs)) {
611 --SvIVX(TOPs);
612 SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
613 }
614 else
615 sv_dec(TOPs);
a0d0e21e
LW
616 SvSETMAGIC(TOPs);
617 SETs(TARG);
618 return NORMAL;
619}
79072805 620
a0d0e21e
LW
621/* Ordinary operators. */
622
623PP(pp_pow)
624{
625 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
626 {
627 dPOPTOPnnrl;
628 SETn( pow( left, right) );
629 RETURN;
93a17b20 630 }
a0d0e21e
LW
631}
632
633PP(pp_multiply)
634{
635 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
636 {
637 dPOPTOPnnrl;
638 SETn( left * right );
639 RETURN;
79072805 640 }
a0d0e21e
LW
641}
642
643PP(pp_divide)
644{
645 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
646 {
647 dPOPnv;
648 if (value == 0.0)
649 DIE("Illegal division by zero");
650#ifdef SLOPPYDIVIDE
651 /* insure that 20./5. == 4. */
652 {
653 double x;
654 I32 k;
655 x = POPn;
656 if ((double)I_32(x) == x &&
657 (double)I_32(value) == value &&
658 (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) {
659 value = k;
660 } else {
661 value = x/value;
79072805 662 }
a0d0e21e
LW
663 }
664#else
665 value = POPn / value;
666#endif
667 PUSHn( value );
668 RETURN;
79072805 669 }
a0d0e21e
LW
670}
671
672PP(pp_modulo)
673{
674 dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
675 {
676 register unsigned long tmpulong;
677 register long tmplong;
678 I32 value;
679
680 tmpulong = (unsigned long) POPn;
681 if (tmpulong == 0L)
682 DIE("Illegal modulus zero");
683 value = TOPn;
684 if (value >= 0.0)
685 value = (I32)(((unsigned long)value) % tmpulong);
686 else {
687 tmplong = (long)value;
688 value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
689 }
690 SETi(value);
691 RETURN;
79072805 692 }
a0d0e21e 693}
79072805 694
a0d0e21e
LW
695PP(pp_repeat)
696{
748a9306
LW
697 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
698 {
a0d0e21e
LW
699 register I32 count = POPi;
700 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
701 dMARK;
702 I32 items = SP - MARK;
703 I32 max;
79072805 704
a0d0e21e
LW
705 max = items * count;
706 MEXTEND(MARK, max);
707 if (count > 1) {
708 while (SP > MARK) {
709 if (*SP)
710 SvTEMP_off((*SP));
711 SP--;
79072805 712 }
a0d0e21e
LW
713 MARK++;
714 repeatcpy((char*)(MARK + items), (char*)MARK,
715 items * sizeof(SV*), count - 1);
716 SP += max;
79072805 717 }
a0d0e21e
LW
718 else if (count <= 0)
719 SP -= items;
79072805 720 }
a0d0e21e
LW
721 else { /* Note: mark already snarfed by pp_list */
722 SV *tmpstr;
723 STRLEN len;
724
725 tmpstr = POPs;
726 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
727 if (SvREADONLY(tmpstr) && curcop != &compiling)
728 DIE("Can't x= to readonly value");
729 if (SvROK(tmpstr))
730 sv_unref(tmpstr);
93a17b20 731 }
a0d0e21e
LW
732 SvSetSV(TARG, tmpstr);
733 SvPV_force(TARG, len);
734 if (count >= 1) {
735 SvGROW(TARG, (count * len) + 1);
736 if (count > 1)
737 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
738 SvCUR(TARG) *= count;
739 *SvEND(TARG) = '\0';
740 (void)SvPOK_only(TARG);
741 }
742 else
743 sv_setsv(TARG, &sv_no);
744 PUSHTARG;
79072805 745 }
a0d0e21e 746 RETURN;
748a9306 747 }
a0d0e21e 748}
79072805 749
a0d0e21e
LW
750PP(pp_subtract)
751{
752 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
753 {
754 dPOPTOPnnrl;
755 SETn( left - right );
756 RETURN;
79072805 757 }
a0d0e21e 758}
79072805 759
a0d0e21e
LW
760PP(pp_left_shift)
761{
762 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
763 {
748a9306
LW
764 dPOPTOPiirl;
765 SETi( left << right );
766 RETURN;
79072805 767 }
a0d0e21e 768}
79072805 769
a0d0e21e
LW
770PP(pp_right_shift)
771{
772 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
773 {
774 dPOPTOPiirl;
775 SETi( left >> right );
776 RETURN;
93a17b20 777 }
79072805
LW
778}
779
a0d0e21e 780PP(pp_lt)
79072805 781{
a0d0e21e
LW
782 dSP; tryAMAGICbinSET(lt,0);
783 {
784 dPOPnv;
785 SETs((TOPn < value) ? &sv_yes : &sv_no);
786 RETURN;
79072805 787 }
a0d0e21e 788}
79072805 789
a0d0e21e
LW
790PP(pp_gt)
791{
792 dSP; tryAMAGICbinSET(gt,0);
793 {
794 dPOPnv;
795 SETs((TOPn > value) ? &sv_yes : &sv_no);
796 RETURN;
79072805 797 }
a0d0e21e
LW
798}
799
800PP(pp_le)
801{
802 dSP; tryAMAGICbinSET(le,0);
803 {
804 dPOPnv;
805 SETs((TOPn <= value) ? &sv_yes : &sv_no);
806 RETURN;
79072805 807 }
a0d0e21e
LW
808}
809
810PP(pp_ge)
811{
812 dSP; tryAMAGICbinSET(ge,0);
813 {
814 dPOPnv;
815 SETs((TOPn >= value) ? &sv_yes : &sv_no);
816 RETURN;
79072805 817 }
a0d0e21e 818}
79072805 819
a0d0e21e
LW
820PP(pp_ne)
821{
822 dSP; tryAMAGICbinSET(ne,0);
823 {
824 dPOPnv;
825 SETs((TOPn != value) ? &sv_yes : &sv_no);
826 RETURN;
827 }
79072805
LW
828}
829
a0d0e21e 830PP(pp_ncmp)
79072805 831{
a0d0e21e
LW
832 dSP; dTARGET; tryAMAGICbin(ncmp,0);
833 {
834 dPOPTOPnnrl;
835 I32 value;
79072805 836
a0d0e21e
LW
837 if (left > right)
838 value = 1;
839 else if (left < right)
840 value = -1;
841 else
842 value = 0;
843 SETi(value);
844 RETURN;
79072805 845 }
a0d0e21e 846}
79072805 847
a0d0e21e
LW
848PP(pp_slt)
849{
850 dSP; tryAMAGICbinSET(slt,0);
851 {
852 dPOPTOPssrl;
853 SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no );
854 RETURN;
855 }
79072805
LW
856}
857
a0d0e21e 858PP(pp_sgt)
79072805 859{
a0d0e21e
LW
860 dSP; tryAMAGICbinSET(sgt,0);
861 {
862 dPOPTOPssrl;
863 SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no );
864 RETURN;
865 }
866}
79072805 867
a0d0e21e
LW
868PP(pp_sle)
869{
870 dSP; tryAMAGICbinSET(sle,0);
871 {
872 dPOPTOPssrl;
873 SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no );
874 RETURN;
79072805 875 }
79072805
LW
876}
877
a0d0e21e
LW
878PP(pp_sge)
879{
880 dSP; tryAMAGICbinSET(sge,0);
881 {
882 dPOPTOPssrl;
883 SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no );
884 RETURN;
885 }
886}
79072805 887
a0d0e21e 888PP(pp_sne)
79072805 889{
a0d0e21e
LW
890 dSP; tryAMAGICbinSET(sne,0);
891 {
892 dPOPTOPssrl;
893 SETs( !sv_eq(left, right) ? &sv_yes : &sv_no );
894 RETURN;
463ee0b2 895 }
79072805
LW
896}
897
a0d0e21e 898PP(pp_scmp)
79072805 899{
a0d0e21e
LW
900 dSP; dTARGET; tryAMAGICbin(scmp,0);
901 {
902 dPOPTOPssrl;
903 SETi( sv_cmp(left, right) );
904 RETURN;
905 }
906}
79072805 907
a0d0e21e
LW
908PP(pp_bit_and) {
909 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
910 {
911 dPOPTOPssrl;
4633a7c4 912 if (SvNIOKp(left) || SvNIOKp(right)) {
a0d0e21e
LW
913 unsigned long value = U_L(SvNV(left));
914 value = value & U_L(SvNV(right));
915 SETn((double)value);
916 }
917 else {
918 do_vop(op->op_type, TARG, left, right);
919 SETTARG;
920 }
921 RETURN;
922 }
923}
79072805 924
a0d0e21e
LW
925PP(pp_bit_xor)
926{
927 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
928 {
929 dPOPTOPssrl;
4633a7c4 930 if (SvNIOKp(left) || SvNIOKp(right)) {
a0d0e21e
LW
931 unsigned long value = U_L(SvNV(left));
932 value = value ^ U_L(SvNV(right));
933 SETn((double)value);
934 }
935 else {
936 do_vop(op->op_type, TARG, left, right);
937 SETTARG;
938 }
939 RETURN;
940 }
941}
79072805 942
a0d0e21e
LW
943PP(pp_bit_or)
944{
945 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
946 {
947 dPOPTOPssrl;
4633a7c4 948 if (SvNIOKp(left) || SvNIOKp(right)) {
a0d0e21e
LW
949 unsigned long value = U_L(SvNV(left));
950 value = value | U_L(SvNV(right));
951 SETn((double)value);
952 }
953 else {
954 do_vop(op->op_type, TARG, left, right);
955 SETTARG;
956 }
957 RETURN;
79072805 958 }
a0d0e21e 959}
79072805 960
a0d0e21e
LW
961PP(pp_negate)
962{
963 dSP; dTARGET; tryAMAGICun(neg);
964 {
965 dTOPss;
4633a7c4
LW
966 if (SvGMAGICAL(sv))
967 mg_get(sv);
968 if (SvNIOKp(sv))
a0d0e21e 969 SETn(-SvNV(sv));
4633a7c4 970 else if (SvPOKp(sv)) {
a0d0e21e
LW
971 STRLEN len;
972 char *s = SvPV(sv, len);
973 if (isALPHA(*s) || *s == '_') {
974 sv_setpvn(TARG, "-", 1);
975 sv_catsv(TARG, sv);
79072805 976 }
a0d0e21e
LW
977 else if (*s == '+' || *s == '-') {
978 sv_setsv(TARG, sv);
979 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805
LW
980 }
981 else
a0d0e21e
LW
982 sv_setnv(TARG, -SvNV(sv));
983 SETTARG;
79072805 984 }
4633a7c4
LW
985 else
986 SETn(-SvNV(sv));
79072805 987 }
a0d0e21e 988 RETURN;
79072805
LW
989}
990
a0d0e21e 991PP(pp_not)
79072805 992{
a0d0e21e
LW
993#ifdef OVERLOAD
994 dSP; tryAMAGICunSET(not);
995#endif /* OVERLOAD */
996 *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
997 return NORMAL;
79072805
LW
998}
999
a0d0e21e 1000PP(pp_complement)
79072805 1001{
a0d0e21e
LW
1002 dSP; dTARGET; tryAMAGICun(compl);
1003 {
1004 dTOPss;
1005 register I32 anum;
1006
4633a7c4 1007 if (SvNIOKp(sv)) {
748a9306
LW
1008 IV iv = ~SvIV(sv);
1009 if (iv < 0)
1010 SETn( (double) ~U_L(SvNV(sv)) );
1011 else
1012 SETi( iv );
a0d0e21e
LW
1013 }
1014 else {
1015 register char *tmps;
1016 register long *tmpl;
1017 STRLEN len;
1018
1019 SvSetSV(TARG, sv);
1020 tmps = SvPV_force(TARG, len);
1021 anum = len;
1022#ifdef LIBERAL
1023 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1024 *tmps = ~*tmps;
1025 tmpl = (long*)tmps;
1026 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1027 *tmpl = ~*tmpl;
1028 tmps = (char*)tmpl;
1029#endif
1030 for ( ; anum > 0; anum--, tmps++)
1031 *tmps = ~*tmps;
1032
1033 SETs(TARG);
1034 }
1035 RETURN;
1036 }
79072805
LW
1037}
1038
a0d0e21e
LW
1039/* integer versions of some of the above */
1040
a0d0e21e 1041PP(pp_i_multiply)
79072805 1042{
a0d0e21e
LW
1043 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1044 {
1045 dPOPTOPiirl;
1046 SETi( left * right );
1047 RETURN;
1048 }
79072805
LW
1049}
1050
a0d0e21e 1051PP(pp_i_divide)
79072805 1052{
a0d0e21e
LW
1053 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1054 {
1055 dPOPiv;
1056 if (value == 0)
1057 DIE("Illegal division by zero");
1058 value = POPi / value;
1059 PUSHi( value );
1060 RETURN;
1061 }
79072805
LW
1062}
1063
a0d0e21e 1064PP(pp_i_modulo)
79072805 1065{
a0d0e21e 1066 dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
79072805 1067 {
a0d0e21e
LW
1068 dPOPTOPiirl;
1069 SETi( left % right );
1070 RETURN;
79072805 1071 }
79072805
LW
1072}
1073
a0d0e21e 1074PP(pp_i_add)
79072805 1075{
a0d0e21e
LW
1076 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1077 {
1078 dPOPTOPiirl;
1079 SETi( left + right );
1080 RETURN;
79072805 1081 }
79072805
LW
1082}
1083
a0d0e21e 1084PP(pp_i_subtract)
79072805 1085{
a0d0e21e
LW
1086 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1087 {
1088 dPOPTOPiirl;
1089 SETi( left - right );
1090 RETURN;
79072805 1091 }
79072805
LW
1092}
1093
a0d0e21e 1094PP(pp_i_lt)
79072805 1095{
a0d0e21e
LW
1096 dSP; tryAMAGICbinSET(lt,0);
1097 {
1098 dPOPTOPiirl;
1099 SETs((left < right) ? &sv_yes : &sv_no);
1100 RETURN;
1101 }
79072805
LW
1102}
1103
a0d0e21e 1104PP(pp_i_gt)
79072805 1105{
a0d0e21e
LW
1106 dSP; tryAMAGICbinSET(gt,0);
1107 {
1108 dPOPTOPiirl;
1109 SETs((left > right) ? &sv_yes : &sv_no);
1110 RETURN;
1111 }
79072805
LW
1112}
1113
a0d0e21e 1114PP(pp_i_le)
79072805 1115{
a0d0e21e
LW
1116 dSP; tryAMAGICbinSET(le,0);
1117 {
1118 dPOPTOPiirl;
1119 SETs((left <= right) ? &sv_yes : &sv_no);
1120 RETURN;
85e6fe83 1121 }
79072805
LW
1122}
1123
a0d0e21e 1124PP(pp_i_ge)
79072805 1125{
a0d0e21e
LW
1126 dSP; tryAMAGICbinSET(ge,0);
1127 {
1128 dPOPTOPiirl;
1129 SETs((left >= right) ? &sv_yes : &sv_no);
1130 RETURN;
1131 }
79072805
LW
1132}
1133
a0d0e21e 1134PP(pp_i_eq)
79072805 1135{
a0d0e21e
LW
1136 dSP; tryAMAGICbinSET(eq,0);
1137 {
1138 dPOPTOPiirl;
1139 SETs((left == right) ? &sv_yes : &sv_no);
1140 RETURN;
1141 }
79072805
LW
1142}
1143
a0d0e21e 1144PP(pp_i_ne)
79072805 1145{
a0d0e21e
LW
1146 dSP; tryAMAGICbinSET(ne,0);
1147 {
1148 dPOPTOPiirl;
1149 SETs((left != right) ? &sv_yes : &sv_no);
1150 RETURN;
1151 }
79072805
LW
1152}
1153
a0d0e21e 1154PP(pp_i_ncmp)
79072805 1155{
a0d0e21e
LW
1156 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1157 {
1158 dPOPTOPiirl;
1159 I32 value;
79072805 1160
a0d0e21e 1161 if (left > right)
79072805 1162 value = 1;
a0d0e21e 1163 else if (left < right)
79072805 1164 value = -1;
a0d0e21e 1165 else
79072805 1166 value = 0;
a0d0e21e
LW
1167 SETi(value);
1168 RETURN;
79072805 1169 }
85e6fe83
LW
1170}
1171
1172PP(pp_i_negate)
1173{
a0d0e21e 1174 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW
1175 SETi(-TOPi);
1176 RETURN;
1177}
1178
79072805
LW
1179/* High falutin' math. */
1180
1181PP(pp_atan2)
1182{
a0d0e21e
LW
1183 dSP; dTARGET; tryAMAGICbin(atan2,0);
1184 {
1185 dPOPTOPnnrl;
1186 SETn(atan2(left, right));
1187 RETURN;
1188 }
79072805
LW
1189}
1190
1191PP(pp_sin)
1192{
a0d0e21e
LW
1193 dSP; dTARGET; tryAMAGICun(sin);
1194 {
1195 double value;
1196 value = POPn;
1197 value = sin(value);
1198 XPUSHn(value);
1199 RETURN;
1200 }
79072805
LW
1201}
1202
1203PP(pp_cos)
1204{
a0d0e21e
LW
1205 dSP; dTARGET; tryAMAGICun(cos);
1206 {
1207 double value;
1208 value = POPn;
1209 value = cos(value);
1210 XPUSHn(value);
1211 RETURN;
1212 }
79072805
LW
1213}
1214
1215PP(pp_rand)
1216{
1217 dSP; dTARGET;
1218 double value;
1219 if (MAXARG < 1)
1220 value = 1.0;
1221 else
1222 value = POPn;
1223 if (value == 0.0)
1224 value = 1.0;
1225#if RANDBITS == 31
1226 value = rand() * value / 2147483648.0;
1227#else
1228#if RANDBITS == 16
1229 value = rand() * value / 65536.0;
1230#else
1231#if RANDBITS == 15
1232 value = rand() * value / 32768.0;
1233#else
1234 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1235#endif
1236#endif
1237#endif
1238 XPUSHn(value);
1239 RETURN;
1240}
1241
1242PP(pp_srand)
1243{
1244 dSP;
1245 I32 anum;
85e6fe83 1246 Time_t when;
79072805
LW
1247
1248 if (MAXARG < 1) {
1249 (void)time(&when);
1250 anum = when;
1251 }
1252 else
1253 anum = POPi;
1254 (void)srand(anum);
1255 EXTEND(SP, 1);
1256 RETPUSHYES;
1257}
1258
1259PP(pp_exp)
1260{
a0d0e21e
LW
1261 dSP; dTARGET; tryAMAGICun(exp);
1262 {
1263 double value;
1264 value = POPn;
1265 value = exp(value);
1266 XPUSHn(value);
1267 RETURN;
1268 }
79072805
LW
1269}
1270
1271PP(pp_log)
1272{
a0d0e21e
LW
1273 dSP; dTARGET; tryAMAGICun(log);
1274 {
1275 double value;
1276 value = POPn;
1277 if (value <= 0.0)
2304df62 1278 DIE("Can't take log of %g", value);
a0d0e21e
LW
1279 value = log(value);
1280 XPUSHn(value);
1281 RETURN;
1282 }
79072805
LW
1283}
1284
1285PP(pp_sqrt)
1286{
a0d0e21e
LW
1287 dSP; dTARGET; tryAMAGICun(sqrt);
1288 {
1289 double value;
1290 value = POPn;
1291 if (value < 0.0)
2304df62 1292 DIE("Can't take sqrt of %g", value);
a0d0e21e
LW
1293 value = sqrt(value);
1294 XPUSHn(value);
1295 RETURN;
1296 }
79072805
LW
1297}
1298
1299PP(pp_int)
1300{
1301 dSP; dTARGET;
1302 double value;
a0d0e21e 1303 value = POPn;
79072805
LW
1304 if (value >= 0.0)
1305 (void)modf(value, &value);
1306 else {
1307 (void)modf(-value, &value);
1308 value = -value;
1309 }
1310 XPUSHn(value);
1311 RETURN;
1312}
1313
463ee0b2
LW
1314PP(pp_abs)
1315{
a0d0e21e
LW
1316 dSP; dTARGET; tryAMAGICun(abs);
1317 {
1318 double value;
1319 value = POPn;
463ee0b2 1320
a0d0e21e 1321 if (value < 0.0)
463ee0b2
LW
1322 value = -value;
1323
a0d0e21e
LW
1324 XPUSHn(value);
1325 RETURN;
1326 }
463ee0b2
LW
1327}
1328
79072805
LW
1329PP(pp_hex)
1330{
1331 dSP; dTARGET;
1332 char *tmps;
1333 I32 argtype;
1334
a0d0e21e 1335 tmps = POPp;
79072805
LW
1336 XPUSHi( scan_hex(tmps, 99, &argtype) );
1337 RETURN;
1338}
1339
1340PP(pp_oct)
1341{
1342 dSP; dTARGET;
1343 I32 value;
1344 I32 argtype;
1345 char *tmps;
1346
a0d0e21e 1347 tmps = POPp;
79072805
LW
1348 while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
1349 tmps++;
1350 if (*tmps == 'x')
1351 value = (I32)scan_hex(++tmps, 99, &argtype);
1352 else
1353 value = (I32)scan_oct(tmps, 99, &argtype);
1354 XPUSHi(value);
1355 RETURN;
1356}
1357
1358/* String stuff. */
1359
1360PP(pp_length)
1361{
1362 dSP; dTARGET;
a0d0e21e 1363 SETi( sv_len(TOPs) );
79072805
LW
1364 RETURN;
1365}
1366
1367PP(pp_substr)
1368{
1369 dSP; dTARGET;
1370 SV *sv;
1371 I32 len;
463ee0b2 1372 STRLEN curlen;
79072805
LW
1373 I32 pos;
1374 I32 rem;
a0d0e21e 1375 I32 lvalue = op->op_flags & OPf_MOD;
79072805 1376 char *tmps;
a0d0e21e 1377 I32 arybase = curcop->cop_arybase;
79072805
LW
1378
1379 if (MAXARG > 2)
1380 len = POPi;
1381 pos = POPi - arybase;
1382 sv = POPs;
a0d0e21e 1383 tmps = SvPV(sv, curlen);
79072805
LW
1384 if (pos < 0)
1385 pos += curlen + arybase;
2304df62 1386 if (pos < 0 || pos > curlen) {
a0d0e21e 1387 if (dowarn || lvalue)
2304df62
AD
1388 warn("substr outside of string");
1389 RETPUSHUNDEF;
1390 }
79072805
LW
1391 else {
1392 if (MAXARG < 3)
1393 len = curlen;
a0d0e21e 1394 else if (len < 0) {
748a9306 1395 len += curlen - pos;
a0d0e21e
LW
1396 if (len < 0)
1397 len = 0;
1398 }
79072805
LW
1399 tmps += pos;
1400 rem = curlen - pos; /* rem=how many bytes left*/
1401 if (rem > len)
1402 rem = len;
1403 sv_setpvn(TARG, tmps, rem);
1404 if (lvalue) { /* it's an lvalue! */
c07a80fd
PP
1405 if (!SvGMAGICAL(sv))
1406 (void)SvPOK_only(sv);
a0d0e21e
LW
1407 if (SvTYPE(TARG) < SVt_PVLV) {
1408 sv_upgrade(TARG, SVt_PVLV);
1409 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 1410 }
a0d0e21e 1411
79072805
LW
1412 LvTYPE(TARG) = 's';
1413 LvTARG(TARG) = sv;
a0d0e21e 1414 LvTARGOFF(TARG) = pos;
79072805
LW
1415 LvTARGLEN(TARG) = rem;
1416 }
1417 }
1418 PUSHs(TARG); /* avoid SvSETMAGIC here */
1419 RETURN;
1420}
1421
1422PP(pp_vec)
1423{
1424 dSP; dTARGET;
1425 register I32 size = POPi;
1426 register I32 offset = POPi;
1427 register SV *src = POPs;
a0d0e21e 1428 I32 lvalue = op->op_flags & OPf_MOD;
463ee0b2
LW
1429 STRLEN srclen;
1430 unsigned char *s = (unsigned char*)SvPV(src, srclen);
79072805
LW
1431 unsigned long retnum;
1432 I32 len;
1433
1434 offset *= size; /* turn into bit offset */
1435 len = (offset + size + 7) / 8;
1436 if (offset < 0 || size < 1)
1437 retnum = 0;
79072805 1438 else {
a0d0e21e
LW
1439 if (lvalue) { /* it's an lvalue! */
1440 if (SvTYPE(TARG) < SVt_PVLV) {
1441 sv_upgrade(TARG, SVt_PVLV);
1442 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1443 }
1444
1445 LvTYPE(TARG) = 'v';
1446 LvTARG(TARG) = src;
1447 LvTARGOFF(TARG) = offset;
1448 LvTARGLEN(TARG) = size;
1449 }
93a17b20 1450 if (len > srclen) {
a0d0e21e
LW
1451 if (size <= 8)
1452 retnum = 0;
1453 else {
1454 offset >>= 3;
748a9306
LW
1455 if (size == 16) {
1456 if (offset >= srclen)
1457 retnum = 0;
a0d0e21e 1458 else
748a9306
LW
1459 retnum = (unsigned long) s[offset] << 8;
1460 }
1461 else if (size == 32) {
1462 if (offset >= srclen)
1463 retnum = 0;
1464 else if (offset + 1 >= srclen)
a0d0e21e 1465 retnum = (unsigned long) s[offset] << 24;
748a9306
LW
1466 else if (offset + 2 >= srclen)
1467 retnum = ((unsigned long) s[offset] << 24) +
1468 ((unsigned long) s[offset + 1] << 16);
1469 else
1470 retnum = ((unsigned long) s[offset] << 24) +
1471 ((unsigned long) s[offset + 1] << 16) +
1472 (s[offset + 2] << 8);
a0d0e21e
LW
1473 }
1474 }
79072805 1475 }
a0d0e21e 1476 else if (size < 8)
79072805
LW
1477 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1478 else {
1479 offset >>= 3;
1480 if (size == 8)
1481 retnum = s[offset];
1482 else if (size == 16)
1483 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1484 else if (size == 32)
1485 retnum = ((unsigned long) s[offset] << 24) +
1486 ((unsigned long) s[offset + 1] << 16) +
1487 (s[offset + 2] << 8) + s[offset+3];
1488 }
79072805
LW
1489 }
1490
1491 sv_setiv(TARG, (I32)retnum);
1492 PUSHs(TARG);
1493 RETURN;
1494}
1495
1496PP(pp_index)
1497{
1498 dSP; dTARGET;
1499 SV *big;
1500 SV *little;
1501 I32 offset;
1502 I32 retval;
1503 char *tmps;
1504 char *tmps2;
463ee0b2 1505 STRLEN biglen;
a0d0e21e 1506 I32 arybase = curcop->cop_arybase;
79072805
LW
1507
1508 if (MAXARG < 3)
1509 offset = 0;
1510 else
1511 offset = POPi - arybase;
1512 little = POPs;
1513 big = POPs;
463ee0b2 1514 tmps = SvPV(big, biglen);
79072805
LW
1515 if (offset < 0)
1516 offset = 0;
93a17b20
LW
1517 else if (offset > biglen)
1518 offset = biglen;
79072805 1519 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
93a17b20 1520 (unsigned char*)tmps + biglen, little)))
79072805
LW
1521 retval = -1 + arybase;
1522 else
1523 retval = tmps2 - tmps + arybase;
1524 PUSHi(retval);
1525 RETURN;
1526}
1527
1528PP(pp_rindex)
1529{
1530 dSP; dTARGET;
1531 SV *big;
1532 SV *little;
463ee0b2
LW
1533 STRLEN blen;
1534 STRLEN llen;
79072805
LW
1535 SV *offstr;
1536 I32 offset;
1537 I32 retval;
1538 char *tmps;
1539 char *tmps2;
a0d0e21e 1540 I32 arybase = curcop->cop_arybase;
79072805 1541
a0d0e21e 1542 if (MAXARG >= 3)
79072805
LW
1543 offstr = POPs;
1544 little = POPs;
1545 big = POPs;
463ee0b2
LW
1546 tmps2 = SvPV(little, llen);
1547 tmps = SvPV(big, blen);
79072805 1548 if (MAXARG < 3)
463ee0b2 1549 offset = blen;
79072805 1550 else
463ee0b2 1551 offset = SvIV(offstr) - arybase + llen;
79072805
LW
1552 if (offset < 0)
1553 offset = 0;
463ee0b2
LW
1554 else if (offset > blen)
1555 offset = blen;
79072805 1556 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 1557 tmps2, tmps2 + llen)))
79072805
LW
1558 retval = -1 + arybase;
1559 else
1560 retval = tmps2 - tmps + arybase;
1561 PUSHi(retval);
1562 RETURN;
1563}
1564
1565PP(pp_sprintf)
1566{
1567 dSP; dMARK; dORIGMARK; dTARGET;
1568 do_sprintf(TARG, SP-MARK, MARK+1);
1569 SP = ORIGMARK;
1570 PUSHTARG;
1571 RETURN;
1572}
1573
79072805
LW
1574PP(pp_ord)
1575{
1576 dSP; dTARGET;
1577 I32 value;
1578 char *tmps;
79072805 1579
79072805 1580#ifndef I286
a0d0e21e 1581 tmps = POPp;
79072805
LW
1582 value = (I32) (*tmps & 255);
1583#else
a0d0e21e
LW
1584 I32 anum;
1585 tmps = POPp;
79072805
LW
1586 anum = (I32) *tmps;
1587 value = (I32) (anum & 255);
1588#endif
1589 XPUSHi(value);
1590 RETURN;
1591}
1592
463ee0b2
LW
1593PP(pp_chr)
1594{
1595 dSP; dTARGET;
1596 char *tmps;
1597
748a9306
LW
1598 (void)SvUPGRADE(TARG,SVt_PV);
1599 SvGROW(TARG,2);
463ee0b2
LW
1600 SvCUR_set(TARG, 1);
1601 tmps = SvPVX(TARG);
748a9306
LW
1602 *tmps++ = POPi;
1603 *tmps = '\0';
a0d0e21e 1604 (void)SvPOK_only(TARG);
463ee0b2
LW
1605 XPUSHs(TARG);
1606 RETURN;
1607}
1608
79072805
LW
1609PP(pp_crypt)
1610{
1611 dSP; dTARGET; dPOPTOPssrl;
1612#ifdef HAS_CRYPT
a0d0e21e 1613 char *tmps = SvPV(left, na);
79072805 1614#ifdef FCRYPT
a0d0e21e 1615 sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
79072805 1616#else
a0d0e21e 1617 sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
79072805
LW
1618#endif
1619#else
1620 DIE(
1621 "The crypt() function is unimplemented due to excessive paranoia.");
1622#endif
1623 SETs(TARG);
1624 RETURN;
1625}
1626
1627PP(pp_ucfirst)
1628{
1629 dSP;
1630 SV *sv = TOPs;
1631 register char *s;
1632
ed6116ce 1633 if (!SvPADTMP(sv)) {
79072805
LW
1634 dTARGET;
1635 sv_setsv(TARG, sv);
1636 sv = TARG;
1637 SETs(sv);
1638 }
a0d0e21e
LW
1639 s = SvPV_force(sv, na);
1640 if (isLOWER(*s))
1641 *s = toUPPER(*s);
79072805
LW
1642
1643 RETURN;
1644}
1645
1646PP(pp_lcfirst)
1647{
1648 dSP;
1649 SV *sv = TOPs;
1650 register char *s;
1651
ed6116ce 1652 if (!SvPADTMP(sv)) {
79072805
LW
1653 dTARGET;
1654 sv_setsv(TARG, sv);
1655 sv = TARG;
1656 SETs(sv);
1657 }
a0d0e21e
LW
1658 s = SvPV_force(sv, na);
1659 if (isUPPER(*s))
1660 *s = toLOWER(*s);
79072805
LW
1661
1662 SETs(sv);
1663 RETURN;
1664}
1665
1666PP(pp_uc)
1667{
1668 dSP;
1669 SV *sv = TOPs;
1670 register char *s;
1671 register char *send;
463ee0b2 1672 STRLEN len;
79072805 1673
ed6116ce 1674 if (!SvPADTMP(sv)) {
79072805
LW
1675 dTARGET;
1676 sv_setsv(TARG, sv);
1677 sv = TARG;
1678 SETs(sv);
1679 }
a0d0e21e 1680 s = SvPV_force(sv, len);
463ee0b2 1681 send = s + len;
79072805 1682 while (s < send) {
a0d0e21e
LW
1683 if (isLOWER(*s))
1684 *s = toUPPER(*s);
79072805
LW
1685 s++;
1686 }
1687 RETURN;
1688}
1689
1690PP(pp_lc)
1691{
1692 dSP;
1693 SV *sv = TOPs;
1694 register char *s;
1695 register char *send;
463ee0b2 1696 STRLEN len;
79072805 1697
ed6116ce 1698 if (!SvPADTMP(sv)) {
79072805
LW
1699 dTARGET;
1700 sv_setsv(TARG, sv);
1701 sv = TARG;
1702 SETs(sv);
1703 }
a0d0e21e 1704 s = SvPV_force(sv, len);
463ee0b2 1705 send = s + len;
79072805 1706 while (s < send) {
a0d0e21e
LW
1707 if (isUPPER(*s))
1708 *s = toLOWER(*s);
79072805
LW
1709 s++;
1710 }
1711 RETURN;
1712}
1713
a0d0e21e 1714PP(pp_quotemeta)
79072805 1715{
a0d0e21e
LW
1716 dSP; dTARGET;
1717 SV *sv = TOPs;
1718 STRLEN len;
1719 register char *s = SvPV(sv,len);
1720 register char *d;
79072805 1721
a0d0e21e
LW
1722 if (len) {
1723 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 1724 SvGROW(TARG, (len * 2) + 1);
a0d0e21e
LW
1725 d = SvPVX(TARG);
1726 while (len--) {
1727 if (!isALNUM(*s))
1728 *d++ = '\\';
1729 *d++ = *s++;
79072805 1730 }
a0d0e21e
LW
1731 *d = '\0';
1732 SvCUR_set(TARG, d - SvPVX(TARG));
1733 (void)SvPOK_only(TARG);
79072805 1734 }
a0d0e21e
LW
1735 else
1736 sv_setpvn(TARG, s, len);
1737 SETs(TARG);
79072805
LW
1738 RETURN;
1739}
1740
a0d0e21e 1741/* Arrays. */
79072805 1742
a0d0e21e 1743PP(pp_aslice)
79072805 1744{
a0d0e21e
LW
1745 dSP; dMARK; dORIGMARK;
1746 register SV** svp;
1747 register AV* av = (AV*)POPs;
1748 register I32 lval = op->op_flags & OPf_MOD;
748a9306
LW
1749 I32 arybase = curcop->cop_arybase;
1750 I32 elem;
79072805 1751
a0d0e21e 1752 if (SvTYPE(av) == SVt_PVAV) {
748a9306
LW
1753 if (lval && op->op_private & OPpLVAL_INTRO) {
1754 I32 max = -1;
1755 for (svp = mark + 1; svp <= sp; svp++) {
1756 elem = SvIVx(*svp);
1757 if (elem > max)
1758 max = elem;
1759 }
1760 if (max > AvMAX(av))
1761 av_extend(av, max);
1762 }
a0d0e21e 1763 while (++MARK <= SP) {
748a9306 1764 elem = SvIVx(*MARK);
a0d0e21e 1765
748a9306
LW
1766 if (elem > 0)
1767 elem -= arybase;
a0d0e21e
LW
1768 svp = av_fetch(av, elem, lval);
1769 if (lval) {
1770 if (!svp || *svp == &sv_undef)
1771 DIE(no_aelem, elem);
1772 if (op->op_private & OPpLVAL_INTRO)
1773 save_svref(svp);
79072805 1774 }
a0d0e21e 1775 *MARK = svp ? *svp : &sv_undef;
79072805
LW
1776 }
1777 }
748a9306 1778 if (GIMME != G_ARRAY) {
a0d0e21e
LW
1779 MARK = ORIGMARK;
1780 *++MARK = *SP;
1781 SP = MARK;
1782 }
79072805
LW
1783 RETURN;
1784}
1785
1786/* Associative arrays. */
1787
1788PP(pp_each)
1789{
1790 dSP; dTARGET;
1791 HV *hash = (HV*)POPs;
c07a80fd 1792 HE *entry;
79072805
LW
1793 I32 i;
1794 char *tmps;
c07a80fd
PP
1795
1796 PUTBACK;
1797 entry = hv_iternext(hash); /* might clobber stack_sp */
1798 SPAGAIN;
79072805 1799
79072805
LW
1800 EXTEND(SP, 2);
1801 if (entry) {
c07a80fd 1802 tmps = hv_iterkey(entry, &i); /* won't clobber stack_sp */
8990e307
LW
1803 if (!i)
1804 tmps = "";
1805 PUSHs(sv_2mortal(newSVpv(tmps, i)));
79072805 1806 if (GIMME == G_ARRAY) {
c07a80fd
PP
1807 PUTBACK;
1808 sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */
1809 SPAGAIN;
8990e307 1810 PUSHs(TARG);
79072805 1811 }
79072805
LW
1812 }
1813 else if (GIMME == G_SCALAR)
1814 RETPUSHUNDEF;
1815
1816 RETURN;
1817}
1818
1819PP(pp_values)
1820{
1821 return do_kv(ARGS);
1822}
1823
1824PP(pp_keys)
1825{
1826 return do_kv(ARGS);
1827}
1828
1829PP(pp_delete)
1830{
1831 dSP;
1832 SV *sv;
1833 SV *tmpsv = POPs;
1834 HV *hv = (HV*)POPs;
1835 char *tmps;
463ee0b2 1836 STRLEN len;
a0d0e21e
LW
1837 if (SvTYPE(hv) != SVt_PVHV) {
1838 DIE("Not a HASH reference");
79072805 1839 }
463ee0b2 1840 tmps = SvPV(tmpsv, len);
748a9306
LW
1841 sv = hv_delete(hv, tmps, len,
1842 op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0);
79072805
LW
1843 if (!sv)
1844 RETPUSHUNDEF;
1845 PUSHs(sv);
1846 RETURN;
1847}
1848
a0d0e21e 1849PP(pp_exists)
79072805 1850{
a0d0e21e
LW
1851 dSP;
1852 SV *tmpsv = POPs;
1853 HV *hv = (HV*)POPs;
1854 char *tmps;
1855 STRLEN len;
1856 if (SvTYPE(hv) != SVt_PVHV) {
1857 DIE("Not a HASH reference");
1858 }
1859 tmps = SvPV(tmpsv, len);
1860 if (hv_exists(hv, tmps, len))
1861 RETPUSHYES;
1862 RETPUSHNO;
1863}
79072805 1864
a0d0e21e
LW
1865PP(pp_hslice)
1866{
1867 dSP; dMARK; dORIGMARK;
1868 register SV **svp;
1869 register HV *hv = (HV*)POPs;
1870 register I32 lval = op->op_flags & OPf_MOD;
79072805 1871
a0d0e21e
LW
1872 if (SvTYPE(hv) == SVt_PVHV) {
1873 while (++MARK <= SP) {
1874 STRLEN keylen;
1875 char *key = SvPV(*MARK, keylen);
79072805 1876
a0d0e21e
LW
1877 svp = hv_fetch(hv, key, keylen, lval);
1878 if (lval) {
1879 if (!svp || *svp == &sv_undef)
1880 DIE(no_helem, key);
1881 if (op->op_private & OPpLVAL_INTRO)
1882 save_svref(svp);
93a17b20 1883 }
a0d0e21e 1884 *MARK = svp ? *svp : &sv_undef;
79072805
LW
1885 }
1886 }
a0d0e21e
LW
1887 if (GIMME != G_ARRAY) {
1888 MARK = ORIGMARK;
1889 *++MARK = *SP;
1890 SP = MARK;
79072805 1891 }
a0d0e21e
LW
1892 RETURN;
1893}
1894
1895/* List operators. */
1896
1897PP(pp_list)
1898{
1899 dSP; dMARK;
1900 if (GIMME != G_ARRAY) {
1901 if (++MARK <= SP)
1902 *MARK = *SP; /* unwanted list, return last item */
8990e307 1903 else
a0d0e21e
LW
1904 *MARK = &sv_undef;
1905 SP = MARK;
79072805 1906 }
a0d0e21e 1907 RETURN;
79072805
LW
1908}
1909
a0d0e21e 1910PP(pp_lslice)
79072805
LW
1911{
1912 dSP;
a0d0e21e
LW
1913 SV **lastrelem = stack_sp;
1914 SV **lastlelem = stack_base + POPMARK;
1915 SV **firstlelem = stack_base + POPMARK + 1;
1916 register SV **firstrelem = lastlelem + 1;
1917 I32 arybase = curcop->cop_arybase;
4633a7c4
LW
1918 I32 lval = op->op_flags & OPf_MOD;
1919 I32 is_something_there = lval;
79072805 1920
a0d0e21e
LW
1921 register I32 max = lastrelem - lastlelem;
1922 register SV **lelem;
1923 register I32 ix;
1924
1925 if (GIMME != G_ARRAY) {
748a9306
LW
1926 ix = SvIVx(*lastlelem);
1927 if (ix < 0)
1928 ix += max;
1929 else
1930 ix -= arybase;
a0d0e21e
LW
1931 if (ix < 0 || ix >= max)
1932 *firstlelem = &sv_undef;
1933 else
1934 *firstlelem = firstrelem[ix];
1935 SP = firstlelem;
1936 RETURN;
1937 }
1938
1939 if (max == 0) {
1940 SP = firstlelem - 1;
1941 RETURN;
1942 }
1943
1944 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 1945 ix = SvIVx(*lelem);
a0d0e21e
LW
1946 if (ix < 0) {
1947 ix += max;
1948 if (ix < 0)
1949 *lelem = &sv_undef;
1950 else if (!(*lelem = firstrelem[ix]))
1951 *lelem = &sv_undef;
79072805 1952 }
748a9306
LW
1953 else {
1954 ix -= arybase;
1955 if (ix >= max || !(*lelem = firstrelem[ix]))
1956 *lelem = &sv_undef;
1957 }
4633a7c4
LW
1958 if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem)))
1959 is_something_there = TRUE;
79072805 1960 }
4633a7c4
LW
1961 if (is_something_there)
1962 SP = lastlelem;
1963 else
1964 SP = firstlelem - 1;
79072805
LW
1965 RETURN;
1966}
1967
a0d0e21e
LW
1968PP(pp_anonlist)
1969{
1970 dSP; dMARK;
1971 I32 items = SP - MARK;
1972 SP = MARK;
1973 XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1)));
1974 RETURN;
1975}
1976
1977PP(pp_anonhash)
79072805
LW
1978{
1979 dSP; dMARK; dORIGMARK;
a0d0e21e
LW
1980 STRLEN len;
1981 HV* hv = (HV*)sv_2mortal((SV*)newHV());
1982
1983 while (MARK < SP) {
1984 SV* key = *++MARK;
1985 char *tmps;
1986 SV *val = NEWSV(46, 0);
1987 if (MARK < SP)
1988 sv_setsv(val, *++MARK);
1989 else
1990 warn("Odd number of elements in hash list");
1991 tmps = SvPV(key,len);
1992 (void)hv_store(hv,tmps,len,val,0);
79072805 1993 }
a0d0e21e
LW
1994 SP = ORIGMARK;
1995 XPUSHs((SV*)hv);
79072805
LW
1996 RETURN;
1997}
1998
a0d0e21e 1999PP(pp_splice)
79072805 2000{
a0d0e21e
LW
2001 dSP; dMARK; dORIGMARK;
2002 register AV *ary = (AV*)*++MARK;
2003 register SV **src;
2004 register SV **dst;
2005 register I32 i;
2006 register I32 offset;
2007 register I32 length;
2008 I32 newlen;
2009 I32 after;
2010 I32 diff;
2011 SV **tmparyval = 0;
79072805 2012
a0d0e21e 2013 SP++;
79072805 2014
a0d0e21e
LW
2015 if (++MARK < SP) {
2016 offset = SvIVx(*MARK);
2017 if (offset < 0)
2018 offset += AvFILL(ary) + 1;
2019 else
2020 offset -= curcop->cop_arybase;
2021 if (++MARK < SP) {
2022 length = SvIVx(*MARK++);
2023 if (length < 0)
2024 length = 0;
79072805
LW
2025 }
2026 else
a0d0e21e 2027 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2028 }
a0d0e21e
LW
2029 else {
2030 offset = 0;
2031 length = AvMAX(ary) + 1;
2032 }
2033 if (offset < 0) {
2034 length += offset;
2035 offset = 0;
2036 if (length < 0)
2037 length = 0;
2038 }
2039 if (offset > AvFILL(ary) + 1)
2040 offset = AvFILL(ary) + 1;
2041 after = AvFILL(ary) + 1 - (offset + length);
2042 if (after < 0) { /* not that much array */
2043 length += after; /* offset+length now in array */
2044 after = 0;
2045 if (!AvALLOC(ary))
2046 av_extend(ary, 0);
2047 }
2048
2049 /* At this point, MARK .. SP-1 is our new LIST */
2050
2051 newlen = SP - MARK;
2052 diff = newlen - length;
2053
2054 if (diff < 0) { /* shrinking the area */
2055 if (newlen) {
2056 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2057 Copy(MARK, tmparyval, newlen, SV*);
79072805 2058 }
a0d0e21e
LW
2059
2060 MARK = ORIGMARK + 1;
2061 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2062 MEXTEND(MARK, length);
2063 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2064 if (AvREAL(ary)) {
2065 for (i = length, dst = MARK; i; i--)
2066 sv_2mortal(*dst++); /* free them eventualy */
2067 }
2068 MARK += length - 1;
79072805 2069 }
a0d0e21e
LW
2070 else {
2071 *MARK = AvARRAY(ary)[offset+length-1];
2072 if (AvREAL(ary)) {
2073 sv_2mortal(*MARK);
2074 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2075 SvREFCNT_dec(*dst++); /* free them now */
79072805 2076 }
a0d0e21e
LW
2077 }
2078 AvFILL(ary) += diff;
2079
2080 /* pull up or down? */
2081
2082 if (offset < after) { /* easier to pull up */
2083 if (offset) { /* esp. if nothing to pull */
2084 src = &AvARRAY(ary)[offset-1];
2085 dst = src - diff; /* diff is negative */
2086 for (i = offset; i > 0; i--) /* can't trust Copy */
2087 *dst-- = *src--;
79072805 2088 }
a0d0e21e
LW
2089 dst = AvARRAY(ary);
2090 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2091 AvMAX(ary) += diff;
2092 }
2093 else {
2094 if (after) { /* anything to pull down? */
2095 src = AvARRAY(ary) + offset + length;
2096 dst = src + diff; /* diff is negative */
2097 Move(src, dst, after, SV*);
79072805 2098 }
a0d0e21e
LW
2099 dst = &AvARRAY(ary)[AvFILL(ary)+1];
2100 /* avoid later double free */
2101 }
2102 i = -diff;
2103 while (i)
2104 dst[--i] = &sv_undef;
2105
2106 if (newlen) {
2107 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2108 newlen; newlen--) {
2109 *dst = NEWSV(46, 0);
2110 sv_setsv(*dst++, *src++);
79072805 2111 }
a0d0e21e
LW
2112 Safefree(tmparyval);
2113 }
2114 }
2115 else { /* no, expanding (or same) */
2116 if (length) {
2117 New(452, tmparyval, length, SV*); /* so remember deletion */
2118 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2119 }
2120
2121 if (diff > 0) { /* expanding */
2122
2123 /* push up or down? */
2124
2125 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2126 if (offset) {
2127 src = AvARRAY(ary);
2128 dst = src - diff;
2129 Move(src, dst, offset, SV*);
79072805 2130 }
a0d0e21e
LW
2131 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2132 AvMAX(ary) += diff;
2133 AvFILL(ary) += diff;
79072805
LW
2134 }
2135 else {
a0d0e21e
LW
2136 if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
2137 av_extend(ary, AvFILL(ary) + diff);
2138 AvFILL(ary) += diff;
2139
2140 if (after) {
2141 dst = AvARRAY(ary) + AvFILL(ary);
2142 src = dst - diff;
2143 for (i = after; i; i--) {
2144 *dst-- = *src--;
2145 }
79072805
LW
2146 }
2147 }
a0d0e21e
LW
2148 }
2149
2150 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2151 *dst = NEWSV(46, 0);
2152 sv_setsv(*dst++, *src++);
2153 }
2154 MARK = ORIGMARK + 1;
2155 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2156 if (length) {
2157 Copy(tmparyval, MARK, length, SV*);
2158 if (AvREAL(ary)) {
2159 for (i = length, dst = MARK; i; i--)
2160 sv_2mortal(*dst++); /* free them eventualy */
79072805 2161 }
a0d0e21e 2162 Safefree(tmparyval);
79072805 2163 }
a0d0e21e
LW
2164 MARK += length - 1;
2165 }
2166 else if (length--) {
2167 *MARK = tmparyval[length];
2168 if (AvREAL(ary)) {
2169 sv_2mortal(*MARK);
2170 while (length-- > 0)
2171 SvREFCNT_dec(tmparyval[length]);
79072805 2172 }
a0d0e21e 2173 Safefree(tmparyval);
79072805 2174 }
a0d0e21e
LW
2175 else
2176 *MARK = &sv_undef;
79072805 2177 }
a0d0e21e 2178 SP = MARK;
79072805
LW
2179 RETURN;
2180}
2181
a0d0e21e 2182PP(pp_push)
79072805
LW
2183{
2184 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
2185 register AV *ary = (AV*)*++MARK;
2186 register SV *sv = &sv_undef;
79072805 2187
a0d0e21e
LW
2188 for (++MARK; MARK <= SP; MARK++) {
2189 sv = NEWSV(51, 0);
2190 if (*MARK)
2191 sv_setsv(sv, *MARK);
2192 av_push(ary, sv);
79072805
LW
2193 }
2194 SP = ORIGMARK;
a0d0e21e 2195 PUSHi( AvFILL(ary) + 1 );
79072805
LW
2196 RETURN;
2197}
2198
a0d0e21e 2199PP(pp_pop)
79072805
LW
2200{
2201 dSP;
a0d0e21e
LW
2202 AV *av = (AV*)POPs;
2203 SV *sv = av_pop(av);
2204 if (sv != &sv_undef && AvREAL(av))
2205 (void)sv_2mortal(sv);
2206 PUSHs(sv);
79072805 2207 RETURN;
79072805
LW
2208}
2209
a0d0e21e 2210PP(pp_shift)
79072805
LW
2211{
2212 dSP;
a0d0e21e
LW
2213 AV *av = (AV*)POPs;
2214 SV *sv = av_shift(av);
79072805 2215 EXTEND(SP, 1);
a0d0e21e 2216 if (!sv)
79072805 2217 RETPUSHUNDEF;
a0d0e21e
LW
2218 if (sv != &sv_undef && AvREAL(av))
2219 (void)sv_2mortal(sv);
2220 PUSHs(sv);
79072805 2221 RETURN;
79072805
LW
2222}
2223
a0d0e21e 2224PP(pp_unshift)
79072805 2225{
a0d0e21e
LW
2226 dSP; dMARK; dORIGMARK; dTARGET;
2227 register AV *ary = (AV*)*++MARK;
2228 register SV *sv;
2229 register I32 i = 0;
79072805 2230
a0d0e21e
LW
2231 av_unshift(ary, SP - MARK);
2232 while (MARK < SP) {
2233 sv = NEWSV(27, 0);
2234 sv_setsv(sv, *++MARK);
2235 (void)av_store(ary, i++, sv);
79072805 2236 }
79072805 2237
a0d0e21e
LW
2238 SP = ORIGMARK;
2239 PUSHi( AvFILL(ary) + 1 );
79072805 2240 RETURN;
79072805
LW
2241}
2242
a0d0e21e 2243PP(pp_reverse)
79072805 2244{
a0d0e21e
LW
2245 dSP; dMARK;
2246 register SV *tmp;
2247 SV **oldsp = SP;
79072805 2248
a0d0e21e
LW
2249 if (GIMME == G_ARRAY) {
2250 MARK++;
2251 while (MARK < SP) {
2252 tmp = *MARK;
2253 *MARK++ = *SP;
2254 *SP-- = tmp;
2255 }
2256 SP = oldsp;
79072805
LW
2257 }
2258 else {
a0d0e21e
LW
2259 register char *up;
2260 register char *down;
2261 register I32 tmp;
2262 dTARGET;
2263 STRLEN len;
79072805 2264
a0d0e21e
LW
2265 if (SP - MARK > 1)
2266 do_join(TARG, &sv_no, MARK, SP);
2267 else
2268 sv_setsv(TARG, *SP);
2269 up = SvPV_force(TARG, len);
2270 if (len > 1) {
2271 down = SvPVX(TARG) + len - 1;
2272 while (down > up) {
2273 tmp = *up;
2274 *up++ = *down;
2275 *down-- = tmp;
2276 }
2277 (void)SvPOK_only(TARG);
79072805 2278 }
a0d0e21e
LW
2279 SP = MARK + 1;
2280 SETTARG;
79072805 2281 }
a0d0e21e 2282 RETURN;
79072805
LW
2283}
2284
a0d0e21e
LW
2285/* Explosives and implosives. */
2286
2287PP(pp_unpack)
79072805
LW
2288{
2289 dSP;
a0d0e21e 2290 dPOPPOPssrl;
ed6116ce 2291 SV *sv;
a0d0e21e
LW
2292 STRLEN llen;
2293 STRLEN rlen;
2294 register char *pat = SvPV(left, llen);
2295 register char *s = SvPV(right, rlen);
2296 char *strend = s + rlen;
2297 char *strbeg = s;
2298 register char *patend = pat + llen;
2299 I32 datumtype;
2300 register I32 len;
2301 register I32 bits;
79072805 2302
a0d0e21e
LW
2303 /* These must not be in registers: */
2304 I16 ashort;
2305 int aint;
2306 I32 along;
ecfc5424
AD
2307#ifdef HAS_QUAD
2308 Quad_t aquad;
a0d0e21e
LW
2309#endif
2310 U16 aushort;
2311 unsigned int auint;
2312 U32 aulong;
ecfc5424
AD
2313#ifdef HAS_QUAD
2314 unsigned Quad_t auquad;
a0d0e21e
LW
2315#endif
2316 char *aptr;
2317 float afloat;
2318 double adouble;
2319 I32 checksum = 0;
2320 register U32 culong;
2321 double cdouble;
2322 static char* bitcount = 0;
79072805 2323
a0d0e21e
LW
2324 if (GIMME != G_ARRAY) { /* arrange to do first one only */
2325 /*SUPPRESS 530*/
2326 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
748a9306 2327 if (strchr("aAbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW
2328 patend++;
2329 while (isDIGIT(*patend) || *patend == '*')
2330 patend++;
2331 }
2332 else
2333 patend++;
79072805 2334 }
a0d0e21e
LW
2335 while (pat < patend) {
2336 reparse:
2337 datumtype = *pat++;
2338 if (pat >= patend)
2339 len = 1;
2340 else if (*pat == '*') {
2341 len = strend - strbeg; /* long enough */
2342 pat++;
2343 }
2344 else if (isDIGIT(*pat)) {
2345 len = *pat++ - '0';
2346 while (isDIGIT(*pat))
2347 len = (len * 10) + (*pat++ - '0');
2348 }
2349 else
2350 len = (datumtype != '@');
2351 switch(datumtype) {
2352 default:
2353 break;
2354 case '%':
2355 if (len == 1 && pat[-1] != '1')
2356 len = 16;
2357 checksum = len;
2358 culong = 0;
2359 cdouble = 0;
2360 if (pat < patend)
2361 goto reparse;
2362 break;
2363 case '@':
2364 if (len > strend - strbeg)
2365 DIE("@ outside of string");
2366 s = strbeg + len;
2367 break;
2368 case 'X':
2369 if (len > s - strbeg)
2370 DIE("X outside of string");
2371 s -= len;
2372 break;
2373 case 'x':
2374 if (len > strend - s)
2375 DIE("x outside of string");
2376 s += len;
2377 break;
2378 case 'A':
2379 case 'a':
2380 if (len > strend - s)
2381 len = strend - s;
2382 if (checksum)
2383 goto uchar_checksum;
2384 sv = NEWSV(35, len);
2385 sv_setpvn(sv, s, len);
2386 s += len;
2387 if (datumtype == 'A') {
2388 aptr = s; /* borrow register */
2389 s = SvPVX(sv) + len - 1;
2390 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2391 s--;
2392 *++s = '\0';
2393 SvCUR_set(sv, s - SvPVX(sv));
2394 s = aptr; /* unborrow register */
2395 }
2396 XPUSHs(sv_2mortal(sv));
2397 break;
2398 case 'B':
2399 case 'b':
2400 if (pat[-1] == '*' || len > (strend - s) * 8)
2401 len = (strend - s) * 8;
2402 if (checksum) {
2403 if (!bitcount) {
2404 Newz(601, bitcount, 256, char);
2405 for (bits = 1; bits < 256; bits++) {
2406 if (bits & 1) bitcount[bits]++;
2407 if (bits & 2) bitcount[bits]++;
2408 if (bits & 4) bitcount[bits]++;
2409 if (bits & 8) bitcount[bits]++;
2410 if (bits & 16) bitcount[bits]++;
2411 if (bits & 32) bitcount[bits]++;
2412 if (bits & 64) bitcount[bits]++;
2413 if (bits & 128) bitcount[bits]++;
2414 }
2415 }
2416 while (len >= 8) {
2417 culong += bitcount[*(unsigned char*)s++];
2418 len -= 8;
2419 }
2420 if (len) {
2421 bits = *s;
2422 if (datumtype == 'b') {
2423 while (len-- > 0) {
2424 if (bits & 1) culong++;
2425 bits >>= 1;
2426 }
2427 }
2428 else {
2429 while (len-- > 0) {
2430 if (bits & 128) culong++;
2431 bits <<= 1;
2432 }
2433 }
2434 }
79072805
LW
2435 break;
2436 }
a0d0e21e
LW
2437 sv = NEWSV(35, len + 1);
2438 SvCUR_set(sv, len);
2439 SvPOK_on(sv);
2440 aptr = pat; /* borrow register */
2441 pat = SvPVX(sv);
2442 if (datumtype == 'b') {
2443 aint = len;
2444 for (len = 0; len < aint; len++) {
2445 if (len & 7) /*SUPPRESS 595*/
2446 bits >>= 1;
2447 else
2448 bits = *s++;
2449 *pat++ = '0' + (bits & 1);
2450 }
2451 }
2452 else {
2453 aint = len;
2454 for (len = 0; len < aint; len++) {
2455 if (len & 7)
2456 bits <<= 1;
2457 else
2458 bits = *s++;
2459 *pat++ = '0' + ((bits & 128) != 0);
2460 }
2461 }
2462 *pat = '\0';
2463 pat = aptr; /* unborrow register */
2464 XPUSHs(sv_2mortal(sv));
2465 break;
2466 case 'H':
2467 case 'h':
2468 if (pat[-1] == '*' || len > (strend - s) * 2)
2469 len = (strend - s) * 2;
2470 sv = NEWSV(35, len + 1);
2471 SvCUR_set(sv, len);
2472 SvPOK_on(sv);
2473 aptr = pat; /* borrow register */
2474 pat = SvPVX(sv);
2475 if (datumtype == 'h') {
2476 aint = len;
2477 for (len = 0; len < aint; len++) {
2478 if (len & 1)
2479 bits >>= 4;
2480 else
2481 bits = *s++;
2482 *pat++ = hexdigit[bits & 15];
2483 }
2484 }
2485 else {
2486 aint = len;
2487 for (len = 0; len < aint; len++) {
2488 if (len & 1)
2489 bits <<= 4;
2490 else
2491 bits = *s++;
2492 *pat++ = hexdigit[(bits >> 4) & 15];
2493 }
2494 }
2495 *pat = '\0';
2496 pat = aptr; /* unborrow register */
2497 XPUSHs(sv_2mortal(sv));
2498 break;
2499 case 'c':
2500 if (len > strend - s)
2501 len = strend - s;
2502 if (checksum) {
2503 while (len-- > 0) {
2504 aint = *s++;
2505 if (aint >= 128) /* fake up signed chars */
2506 aint -= 256;
2507 culong += aint;
2508 }
2509 }
2510 else {
2511 EXTEND(SP, len);
2512 while (len-- > 0) {
2513 aint = *s++;
2514 if (aint >= 128) /* fake up signed chars */
2515 aint -= 256;
2516 sv = NEWSV(36, 0);
2517 sv_setiv(sv, (I32)aint);
2518 PUSHs(sv_2mortal(sv));
2519 }
2520 }
2521 break;
2522 case 'C':
2523 if (len > strend - s)
2524 len = strend - s;
2525 if (checksum) {
2526 uchar_checksum:
2527 while (len-- > 0) {
2528 auint = *s++ & 255;
2529 culong += auint;
2530 }
2531 }
2532 else {
2533 EXTEND(SP, len);
2534 while (len-- > 0) {
2535 auint = *s++ & 255;
2536 sv = NEWSV(37, 0);
2537 sv_setiv(sv, (I32)auint);
2538 PUSHs(sv_2mortal(sv));
2539 }
2540 }
2541 break;
2542 case 's':
2543 along = (strend - s) / sizeof(I16);
2544 if (len > along)
2545 len = along;
2546 if (checksum) {
2547 while (len-- > 0) {
2548 Copy(s, &ashort, 1, I16);
2549 s += sizeof(I16);
2550 culong += ashort;
2551 }
2552 }
2553 else {
2554 EXTEND(SP, len);
2555 while (len-- > 0) {
2556 Copy(s, &ashort, 1, I16);
2557 s += sizeof(I16);
2558 sv = NEWSV(38, 0);
2559 sv_setiv(sv, (I32)ashort);
2560 PUSHs(sv_2mortal(sv));
2561 }
2562 }
2563 break;
2564 case 'v':
2565 case 'n':
2566 case 'S':
2567 along = (strend - s) / sizeof(U16);
2568 if (len > along)
2569 len = along;
2570 if (checksum) {
2571 while (len-- > 0) {
2572 Copy(s, &aushort, 1, U16);
2573 s += sizeof(U16);
2574#ifdef HAS_NTOHS
2575 if (datumtype == 'n')
2576 aushort = ntohs(aushort);
79072805 2577#endif
a0d0e21e
LW
2578#ifdef HAS_VTOHS
2579 if (datumtype == 'v')
2580 aushort = vtohs(aushort);
79072805 2581#endif
a0d0e21e
LW
2582 culong += aushort;
2583 }
2584 }
2585 else {
2586 EXTEND(SP, len);
2587 while (len-- > 0) {
2588 Copy(s, &aushort, 1, U16);
2589 s += sizeof(U16);
2590 sv = NEWSV(39, 0);
2591#ifdef HAS_NTOHS
2592 if (datumtype == 'n')
2593 aushort = ntohs(aushort);
79072805 2594#endif
a0d0e21e
LW
2595#ifdef HAS_VTOHS
2596 if (datumtype == 'v')
2597 aushort = vtohs(aushort);
79072805 2598#endif
a0d0e21e
LW
2599 sv_setiv(sv, (I32)aushort);
2600 PUSHs(sv_2mortal(sv));
2601 }
2602 }
2603 break;
2604 case 'i':
2605 along = (strend - s) / sizeof(int);
2606 if (len > along)
2607 len = along;
2608 if (checksum) {
2609 while (len-- > 0) {
2610 Copy(s, &aint, 1, int);
2611 s += sizeof(int);
2612 if (checksum > 32)
2613 cdouble += (double)aint;
2614 else
2615 culong += aint;
2616 }
2617 }
2618 else {
2619 EXTEND(SP, len);
2620 while (len-- > 0) {
2621 Copy(s, &aint, 1, int);
2622 s += sizeof(int);
2623 sv = NEWSV(40, 0);
2624 sv_setiv(sv, (I32)aint);
2625 PUSHs(sv_2mortal(sv));
2626 }
2627 }
2628 break;
2629 case 'I':
2630 along = (strend - s) / sizeof(unsigned int);
2631 if (len > along)
2632 len = along;
2633 if (checksum) {
2634 while (len-- > 0) {
2635 Copy(s, &auint, 1, unsigned int);
2636 s += sizeof(unsigned int);
2637 if (checksum > 32)
2638 cdouble += (double)auint;
2639 else
2640 culong += auint;
2641 }
2642 }
2643 else {
2644 EXTEND(SP, len);
2645 while (len-- > 0) {
2646 Copy(s, &auint, 1, unsigned int);
2647 s += sizeof(unsigned int);
2648 sv = NEWSV(41, 0);
2649 sv_setiv(sv, (I32)auint);
2650 PUSHs(sv_2mortal(sv));
2651 }
2652 }
2653 break;
2654 case 'l':
2655 along = (strend - s) / sizeof(I32);
2656 if (len > along)
2657 len = along;
2658 if (checksum) {
2659 while (len-- > 0) {
2660 Copy(s, &along, 1, I32);
2661 s += sizeof(I32);
2662 if (checksum > 32)
2663 cdouble += (double)along;
2664 else
2665 culong += along;
2666 }
2667 }
2668 else {
2669 EXTEND(SP, len);
2670 while (len-- > 0) {
2671 Copy(s, &along, 1, I32);
2672 s += sizeof(I32);
2673 sv = NEWSV(42, 0);
2674 sv_setiv(sv, (I32)along);
2675 PUSHs(sv_2mortal(sv));
2676 }
79072805 2677 }
a0d0e21e
LW
2678 break;
2679 case 'V':
2680 case 'N':
2681 case 'L':
2682 along = (strend - s) / sizeof(U32);
2683 if (len > along)
2684 len = along;
2685 if (checksum) {
2686 while (len-- > 0) {
2687 Copy(s, &aulong, 1, U32);
2688 s += sizeof(U32);
2689#ifdef HAS_NTOHL
2690 if (datumtype == 'N')
2691 aulong = ntohl(aulong);
79072805 2692#endif
a0d0e21e
LW
2693#ifdef HAS_VTOHL
2694 if (datumtype == 'V')
2695 aulong = vtohl(aulong);
79072805 2696#endif
a0d0e21e
LW
2697 if (checksum > 32)
2698 cdouble += (double)aulong;
2699 else
2700 culong += aulong;
2701 }
2702 }
2703 else {
2704 EXTEND(SP, len);
2705 while (len-- > 0) {
2706 Copy(s, &aulong, 1, U32);
2707 s += sizeof(U32);
2708 sv = NEWSV(43, 0);
2709#ifdef HAS_NTOHL
2710 if (datumtype == 'N')
2711 aulong = ntohl(aulong);
79072805 2712#endif
a0d0e21e
LW
2713#ifdef HAS_VTOHL
2714 if (datumtype == 'V')
2715 aulong = vtohl(aulong);
79072805 2716#endif
a0d0e21e
LW
2717 sv_setnv(sv, (double)aulong);
2718 PUSHs(sv_2mortal(sv));
2719 }
2720 }
2721 break;
2722 case 'p':
2723 along = (strend - s) / sizeof(char*);
2724 if (len > along)
2725 len = along;
2726 EXTEND(SP, len);
2727 while (len-- > 0) {
2728 if (sizeof(char*) > strend - s)
2729 break;
2730 else {
2731 Copy(s, &aptr, 1, char*);
2732 s += sizeof(char*);
2733 }
2734 sv = NEWSV(44, 0);
2735 if (aptr)
2736 sv_setpv(sv, aptr);
2737 PUSHs(sv_2mortal(sv));
2738 }
2739 break;
2740 case 'P':
2741 EXTEND(SP, 1);
2742 if (sizeof(char*) > strend - s)
2743 break;
2744 else {
2745 Copy(s, &aptr, 1, char*);
2746 s += sizeof(char*);
2747 }
2748 sv = NEWSV(44, 0);
2749 if (aptr)
2750 sv_setpvn(sv, aptr, len);
2751 PUSHs(sv_2mortal(sv));
2752 break;
ecfc5424 2753#ifdef HAS_QUAD
a0d0e21e
LW
2754 case 'q':
2755 EXTEND(SP, len);
2756 while (len-- > 0) {
ecfc5424 2757 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW
2758 aquad = 0;
2759 else {
ecfc5424
AD
2760 Copy(s, &aquad, 1, Quad_t);
2761 s += sizeof(Quad_t);
a0d0e21e
LW
2762 }
2763 sv = NEWSV(42, 0);
2764 sv_setiv(sv, (IV)aquad);
2765 PUSHs(sv_2mortal(sv));
2766 }
2767 break;
2768 case 'Q':
2769 EXTEND(SP, len);
2770 while (len-- > 0) {
ecfc5424 2771 if (s + sizeof(unsigned Quad_t) > strend)
a0d0e21e
LW
2772 auquad = 0;
2773 else {
ecfc5424
AD
2774 Copy(s, &auquad, 1, unsigned Quad_t);
2775 s += sizeof(unsigned Quad_t);
a0d0e21e
LW
2776 }
2777 sv = NEWSV(43, 0);
2778 sv_setiv(sv, (IV)auquad);
2779 PUSHs(sv_2mortal(sv));
2780 }
2781 break;
79072805 2782#endif
a0d0e21e
LW
2783 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2784 case 'f':
2785 case 'F':
2786 along = (strend - s) / sizeof(float);
2787 if (len > along)
2788 len = along;
2789 if (checksum) {
2790 while (len-- > 0) {
2791 Copy(s, &afloat, 1, float);
2792 s += sizeof(float);
2793 cdouble += afloat;
2794 }
2795 }
2796 else {
2797 EXTEND(SP, len);
2798 while (len-- > 0) {
2799 Copy(s, &afloat, 1, float);
2800 s += sizeof(float);
2801 sv = NEWSV(47, 0);
2802 sv_setnv(sv, (double)afloat);
2803 PUSHs(sv_2mortal(sv));
2804 }
2805 }
2806 break;
2807 case 'd':
2808 case 'D':
2809 along = (strend - s) / sizeof(double);
2810 if (len > along)
2811 len = along;
2812 if (checksum) {
2813 while (len-- > 0) {
2814 Copy(s, &adouble, 1, double);
2815 s += sizeof(double);
2816 cdouble += adouble;
2817 }
2818 }
2819 else {
2820 EXTEND(SP, len);
2821 while (len-- > 0) {
2822 Copy(s, &adouble, 1, double);
2823 s += sizeof(double);
2824 sv = NEWSV(48, 0);
2825 sv_setnv(sv, (double)adouble);
2826 PUSHs(sv_2mortal(sv));
2827 }
2828 }
2829 break;
2830 case 'u':
2831 along = (strend - s) * 3 / 4;
2832 sv = NEWSV(42, along);
2833 while (s < strend && *s > ' ' && *s < 'a') {
2834 I32 a, b, c, d;
2835 char hunk[4];
79072805 2836
a0d0e21e
LW
2837 hunk[3] = '\0';
2838 len = (*s++ - ' ') & 077;
2839 while (len > 0) {
2840 if (s < strend && *s >= ' ')
2841 a = (*s++ - ' ') & 077;
2842 else
2843 a = 0;
2844 if (s < strend && *s >= ' ')
2845 b = (*s++ - ' ') & 077;
2846 else
2847 b = 0;
2848 if (s < strend && *s >= ' ')
2849 c = (*s++ - ' ') & 077;
2850 else
2851 c = 0;
2852 if (s < strend && *s >= ' ')
2853 d = (*s++ - ' ') & 077;
2854 else
2855 d = 0;
2856 hunk[0] = a << 2 | b >> 4;
2857 hunk[1] = b << 4 | c >> 2;
2858 hunk[2] = c << 6 | d;
2859 sv_catpvn(sv, hunk, len > 3 ? 3 : len);
2860 len -= 3;
2861 }
2862 if (*s == '\n')
2863 s++;
2864 else if (s[1] == '\n') /* possible checksum byte */
2865 s += 2;
79072805 2866 }
a0d0e21e
LW
2867 XPUSHs(sv_2mortal(sv));
2868 break;
79072805 2869 }
a0d0e21e
LW
2870 if (checksum) {
2871 sv = NEWSV(42, 0);
2872 if (strchr("fFdD", datumtype) ||
2873 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
2874 double trouble;
79072805 2875
a0d0e21e
LW
2876 adouble = 1.0;
2877 while (checksum >= 16) {
2878 checksum -= 16;
2879 adouble *= 65536.0;
2880 }
2881 while (checksum >= 4) {
2882 checksum -= 4;
2883 adouble *= 16.0;
2884 }
2885 while (checksum--)
2886 adouble *= 2.0;
2887 along = (1 << checksum) - 1;
2888 while (cdouble < 0.0)
2889 cdouble += adouble;
2890 cdouble = modf(cdouble / adouble, &trouble) * adouble;
2891 sv_setnv(sv, cdouble);
2892 }
2893 else {
2894 if (checksum < 32) {
2895 along = (1 << checksum) - 1;
2896 culong &= (U32)along;
2897 }
2898 sv_setnv(sv, (double)culong);
2899 }
2900 XPUSHs(sv_2mortal(sv));
2901 checksum = 0;
79072805 2902 }
79072805 2903 }
79072805 2904 RETURN;
79072805
LW
2905}
2906
a0d0e21e
LW
2907static void
2908doencodes(sv, s, len)
2909register SV *sv;
2910register char *s;
2911register I32 len;
79072805 2912{
a0d0e21e 2913 char hunk[5];
79072805 2914
a0d0e21e
LW
2915 *hunk = len + ' ';
2916 sv_catpvn(sv, hunk, 1);
2917 hunk[4] = '\0';
2918 while (len > 0) {
2919 hunk[0] = ' ' + (077 & (*s >> 2));
2920 hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
2921 hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
2922 hunk[3] = ' ' + (077 & (s[2] & 077));
2923 sv_catpvn(sv, hunk, 4);
2924 s += 3;
2925 len -= 3;
2926 }
2927 for (s = SvPVX(sv); *s; s++) {
2928 if (*s == ' ')
2929 *s = '`';
2930 }
2931 sv_catpvn(sv, "\n", 1);
79072805
LW
2932}
2933
a0d0e21e 2934PP(pp_pack)
79072805 2935{
a0d0e21e
LW
2936 dSP; dMARK; dORIGMARK; dTARGET;
2937 register SV *cat = TARG;
2938 register I32 items;
2939 STRLEN fromlen;
2940 register char *pat = SvPVx(*++MARK, fromlen);
2941 register char *patend = pat + fromlen;
2942 register I32 len;
2943 I32 datumtype;
2944 SV *fromstr;
2945 /*SUPPRESS 442*/
2946 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2947 static char *space10 = " ";
79072805 2948
a0d0e21e
LW
2949 /* These must not be in registers: */
2950 char achar;
2951 I16 ashort;
2952 int aint;
2953 unsigned int auint;
2954 I32 along;
2955 U32 aulong;
ecfc5424
AD
2956#ifdef HAS_QUAD
2957 Quad_t aquad;
2958 unsigned Quad_t auquad;
79072805 2959#endif
a0d0e21e
LW
2960 char *aptr;
2961 float afloat;
2962 double adouble;
79072805 2963
a0d0e21e
LW
2964 items = SP - MARK;
2965 MARK++;
2966 sv_setpvn(cat, "", 0);
2967 while (pat < patend) {
2968#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
2969 datumtype = *pat++;
2970 if (*pat == '*') {
2971 len = strchr("@Xxu", datumtype) ? 0 : items;
2972 pat++;
2973 }
2974 else if (isDIGIT(*pat)) {
2975 len = *pat++ - '0';
2976 while (isDIGIT(*pat))
2977 len = (len * 10) + (*pat++ - '0');
2978 }
2979 else
2980 len = 1;
2981 switch(datumtype) {
2982 default:
2983 break;
2984 case '%':
2985 DIE("%% may only be used in unpack");
2986 case '@':
2987 len -= SvCUR(cat);
2988 if (len > 0)
2989 goto grow;
2990 len = -len;
2991 if (len > 0)
2992 goto shrink;
2993 break;
2994 case 'X':
2995 shrink:
2996 if (SvCUR(cat) < len)
2997 DIE("X outside of string");
2998 SvCUR(cat) -= len;
2999 *SvEND(cat) = '\0';
3000 break;
3001 case 'x':
3002 grow:
3003 while (len >= 10) {
3004 sv_catpvn(cat, null10, 10);
3005 len -= 10;
3006 }
3007 sv_catpvn(cat, null10, len);
3008 break;
3009 case 'A':
3010 case 'a':
3011 fromstr = NEXTFROM;
3012 aptr = SvPV(fromstr, fromlen);
3013 if (pat[-1] == '*')
3014 len = fromlen;
3015 if (fromlen > len)
3016 sv_catpvn(cat, aptr, len);
3017 else {
3018 sv_catpvn(cat, aptr, fromlen);
3019 len -= fromlen;
3020 if (datumtype == 'A') {
3021 while (len >= 10) {
3022 sv_catpvn(cat, space10, 10);
3023 len -= 10;
3024 }
3025 sv_catpvn(cat, space10, len);
3026 }
3027 else {
3028 while (len >= 10) {
3029 sv_catpvn(cat, null10, 10);
3030 len -= 10;
3031 }
3032 sv_catpvn(cat, null10, len);
3033 }
3034 }
3035 break;
3036 case 'B':
3037 case 'b':
3038 {
3039 char *savepat = pat;
3040 I32 saveitems;
79072805 3041
a0d0e21e
LW
3042 fromstr = NEXTFROM;
3043 saveitems = items;
3044 aptr = SvPV(fromstr, fromlen);
3045 if (pat[-1] == '*')
3046 len = fromlen;
3047 pat = aptr;
3048 aint = SvCUR(cat);
3049 SvCUR(cat) += (len+7)/8;
3050 SvGROW(cat, SvCUR(cat) + 1);
3051 aptr = SvPVX(cat) + aint;
3052 if (len > fromlen)
3053 len = fromlen;
3054 aint = len;
3055 items = 0;
3056 if (datumtype == 'B') {
3057 for (len = 0; len++ < aint;) {
3058 items |= *pat++ & 1;
3059 if (len & 7)
3060 items <<= 1;
3061 else {
3062 *aptr++ = items & 0xff;
3063 items = 0;
3064 }
3065 }
3066 }
3067 else {
3068 for (len = 0; len++ < aint;) {
3069 if (*pat++ & 1)
3070 items |= 128;
3071 if (len & 7)
3072 items >>= 1;
3073 else {
3074 *aptr++ = items & 0xff;
3075 items = 0;
3076 }
3077 }
3078 }
3079 if (aint & 7) {
3080 if (datumtype == 'B')
3081 items <<= 7 - (aint & 7);
3082 else
3083 items >>= 7 - (aint & 7);
3084 *aptr++ = items & 0xff;
3085 }
3086 pat = SvPVX(cat) + SvCUR(cat);
3087 while (aptr <= pat)
3088 *aptr++ = '\0';
79072805 3089
a0d0e21e
LW
3090 pat = savepat;
3091 items = saveitems;
3092 }
3093 break;
3094 case 'H':
3095 case 'h':
3096 {
3097 char *savepat = pat;
3098 I32 saveitems;
79072805 3099
a0d0e21e
LW
3100 fromstr = NEXTFROM;
3101 saveitems = items;
3102 aptr = SvPV(fromstr, fromlen);
3103 if (pat[-1] == '*')
3104 len = fromlen;
3105 pat = aptr;
3106 aint = SvCUR(cat);
3107 SvCUR(cat) += (len+1)/2;
3108 SvGROW(cat, SvCUR(cat) + 1);
3109 aptr = SvPVX(cat) + aint;
3110 if (len > fromlen)
3111 len = fromlen;
3112 aint = len;
3113 items = 0;
3114 if (datumtype == 'H') {
3115 for (len = 0; len++ < aint;) {
3116 if (isALPHA(*pat))
3117 items |= ((*pat++ & 15) + 9) & 15;
3118 else
3119 items |= *pat++ & 15;
3120 if (len & 1)
3121 items <<= 4;
3122 else {
3123 *aptr++ = items & 0xff;
3124 items = 0;
3125 }
3126 }
3127 }
3128 else {
3129 for (len = 0; len++ < aint;) {
3130 if (isALPHA(*pat))
3131 items |= (((*pat++ & 15) + 9) & 15) << 4;
3132 else
3133 items |= (*pat++ & 15) << 4;
3134 if (len & 1)
3135 items >>= 4;
3136 else {
3137 *aptr++ = items & 0xff;
3138 items = 0;
3139 }
3140 }
3141 }
3142 if (aint & 1)
3143 *aptr++ = items & 0xff;
3144 pat = SvPVX(cat) + SvCUR(cat);
3145 while (aptr <= pat)
3146 *aptr++ = '\0';
79072805 3147
a0d0e21e
LW
3148 pat = savepat;
3149 items = saveitems;
3150 }
3151 break;
3152 case 'C':
3153 case 'c':
3154 while (len-- > 0) {
3155 fromstr = NEXTFROM;
3156 aint = SvIV(fromstr);
3157 achar = aint;
3158 sv_catpvn(cat, &achar, sizeof(char));
3159 }
3160 break;
3161 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3162 case 'f':
3163 case 'F':
3164 while (len-- > 0) {
3165 fromstr = NEXTFROM;
3166 afloat = (float)SvNV(fromstr);
3167 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3168 }
3169 break;
3170 case 'd':
3171 case 'D':
3172 while (len-- > 0) {
3173 fromstr = NEXTFROM;
3174 adouble = (double)SvNV(fromstr);
3175 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3176 }
3177 break;
3178 case 'n':
3179 while (len-- > 0) {
3180 fromstr = NEXTFROM;
3181 ashort = (I16)SvIV(fromstr);
3182#ifdef HAS_HTONS
3183 ashort = htons(ashort);
79072805 3184#endif
a0d0e21e
LW
3185 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3186 }
3187 break;
3188 case 'v':
3189 while (len-- > 0) {
3190 fromstr = NEXTFROM;
3191 ashort = (I16)SvIV(fromstr);
3192#ifdef HAS_HTOVS
3193 ashort = htovs(ashort);
79072805 3194#endif
a0d0e21e
LW
3195 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3196 }
3197 break;
3198 case 'S':
3199 case 's':
3200 while (len-- > 0) {
3201 fromstr = NEXTFROM;
3202 ashort = (I16)SvIV(fromstr);
3203 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3204 }
3205 break;
3206 case 'I':
3207 while (len-- > 0) {
3208 fromstr = NEXTFROM;
3209 auint = U_I(SvNV(fromstr));
3210 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3211 }
3212 break;
3213 case 'i':
3214 while (len-- > 0) {
3215 fromstr = NEXTFROM;
3216 aint = SvIV(fromstr);
3217 sv_catpvn(cat, (char*)&aint, sizeof(int));
3218 }
3219 break;
3220 case 'N':
3221 while (len-- > 0) {
3222 fromstr = NEXTFROM;
3223 aulong = U_L(SvNV(fromstr));
3224#ifdef HAS_HTONL
3225 aulong = htonl(aulong);
79072805 3226#endif
a0d0e21e
LW
3227 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3228 }
3229 break;
3230 case 'V':
3231 while (len-- > 0) {
3232 fromstr = NEXTFROM;
3233 aulong = U_L(SvNV(fromstr));
3234#ifdef HAS_HTOVL
3235 aulong = htovl(aulong);
79072805 3236#endif
a0d0e21e
LW
3237 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3238 }
3239 break;
3240 case 'L':
3241 while (len-- > 0) {
3242 fromstr = NEXTFROM;
3243 aulong = U_L(SvNV(fromstr));
3244 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3245 }
3246 break;
3247 case 'l':
3248 while (len-- > 0) {
3249 fromstr = NEXTFROM;
3250 along = SvIV(fromstr);
3251 sv_catpvn(cat, (char*)&along, sizeof(I32));
3252 }
3253 break;
ecfc5424 3254#ifdef HAS_QUAD
a0d0e21e
LW
3255 case 'Q':
3256 while (len-- > 0) {
3257 fromstr = NEXTFROM;
ecfc5424
AD
3258 auquad = (unsigned Quad_t)SvIV(fromstr);
3259 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
a0d0e21e
LW
3260 }
3261 break;
3262 case 'q':
3263 while (len-- > 0) {
3264 fromstr = NEXTFROM;
ecfc5424
AD
3265 aquad = (Quad_t)SvIV(fromstr);
3266 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW
3267 }
3268 break;
ecfc5424 3269#endif /* HAS_QUAD */
a0d0e21e
LW
3270 case 'P':
3271 len = 1; /* assume SV is correct length */
3272 /* FALL THROUGH */
3273 case 'p':
3274 while (len-- > 0) {
3275 fromstr = NEXTFROM;
3276 aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */
3277 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
3278 }
3279 break;
3280 case 'u':
3281 fromstr = NEXTFROM;
3282 aptr = SvPV(fromstr, fromlen);
3283 SvGROW(cat, fromlen * 4 / 3);
3284 if (len <= 1)
3285 len = 45;
3286 else
3287 len = len / 3 * 3;
3288 while (fromlen > 0) {
3289 I32 todo;
79072805 3290
a0d0e21e
LW
3291 if (fromlen > len)
3292 todo = len;
3293 else
3294 todo = fromlen;
3295 doencodes(cat, aptr, todo);
3296 fromlen -= todo;
3297 aptr += todo;
3298 }
3299 break;
3300 }
3301 }
3302 SvSETMAGIC(cat);
3303 SP = ORIGMARK;
3304 PUSHs(cat);
3305 RETURN;
79072805 3306}
a0d0e21e 3307#undef NEXTFROM
79072805 3308
a0d0e21e 3309PP(pp_split)
79072805 3310{
a0d0e21e
LW
3311 dSP; dTARG;
3312 AV *ary;
3313 register I32 limit = POPi; /* note, negative is forever */
3314 SV *sv = POPs;
3315 STRLEN len;
3316 register char *s = SvPV(sv, len);
3317 char *strend = s + len;
3318 register PMOP *pm = (PMOP*)POPs;
3319 register SV *dstr;
3320 register char *m;
3321 I32 iters = 0;
3322 I32 maxiters = (strend - s) + 10;
3323 I32 i;
3324 char *orig;
3325 I32 origlimit = limit;
3326 I32 realarray = 0;
3327 I32 base;
3328 AV *oldstack = stack;
3329 register REGEXP *rx = pm->op_pmregexp;
3330 I32 gimme = GIMME;
c07a80fd 3331 I32 oldsave = savestack_ix;
79072805 3332
a0d0e21e
LW
3333 if (!pm || !s)
3334 DIE("panic: do_split");
3335 if (pm->op_pmreplroot)
3336 ary = GvAVn((GV*)pm->op_pmreplroot);
3337 else if (gimme != G_ARRAY)
3338 ary = GvAVn(defgv);
79072805 3339 else
a0d0e21e
LW
3340 ary = Nullav;
3341 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
3342 realarray = 1;
3343 if (!AvREAL(ary)) {
3344 AvREAL_on(ary);
3345 for (i = AvFILL(ary); i >= 0; i--)
3346 AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
79072805 3347 }
a0d0e21e
LW
3348 av_extend(ary,0);
3349 av_clear(ary);
3350 /* temporarily switch stacks */
3351 SWITCHSTACK(stack, ary);
79072805 3352 }
a0d0e21e
LW
3353 base = SP - stack_base;
3354 orig = s;
3355 if (pm->op_pmflags & PMf_SKIPWHITE) {
3356 while (isSPACE(*s))
3357 s++;
3358 }
c07a80fd
PP
3359 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3360 SAVEINT(multiline);
3361 multiline = pm->op_pmflags & PMf_MULTILINE;
3362 }
3363
a0d0e21e
LW
3364 if (!limit)
3365 limit = maxiters + 2;
3366 if (pm->op_pmflags & PMf_WHITE) {
3367 while (--limit) {
3368 /*SUPPRESS 530*/
3369 for (m = s; m < strend && !isSPACE(*m); m++) ;
3370 if (m >= strend)
3371 break;
3372 dstr = NEWSV(30, m-s);
3373 sv_setpvn(dstr, s, m-s);
3374 if (!realarray)
3375 sv_2mortal(dstr);
3376 XPUSHs(dstr);
3377 /*SUPPRESS 530*/
3378 for (s = m + 1; s < strend && isSPACE(*s); s++) ;
79072805
LW
3379 }
3380 }
a0d0e21e
LW
3381 else if (strEQ("^", rx->precomp)) {
3382 while (--limit) {
3383 /*SUPPRESS 530*/
3384 for (m = s; m < strend && *m != '\n'; m++) ;
3385 m++;
3386 if (m >= strend)
3387 break;
3388 dstr = NEWSV(30, m-s);
3389 sv_setpvn(dstr, s, m-s);
3390 if (!realarray)
3391 sv_2mortal(dstr);
3392 XPUSHs(dstr);
3393 s = m;
3394 }
3395 }
3396 else if (pm->op_pmshort) {
3397 i = SvCUR(pm->op_pmshort);
3398 if (i == 1) {
3399 I32 fold = (pm->op_pmflags & PMf_FOLD);
3400 i = *SvPVX(pm->op_pmshort);
3401 if (fold && isUPPER(i))
3402 i = toLOWER(i);
3403 while (--limit) {
3404 if (fold) {
3405 for ( m = s;
3406 m < strend && *m != i &&
3407 (!isUPPER(*m) || toLOWER(*m) != i);
3408 m++) /*SUPPRESS 530*/
3409 ;
3410 }
3411 else /*SUPPRESS 530*/
3412 for (m = s; m < strend && *m != i; m++) ;
3413 if (m >= strend)
3414 break;
3415 dstr = NEWSV(30, m-s);
3416 sv_setpvn(dstr, s, m-s);
3417 if (!realarray)
3418 sv_2mortal(dstr);
3419 XPUSHs(dstr);
3420 s = m + 1;
3421 }
3422 }
3423 else {
3424#ifndef lint
3425 while (s < strend && --limit &&
3426 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
3427 pm->op_pmshort)) )
79072805 3428#endif
a0d0e21e
LW
3429 {
3430 dstr = NEWSV(31, m-s);
3431 sv_setpvn(dstr, s, m-s);
3432 if (!realarray)
3433 sv_2mortal(dstr);
3434 XPUSHs(dstr);
3435 s = m + i;
3436 }
463ee0b2 3437 }
463ee0b2 3438 }
a0d0e21e
LW
3439 else {
3440 maxiters += (strend - s) * rx->nparens;
3441 while (s < strend && --limit &&
e50aee73 3442 pregexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
a0d0e21e
LW
3443 if (rx->subbase
3444 && rx->subbase != orig) {
3445 m = s;
3446 s = orig;
3447 orig = rx->subbase;
3448 s = orig + (m - s);
3449 strend = s + (strend - m);
3450 }
3451 m = rx->startp[0];
3452 dstr = NEWSV(32, m-s);
3453 sv_setpvn(dstr, s, m-s);
3454 if (!realarray)
3455 sv_2mortal(dstr);
3456 XPUSHs(dstr);
3457 if (rx->nparens) {
3458 for (i = 1; i <= rx->nparens; i++) {
3459 s = rx->startp[i];
3460 m = rx->endp[i];
748a9306
LW
3461 if (m && s) {
3462 dstr = NEWSV(33, m-s);
3463 sv_setpvn(dstr, s, m-s);
3464 }
3465 else
3466 dstr = NEWSV(33, 0);
a0d0e21e
LW
3467 if (!realarray)
3468 sv_2mortal(dstr);
3469 XPUSHs(dstr);
3470 }
3471 }
3472 s = rx->endp[0];
3473 }
79072805 3474 }
c07a80fd 3475 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
3476 iters = (SP - stack_base) - base;
3477 if (iters > maxiters)
3478 DIE("Split loop");
3479
3480 /* keep field after final delim? */
3481 if (s < strend || (iters && origlimit)) {
3482 dstr = NEWSV(34, strend-s);
3483 sv_setpvn(dstr, s, strend-s);
3484 if (!realarray)
3485 sv_2mortal(dstr);
3486 XPUSHs(dstr);
3487 iters++;
79072805 3488 }
a0d0e21e
LW
3489 else if (!origlimit) {
3490 while (iters > 0 && SvCUR(TOPs) == 0)
3491 iters--, SP--;
3492 }
3493 if (realarray) {
3494 SWITCHSTACK(ary, oldstack);
3495 if (gimme == G_ARRAY) {
3496 EXTEND(SP, iters);
3497 Copy(AvARRAY(ary), SP + 1, iters, SV*);
3498 SP += iters;
3499 RETURN;
3500 }
3501 }
3502 else {
3503 if (gimme == G_ARRAY)
3504 RETURN;
3505 }
3506 if (iters || !pm->op_pmreplroot) {
3507 GETTARGET;
3508 PUSHi(iters);
3509 RETURN;
3510 }
3511 RETPUSHUNDEF;
79072805 3512}
85e6fe83 3513