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