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