This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
perl5a5:pat/inherit.pat
[perl5.git] / pp.c
CommitLineData
79072805
LW		 1/***********************************************************
2 *
3 * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
4 *
5 * Description:
6 * Push/Pop code.
7 *
8 * Standards:
9 *
10 * Created:
11 * Mon Jun 15 16:45:59 1992
12 *
13 * Author:
14 * Larry Wall <lwall@netlabs.com>
15 *
16 * $Log: pp.c, v $
17 * Revision 4.1 92/08/07 18:26:21 lwall
18 *
19 *
20 **********************************************************/
21
22#include "EXTERN.h"
23#include "perl.h"
24
25#ifdef HAS_SOCKET
26#include <sys/socket.h>
27#include <netdb.h>
28#ifndef ENOTSOCK
29#include <net/errno.h>
30#endif
31#endif
32
33#ifdef HAS_SELECT
34#ifdef I_SYS_SELECT
35#ifndef I_SYS_TIME
36#include <sys/select.h>
37#endif
38#endif
39#endif
40
41#ifdef HOST_NOT_FOUND
42extern int h_errno;
43#endif
44
45#ifdef I_PWD
46#include <pwd.h>
47#endif
48#ifdef I_GRP
49#include <grp.h>
50#endif
51#ifdef I_UTIME
52#include <utime.h>
53#endif
54#ifdef I_FCNTL
55#include <fcntl.h>
56#endif
57#ifdef I_SYS_FILE
58#include <sys/file.h>
59#endif
60
61#ifdef I_VARARGS
62# include <varargs.h>
63#endif
64
463ee0b2
LW		 65static I32 dopoptosub P((I32 startingblock));
66
79072805
LW		 67/* Nothing. */
68
69PP(pp_null)
70{
71 return NORMAL;
72}
73
93a17b20
LW		 74PP(pp_stub)
75{
76 dSP;
77 if (GIMME != G_ARRAY) {
78 XPUSHs(&sv_undef);
79 }
80 RETURN;
81}
82
79072805
LW		 83PP(pp_scalar)
84{
85 return NORMAL;
86}
87
88/* Pushy stuff. */
89
90PP(pp_pushmark)
91{
92 if (++markstack_ptr == markstack_max) {
93 I32 oldmax = markstack_max - markstack;
94 I32 newmax = oldmax * 3 / 2;
95
96 Renew(markstack, newmax, I32);
97 markstack_ptr = markstack + oldmax;
98 markstack_max = markstack + newmax;
99 }
100 *markstack_ptr = stack_sp - stack_base;
101 return NORMAL;
102}
103
104PP(pp_wantarray)
105{
106 dSP;
107 I32 cxix;
108 EXTEND(SP, 1);
109
110 cxix = dopoptosub(cxstack_ix);
111 if (cxix < 0)
112 RETPUSHUNDEF;
113
114 if (cxstack[cxix].blk_gimme == G_ARRAY)
115 RETPUSHYES;
116 else
117 RETPUSHNO;
118}
119
79072805
LW		 120PP(pp_const)
121{
122 dSP;
123 XPUSHs(cSVOP->op_sv);
124 RETURN;
125}
126
127static void
128ucase(s,send)
129register char *s;
130register char *send;
131{
132 while (s < send) {
133 if (isLOWER(*s))
134 *s = toupper(*s);
135 s++;
136 }
137}
138
139static void
140lcase(s,send)
141register char *s;
142register char *send;
143{
144 while (s < send) {
145 if (isUPPER(*s))
146 *s = tolower(*s);
147 s++;
148 }
149}
150
151PP(pp_interp)
152{
153 DIE("panic: pp_interp");
154}
155
156PP(pp_gvsv)
157{
158 dSP;
159 EXTEND(sp,1);
93a17b20 160 if (op->op_flags & OPf_INTRO)
79072805
LW		 161 PUSHs(save_scalar(cGVOP->op_gv));
162 else
163 PUSHs(GvSV(cGVOP->op_gv));
164 RETURN;
165}
166
167PP(pp_gv)
168{
169 dSP;
170 XPUSHs((SV*)cGVOP->op_gv);
171 RETURN;
172}
173
93a17b20
LW		 174PP(pp_padsv)
175{
176 dSP; dTARGET;
177 XPUSHs(TARG);
178 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
179 SvOK_off(TARG);
180 RETURN;
181}
182
183PP(pp_padav)
184{
185 dSP; dTARGET;
186 XPUSHs(TARG);
187 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
463ee0b2 188 av_clear((AV*)TARG);
93a17b20
LW		 189 if (op->op_flags & OPf_LVAL)
190 RETURN;
191 PUTBACK;
192 return pp_rv2av();
193}
194
195PP(pp_padhv)
196{
197 dSP; dTARGET;
198 XPUSHs(TARG);
199 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
463ee0b2 200 hv_clear((HV*)TARG);
93a17b20
LW		 201 if (op->op_flags & OPf_LVAL)
202 RETURN;
203 PUTBACK;
204 return pp_rv2hv();
205}
206
79072805
LW		 207PP(pp_pushre)
208{
209 dSP;
210 XPUSHs((SV*)op);
211 RETURN;
212}
213
214/* Translations. */
215
216PP(pp_rv2gv)
217{
218 dSP; dTOPss;
219 if (SvTYPE(sv) == SVt_REF) {
220 sv = (SV*)SvANY(sv);
221 if (SvTYPE(sv) != SVt_PVGV)
222 DIE("Not a glob reference");
223 }
224 else {
93a17b20
LW		 225 if (SvTYPE(sv) != SVt_PVGV) {
226 if (!SvOK(sv))
227 DIE(no_usym);
463ee0b2 228 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
93a17b20 229 }
79072805 230 }
93a17b20 231 if (op->op_flags & OPf_INTRO) {
79072805
LW		 232 GP *ogp = GvGP(sv);
233
234 SSCHECK(3);
235 SSPUSHPTR(sv);
236 SSPUSHPTR(ogp);
237 SSPUSHINT(SAVEt_GP);
238
239 if (op->op_flags & OPf_SPECIAL)
240 GvGP(sv)->gp_refcnt++; /* will soon be assigned */
241 else {
242 GP *gp;
243 Newz(602,gp, 1, GP);
244 GvGP(sv) = gp;
245 GvREFCNT(sv) = 1;
246 GvSV(sv) = NEWSV(72,0);
247 GvLINE(sv) = curcop->cop_line;
248 GvEGV(sv) = sv;
249 }
250 }
251 SETs(sv);
252 RETURN;
253}
254
255PP(pp_sv2len)
256{
257 dSP; dTARGET;
258 dPOPss;
259 PUSHi(sv_len(sv));
260 RETURN;
261}
262
263PP(pp_rv2sv)
264{
265 dSP; dTOPss;
266
267 if (SvTYPE(sv) == SVt_REF) {
268 sv = (SV*)SvANY(sv);
269 switch (SvTYPE(sv)) {
270 case SVt_PVAV:
271 case SVt_PVHV:
272 case SVt_PVCV:
273 DIE("Not a scalar reference");
274 }
275 }
276 else {
463ee0b2
LW		 277 GV *gv = sv;
278 if (SvTYPE(gv) != SVt_PVGV) {
93a17b20
LW		 279 if (!SvOK(sv))
280 DIE(no_usym);
463ee0b2
LW		 281 gv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
282 }
283 sv = GvSV(gv);
284 if (op->op_private == OP_RV2HV &&
285 (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVHV)) {
286 sv_free(sv);
287 sv = NEWSV(0,0);
288 sv_upgrade(sv, SVt_REF);
289 SvANY(sv) = (void*)sv_ref((SV*)newHV());
290 GvSV(gv) = sv;
291 }
292 else if (op->op_private == OP_RV2AV &&
293 (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVAV)) {
294 sv_free(sv);
295 sv = NEWSV(0,0);
296 sv_upgrade(sv, SVt_REF);
297 SvANY(sv) = (void*)sv_ref((SV*)newAV());
298 GvSV(gv) = sv;
93a17b20 299 }
79072805 300 }
93a17b20 301 if (op->op_flags & OPf_INTRO)
79072805
LW		 302 SETs(save_scalar((GV*)TOPs));
303 else
304 SETs(sv);
305 RETURN;
306}
307
308PP(pp_av2arylen)
309{
310 dSP;
311 AV *av = (AV*)TOPs;
312 SV *sv = AvARYLEN(av);
313 if (!sv) {
314 AvARYLEN(av) = sv = NEWSV(0,0);
315 sv_upgrade(sv, SVt_IV);
316 sv_magic(sv, (SV*)av, '#', Nullch, 0);
317 }
318 SETs(sv);
319 RETURN;
320}
321
322PP(pp_rv2cv)
323{
324 dSP;
325 SV *sv;
326 GV *gv;
327 HV *stash;
328 CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
329
330 SETs((SV*)cv);
331 RETURN;
332}
333
334PP(pp_refgen)
335{
336 dSP; dTOPss;
337 SV* rv;
338 if (!sv)
339 RETSETUNDEF;
340 rv = sv_mortalcopy(&sv_undef);
341 sv_upgrade(rv, SVt_REF);
342 SvANY(rv) = (void*)sv_ref(sv);
343 SETs(rv);
344 RETURN;
345}
346
347PP(pp_ref)
348{
463ee0b2
LW		 349 dSP; dTARGET;
350 SV *sv;
79072805
LW		 351 char *pv;
352
463ee0b2
LW		 353 if (MAXARG < 1) {
354 sv = GvSV(defgv);
355 EXTEND(SP, 1);
356 }
357 else
358 sv = POPs;
79072805 359 if (SvTYPE(sv) != SVt_REF)
463ee0b2 360 RETPUSHUNDEF;
79072805
LW		 361
362 sv = (SV*)SvANY(sv);
363 if (SvSTORAGE(sv) == 'O')
364 pv = HvNAME(SvSTASH(sv));
365 else {
366 switch (SvTYPE(sv)) {
367 case SVt_REF: pv = "REF"; break;
368 case SVt_NULL:
369 case SVt_IV:
370 case SVt_NV:
371 case SVt_PV:
372 case SVt_PVIV:
373 case SVt_PVNV:
374 case SVt_PVMG:
375 case SVt_PVBM: pv = "SCALAR"; break;
376 case SVt_PVLV: pv = "LVALUE"; break;
377 case SVt_PVAV: pv = "ARRAY"; break;
378 case SVt_PVHV: pv = "HASH"; break;
379 case SVt_PVCV: pv = "CODE"; break;
380 case SVt_PVGV: pv = "GLOB"; break;
381 case SVt_PVFM: pv = "FORMLINE"; break;
382 default: pv = "UNKNOWN"; break;
383 }
384 }
463ee0b2 385 PUSHp(pv, strlen(pv));
79072805
LW		 386 RETURN;
387}
388
389PP(pp_bless)
390{
463ee0b2 391 dSP;
79072805 392 register SV* ref;
463ee0b2
LW		 393 SV *sv;
394 HV *stash;
79072805 395
463ee0b2
LW		 396 if (MAXARG == 1)
397 stash = curcop->cop_stash;
398 else
399 stash = fetch_stash(POPs, TRUE);
79072805 400
463ee0b2
LW		 401 sv = TOPs;
402 if (SvTYPE(sv) != SVt_REF)
403 DIE("Can't bless non-reference value");
79072805
LW		 404 ref = (SV*)SvANY(sv);
405 if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
406 DIE("Can't bless temporary scalar");
407 SvSTORAGE(ref) = 'O';
408 SvUPGRADE(ref, SVt_PVMG);
463ee0b2 409 SvSTASH(ref) = stash;
79072805
LW		 410 RETURN;
411}
412
413/* Pushy I/O. */
414
415PP(pp_backtick)
416{
417 dSP; dTARGET;
418 FILE *fp;
419 char *tmps = POPp;
79072805 420 TAINT_PROPER("``");
79072805
LW		 421 fp = my_popen(tmps, "r");
422 if (fp) {
423 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
424 if (GIMME == G_SCALAR) {
425 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
426 /*SUPPRESS 530*/
427 ;
428 XPUSHs(TARG);
429 }
430 else {
431 SV *sv;
432
433 for (;;) {
434 sv = NEWSV(56, 80);
435 if (sv_gets(sv, fp, 0) == Nullch) {
436 sv_free(sv);
437 break;
438 }
439 XPUSHs(sv_2mortal(sv));
440 if (SvLEN(sv) - SvCUR(sv) > 20) {
441 SvLEN_set(sv, SvCUR(sv)+1);
463ee0b2 442 Renew(SvPVX(sv), SvLEN(sv), char);
79072805
LW		 443 }
444 }
445 }
446 statusvalue = my_pclose(fp);
447 }
448 else {
449 statusvalue = -1;
450 if (GIMME == G_SCALAR)
451 RETPUSHUNDEF;
452 }
453
454 RETURN;
455}
456
457OP *
458do_readline()
459{
460 dSP; dTARGETSTACKED;
461 register SV *sv;
462 STRLEN tmplen;
463 STRLEN offset;
464 FILE *fp;
465 register IO *io = GvIO(last_in_gv);
466 register I32 type = op->op_type;
467
468 fp = Nullfp;
469 if (io) {
470 fp = io->ifp;
471 if (!fp) {
472 if (io->flags & IOf_ARGV) {
473 if (io->flags & IOf_START) {
474 io->flags &= ~IOf_START;
475 io->lines = 0;
476 if (av_len(GvAVn(last_in_gv)) < 0) {
477 SV *tmpstr = newSVpv("-", 1); /* assume stdin */
478 (void)av_push(GvAVn(last_in_gv), tmpstr);
479 }
480 }
481 fp = nextargv(last_in_gv);
482 if (!fp) { /* Note: fp != io->ifp */
483 (void)do_close(last_in_gv, FALSE); /* now it does*/
484 io->flags |= IOf_START;
485 }
486 }
487 else if (type == OP_GLOB) {
488 SV *tmpcmd = NEWSV(55, 0);
489 SV *tmpglob = POPs;
490#ifdef DOSISH
491 sv_setpv(tmpcmd, "perlglob ");
492 sv_catsv(tmpcmd, tmpglob);
493 sv_catpv(tmpcmd, " |");
494#else
495#ifdef CSH
496 sv_setpvn(tmpcmd, cshname, cshlen);
497 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
498 sv_catsv(tmpcmd, tmpglob);
499 sv_catpv(tmpcmd, "'|");
500#else
501 sv_setpv(tmpcmd, "echo ");
502 sv_catsv(tmpcmd, tmpglob);
503 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
504#endif /* !CSH */
505#endif /* !MSDOS */
463ee0b2 506 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd));
79072805
LW		 507 fp = io->ifp;
508 sv_free(tmpcmd);
509 }
510 }
511 else if (type == OP_GLOB)
512 SP--;
513 }
514 if (!fp) {
515 if (dowarn)
516 warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
517 if (GIMME == G_SCALAR)
518 RETPUSHUNDEF;
519 RETURN;
520 }
521 if (GIMME == G_ARRAY) {
522 sv = sv_2mortal(NEWSV(57, 80));
523 offset = 0;
524 }
525 else {
526 sv = TARG;
527 SvUPGRADE(sv, SVt_PV);
528 tmplen = SvLEN(sv); /* remember if already alloced */
529 if (!tmplen)
530 Sv_Grow(sv, 80); /* try short-buffering it */
531 if (type == OP_RCATLINE)
532 offset = SvCUR(sv);
533 else
534 offset = 0;
535 }
536 for (;;) {
537 if (!sv_gets(sv, fp, offset)) {
538 clearerr(fp);
539 if (io->flags & IOf_ARGV) {
540 fp = nextargv(last_in_gv);
541 if (fp)
542 continue;
543 (void)do_close(last_in_gv, FALSE);
544 io->flags |= IOf_START;
545 }
546 else if (type == OP_GLOB) {
547 (void)do_close(last_in_gv, FALSE);
548 }
549 if (GIMME == G_SCALAR)
550 RETPUSHUNDEF;
551 RETURN;
552 }
553 io->lines++;
554 XPUSHs(sv);
463ee0b2
LW		 555 if (tainting) {
556 tainted = TRUE;
557 SvTAINT(sv); /* Anything from the outside world...*/
558 }
79072805
LW		 559 if (type == OP_GLOB) {
560 char *tmps;
561
562 if (SvCUR(sv) > 0)
563 SvCUR(sv)--;
564 if (*SvEND(sv) == rschar)
565 *SvEND(sv) = '\0';
566 else
567 SvCUR(sv)++;
463ee0b2 568 for (tmps = SvPVX(sv); *tmps; tmps++)
79072805 569 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
93a17b20 570 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
79072805 571 break;
463ee0b2 572 if (*tmps && stat(SvPVX(sv), &statbuf) < 0) {
79072805
LW		 573 POPs; /* Unmatched wildcard? Chuck it... */
574 continue;
575 }
576 }
577 if (GIMME == G_ARRAY) {
578 if (SvLEN(sv) - SvCUR(sv) > 20) {
579 SvLEN_set(sv, SvCUR(sv)+1);
463ee0b2 580 Renew(SvPVX(sv), SvLEN(sv), char);
79072805
LW		 581 }
582 sv = sv_2mortal(NEWSV(58, 80));
583 continue;
584 }
585 else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
586 /* try to reclaim a bit of scalar space (only on 1st alloc) */
587 if (SvCUR(sv) < 60)
588 SvLEN_set(sv, 80);
589 else
590 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
463ee0b2 591 Renew(SvPVX(sv), SvLEN(sv), char);
79072805
LW		 592 }
593 RETURN;
594 }
595}
596
597PP(pp_glob)
598{
599 OP *result;
600 ENTER;
601 SAVEINT(rschar);
602 SAVEINT(rslen);
603
604 SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
605 last_in_gv = (GV*)*stack_sp--;
606
607 rslen = 1;
608#ifdef DOSISH
609 rschar = 0;
610#else
611#ifdef CSH
612 rschar = 0;
613#else
614 rschar = '\n';
615#endif /* !CSH */
616#endif /* !MSDOS */
617 result = do_readline();
618 LEAVE;
619 return result;
620}
621
622PP(pp_readline)
623{
624 last_in_gv = (GV*)(*stack_sp--);
625 return do_readline();
626}
627
628PP(pp_indread)
629{
463ee0b2 630 last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE);
79072805
LW		 631 return do_readline();
632}
633
634PP(pp_rcatline)
635{
636 last_in_gv = cGVOP->op_gv;
637 return do_readline();
638}
639
463ee0b2
LW		 640PP(pp_regcmaybe)
641{
642 return NORMAL;
643}
644
79072805
LW		 645PP(pp_regcomp) {
646 dSP;
647 register PMOP *pm = (PMOP*)cLOGOP->op_other;
648 register char *t;
649 I32 global;
650 SV *tmpstr;
651 register REGEXP *rx = pm->op_pmregexp;
463ee0b2 652 STRLEN len;
79072805
LW		 653
654 global = pm->op_pmflags & PMf_GLOBAL;
655 tmpstr = POPs;
463ee0b2 656 t = SvPV(tmpstr, len);
79072805
LW		 657 if (!global && rx)
658 regfree(rx);
659 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
463ee0b2 660 pm->op_pmregexp = regcomp(t, t + len,
79072805
LW		 661 pm->op_pmflags & PMf_FOLD);
662 if (!pm->op_pmregexp->prelen && curpm)
663 pm = curpm;
664 if (pm->op_pmflags & PMf_KEEP) {
665 if (!(pm->op_pmflags & PMf_FOLD))
666 scan_prefix(pm, pm->op_pmregexp->precomp,
667 pm->op_pmregexp->prelen);
668 pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
669 hoistmust(pm);
463ee0b2 670 cLOGOP->op_first->op_next = op->op_next;
79072805
LW		 671 /* XXX delete push code */
672 }
673 RETURN;
674}
675
676PP(pp_match)
677{
678 dSP; dTARG;
679 register PMOP *pm = cPMOP;
680 register char *t;
681 register char *s;
682 char *strend;
683 SV *tmpstr;
79072805
LW		 684 I32 global;
685 I32 safebase;
686 char *truebase;
687 register REGEXP *rx = pm->op_pmregexp;
688 I32 gimme = GIMME;
463ee0b2 689 STRLEN len;
79072805 690
79072805
LW		 691 if (op->op_flags & OPf_STACKED)
692 TARG = POPs;
693 else {
694 TARG = GvSV(defgv);
695 EXTEND(SP,1);
696 }
463ee0b2
LW		 697 s = SvPV(TARG, len);
698 strend = s + len;
79072805
LW		 699 if (!s)
700 DIE("panic: do_match");
701
702 if (pm->op_pmflags & PMf_USED) {
703 if (gimme == G_ARRAY)
704 RETURN;
705 RETPUSHNO;
706 }
707
708 if (!rx->prelen && curpm) {
709 pm = curpm;
710 rx = pm->op_pmregexp;
711 }
712 truebase = t = s;
93a17b20
LW		 713 if (global = pm->op_pmflags & PMf_GLOBAL) {
714 rx->startp[0] = 0;
715 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
716 MAGIC* mg = mg_find(TARG, 'g');
717 if (mg && mg->mg_ptr) {
718 rx->startp[0] = mg->mg_ptr;
719 rx->endp[0] = mg->mg_ptr + mg->mg_len;
720 }
721 }
722 }
723 safebase = (gimme == G_ARRAY) || global;
724
79072805
LW		 725play_it_again:
726 if (global && rx->startp[0]) {
727 t = s = rx->endp[0];
728 if (s == rx->startp[0])
729 s++, t++;
730 if (s > strend)
731 goto nope;
732 }
93a17b20 733 if (pm->op_pmshort) {
79072805
LW		 734 if (pm->op_pmflags & PMf_SCANFIRST) {
735 if (SvSCREAM(TARG)) {
736 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
737 goto nope;
738 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
739 goto nope;
740 else if (pm->op_pmflags & PMf_ALL)
741 goto yup;
742 }
743 else if (!(s = fbm_instr((unsigned char*)s,
744 (unsigned char*)strend, pm->op_pmshort)))
745 goto nope;
746 else if (pm->op_pmflags & PMf_ALL)
747 goto yup;
748 if (s && rx->regback >= 0) {
749 ++BmUSEFUL(pm->op_pmshort);
750 s -= rx->regback;
751 if (s < t)
752 s = t;
753 }
754 else
755 s = t;
756 }
757 else if (!multiline) {
463ee0b2
LW		 758 if (*SvPVX(pm->op_pmshort) != *s ||
759 bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
79072805 760 if (pm->op_pmflags & PMf_FOLD) {
463ee0b2 761 if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
79072805
LW		 762 goto nope;
763 }
764 else
765 goto nope;
766 }
767 }
768 if (--BmUSEFUL(pm->op_pmshort) < 0) {
769 sv_free(pm->op_pmshort);
770 pm->op_pmshort = Nullsv; /* opt is being useless */
771 }
772 }
773 if (!rx->nparens && !global) {
774 gimme = G_SCALAR; /* accidental array context? */
775 safebase = FALSE;
776 }
777 if (regexec(rx, s, strend, truebase, 0,
778 SvSCREAM(TARG) ? TARG : Nullsv,
779 safebase)) {
780 curpm = pm;
781 if (pm->op_pmflags & PMf_ONCE)
782 pm->op_pmflags |= PMf_USED;
783 goto gotcha;
784 }
93a17b20
LW		 785 else
786 goto ret_no;
79072805
LW		 787 /*NOTREACHED*/
788
789 gotcha:
790 if (gimme == G_ARRAY) {
791 I32 iters, i, len;
792
793 iters = rx->nparens;
794 if (global && !iters)
795 i = 1;
796 else
797 i = 0;
798 EXTEND(SP, iters + i);
799 for (i = !i; i <= iters; i++) {
800 PUSHs(sv_mortalcopy(&sv_no));
801 /*SUPPRESS 560*/
802 if (s = rx->startp[i]) {
803 len = rx->endp[i] - s;
804 if (len > 0)
805 sv_setpvn(*SP, s, len);
806 }
807 }
808 if (global) {
809 truebase = rx->subbeg;
810 goto play_it_again;
811 }
812 RETURN;
813 }
814 else {
93a17b20
LW		 815 if (global) {
816 MAGIC* mg = 0;
817 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
818 mg = mg_find(TARG, 'g');
819 if (!mg) {
820 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
821 mg = mg_find(TARG, 'g');
822 }
823 mg->mg_ptr = rx->startp[0];
824 mg->mg_len = rx->endp[0] - rx->startp[0];
825 }
79072805
LW		 826 RETPUSHYES;
827 }
828
829yup:
830 ++BmUSEFUL(pm->op_pmshort);
831 curpm = pm;
832 if (pm->op_pmflags & PMf_ONCE)
833 pm->op_pmflags |= PMf_USED;
834 if (global) {
835 rx->subbeg = t;
836 rx->subend = strend;
837 rx->startp[0] = s;
838 rx->endp[0] = s + SvCUR(pm->op_pmshort);
839 goto gotcha;
840 }
841 if (sawampersand) {
842 char *tmps;
843
844 if (rx->subbase)
845 Safefree(rx->subbase);
846 tmps = rx->subbase = nsavestr(t, strend-t);
847 rx->subbeg = tmps;
848 rx->subend = tmps + (strend-t);
849 tmps = rx->startp[0] = tmps + (s - t);
850 rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
851 }
852 RETPUSHYES;
853
854nope:
79072805
LW		 855 if (pm->op_pmshort)
856 ++BmUSEFUL(pm->op_pmshort);
93a17b20
LW		 857
858ret_no:
859 if (global) {
860 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
861 MAGIC* mg = mg_find(TARG, 'g');
862 if (mg) {
863 mg->mg_ptr = 0;
864 mg->mg_len = 0;
865 }
866 }
867 }
79072805
LW		 868 if (gimme == G_ARRAY)
869 RETURN;
870 RETPUSHNO;
871}
872
873PP(pp_subst)
874{
875 dSP; dTARG;
876 register PMOP *pm = cPMOP;
877 PMOP *rpm = pm;
878 register SV *dstr;
879 register char *s;
880 char *strend;
881 register char *m;
882 char *c;
883 register char *d;
463ee0b2 884 STRLEN clen;
79072805
LW		 885 I32 iters = 0;
886 I32 maxiters;
887 register I32 i;
888 bool once;
889 char *orig;
890 I32 safebase;
891 register REGEXP *rx = pm->op_pmregexp;
463ee0b2 892 STRLEN len;
79072805
LW		 893
894 if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
895 dstr = POPs;
896 if (op->op_flags & OPf_STACKED)
897 TARG = POPs;
898 else {
899 TARG = GvSV(defgv);
900 EXTEND(SP,1);
901 }
463ee0b2 902 s = SvPV(TARG, len);
79072805
LW		 903 if (!pm || !s)
904 DIE("panic: do_subst");
905
463ee0b2 906 strend = s + len;
79072805
LW		 907 maxiters = (strend - s) + 10;
908
909 if (!rx->prelen && curpm) {
910 pm = curpm;
911 rx = pm->op_pmregexp;
912 }
913 safebase = ((!rx || !rx->nparens) && !sawampersand);
914 orig = m = s;
93a17b20 915 if (pm->op_pmshort) {
79072805
LW		 916 if (pm->op_pmflags & PMf_SCANFIRST) {
917 if (SvSCREAM(TARG)) {
918 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
919 goto nope;
920 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
921 goto nope;
922 }
923 else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
924 pm->op_pmshort)))
925 goto nope;
926 if (s && rx->regback >= 0) {
927 ++BmUSEFUL(pm->op_pmshort);
928 s -= rx->regback;
929 if (s < m)
930 s = m;
931 }
932 else
933 s = m;
934 }
935 else if (!multiline) {
463ee0b2
LW		 936 if (*SvPVX(pm->op_pmshort) != *s ||
937 bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
79072805 938 if (pm->op_pmflags & PMf_FOLD) {
463ee0b2 939 if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
79072805
LW		 940 goto nope;
941 }
942 else
943 goto nope;
944 }
945 }
946 if (--BmUSEFUL(pm->op_pmshort) < 0) {
947 sv_free(pm->op_pmshort);
948 pm->op_pmshort = Nullsv; /* opt is being useless */
949 }
950 }
951 once = !(rpm->op_pmflags & PMf_GLOBAL);
952 if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
463ee0b2 953 c = SvPV(dstr, clen);
79072805
LW		 954 if (clen <= rx->minlen) {
955 /* can do inplace substitution */
956 if (regexec(rx, s, strend, orig, 0,
957 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
958 if (rx->subbase) /* oops, no we can't */
959 goto long_way;
960 d = s;
961 curpm = pm;
962 SvSCREAM_off(TARG); /* disable possible screamer */
963 if (once) {
964 m = rx->startp[0];
965 d = rx->endp[0];
966 s = orig;
967 if (m - s > strend - d) { /* faster to shorten from end */
968 if (clen) {
969 Copy(c, m, clen, char);
970 m += clen;
971 }
972 i = strend - d;
973 if (i > 0) {
974 Move(d, m, i, char);
975 m += i;
976 }
977 *m = '\0';
978 SvCUR_set(TARG, m - s);
463ee0b2 979 SvPOK_only(TARG);
79072805
LW		 980 SvSETMAGIC(TARG);
981 PUSHs(&sv_yes);
982 RETURN;
983 }
984 /*SUPPRESS 560*/
985 else if (i = m - s) { /* faster from front */
986 d -= clen;
987 m = d;
988 sv_chop(TARG, d-i);
989 s += i;
990 while (i--)
991 *--d = *--s;
992 if (clen)
993 Copy(c, m, clen, char);
463ee0b2 994 SvPOK_only(TARG);
79072805
LW		 995 SvSETMAGIC(TARG);
996 PUSHs(&sv_yes);
997 RETURN;
998 }
999 else if (clen) {
1000 d -= clen;
1001 sv_chop(TARG, d);
1002 Copy(c, d, clen, char);
463ee0b2 1003 SvPOK_only(TARG);
79072805
LW		 1004 SvSETMAGIC(TARG);
1005 PUSHs(&sv_yes);
1006 RETURN;
1007 }
1008 else {
1009 sv_chop(TARG, d);
463ee0b2 1010 SvPOK_only(TARG);
79072805
LW		 1011 SvSETMAGIC(TARG);
1012 PUSHs(&sv_yes);
1013 RETURN;
1014 }
1015 /* NOTREACHED */
1016 }
1017 do {
1018 if (iters++ > maxiters)
1019 DIE("Substitution loop");
1020 m = rx->startp[0];
1021 /*SUPPRESS 560*/
1022 if (i = m - s) {
1023 if (s != d)
1024 Move(s, d, i, char);
1025 d += i;
1026 }
1027 if (clen) {
1028 Copy(c, d, clen, char);
1029 d += clen;
1030 }
1031 s = rx->endp[0];
1032 } while (regexec(rx, s, strend, orig, s == m,
1033 Nullsv, TRUE)); /* (don't match same null twice) */
1034 if (s != d) {
1035 i = strend - s;
463ee0b2 1036 SvCUR_set(TARG, d - SvPVX(TARG) + i);
79072805
LW		 1037 Move(s, d, i+1, char); /* include the Null */
1038 }
463ee0b2 1039 SvPOK_only(TARG);
79072805
LW		 1040 SvSETMAGIC(TARG);
1041 PUSHs(sv_2mortal(newSVnv((double)iters)));
1042 RETURN;
1043 }
1044 PUSHs(&sv_no);
1045 RETURN;
1046 }
1047 }
1048 else
1049 c = Nullch;
1050 if (regexec(rx, s, strend, orig, 0,
1051 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1052 long_way:
1053 dstr = NEWSV(25, sv_len(TARG));
1054 sv_setpvn(dstr, m, s-m);
1055 curpm = pm;
1056 if (!c) {
1057 register CONTEXT *cx;
1058 PUSHSUBST(cx);
1059 RETURNOP(cPMOP->op_pmreplroot);
1060 }
1061 do {
1062 if (iters++ > maxiters)
1063 DIE("Substitution loop");
1064 if (rx->subbase && rx->subbase != orig) {
1065 m = s;
1066 s = orig;
1067 orig = rx->subbase;
1068 s = orig + (m - s);
1069 strend = s + (strend - m);
1070 }
1071 m = rx->startp[0];
1072 sv_catpvn(dstr, s, m-s);
1073 s = rx->endp[0];
1074 if (clen)
1075 sv_catpvn(dstr, c, clen);
1076 if (once)
1077 break;
1078 } while (regexec(rx, s, strend, orig, s == m, Nullsv,
1079 safebase));
1080 sv_catpvn(dstr, s, strend - s);
1081 sv_replace(TARG, dstr);
463ee0b2 1082 SvPOK_only(TARG);
79072805
LW		 1083 SvSETMAGIC(TARG);
1084 PUSHs(sv_2mortal(newSVnv((double)iters)));
1085 RETURN;
1086 }
1087 PUSHs(&sv_no);
1088 RETURN;
1089
1090nope:
1091 ++BmUSEFUL(pm->op_pmshort);
1092 PUSHs(&sv_no);
1093 RETURN;
1094}
1095
1096PP(pp_substcont)
1097{
1098 dSP;
1099 register PMOP *pm = (PMOP*) cLOGOP->op_other;
1100 register CONTEXT *cx = &cxstack[cxstack_ix];
1101 register SV *dstr = cx->sb_dstr;
1102 register char *s = cx->sb_s;
1103 register char *m = cx->sb_m;
1104 char *orig = cx->sb_orig;
1105 register REGEXP *rx = pm->op_pmregexp;
1106
1107 if (cx->sb_iters++) {
1108 if (cx->sb_iters > cx->sb_maxiters)
1109 DIE("Substitution loop");
1110
1111 sv_catsv(dstr, POPs);
1112 if (rx->subbase)
1113 Safefree(rx->subbase);
1114 rx->subbase = cx->sb_subbase;
1115
1116 /* Are we done */
1117 if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
1118 s == m, Nullsv, cx->sb_safebase))
1119 {
1120 SV *targ = cx->sb_targ;
1121 sv_catpvn(dstr, s, cx->sb_strend - s);
1122 sv_replace(targ, dstr);
463ee0b2 1123 SvPOK_only(targ);
79072805
LW		 1124 SvSETMAGIC(targ);
1125 PUSHs(sv_2mortal(newSVnv((double)(cx->sb_iters - 1))));
1126 POPSUBST(cx);
1127 RETURNOP(pm->op_next);
1128 }
1129 }
1130 if (rx->subbase && rx->subbase != orig) {
1131 m = s;
1132 s = orig;
1133 cx->sb_orig = orig = rx->subbase;
1134 s = orig + (m - s);
1135 cx->sb_strend = s + (cx->sb_strend - m);
1136 }
1137 cx->sb_m = m = rx->startp[0];
1138 sv_catpvn(dstr, s, m-s);
1139 cx->sb_s = rx->endp[0];
1140 cx->sb_subbase = rx->subbase;
1141
1142 rx->subbase = Nullch; /* so recursion works */
1143 RETURNOP(pm->op_pmreplstart);
1144}
1145
1146PP(pp_trans)
1147{
1148 dSP; dTARG;
1149 SV *sv;
1150
1151 if (op->op_flags & OPf_STACKED)
1152 sv = POPs;
1153 else {
1154 sv = GvSV(defgv);
1155 EXTEND(SP,1);
1156 }
1157 TARG = NEWSV(27,0);
1158 PUSHi(do_trans(sv, op));
1159 RETURN;
1160}
1161
1162/* Lvalue operators. */
1163
1164PP(pp_sassign)
1165{
1166 dSP; dPOPTOPssrl;
463ee0b2 1167 if (tainting && tainted && (!SvMAGICAL(lstr) || !mg_find(lstr, 't'))) {
79072805 1168 TAINT_NOT;
463ee0b2 1169 }
79072805
LW		 1170 SvSetSV(rstr, lstr);
1171 SvSETMAGIC(rstr);
1172 SETs(rstr);
1173 RETURN;
1174}
1175
1176PP(pp_aassign)
1177{
1178 dSP;
1179 SV **lastlelem = stack_sp;
1180 SV **lastrelem = stack_base + POPMARK;
1181 SV **firstrelem = stack_base + POPMARK + 1;
1182 SV **firstlelem = lastrelem + 1;
1183
1184 register SV **relem;
1185 register SV **lelem;
1186
1187 register SV *sv;
1188 register AV *ary;
1189
1190 HV *hash;
1191 I32 i;
463ee0b2 1192 int magic;
79072805
LW		 1193
1194 delaymagic = DM_DELAY; /* catch simultaneous items */
1195
1196 /* If there's a common identifier on both sides we have to take
1197 * special care that assigning the identifier on the left doesn't
1198 * clobber a value on the right that's used later in the list.
1199 */
1200 if (op->op_private & OPpASSIGN_COMMON) {
1201 for (relem = firstrelem; relem <= lastrelem; relem++) {
1202 /*SUPPRESS 560*/
1203 if (sv = *relem)
1204 *relem = sv_mortalcopy(sv);
1205 }
1206 }
1207
1208 relem = firstrelem;
1209 lelem = firstlelem;
1210 ary = Null(AV*);
1211 hash = Null(HV*);
1212 while (lelem <= lastlelem) {
1213 sv = *lelem++;
1214 switch (SvTYPE(sv)) {
1215 case SVt_PVAV:
1216 ary = (AV*)sv;
463ee0b2 1217 magic = SvMAGICAL(ary) != 0;
79072805
LW		 1218 AvREAL_on(ary);
1219 AvFILL(ary) = -1;
1220 i = 0;
1221 while (relem <= lastrelem) { /* gobble up all the rest */
1222 sv = NEWSV(28,0);
1223 if (*relem)
1224 sv_setsv(sv,*relem);
1225 *(relem++) = sv;
1226 (void)av_store(ary,i++,sv);
463ee0b2
LW		 1227 if (magic)
1228 mg_set(sv);
79072805
LW		 1229 }
1230 break;
1231 case SVt_PVHV: {
1232 char *tmps;
1233 SV *tmpstr;
79072805
LW		 1234
1235 hash = (HV*)sv;
463ee0b2
LW		 1236 magic = SvMAGICAL(hash) != 0;
1237 hv_clear(hash);
79072805
LW		 1238
1239 while (relem < lastrelem) { /* gobble up all the rest */
463ee0b2 1240 STRLEN len;
79072805
LW		 1241 if (*relem)
1242 sv = *(relem++);
1243 else
1244 sv = &sv_no, relem++;
463ee0b2 1245 tmps = SvPV(sv, len);
79072805
LW		 1246 tmpstr = NEWSV(29,0);
1247 if (*relem)
1248 sv_setsv(tmpstr,*relem); /* value */
1249 *(relem++) = tmpstr;
463ee0b2
LW		 1250 (void)hv_store(hash,tmps,len,tmpstr,0);
1251 if (magic)
1252 mg_set(tmpstr);
79072805
LW		 1253 }
1254 }
1255 break;
1256 default:
1257 if (SvREADONLY(sv)) {
1258 if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
1259 DIE(no_modify);
1260 if (relem <= lastrelem)
1261 relem++;
1262 break;
1263 }
1264 if (relem <= lastrelem) {
1265 sv_setsv(sv, *relem);
1266 *(relem++) = sv;
1267 }
1268 else
1269 sv_setsv(sv, &sv_undef);
1270 SvSETMAGIC(sv);
1271 break;
1272 }
1273 }
1274 if (delaymagic & ~DM_DELAY) {
1275 if (delaymagic & DM_UID) {
1276#ifdef HAS_SETREUID
1277 (void)setreuid(uid,euid);
1278#else /* not HAS_SETREUID */
1279#ifdef HAS_SETRUID
1280 if ((delaymagic & DM_UID) == DM_RUID) {
1281 (void)setruid(uid);
1282 delaymagic =~ DM_RUID;
1283 }
1284#endif /* HAS_SETRUID */
1285#ifdef HAS_SETEUID
1286 if ((delaymagic & DM_UID) == DM_EUID) {
1287 (void)seteuid(uid);
1288 delaymagic =~ DM_EUID;
1289 }
1290#endif /* HAS_SETEUID */
1291 if (delaymagic & DM_UID) {
1292 if (uid != euid)
1293 DIE("No setreuid available");
1294 (void)setuid(uid);
1295 }
1296#endif /* not HAS_SETREUID */
1297 uid = (int)getuid();
1298 euid = (int)geteuid();
1299 }
1300 if (delaymagic & DM_GID) {
1301#ifdef HAS_SETREGID
1302 (void)setregid(gid,egid);
1303#else /* not HAS_SETREGID */
1304#ifdef HAS_SETRGID
1305 if ((delaymagic & DM_GID) == DM_RGID) {
1306 (void)setrgid(gid);
1307 delaymagic =~ DM_RGID;
1308 }
1309#endif /* HAS_SETRGID */
1310#ifdef HAS_SETEGID
1311 if ((delaymagic & DM_GID) == DM_EGID) {
1312 (void)setegid(gid);
1313 delaymagic =~ DM_EGID;
1314 }
1315#endif /* HAS_SETEGID */
1316 if (delaymagic & DM_GID) {
1317 if (gid != egid)
1318 DIE("No setregid available");
1319 (void)setgid(gid);
1320 }
1321#endif /* not HAS_SETREGID */
1322 gid = (int)getgid();
1323 egid = (int)getegid();
1324 }
463ee0b2 1325 tainting |= (euid != uid || egid != gid);
79072805
LW		 1326 }
1327 delaymagic = 0;
1328 if (GIMME == G_ARRAY) {
1329 if (ary || hash)
1330 SP = lastrelem;
1331 else
1332 SP = firstrelem + (lastlelem - firstlelem);
1333 RETURN;
1334 }
1335 else {
1336 dTARGET;
1337 SP = firstrelem;
1338 SETi(lastrelem - firstrelem + 1);
1339 RETURN;
1340 }
1341}
1342
1343PP(pp_schop)
1344{
1345 dSP; dTARGET;
1346 SV *sv;
1347
1348 if (MAXARG < 1)
1349 sv = GvSV(defgv);
1350 else
1351 sv = POPs;
1352 do_chop(TARG, sv);
1353 PUSHTARG;
1354 RETURN;
1355}
1356
1357PP(pp_chop)
1358{
1359 dSP; dMARK; dTARGET;
1360 while (SP > MARK)
1361 do_chop(TARG, POPs);
1362 PUSHTARG;
1363 RETURN;
1364}
1365
1366PP(pp_defined)
1367{
1368 dSP;
1369 register SV* sv;
1370
1371 if (MAXARG < 1) {
1372 sv = GvSV(defgv);
1373 EXTEND(SP, 1);
1374 }
1375 else
1376 sv = POPs;
1377 if (!sv || !SvANY(sv))
1378 RETPUSHNO;
1379 switch (SvTYPE(sv)) {
1380 case SVt_PVAV:
1381 if (AvMAX(sv) >= 0)
1382 RETPUSHYES;
1383 break;
1384 case SVt_PVHV:
1385 if (HvARRAY(sv))
1386 RETPUSHYES;
1387 break;
1388 case SVt_PVCV:
1389 if (CvROOT(sv))
1390 RETPUSHYES;
1391 break;
1392 default:
1393 if (SvOK(sv))
1394 RETPUSHYES;
1395 }
1396 RETPUSHNO;
1397}
1398
1399PP(pp_undef)
1400{
1401 dSP;
1402 SV *sv;
1403
1404 if (!op->op_private)
1405 RETPUSHUNDEF;
1406
1407 sv = POPs;
93a17b20 1408 if (!sv || SvREADONLY(sv))
79072805
LW		 1409 RETPUSHUNDEF;
1410
1411 switch (SvTYPE(sv)) {
1412 case SVt_NULL:
1413 break;
463ee0b2
LW		 1414 case SVt_REF:
1415 sv_free((SV*)SvANY(sv));
1416 SvANY(sv) = 0;
1417 SvTYPE(sv) = SVt_NULL;
1418 break;
79072805
LW		 1419 case SVt_PVAV:
1420 av_undef((AV*)sv);
1421 break;
1422 case SVt_PVHV:
463ee0b2 1423 hv_undef((HV*)sv);
79072805 1424 break;
463ee0b2
LW		 1425 case SVt_PVCV:
1426 sub_generation++;
1427 cv_clear((CV*)sv);
79072805 1428 break;
79072805
LW		 1429 default:
1430 if (sv != GvSV(defgv)) {
1431 if (SvPOK(sv) && SvLEN(sv)) {
1432 SvOOK_off(sv);
463ee0b2 1433 Safefree(SvPVX(sv));
79072805
LW		 1434 SvPV_set(sv, Nullch);
1435 SvLEN_set(sv, 0);
1436 }
1437 SvOK_off(sv);
1438 SvSETMAGIC(sv);
1439 }
1440 }
1441
1442 RETPUSHUNDEF;
1443}
1444
1445PP(pp_study)
1446{
1447 dSP; dTARGET;
1448 register unsigned char *s;
1449 register I32 pos;
1450 register I32 ch;
1451 register I32 *sfirst;
1452 register I32 *snext;
1453 I32 retval;
463ee0b2 1454 STRLEN len;
79072805 1455
463ee0b2
LW		 1456 s = (unsigned char*)(SvPV(TARG, len));
1457 pos = len;
79072805
LW		 1458 if (lastscream)
1459 SvSCREAM_off(lastscream);
1460 lastscream = TARG;
1461 if (pos <= 0) {
1462 retval = 0;
1463 goto ret;
1464 }
1465 if (pos > maxscream) {
1466 if (maxscream < 0) {
1467 maxscream = pos + 80;
1468 New(301, screamfirst, 256, I32);
1469 New(302, screamnext, maxscream, I32);
1470 }
1471 else {
1472 maxscream = pos + pos / 4;
1473 Renew(screamnext, maxscream, I32);
1474 }
1475 }
1476
1477 sfirst = screamfirst;
1478 snext = screamnext;
1479
1480 if (!sfirst || !snext)
1481 DIE("do_study: out of memory");
1482
1483 for (ch = 256; ch; --ch)
1484 *sfirst++ = -1;
1485 sfirst -= 256;
1486
1487 while (--pos >= 0) {
1488 ch = s[pos];
1489 if (sfirst[ch] >= 0)
1490 snext[pos] = sfirst[ch] - pos;
1491 else
1492 snext[pos] = -pos;
1493 sfirst[ch] = pos;
1494
1495 /* If there were any case insensitive searches, we must assume they
1496 * all are. This speeds up insensitive searches much more than
1497 * it slows down sensitive ones.
1498 */
1499 if (sawi)
1500 sfirst[fold[ch]] = pos;
1501 }
1502
1503 SvSCREAM_on(TARG);
1504 retval = 1;
1505 ret:
1506 XPUSHs(sv_2mortal(newSVnv((double)retval)));
1507 RETURN;
1508}
1509
1510PP(pp_preinc)
1511{
1512 dSP;
1513 sv_inc(TOPs);
1514 SvSETMAGIC(TOPs);
1515 return NORMAL;
1516}
1517
1518PP(pp_predec)
1519{
1520 dSP;
1521 sv_dec(TOPs);
1522 SvSETMAGIC(TOPs);
1523 return NORMAL;
1524}
1525
1526PP(pp_postinc)
1527{
1528 dSP; dTARGET;
1529 sv_setsv(TARG, TOPs);
1530 sv_inc(TOPs);
1531 SvSETMAGIC(TOPs);
1532 SETs(TARG);
1533 return NORMAL;
1534}
1535
1536PP(pp_postdec)
1537{
1538 dSP; dTARGET;
1539 sv_setsv(TARG, TOPs);
1540 sv_dec(TOPs);
1541 SvSETMAGIC(TOPs);
1542 SETs(TARG);
1543 return NORMAL;
1544}
1545
1546/* Ordinary operators. */
1547
1548PP(pp_pow)
1549{
1550 dSP; dATARGET; dPOPTOPnnrl;
1551 SETn( pow( left, right) );
1552 RETURN;
1553}
1554
1555PP(pp_multiply)
1556{
1557 dSP; dATARGET; dPOPTOPnnrl;
1558 SETn( left * right );
1559 RETURN;
1560}
1561
1562PP(pp_divide)
1563{
1564 dSP; dATARGET; dPOPnv;
1565 if (value == 0.0)
1566 DIE("Illegal division by zero");
1567#ifdef SLOPPYDIVIDE
1568 /* insure that 20./5. == 4. */
1569 {
1570 double x;
1571 I32 k;
1572 x = POPn;
1573 if ((double)(I32)x == x &&
1574 (double)(I32)value == value &&
1575 (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
1576 value = k;
1577 } else {
1578 value = x/value;
1579 }
1580 }
1581#else
1582 value = POPn / value;
1583#endif
1584 PUSHn( value );
1585 RETURN;
1586}
1587
1588PP(pp_modulo)
1589{
1590 dSP; dATARGET;
1591 register unsigned long tmpulong;
1592 register long tmplong;
1593 I32 value;
1594
1595 tmpulong = (unsigned long) POPn;
1596 if (tmpulong == 0L)
1597 DIE("Illegal modulus zero");
1598 value = TOPn;
1599 if (value >= 0.0)
1600 value = (I32)(((unsigned long)value) % tmpulong);
1601 else {
1602 tmplong = (long)value;
1603 value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
1604 }
1605 SETi(value);
1606 RETURN;
1607}
1608
1609PP(pp_repeat)
1610{
1611 dSP; dATARGET;
1612 register I32 count = POPi;
1613 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
1614 dMARK;
1615 I32 items = SP - MARK;
1616 I32 max;
1617
1618 max = items * count;
1619 MEXTEND(MARK, max);
1620 if (count > 1) {
1621 while (SP > MARK) {
1622 if (*SP)
1623 SvTEMP_off((*SP));
1624 SP--;
1625 }
1626 MARK++;
463ee0b2
LW		 1627 repeatcpy((char*)(MARK + items), (char*)MARK,
1628 items * sizeof(SV*), count - 1);
79072805
LW		 1629 }
1630 SP += max;
1631 }
1632 else { /* Note: mark already snarfed by pp_list */
1633 SV *tmpstr;
1634 char *tmps;
1635
1636 tmpstr = POPs;
463ee0b2
LW		 1637 if (SvREADONLY(tmpstr))
1638 DIE("Can't x= to readonly value");
79072805
LW		 1639 SvSetSV(TARG, tmpstr);
1640 if (count >= 1) {
463ee0b2
LW		 1641 STRLEN len;
1642 STRLEN tlen;
79072805 1643 tmpstr = NEWSV(50, 0);
463ee0b2
LW		 1644 tmps = SvPV(TARG, len);
1645 sv_setpvn(tmpstr, tmps, len);
1646 tmps = SvPV(tmpstr, tlen); /* force to be string */
1647 SvGROW(TARG, (count * len) + 1);
1648 repeatcpy((char*)SvPVX(TARG), tmps, tlen, count);
79072805
LW		 1649 SvCUR(TARG) *= count;
1650 *SvEND(TARG) = '\0';
463ee0b2 1651 SvPOK_only(TARG);
79072805
LW		 1652 sv_free(tmpstr);
1653 }
93a17b20 1654 else
79072805 1655 sv_setsv(TARG, &sv_no);
79072805
LW		 1656 PUSHTARG;
1657 }
1658 RETURN;
1659}
1660
1661PP(pp_add)
1662{
1663 dSP; dATARGET; dPOPTOPnnrl;
1664 SETn( left + right );
1665 RETURN;
1666}
1667
1668PP(pp_intadd)
1669{
1670 dSP; dATARGET; dPOPTOPiirl;
1671 SETi( left + right );
1672 RETURN;
1673}
1674
1675PP(pp_subtract)
1676{
1677 dSP; dATARGET; dPOPTOPnnrl;
1678 SETn( left - right );
1679 RETURN;
1680}
1681
1682PP(pp_concat)
1683{
1684 dSP; dATARGET; dPOPTOPssrl;
1685 SvSetSV(TARG, lstr);
1686 sv_catsv(TARG, rstr);
1687 SETTARG;
1688 RETURN;
1689}
1690
1691PP(pp_left_shift)
1692{
1693 dSP; dATARGET;
1694 I32 anum = POPi;
1695 double value = TOPn;
1696 SETi( U_L(value) << anum );
1697 RETURN;
1698}
1699
1700PP(pp_right_shift)
1701{
1702 dSP; dATARGET;
1703 I32 anum = POPi;
1704 double value = TOPn;
1705 SETi( U_L(value) >> anum );
1706 RETURN;
1707}
1708
1709PP(pp_lt)
1710{
1711 dSP; dPOPnv;
1712 SETs((TOPn < value) ? &sv_yes : &sv_no);
1713 RETURN;
1714}
1715
1716PP(pp_gt)
1717{
1718 dSP; dPOPnv;
1719 SETs((TOPn > value) ? &sv_yes : &sv_no);
1720 RETURN;
1721}
1722
1723PP(pp_le)
1724{
1725 dSP; dPOPnv;
1726 SETs((TOPn <= value) ? &sv_yes : &sv_no);
1727 RETURN;
1728}
1729
1730PP(pp_ge)
1731{
1732 dSP; dPOPnv;
1733 SETs((TOPn >= value) ? &sv_yes : &sv_no);
1734 RETURN;
1735}
1736
1737PP(pp_eq)
1738{
93a17b20 1739 dSP; dPOPnv;
79072805
LW		 1740 SETs((TOPn == value) ? &sv_yes : &sv_no);
1741 RETURN;
1742}
1743
1744PP(pp_ne)
1745{
1746 dSP; dPOPnv;
1747 SETs((TOPn != value) ? &sv_yes : &sv_no);
1748 RETURN;
1749}
1750
1751PP(pp_ncmp)
1752{
1753 dSP; dTARGET; dPOPTOPnnrl;
1754 I32 value;
1755
1756 if (left > right)
1757 value = 1;
1758 else if (left < right)
1759 value = -1;
1760 else
1761 value = 0;
1762 SETi(value);
1763 RETURN;
1764}
1765
1766PP(pp_slt)
1767{
1768 dSP; dPOPTOPssrl;
1769 SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
1770 RETURN;
1771}
1772
1773PP(pp_sgt)
1774{
1775 dSP; dPOPTOPssrl;
1776 SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
1777 RETURN;
1778}
1779
1780PP(pp_sle)
1781{
1782 dSP; dPOPTOPssrl;
1783 SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
1784 RETURN;
1785}
1786
1787PP(pp_sge)
1788{
1789 dSP; dPOPTOPssrl;
1790 SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
1791 RETURN;
1792}
1793
1794PP(pp_seq)
1795{
1796 dSP; dPOPTOPssrl;
1797 SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1798 RETURN;
1799}
1800
1801PP(pp_sne)
1802{
1803 dSP; dPOPTOPssrl;
1804 SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1805 RETURN;
1806}
1807
1808PP(pp_scmp)
1809{
1810 dSP; dTARGET;
1811 dPOPTOPssrl;
1812 SETi( sv_cmp(lstr, rstr) );
1813 RETURN;
1814}
1815
1816PP(pp_bit_and)
1817{
1818 dSP; dATARGET; dPOPTOPssrl;
1819 if (SvNIOK(lstr) || SvNIOK(rstr)) {
463ee0b2
LW		 1820 I32 value = SvIV(lstr);
1821 value = value & SvIV(rstr);
79072805
LW		 1822 SETi(value);
1823 }
1824 else {
1825 do_vop(op->op_type, TARG, lstr, rstr);
1826 SETTARG;
1827 }
1828 RETURN;
1829}
1830
1831PP(pp_xor)
1832{
1833 dSP; dATARGET; dPOPTOPssrl;
1834 if (SvNIOK(lstr) || SvNIOK(rstr)) {
463ee0b2
LW		 1835 I32 value = SvIV(lstr);
1836 value = value ^ SvIV(rstr);
79072805
LW		 1837 SETi(value);
1838 }
1839 else {
1840 do_vop(op->op_type, TARG, lstr, rstr);
1841 SETTARG;
1842 }
1843 RETURN;
1844}
1845
1846PP(pp_bit_or)
1847{
1848 dSP; dATARGET; dPOPTOPssrl;
1849 if (SvNIOK(lstr) || SvNIOK(rstr)) {
463ee0b2
LW		 1850 I32 value = SvIV(lstr);
1851 value = value | SvIV(rstr);
79072805
LW		 1852 SETi(value);
1853 }
1854 else {
1855 do_vop(op->op_type, TARG, lstr, rstr);
1856 SETTARG;
1857 }
1858 RETURN;
1859}
1860
1861PP(pp_negate)
1862{
1863 dSP; dTARGET;
1864 SETn(-TOPn);
1865 RETURN;
1866}
1867
1868PP(pp_not)
1869{
1870 *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
1871 return NORMAL;
1872}
1873
1874PP(pp_complement)
1875{
1876 dSP; dTARGET; dTOPss;
1877 register I32 anum;
1878
1879 if (SvNIOK(sv)) {
463ee0b2 1880 SETi( ~SvIV(sv) );
79072805
LW		 1881 }
1882 else {
1883 register char *tmps;
1884 register long *tmpl;
463ee0b2 1885 STRLEN len;
79072805
LW		 1886
1887 SvSetSV(TARG, sv);
463ee0b2
LW		 1888 tmps = SvPV(TARG, len);
1889 anum = len;
79072805
LW		 1890#ifdef LIBERAL
1891 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1892 *tmps = ~*tmps;
1893 tmpl = (long*)tmps;
1894 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1895 *tmpl = ~*tmpl;
1896 tmps = (char*)tmpl;
1897#endif
1898 for ( ; anum > 0; anum--, tmps++)
1899 *tmps = ~*tmps;
1900
1901 SETs(TARG);
1902 }
1903 RETURN;
1904}
1905
1906/* High falutin' math. */
1907
1908PP(pp_atan2)
1909{
1910 dSP; dTARGET; dPOPTOPnnrl;
1911 SETn(atan2(left, right));
1912 RETURN;
1913}
1914
1915PP(pp_sin)
1916{
1917 dSP; dTARGET;
1918 double value;
1919 if (MAXARG < 1)
463ee0b2 1920 value = SvNVx(GvSV(defgv));
79072805
LW		 1921 else
1922 value = POPn;
1923 value = sin(value);
1924 XPUSHn(value);
1925 RETURN;
1926}
1927
1928PP(pp_cos)
1929{
1930 dSP; dTARGET;
1931 double value;
1932 if (MAXARG < 1)
463ee0b2 1933 value = SvNVx(GvSV(defgv));
79072805
LW		 1934 else
1935 value = POPn;
1936 value = cos(value);
1937 XPUSHn(value);
1938 RETURN;
1939}
1940
1941PP(pp_rand)
1942{
1943 dSP; dTARGET;
1944 double value;
1945 if (MAXARG < 1)
1946 value = 1.0;
1947 else
1948 value = POPn;
1949 if (value == 0.0)
1950 value = 1.0;
1951#if RANDBITS == 31
1952 value = rand() * value / 2147483648.0;
1953#else
1954#if RANDBITS == 16
1955 value = rand() * value / 65536.0;
1956#else
1957#if RANDBITS == 15
1958 value = rand() * value / 32768.0;
1959#else
1960 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1961#endif
1962#endif
1963#endif
1964 XPUSHn(value);
1965 RETURN;
1966}
1967
1968PP(pp_srand)
1969{
1970 dSP;
1971 I32 anum;
1972 time_t when;
1973
1974 if (MAXARG < 1) {
1975 (void)time(&when);
1976 anum = when;
1977 }
1978 else
1979 anum = POPi;
1980 (void)srand(anum);
1981 EXTEND(SP, 1);
1982 RETPUSHYES;
1983}
1984
1985PP(pp_exp)
1986{
1987 dSP; dTARGET;
1988 double value;
1989 if (MAXARG < 1)
463ee0b2 1990 value = SvNVx(GvSV(defgv));
79072805
LW		 1991 else
1992 value = POPn;
1993 value = exp(value);
1994 XPUSHn(value);
1995 RETURN;
1996}
1997
1998PP(pp_log)
1999{
2000 dSP; dTARGET;
2001 double value;
2002 if (MAXARG < 1)
463ee0b2 2003 value = SvNVx(GvSV(defgv));
79072805
LW		 2004 else
2005 value = POPn;
2006 if (value <= 0.0)
2007 DIE("Can't take log of %g\n", value);
2008 value = log(value);
2009 XPUSHn(value);
2010 RETURN;
2011}
2012
2013PP(pp_sqrt)
2014{
2015 dSP; dTARGET;
2016 double value;
2017 if (MAXARG < 1)
463ee0b2 2018 value = SvNVx(GvSV(defgv));
79072805
LW		 2019 else
2020 value = POPn;
2021 if (value < 0.0)
2022 DIE("Can't take sqrt of %g\n", value);
2023 value = sqrt(value);
2024 XPUSHn(value);
2025 RETURN;
2026}
2027
2028PP(pp_int)
2029{
2030 dSP; dTARGET;
2031 double value;
2032 if (MAXARG < 1)
463ee0b2 2033 value = SvNVx(GvSV(defgv));
79072805
LW		 2034 else
2035 value = POPn;
2036 if (value >= 0.0)
2037 (void)modf(value, &value);
2038 else {
2039 (void)modf(-value, &value);
2040 value = -value;
2041 }
2042 XPUSHn(value);
2043 RETURN;
2044}
2045
463ee0b2
LW		 2046PP(pp_abs)
2047{
2048 dSP; dTARGET;
2049 double value;
2050 if (MAXARG < 1)
2051 value = SvNVx(GvSV(defgv));
2052 else
2053 value = POPn;
2054
2055 if (value < 0.0)
2056 value = -value;
2057
2058 XPUSHn(value);
2059 RETURN;
2060}
2061
79072805
LW		 2062PP(pp_hex)
2063{
2064 dSP; dTARGET;
2065 char *tmps;
2066 I32 argtype;
2067
2068 if (MAXARG < 1)
463ee0b2 2069 tmps = SvPVx(GvSV(defgv), na);
79072805
LW		 2070 else
2071 tmps = POPp;
2072 XPUSHi( scan_hex(tmps, 99, &argtype) );
2073 RETURN;
2074}
2075
2076PP(pp_oct)
2077{
2078 dSP; dTARGET;
2079 I32 value;
2080 I32 argtype;
2081 char *tmps;
2082
2083 if (MAXARG < 1)
463ee0b2 2084 tmps = SvPVx(GvSV(defgv), na);
79072805
LW		 2085 else
2086 tmps = POPp;
2087 while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
2088 tmps++;
2089 if (*tmps == 'x')
2090 value = (I32)scan_hex(++tmps, 99, &argtype);
2091 else
2092 value = (I32)scan_oct(tmps, 99, &argtype);
2093 XPUSHi(value);
2094 RETURN;
2095}
2096
2097/* String stuff. */
2098
2099PP(pp_length)
2100{
2101 dSP; dTARGET;
2102 if (MAXARG < 1) {
2103 XPUSHi( sv_len(GvSV(defgv)) );
2104 }
2105 else
2106 SETi( sv_len(TOPs) );
2107 RETURN;
2108}
2109
2110PP(pp_substr)
2111{
2112 dSP; dTARGET;
2113 SV *sv;
2114 I32 len;
463ee0b2 2115 STRLEN curlen;
79072805
LW		 2116 I32 pos;
2117 I32 rem;
2118 I32 lvalue = op->op_flags & OPf_LVAL;
2119 char *tmps;
2120
2121 if (MAXARG > 2)
2122 len = POPi;
2123 pos = POPi - arybase;
2124 sv = POPs;
463ee0b2 2125 tmps = SvPV(sv, curlen); /* force conversion to string */
79072805
LW		 2126 if (pos < 0)
2127 pos += curlen + arybase;
2128 if (pos < 0 || pos > curlen)
2129 sv_setpvn(TARG, "", 0);
2130 else {
2131 if (MAXARG < 3)
2132 len = curlen;
2133 if (len < 0)
2134 len = 0;
2135 tmps += pos;
2136 rem = curlen - pos; /* rem=how many bytes left*/
2137 if (rem > len)
2138 rem = len;
2139 sv_setpvn(TARG, tmps, rem);
2140 if (lvalue) { /* it's an lvalue! */
463ee0b2
LW		 2141 if (SvREADONLY(sv))
2142 DIE(no_modify);
79072805
LW		 2143 LvTYPE(TARG) = 's';
2144 LvTARG(TARG) = sv;
463ee0b2 2145 LvTARGOFF(TARG) = tmps - SvPV(sv, na);
79072805
LW		 2146 LvTARGLEN(TARG) = rem;
2147 }
2148 }
2149 PUSHs(TARG); /* avoid SvSETMAGIC here */
2150 RETURN;
2151}
2152
2153PP(pp_vec)
2154{
2155 dSP; dTARGET;
2156 register I32 size = POPi;
2157 register I32 offset = POPi;
2158 register SV *src = POPs;
2159 I32 lvalue = op->op_flags & OPf_LVAL;
463ee0b2
LW		 2160 STRLEN srclen;
2161 unsigned char *s = (unsigned char*)SvPV(src, srclen);
79072805
LW		 2162 unsigned long retnum;
2163 I32 len;
2164
2165 offset *= size; /* turn into bit offset */
2166 len = (offset + size + 7) / 8;
2167 if (offset < 0 || size < 1)
2168 retnum = 0;
93a17b20 2169 else if (!lvalue && len > srclen)
79072805
LW		 2170 retnum = 0;
2171 else {
93a17b20 2172 if (len > srclen) {
79072805 2173 SvGROW(src, len);
463ee0b2 2174 (void)memzero(SvPVX(src) + srclen, len - srclen);
79072805
LW		 2175 SvCUR_set(src, len);
2176 }
463ee0b2 2177 s = (unsigned char*)SvPV(src, na);
79072805
LW		 2178 if (size < 8)
2179 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2180 else {
2181 offset >>= 3;
2182 if (size == 8)
2183 retnum = s[offset];
2184 else if (size == 16)
2185 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2186 else if (size == 32)
2187 retnum = ((unsigned long) s[offset] << 24) +
2188 ((unsigned long) s[offset + 1] << 16) +
2189 (s[offset + 2] << 8) + s[offset+3];
2190 }
2191
2192 if (lvalue) { /* it's an lvalue! */
463ee0b2
LW		 2193 if (SvREADONLY(src))
2194 DIE(no_modify);
79072805
LW		 2195 LvTYPE(TARG) = 'v';
2196 LvTARG(TARG) = src;
2197 LvTARGOFF(TARG) = offset;
2198 LvTARGLEN(TARG) = size;
2199 }
2200 }
2201
2202 sv_setiv(TARG, (I32)retnum);
2203 PUSHs(TARG);
2204 RETURN;
2205}
2206
2207PP(pp_index)
2208{
2209 dSP; dTARGET;
2210 SV *big;
2211 SV *little;
2212 I32 offset;
2213 I32 retval;
2214 char *tmps;
2215 char *tmps2;
463ee0b2 2216 STRLEN biglen;
79072805
LW		 2217
2218 if (MAXARG < 3)
2219 offset = 0;
2220 else
2221 offset = POPi - arybase;
2222 little = POPs;
2223 big = POPs;
463ee0b2 2224 tmps = SvPV(big, biglen);
79072805
LW		 2225 if (offset < 0)
2226 offset = 0;
93a17b20
LW		 2227 else if (offset > biglen)
2228 offset = biglen;
79072805 2229 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
93a17b20 2230 (unsigned char*)tmps + biglen, little)))
79072805
LW		 2231 retval = -1 + arybase;
2232 else
2233 retval = tmps2 - tmps + arybase;
2234 PUSHi(retval);
2235 RETURN;
2236}
2237
2238PP(pp_rindex)
2239{
2240 dSP; dTARGET;
2241 SV *big;
2242 SV *little;
463ee0b2
LW		 2243 STRLEN blen;
2244 STRLEN llen;
79072805
LW		 2245 SV *offstr;
2246 I32 offset;
2247 I32 retval;
2248 char *tmps;
2249 char *tmps2;
2250
2251 if (MAXARG == 3)
2252 offstr = POPs;
2253 little = POPs;
2254 big = POPs;
463ee0b2
LW		 2255 tmps2 = SvPV(little, llen);
2256 tmps = SvPV(big, blen);
79072805 2257 if (MAXARG < 3)
463ee0b2 2258 offset = blen;
79072805 2259 else
463ee0b2 2260 offset = SvIV(offstr) - arybase + llen;
79072805
LW		 2261 if (offset < 0)
2262 offset = 0;
463ee0b2
LW		 2263 else if (offset > blen)
2264 offset = blen;
79072805 2265 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2266 tmps2, tmps2 + llen)))
79072805
LW		 2267 retval = -1 + arybase;
2268 else
2269 retval = tmps2 - tmps + arybase;
2270 PUSHi(retval);
2271 RETURN;
2272}
2273
2274PP(pp_sprintf)
2275{
2276 dSP; dMARK; dORIGMARK; dTARGET;
2277 do_sprintf(TARG, SP-MARK, MARK+1);
2278 SP = ORIGMARK;
2279 PUSHTARG;
2280 RETURN;
2281}
2282
2283static void
2284doparseform(sv)
2285SV *sv;
2286{
463ee0b2
LW		 2287 STRLEN len;
2288 register char *s = SvPV(sv, len);
2289 register char *send = s + len;
79072805
LW		 2290 register char *base;
2291 register I32 skipspaces = 0;
2292 bool noblank;
2293 bool repeat;
2294 bool postspace = FALSE;
2295 U16 *fops;
2296 register U16 *fpc;
2297 U16 *linepc;
2298 register I32 arg;
2299 bool ischop;
2300
2301 New(804, fops, send - s, U16); /* Almost certainly too long... */
2302 fpc = fops;
2303
2304 if (s < send) {
2305 linepc = fpc;
2306 *fpc++ = FF_LINEMARK;
2307 noblank = repeat = FALSE;
2308 base = s;
2309 }
2310
2311 while (s <= send) {
2312 switch (*s++) {
2313 default:
2314 skipspaces = 0;
2315 continue;
2316
2317 case '~':
2318 if (*s == '~') {
2319 repeat = TRUE;
2320 *s = ' ';
2321 }
2322 noblank = TRUE;
2323 s[-1] = ' ';
2324 /* FALL THROUGH */
2325 case ' ': case '\t':
2326 skipspaces++;
2327 continue;
2328
2329 case '\n': case 0:
2330 arg = s - base;
2331 skipspaces++;
2332 arg -= skipspaces;
2333 if (arg) {
2334 if (postspace) {
2335 *fpc++ = FF_SPACE;
2336 postspace = FALSE;
2337 }
2338 *fpc++ = FF_LITERAL;
2339 *fpc++ = arg;
2340 }
2341 if (s <= send)
2342 skipspaces--;
2343 if (skipspaces) {
2344 *fpc++ = FF_SKIP;
2345 *fpc++ = skipspaces;
2346 }
2347 skipspaces = 0;
2348 if (s <= send)
2349 *fpc++ = FF_NEWLINE;
2350 if (noblank) {
2351 *fpc++ = FF_BLANK;
2352 if (repeat)
2353 arg = fpc - linepc + 1;
2354 else
2355 arg = 0;
2356 *fpc++ = arg;
2357 }
2358 if (s < send) {
2359 linepc = fpc;
2360 *fpc++ = FF_LINEMARK;
2361 noblank = repeat = FALSE;
2362 base = s;
2363 }
2364 else
2365 s++;
2366 continue;
2367
2368 case '@':
2369 case '^':
2370 ischop = s[-1] == '^';
2371
2372 if (postspace) {
2373 *fpc++ = FF_SPACE;
2374 postspace = FALSE;
2375 }
2376 arg = (s - base) - 1;
2377 if (arg) {
2378 *fpc++ = FF_LITERAL;
2379 *fpc++ = arg;
2380 }
2381
2382 base = s - 1;
2383 *fpc++ = FF_FETCH;
2384 if (*s == '*') {
2385 s++;
2386 *fpc++ = 0;
2387 *fpc++ = FF_LINEGLOB;
2388 }
2389 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2390 arg = ischop ? 512 : 0;
2391 base = s - 1;
2392 while (*s == '#')
2393 s++;
2394 if (*s == '.') {
2395 char *f;
2396 s++;
2397 f = s;
2398 while (*s == '#')
2399 s++;
2400 arg |= 256 + (s - f);
2401 }
2402 *fpc++ = s - base; /* fieldsize for FETCH */
2403 *fpc++ = FF_DECIMAL;
2404 *fpc++ = arg;
2405 }
2406 else {
2407 I32 prespace = 0;
2408 bool ismore = FALSE;
2409
2410 if (*s == '>') {
2411 while (*++s == '>') ;
2412 prespace = FF_SPACE;
2413 }
2414 else if (*s == '|') {
2415 while (*++s == '|') ;
2416 prespace = FF_HALFSPACE;
2417 postspace = TRUE;
2418 }
2419 else {
2420 if (*s == '<')
2421 while (*++s == '<') ;
2422 postspace = TRUE;
2423 }
2424 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2425 s += 3;
2426 ismore = TRUE;
2427 }
2428 *fpc++ = s - base; /* fieldsize for FETCH */
2429
2430 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2431
2432 if (prespace)
2433 *fpc++ = prespace;
2434 *fpc++ = FF_ITEM;
2435 if (ismore)
2436 *fpc++ = FF_MORE;
2437 if (ischop)
2438 *fpc++ = FF_CHOP;
2439 }
2440 base = s;
2441 skipspaces = 0;
2442 continue;
2443 }
2444 }
2445 *fpc++ = FF_END;
2446
2447 arg = fpc - fops;
2448 SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
2449
463ee0b2 2450 s = SvPVX(sv) + SvCUR(sv);
79072805
LW		 2451 s += 2 + (SvCUR(sv) & 1);
2452
2453 Copy(fops, s, arg, U16);
2454 Safefree(fops);
2455}
2456
2457PP(pp_formline)
2458{
2459 dSP; dMARK; dORIGMARK;
2460 register SV *form = *++MARK;
2461 register U16 *fpc;
2462 register char *t;
2463 register char *f;
2464 register char *s;
2465 register char *send;
2466 register I32 arg;
2467 register SV *sv;
2468 I32 itemsize;
2469 I32 fieldsize;
2470 I32 lines = 0;
93a17b20 2471 bool chopspace = (strchr(chopset, ' ') != Nullch);
79072805
LW		 2472 char *chophere;
2473 char *linemark;
2474 char *formmark;
2475 SV **markmark;
2476 double value;
2477 bool gotsome;
463ee0b2 2478 STRLEN len;
79072805
LW		 2479
2480 if (!SvCOMPILED(form))
2481 doparseform(form);
2482
463ee0b2 2483 SvUPGRADE(formtarget, SVt_PV);
79072805 2484 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
463ee0b2
LW		 2485 t = SvPV(formtarget, len);
2486 t += len;
2487 f = SvPV(form, len);
79072805 2488
463ee0b2
LW		 2489 s = f + len;
2490 s += 2 + (len & 1);
79072805
LW		 2491
2492 fpc = (U16*)s;
2493
2494 for (;;) {
2495 DEBUG_f( {
2496 char *name = "???";
2497 arg = -1;
2498 switch (*fpc) {
2499 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
2500 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
2501 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
2502 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
2503 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
2504
2505 case FF_CHECKNL: name = "CHECKNL"; break;
2506 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
2507 case FF_SPACE: name = "SPACE"; break;
2508 case FF_HALFSPACE: name = "HALFSPACE"; break;
2509 case FF_ITEM: name = "ITEM"; break;
2510 case FF_CHOP: name = "CHOP"; break;
2511 case FF_LINEGLOB: name = "LINEGLOB"; break;
2512 case FF_NEWLINE: name = "NEWLINE"; break;
2513 case FF_MORE: name = "MORE"; break;
2514 case FF_LINEMARK: name = "LINEMARK"; break;
2515 case FF_END: name = "END"; break;
2516 }
2517 if (arg >= 0)
2518 fprintf(stderr, "%-16s%d\n", name, arg);
2519 else
2520 fprintf(stderr, "%-16s\n", name);
2521 } )
2522 switch (*fpc++) {
2523 case FF_LINEMARK:
2524 linemark = t;
2525 formmark = f;
2526 markmark = MARK;
2527 lines++;
2528 gotsome = FALSE;
2529 break;
2530
2531 case FF_LITERAL:
2532 arg = *fpc++;
2533 while (arg--)
2534 *t++ = *f++;
2535 break;
2536
2537 case FF_SKIP:
2538 f += *fpc++;
2539 break;
2540
2541 case FF_FETCH:
2542 arg = *fpc++;
2543 f += arg;
2544 fieldsize = arg;
2545
2546 if (MARK < SP)
2547 sv = *++MARK;
2548 else {
2549 sv = &sv_no;
2550 if (dowarn)
2551 warn("Not enough format arguments");
2552 }
2553 break;
2554
2555 case FF_CHECKNL:
463ee0b2
LW		 2556 s = SvPV(sv, len);
2557 itemsize = len;
79072805
LW		 2558 if (itemsize > fieldsize)
2559 itemsize = fieldsize;
2560 send = chophere = s + itemsize;
2561 while (s < send) {
2562 if (*s & ~31)
2563 gotsome = TRUE;
2564 else if (*s == '\n')
2565 break;
2566 s++;
2567 }
463ee0b2 2568 itemsize = s - SvPVX(sv);
79072805
LW		 2569 break;
2570
2571 case FF_CHECKCHOP:
463ee0b2
LW		 2572 s = SvPV(sv, len);
2573 itemsize = len;
79072805
LW		 2574 if (itemsize > fieldsize)
2575 itemsize = fieldsize;
2576 send = chophere = s + itemsize;
2577 while (s < send || (s == send && isSPACE(*s))) {
2578 if (isSPACE(*s)) {
2579 if (chopspace)
2580 chophere = s;
2581 if (*s == '\r')
2582 break;
2583 }
2584 else {
2585 if (*s & ~31)
2586 gotsome = TRUE;
93a17b20 2587 if (strchr(chopset, *s))
79072805
LW		 2588 chophere = s + 1;
2589 }
2590 s++;
2591 }
463ee0b2 2592 itemsize = chophere - SvPVX(sv);
79072805
LW		 2593 break;
2594
2595 case FF_SPACE:
2596 arg = fieldsize - itemsize;
2597 if (arg) {
2598 fieldsize -= arg;
2599 while (arg-- > 0)
2600 *t++ = ' ';
2601 }
2602 break;
2603
2604 case FF_HALFSPACE:
2605 arg = fieldsize - itemsize;
2606 if (arg) {
2607 arg /= 2;
2608 fieldsize -= arg;
2609 while (arg-- > 0)
2610 *t++ = ' ';
2611 }
2612 break;
2613
2614 case FF_ITEM:
2615 arg = itemsize;
463ee0b2 2616 s = SvPVX(sv);
79072805
LW		 2617 while (arg--) {
2618 if ((*t++ = *s++) < ' ')
2619 t[-1] = ' ';
2620 }
2621 break;
2622
2623 case FF_CHOP:
2624 s = chophere;
2625 if (chopspace) {
2626 while (*s && isSPACE(*s))
2627 s++;
2628 }
2629 sv_chop(sv,s);
2630 break;
2631
2632 case FF_LINEGLOB:
463ee0b2
LW		 2633 s = SvPV(sv, len);
2634 itemsize = len;
79072805
LW		 2635 if (itemsize) {
2636 gotsome = TRUE;
2637 send = s + itemsize;
2638 while (s < send) {
2639 if (*s++ == '\n') {
2640 if (s == send)
2641 itemsize--;
2642 else
2643 lines++;
2644 }
2645 }
463ee0b2
LW		 2646 SvCUR_set(formtarget, t - SvPVX(formtarget));
2647 sv_catpvn(formtarget, SvPVX(sv), itemsize);
79072805 2648 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
463ee0b2 2649 t = SvPVX(formtarget) + SvCUR(formtarget);
79072805
LW		 2650 }
2651 break;
2652
2653 case FF_DECIMAL:
2654 /* If the field is marked with ^ and the value is undefined,
2655 blank it out. */
2656 arg = *fpc++;
2657 if ((arg & 512) && !SvOK(sv)) {
2658 arg = fieldsize;
2659 while (arg--)
2660 *t++ = ' ';
2661 break;
2662 }
2663 gotsome = TRUE;
463ee0b2 2664 value = SvNV(sv);
79072805
LW		 2665 if (arg & 256) {
2666 sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
2667 } else {
2668 sprintf(t, "%*.0f", fieldsize, value);
2669 }
2670 t += fieldsize;
2671 break;
2672
2673 case FF_NEWLINE:
2674 f++;
2675 while (t-- > linemark && *t == ' ') ;
2676 t++;
2677 *t++ = '\n';
2678 break;
2679
2680 case FF_BLANK:
2681 arg = *fpc++;
2682 if (gotsome) {
2683 if (arg) { /* repeat until fields exhausted? */
2684 fpc -= arg;
2685 f = formmark;
2686 MARK = markmark;
2687 if (lines == 200) {
2688 arg = t - linemark;
2689 if (strnEQ(linemark, linemark - t, arg))
2690 DIE("Runaway format");
2691 }
463ee0b2 2692 arg = t - SvPVX(formtarget);
79072805 2693 SvGROW(formtarget,
463ee0b2
LW		 2694 (t - SvPVX(formtarget)) + (f - formmark) + 1);
2695 t = SvPVX(formtarget) + arg;
79072805
LW		 2696 }
2697 }
2698 else {
2699 t = linemark;
2700 lines--;
2701 }
2702 break;
2703
2704 case FF_MORE:
93a17b20 2705 if (SvCUROK(sv)) {
79072805
LW		 2706 arg = fieldsize - itemsize;
2707 if (arg) {
2708 fieldsize -= arg;
2709 while (arg-- > 0)
2710 *t++ = ' ';
2711 }
2712 s = t - 3;
2713 if (strnEQ(s," ",3)) {
463ee0b2 2714 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
79072805
LW		 2715 s--;
2716 }
2717 *s++ = '.';
2718 *s++ = '.';
2719 *s++ = '.';
2720 }
2721 break;
2722
2723 case FF_END:
2724 *t = '\0';
463ee0b2 2725 SvCUR_set(formtarget, t - SvPVX(formtarget));
79072805
LW		 2726 FmLINES(formtarget) += lines;
2727 SP = ORIGMARK;
2728 RETPUSHYES;
2729 }
2730 }
2731}
2732
2733PP(pp_ord)
2734{
2735 dSP; dTARGET;
2736 I32 value;
2737 char *tmps;
2738 I32 anum;
2739
2740 if (MAXARG < 1)
463ee0b2 2741 tmps = SvPVx(GvSV(defgv), na);
79072805
LW		 2742 else
2743 tmps = POPp;
2744#ifndef I286
2745 value = (I32) (*tmps & 255);
2746#else
2747 anum = (I32) *tmps;
2748 value = (I32) (anum & 255);
2749#endif
2750 XPUSHi(value);
2751 RETURN;
2752}
2753
463ee0b2
LW		 2754PP(pp_chr)
2755{
2756 dSP; dTARGET;
2757 char *tmps;
2758
2759 if (SvTYPE(TARG) == SVt_NULL) {
2760 sv_upgrade(TARG,SVt_PV);
2761 SvGROW(TARG,1);
2762 }
2763 SvCUR_set(TARG, 1);
2764 tmps = SvPVX(TARG);
2765 if (MAXARG < 1)
2766 *tmps = SvIVx(GvSV(defgv));
2767 else
2768 *tmps = POPi;
2769 SvPOK_only(TARG);
2770 XPUSHs(TARG);
2771 RETURN;
2772}
2773
79072805
LW		 2774PP(pp_crypt)
2775{
2776 dSP; dTARGET; dPOPTOPssrl;
2777#ifdef HAS_CRYPT
463ee0b2 2778 char *tmps = SvPV(lstr, na);
79072805 2779#ifdef FCRYPT
463ee0b2 2780 sv_setpv(TARG, fcrypt(tmps, SvPV(rstr, na)));
79072805 2781#else
463ee0b2 2782 sv_setpv(TARG, crypt(tmps, SvPV(rstr, na)));
79072805
LW		 2783#endif
2784#else
2785 DIE(
2786 "The crypt() function is unimplemented due to excessive paranoia.");
2787#endif
2788 SETs(TARG);
2789 RETURN;
2790}
2791
2792PP(pp_ucfirst)
2793{
2794 dSP;
2795 SV *sv = TOPs;
2796 register char *s;
2797
2798 if (SvSTORAGE(sv) != 'T') {
2799 dTARGET;
2800 sv_setsv(TARG, sv);
2801 sv = TARG;
2802 SETs(sv);
2803 }
463ee0b2 2804 s = SvPV(sv, na);
79072805
LW		 2805 if (isascii(*s) && islower(*s))
2806 *s = toupper(*s);
2807
2808 RETURN;
2809}
2810
2811PP(pp_lcfirst)
2812{
2813 dSP;
2814 SV *sv = TOPs;
2815 register char *s;
2816
2817 if (SvSTORAGE(sv) != 'T') {
2818 dTARGET;
2819 sv_setsv(TARG, sv);
2820 sv = TARG;
2821 SETs(sv);
2822 }
463ee0b2 2823 s = SvPV(sv, na);
79072805
LW		 2824 if (isascii(*s) && isupper(*s))
2825 *s = tolower(*s);
2826
2827 SETs(sv);
2828 RETURN;
2829}
2830
2831PP(pp_uc)
2832{
2833 dSP;
2834 SV *sv = TOPs;
2835 register char *s;
2836 register char *send;
463ee0b2 2837 STRLEN len;
79072805
LW		 2838
2839 if (SvSTORAGE(sv) != 'T') {
2840 dTARGET;
2841 sv_setsv(TARG, sv);
2842 sv = TARG;
2843 SETs(sv);
2844 }
463ee0b2
LW		 2845 s = SvPV(sv, len);
2846 send = s + len;
79072805
LW		 2847 while (s < send) {
2848 if (isascii(*s) && islower(*s))
2849 *s = toupper(*s);
2850 s++;
2851 }
2852 RETURN;
2853}
2854
2855PP(pp_lc)
2856{
2857 dSP;
2858 SV *sv = TOPs;
2859 register char *s;
2860 register char *send;
463ee0b2 2861 STRLEN len;
79072805
LW		 2862
2863 if (SvSTORAGE(sv) != 'T') {
2864 dTARGET;
2865 sv_setsv(TARG, sv);
2866 sv = TARG;
2867 SETs(sv);
2868 }
463ee0b2
LW		 2869 s = SvPV(sv, len);
2870 send = s + len;
79072805
LW		 2871 while (s < send) {
2872 if (isascii(*s) && isupper(*s))
2873 *s = tolower(*s);
2874 s++;
2875 }
2876 RETURN;
2877}
2878
2879/* Arrays. */
2880
2881PP(pp_rv2av)
2882{
2883 dSP; dPOPss;
2884
2885 AV *av;
2886
2887 if (SvTYPE(sv) == SVt_REF) {
2888 av = (AV*)SvANY(sv);
2889 if (SvTYPE(av) != SVt_PVAV)
2890 DIE("Not an array reference");
2891 if (op->op_flags & OPf_LVAL) {
93a17b20 2892 if (op->op_flags & OPf_INTRO)
463ee0b2 2893 av = (AV*)save_svref((SV**)sv);
79072805
LW		 2894 PUSHs((SV*)av);
2895 RETURN;
2896 }
2897 }
2898 else {
93a17b20
LW		 2899 if (SvTYPE(sv) == SVt_PVAV) {
2900 av = (AV*)sv;
2901 if (op->op_flags & OPf_LVAL) {
2902 PUSHs((SV*)av);
2903 RETURN;
2904 }
2905 }
2906 else {
2907 if (SvTYPE(sv) != SVt_PVGV) {
2908 if (!SvOK(sv))
2909 DIE(no_usym);
463ee0b2 2910 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
93a17b20
LW		 2911 }
2912 av = GvAVn(sv);
2913 if (op->op_flags & OPf_LVAL) {
2914 if (op->op_flags & OPf_INTRO)
2915 av = save_ary(sv);
2916 PUSHs((SV*)av);
2917 RETURN;
2918 }
79072805
LW		 2919 }
2920 }
2921
2922 if (GIMME == G_ARRAY) {
2923 I32 maxarg = AvFILL(av) + 1;
2924 EXTEND(SP, maxarg);
2925 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2926 SP += maxarg;
2927 }
2928 else {
2929 dTARGET;
2930 I32 maxarg = AvFILL(av) + 1;
2931 PUSHi(maxarg);
2932 }
2933 RETURN;
2934}
2935
2936PP(pp_aelemfast)
2937{
2938 dSP;
2939 AV *av = (AV*)cSVOP->op_sv;
2940 SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
2941 PUSHs(svp ? *svp : &sv_undef);
2942 RETURN;
2943}
2944
2945PP(pp_aelem)
2946{
2947 dSP;
2948 SV** svp;
2949 I32 elem = POPi - arybase;
2950 AV *av = (AV*)POPs;
2951
2952 if (op->op_flags & OPf_LVAL) {
2953 svp = av_fetch(av, elem, TRUE);
2954 if (!svp || *svp == &sv_undef)
93a17b20
LW		 2955 DIE(no_aelem, elem);
2956 if (op->op_flags & OPf_INTRO)
79072805 2957 save_svref(svp);
463ee0b2 2958 else if (!SvOK(*svp)) {
79072805
LW		 2959 if (op->op_private == OP_RV2HV) {
2960 sv_free(*svp);
463ee0b2
LW		 2961 *svp = NEWSV(0,0);
2962 sv_upgrade(*svp, SVt_REF);
2963 SvANY(*svp) = (void*)sv_ref((SV*)newHV());
79072805
LW		 2964 }
2965 else if (op->op_private == OP_RV2AV) {
2966 sv_free(*svp);
463ee0b2
LW		 2967 *svp = NEWSV(0,0);
2968 sv_upgrade(*svp, SVt_REF);
2969 SvANY(*svp) = (void*)sv_ref((SV*)newAV());
79072805
LW		 2970 }
2971 }
2972 }
2973 else
2974 svp = av_fetch(av, elem, FALSE);
2975 PUSHs(svp ? *svp : &sv_undef);
2976 RETURN;
2977}
2978
2979PP(pp_aslice)
2980{
2981 dSP; dMARK; dORIGMARK;
2982 register SV** svp;
2983 register AV* av = (AV*)POPs;
2984 register I32 lval = op->op_flags & OPf_LVAL;
2985 I32 is_something_there = lval;
2986
2987 while (++MARK <= SP) {
463ee0b2 2988 I32 elem = SvIVx(*MARK);
79072805
LW		 2989
2990 if (lval) {
2991 svp = av_fetch(av, elem, TRUE);
2992 if (!svp || *svp == &sv_undef)
93a17b20
LW		 2993 DIE(no_aelem, elem);
2994 if (op->op_flags & OPf_INTRO)
79072805
LW		 2995 save_svref(svp);
2996 }
2997 else {
2998 svp = av_fetch(av, elem, FALSE);
2999 if (!is_something_there && svp && SvOK(*svp))
3000 is_something_there = TRUE;
3001 }
3002 *MARK = svp ? *svp : &sv_undef;
3003 }
3004 if (!is_something_there)
3005 SP = ORIGMARK;
3006 RETURN;
3007}
3008
3009/* Associative arrays. */
3010
3011PP(pp_each)
3012{
3013 dSP; dTARGET;
3014 HV *hash = (HV*)POPs;
3015 HE *entry = hv_iternext(hash);
3016 I32 i;
3017 char *tmps;
3018
3019 if (mystrk) {
3020 sv_free(mystrk);
3021 mystrk = Nullsv;
3022 }
3023
3024 EXTEND(SP, 2);
3025 if (entry) {
3026 if (GIMME == G_ARRAY) {
3027 tmps = hv_iterkey(entry, &i);
3028 if (!i)
3029 tmps = "";
3030 mystrk = newSVpv(tmps, i);
3031 PUSHs(mystrk);
3032 }
3033 sv_setsv(TARG, hv_iterval(hash, entry));
3034 PUSHs(TARG);
3035 }
3036 else if (GIMME == G_SCALAR)
3037 RETPUSHUNDEF;
3038
3039 RETURN;
3040}
3041
3042PP(pp_values)
3043{
3044 return do_kv(ARGS);
3045}
3046
3047PP(pp_keys)
3048{
3049 return do_kv(ARGS);
3050}
3051
3052PP(pp_delete)
3053{
3054 dSP;
3055 SV *sv;
3056 SV *tmpsv = POPs;
3057 HV *hv = (HV*)POPs;
3058 char *tmps;
463ee0b2 3059 STRLEN len;
79072805
LW		 3060 if (!hv) {
3061 DIE("Not an associative array reference");
3062 }
463ee0b2
LW		 3063 tmps = SvPV(tmpsv, len);
3064 sv = hv_delete(hv, tmps, len);
79072805
LW		 3065 if (!sv)
3066 RETPUSHUNDEF;
3067 PUSHs(sv);
3068 RETURN;
3069}
3070
3071PP(pp_rv2hv)
3072{
3073
3074 dSP; dTOPss;
3075
3076 HV *hv;
3077
3078 if (SvTYPE(sv) == SVt_REF) {
3079 hv = (HV*)SvANY(sv);
3080 if (SvTYPE(hv) != SVt_PVHV)
3081 DIE("Not an associative array reference");
3082 if (op->op_flags & OPf_LVAL) {
93a17b20 3083 if (op->op_flags & OPf_INTRO)
463ee0b2 3084 hv = (HV*)save_svref((SV**)sv);
79072805
LW		 3085 SETs((SV*)hv);
3086 RETURN;
3087 }
3088 }
3089 else {
93a17b20
LW		 3090 if (SvTYPE(sv) == SVt_PVHV) {
3091 hv = (HV*)sv;
3092 if (op->op_flags & OPf_LVAL) {
3093 SETs((SV*)hv);
3094 RETURN;
3095 }
3096 }
3097 else {
3098 if (SvTYPE(sv) != SVt_PVGV) {
3099 if (!SvOK(sv))
3100 DIE(no_usym);
463ee0b2 3101 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
93a17b20
LW		 3102 }
3103 hv = GvHVn(sv);
3104 if (op->op_flags & OPf_LVAL) {
3105 if (op->op_flags & OPf_INTRO)
3106 hv = save_hash(sv);
3107 SETs((SV*)hv);
3108 RETURN;
3109 }
79072805
LW		 3110 }
3111 }
3112
3113 if (GIMME == G_ARRAY) { /* array wanted */
3114 *stack_sp = (SV*)hv;
3115 return do_kv(ARGS);
3116 }
3117 else {
3118 dTARGET;
3119 if (HvFILL(hv))
3120 sv_setiv(TARG, 0);
3121 else {
463ee0b2 3122 sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
79072805
LW		 3123 sv_setpv(TARG, buf);
3124 }
3125 SETTARG;
3126 RETURN;
3127 }
3128}
3129
3130PP(pp_helem)
3131{
3132 dSP;
3133 SV** svp;
3134 SV *keysv = POPs;
463ee0b2
LW		 3135 STRLEN keylen;
3136 char *key = SvPV(keysv, keylen);
79072805
LW		 3137 HV *hv = (HV*)POPs;
3138
3139 if (op->op_flags & OPf_LVAL) {
3140 svp = hv_fetch(hv, key, keylen, TRUE);
3141 if (!svp || *svp == &sv_undef)
93a17b20
LW		 3142 DIE(no_helem, key);
3143 if (op->op_flags & OPf_INTRO)
79072805 3144 save_svref(svp);
463ee0b2 3145 else if (!SvOK(*svp)) {
79072805
LW		 3146 if (op->op_private == OP_RV2HV) {
3147 sv_free(*svp);
463ee0b2
LW		 3148 *svp = NEWSV(0,0);
3149 sv_upgrade(*svp, SVt_REF);
3150 SvANY(*svp) = (void*)sv_ref((SV*)newHV());
79072805
LW		 3151 }
3152 else if (op->op_private == OP_RV2AV) {
3153 sv_free(*svp);
463ee0b2
LW		 3154 *svp = NEWSV(0,0);
3155 sv_upgrade(*svp, SVt_REF);
3156 SvANY(*svp) = (void*)sv_ref((SV*)newAV());
79072805
LW		 3157 }
3158 }
3159 }
3160 else
3161 svp = hv_fetch(hv, key, keylen, FALSE);
3162 PUSHs(svp ? *svp : &sv_undef);
3163 RETURN;
3164}
3165
3166PP(pp_hslice)
3167{
3168 dSP; dMARK; dORIGMARK;
3169 register SV **svp;
3170 register HV *hv = (HV*)POPs;
3171 register I32 lval = op->op_flags & OPf_LVAL;
3172 I32 is_something_there = lval;
3173
3174 while (++MARK <= SP) {
463ee0b2
LW		 3175 STRLEN keylen;
3176 char *key = SvPV(*MARK, keylen);
79072805
LW		 3177
3178 if (lval) {
3179 svp = hv_fetch(hv, key, keylen, TRUE);
3180 if (!svp || *svp == &sv_undef)
93a17b20
LW		 3181 DIE(no_helem, key);
3182 if (op->op_flags & OPf_INTRO)
79072805
LW		 3183 save_svref(svp);
3184 }
3185 else {
3186 svp = hv_fetch(hv, key, keylen, FALSE);
3187 if (!is_something_there && svp && SvOK(*svp))
3188 is_something_there = TRUE;
3189 }
3190 *MARK = svp ? *svp : &sv_undef;
3191 }
3192 if (!is_something_there)
3193 SP = ORIGMARK;
3194 RETURN;
3195}
3196
3197/* Explosives and implosives. */
3198
3199PP(pp_unpack)
3200{
3201 dSP;
3202 dPOPPOPssrl;
3203 SV *sv;
463ee0b2
LW		 3204 STRLEN llen;
3205 STRLEN rlen;
3206 register char *pat = SvPV(lstr, llen);
3207 register char *s = SvPV(rstr, rlen);
3208 char *strend = s + rlen;
79072805 3209 char *strbeg = s;
463ee0b2 3210 register char *patend = pat + llen;
79072805
LW		 3211 I32 datumtype;
3212 register I32 len;
3213 register I32 bits;
3214
3215 /* These must not be in registers: */
3216 I16 ashort;
3217 int aint;
3218 I32 along;
3219#ifdef QUAD
3220 quad aquad;
3221#endif
3222 U16 aushort;
3223 unsigned int auint;
3224 U32 aulong;
3225#ifdef QUAD
3226 unsigned quad auquad;
3227#endif
3228 char *aptr;
3229 float afloat;
3230 double adouble;
3231 I32 checksum = 0;
3232 register U32 culong;
3233 double cdouble;
3234 static char* bitcount = 0;
3235
3236 if (GIMME != G_ARRAY) { /* arrange to do first one only */
3237 /*SUPPRESS 530*/
3238 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
93a17b20 3239 if (strchr("aAbBhH", *patend) || *pat == '%') {
79072805
LW		 3240 patend++;
3241 while (isDIGIT(*patend) || *patend == '*')
3242 patend++;
3243 }
3244 else
3245 patend++;
3246 }
3247 while (pat < patend) {
3248 reparse:
3249 datumtype = *pat++;
3250 if (pat >= patend)
3251 len = 1;
3252 else if (*pat == '*') {
3253 len = strend - strbeg; /* long enough */
3254 pat++;
3255 }
3256 else if (isDIGIT(*pat)) {
3257 len = *pat++ - '0';
3258 while (isDIGIT(*pat))
3259 len = (len * 10) + (*pat++ - '0');
3260 }
3261 else
3262 len = (datumtype != '@');
3263 switch(datumtype) {
3264 default:
3265 break;
3266 case '%':
3267 if (len == 1 && pat[-1] != '1')
3268 len = 16;
3269 checksum = len;
3270 culong = 0;
3271 cdouble = 0;
3272 if (pat < patend)
3273 goto reparse;
3274 break;
3275 case '@':
3276 if (len > strend - strbeg)
3277 DIE("@ outside of string");
3278 s = strbeg + len;
3279 break;
3280 case 'X':
3281 if (len > s - strbeg)
3282 DIE("X outside of string");
3283 s -= len;
3284 break;
3285 case 'x':
3286 if (len > strend - s)
3287 DIE("x outside of string");
3288 s += len;
3289 break;
3290 case 'A':
3291 case 'a':
3292 if (len > strend - s)
3293 len = strend - s;
3294 if (checksum)
3295 goto uchar_checksum;
3296 sv = NEWSV(35, len);
3297 sv_setpvn(sv, s, len);
3298 s += len;
3299 if (datumtype == 'A') {
3300 aptr = s; /* borrow register */
463ee0b2
LW		 3301 s = SvPVX(sv) + len - 1;
3302 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
79072805
LW		 3303 s--;
3304 *++s = '\0';
463ee0b2 3305 SvCUR_set(sv, s - SvPVX(sv));
79072805
LW		 3306 s = aptr; /* unborrow register */
3307 }
3308 XPUSHs(sv_2mortal(sv));
3309 break;
3310 case 'B':
3311 case 'b':
3312 if (pat[-1] == '*' || len > (strend - s) * 8)
3313 len = (strend - s) * 8;
3314 if (checksum) {
3315 if (!bitcount) {
3316 Newz(601, bitcount, 256, char);
3317 for (bits = 1; bits < 256; bits++) {
3318 if (bits & 1) bitcount[bits]++;
3319 if (bits & 2) bitcount[bits]++;
3320 if (bits & 4) bitcount[bits]++;
3321 if (bits & 8) bitcount[bits]++;
3322 if (bits & 16) bitcount[bits]++;
3323 if (bits & 32) bitcount[bits]++;
3324 if (bits & 64) bitcount[bits]++;
3325 if (bits & 128) bitcount[bits]++;
3326 }
3327 }
3328 while (len >= 8) {
3329 culong += bitcount[*(unsigned char*)s++];
3330 len -= 8;
3331 }
3332 if (len) {
3333 bits = *s;
3334 if (datumtype == 'b') {
3335 while (len-- > 0) {
3336 if (bits & 1) culong++;
3337 bits >>= 1;
3338 }
3339 }
3340 else {
3341 while (len-- > 0) {
3342 if (bits & 128) culong++;
3343 bits <<= 1;
3344 }
3345 }
3346 }
3347 break;
3348 }
3349 sv = NEWSV(35, len + 1);
3350 SvCUR_set(sv, len);
3351 SvPOK_on(sv);
3352 aptr = pat; /* borrow register */
463ee0b2 3353 pat = SvPVX(sv);
79072805
LW		 3354 if (datumtype == 'b') {
3355 aint = len;
3356 for (len = 0; len < aint; len++) {
3357 if (len & 7) /*SUPPRESS 595*/
3358 bits >>= 1;
3359 else
3360 bits = *s++;
3361 *pat++ = '0' + (bits & 1);
3362 }
3363 }
3364 else {
3365 aint = len;
3366 for (len = 0; len < aint; len++) {
3367 if (len & 7)
3368 bits <<= 1;
3369 else
3370 bits = *s++;
3371 *pat++ = '0' + ((bits & 128) != 0);
3372 }
3373 }
3374 *pat = '\0';
3375 pat = aptr; /* unborrow register */
3376 XPUSHs(sv_2mortal(sv));
3377 break;
3378 case 'H':
3379 case 'h':
3380 if (pat[-1] == '*' || len > (strend - s) * 2)
3381 len = (strend - s) * 2;
3382 sv = NEWSV(35, len + 1);
3383 SvCUR_set(sv, len);
3384 SvPOK_on(sv);
3385 aptr = pat; /* borrow register */
463ee0b2 3386 pat = SvPVX(sv);
79072805
LW		 3387 if (datumtype == 'h') {
3388 aint = len;
3389 for (len = 0; len < aint; len++) {
3390 if (len & 1)
3391 bits >>= 4;
3392 else
3393 bits = *s++;
3394 *pat++ = hexdigit[bits & 15];
3395 }
3396 }
3397 else {
3398 aint = len;
3399 for (len = 0; len < aint; len++) {
3400 if (len & 1)
3401 bits <<= 4;
3402 else
3403 bits = *s++;
3404 *pat++ = hexdigit[(bits >> 4) & 15];
3405 }
3406 }
3407 *pat = '\0';
3408 pat = aptr; /* unborrow register */
3409 XPUSHs(sv_2mortal(sv));
3410 break;
3411 case 'c':
3412 if (len > strend - s)
3413 len = strend - s;
3414 if (checksum) {
3415 while (len-- > 0) {
3416 aint = *s++;
3417 if (aint >= 128) /* fake up signed chars */
3418 aint -= 256;
3419 culong += aint;
3420 }
3421 }
3422 else {
3423 EXTEND(SP, len);
3424 while (len-- > 0) {
3425 aint = *s++;
3426 if (aint >= 128) /* fake up signed chars */
3427 aint -= 256;
3428 sv = NEWSV(36, 0);
3429 sv_setiv(sv, (I32)aint);
3430 PUSHs(sv_2mortal(sv));
3431 }
3432 }
3433 break;
3434 case 'C':
3435 if (len > strend - s)
3436 len = strend - s;
3437 if (checksum) {
3438 uchar_checksum:
3439 while (len-- > 0) {
3440 auint = *s++ & 255;
3441 culong += auint;
3442 }
3443 }
3444 else {
3445 EXTEND(SP, len);
3446 while (len-- > 0) {
3447 auint = *s++ & 255;
3448 sv = NEWSV(37, 0);
3449 sv_setiv(sv, (I32)auint);
3450 PUSHs(sv_2mortal(sv));
3451 }
3452 }
3453 break;
3454 case 's':
3455 along = (strend - s) / sizeof(I16);
3456 if (len > along)
3457 len = along;
3458 if (checksum) {
3459 while (len-- > 0) {
3460 Copy(s, &ashort, 1, I16);
3461 s += sizeof(I16);
3462 culong += ashort;
3463 }
3464 }
3465 else {
3466 EXTEND(SP, len);
3467 while (len-- > 0) {
3468 Copy(s, &ashort, 1, I16);
3469 s += sizeof(I16);
3470 sv = NEWSV(38, 0);
3471 sv_setiv(sv, (I32)ashort);
3472 PUSHs(sv_2mortal(sv));
3473 }
3474 }
3475 break;
3476 case 'v':
3477 case 'n':
3478 case 'S':
3479 along = (strend - s) / sizeof(U16);
3480 if (len > along)
3481 len = along;
3482 if (checksum) {
3483 while (len-- > 0) {
3484 Copy(s, &aushort, 1, U16);
3485 s += sizeof(U16);
3486#ifdef HAS_NTOHS
3487 if (datumtype == 'n')
3488 aushort = ntohs(aushort);
3489#endif
3490#ifdef HAS_VTOHS
3491 if (datumtype == 'v')
3492 aushort = vtohs(aushort);
3493#endif
3494 culong += aushort;
3495 }
3496 }
3497 else {
3498 EXTEND(SP, len);
3499 while (len-- > 0) {
3500 Copy(s, &aushort, 1, U16);
3501 s += sizeof(U16);
3502 sv = NEWSV(39, 0);
3503#ifdef HAS_NTOHS
3504 if (datumtype == 'n')
3505 aushort = ntohs(aushort);
3506#endif
3507#ifdef HAS_VTOHS
3508 if (datumtype == 'v')
3509 aushort = vtohs(aushort);
3510#endif
3511 sv_setiv(sv, (I32)aushort);
3512 PUSHs(sv_2mortal(sv));
3513 }
3514 }
3515 break;
3516 case 'i':
3517 along = (strend - s) / sizeof(int);
3518 if (len > along)
3519 len = along;
3520 if (checksum) {
3521 while (len-- > 0) {
3522 Copy(s, &aint, 1, int);
3523 s += sizeof(int);
3524 if (checksum > 32)
3525 cdouble += (double)aint;
3526 else
3527 culong += aint;
3528 }
3529 }
3530 else {
3531 EXTEND(SP, len);
3532 while (len-- > 0) {
3533 Copy(s, &aint, 1, int);
3534 s += sizeof(int);
3535 sv = NEWSV(40, 0);
3536 sv_setiv(sv, (I32)aint);
3537 PUSHs(sv_2mortal(sv));
3538 }
3539 }
3540 break;
3541 case 'I':
3542 along = (strend - s) / sizeof(unsigned int);
3543 if (len > along)
3544 len = along;
3545 if (checksum) {
3546 while (len-- > 0) {
3547 Copy(s, &auint, 1, unsigned int);
3548 s += sizeof(unsigned int);
3549 if (checksum > 32)
3550 cdouble += (double)auint;
3551 else
3552 culong += auint;
3553 }
3554 }
3555 else {
3556 EXTEND(SP, len);
3557 while (len-- > 0) {
3558 Copy(s, &auint, 1, unsigned int);
3559 s += sizeof(unsigned int);
3560 sv = NEWSV(41, 0);
3561 sv_setiv(sv, (I32)auint);
3562 PUSHs(sv_2mortal(sv));
3563 }
3564 }
3565 break;
3566 case 'l':
3567 along = (strend - s) / sizeof(I32);
3568 if (len > along)
3569 len = along;
3570 if (checksum) {
3571 while (len-- > 0) {
3572 Copy(s, &along, 1, I32);
3573 s += sizeof(I32);
3574 if (checksum > 32)
3575 cdouble += (double)along;
3576 else
3577 culong += along;
3578 }
3579 }
3580 else {
3581 EXTEND(SP, len);
3582 while (len-- > 0) {
3583 Copy(s, &along, 1, I32);
3584 s += sizeof(I32);
3585 sv = NEWSV(42, 0);
3586 sv_setiv(sv, (I32)along);
3587 PUSHs(sv_2mortal(sv));
3588 }
3589 }
3590 break;
3591 case 'V':
3592 case 'N':
3593 case 'L':
3594 along = (strend - s) / sizeof(U32);
3595 if (len > along)
3596 len = along;
3597 if (checksum) {
3598 while (len-- > 0) {
3599 Copy(s, &aulong, 1, U32);
3600 s += sizeof(U32);
3601#ifdef HAS_NTOHL
3602 if (datumtype == 'N')
3603 aulong = ntohl(aulong);
3604#endif
3605#ifdef HAS_VTOHL
3606 if (datumtype == 'V')
3607 aulong = vtohl(aulong);
3608#endif
3609 if (checksum > 32)
3610 cdouble += (double)aulong;
3611 else
3612 culong += aulong;
3613 }
3614 }
3615 else {
3616 EXTEND(SP, len);
3617 while (len-- > 0) {
3618 Copy(s, &aulong, 1, U32);
3619 s += sizeof(U32);
3620 sv = NEWSV(43, 0);
3621#ifdef HAS_NTOHL
3622 if (datumtype == 'N')
3623 aulong = ntohl(aulong);
3624#endif
3625#ifdef HAS_VTOHL
3626 if (datumtype == 'V')
3627 aulong = vtohl(aulong);
3628#endif
3629 sv_setnv(sv, (double)aulong);
3630 PUSHs(sv_2mortal(sv));
3631 }
3632 }
3633 break;
3634 case 'p':
3635 along = (strend - s) / sizeof(char*);
3636 if (len > along)
3637 len = along;
3638 EXTEND(SP, len);
3639 while (len-- > 0) {
3640 if (sizeof(char*) > strend - s)
3641 break;
3642 else {
3643 Copy(s, &aptr, 1, char*);
3644 s += sizeof(char*);
3645 }
3646 sv = NEWSV(44, 0);
3647 if (aptr)
3648 sv_setpv(sv, aptr);
3649 PUSHs(sv_2mortal(sv));
3650 }
3651 break;
463ee0b2
LW		 3652 case 'P':
3653 EXTEND(SP, 1);
3654 if (sizeof(char*) > strend - s)
3655 break;
3656 else {
3657 Copy(s, &aptr, 1, char*);
3658 s += sizeof(char*);
3659 }
3660 sv = NEWSV(44, 0);
3661 if (aptr)
3662 sv_setpvn(sv, aptr, len);
3663 PUSHs(sv_2mortal(sv));
3664 break;
79072805
LW		 3665#ifdef QUAD
3666 case 'q':
3667 EXTEND(SP, len);
3668 while (len-- > 0) {
3669 if (s + sizeof(quad) > strend)
3670 aquad = 0;
3671 else {
3672 Copy(s, &aquad, 1, quad);
3673 s += sizeof(quad);
3674 }
3675 sv = NEWSV(42, 0);
3676 sv_setnv(sv, (double)aquad);
3677 PUSHs(sv_2mortal(sv));
3678 }
3679 break;
3680 case 'Q':
3681 EXTEND(SP, len);
3682 while (len-- > 0) {
3683 if (s + sizeof(unsigned quad) > strend)
3684 auquad = 0;
3685 else {
3686 Copy(s, &auquad, 1, unsigned quad);
3687 s += sizeof(unsigned quad);
3688 }
3689 sv = NEWSV(43, 0);
3690 sv_setnv(sv, (double)auquad);
3691 PUSHs(sv_2mortal(sv));
3692 }
3693 break;
3694#endif
3695 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3696 case 'f':
3697 case 'F':
3698 along = (strend - s) / sizeof(float);
3699 if (len > along)
3700 len = along;
3701 if (checksum) {
3702 while (len-- > 0) {
3703 Copy(s, &afloat, 1, float);
3704 s += sizeof(float);
3705 cdouble += afloat;
3706 }
3707 }
3708 else {
3709 EXTEND(SP, len);
3710 while (len-- > 0) {
3711 Copy(s, &afloat, 1, float);
3712 s += sizeof(float);
3713 sv = NEWSV(47, 0);
3714 sv_setnv(sv, (double)afloat);
3715 PUSHs(sv_2mortal(sv));
3716 }
3717 }
3718 break;
3719 case 'd':
3720 case 'D':
3721 along = (strend - s) / sizeof(double);
3722 if (len > along)
3723 len = along;
3724 if (checksum) {
3725 while (len-- > 0) {
3726 Copy(s, &adouble, 1, double);
3727 s += sizeof(double);
3728 cdouble += adouble;
3729 }
3730 }
3731 else {
3732 EXTEND(SP, len);
3733 while (len-- > 0) {
3734 Copy(s, &adouble, 1, double);
3735 s += sizeof(double);
3736 sv = NEWSV(48, 0);
3737 sv_setnv(sv, (double)adouble);
3738 PUSHs(sv_2mortal(sv));
3739 }
3740 }
3741 break;
3742 case 'u':
3743 along = (strend - s) * 3 / 4;
3744 sv = NEWSV(42, along);
3745 while (s < strend && *s > ' ' && *s < 'a') {
3746 I32 a, b, c, d;
3747 char hunk[4];
3748
3749 hunk[3] = '\0';
3750 len = (*s++ - ' ') & 077;
3751 while (len > 0) {
3752 if (s < strend && *s >= ' ')
3753 a = (*s++ - ' ') & 077;
3754 else
3755 a = 0;
3756 if (s < strend && *s >= ' ')
3757 b = (*s++ - ' ') & 077;
3758 else
3759 b = 0;
3760 if (s < strend && *s >= ' ')
3761 c = (*s++ - ' ') & 077;
3762 else
3763 c = 0;
3764 if (s < strend && *s >= ' ')
3765 d = (*s++ - ' ') & 077;
3766 else
3767 d = 0;
3768 hunk[0] = a << 2 | b >> 4;
3769 hunk[1] = b << 4 | c >> 2;
3770 hunk[2] = c << 6 | d;
3771 sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3772 len -= 3;
3773 }
3774 if (*s == '\n')
3775 s++;
3776 else if (s[1] == '\n') /* possible checksum byte */
3777 s += 2;
3778 }
3779 XPUSHs(sv_2mortal(sv));
3780 break;
3781 }
3782 if (checksum) {
3783 sv = NEWSV(42, 0);
93a17b20
LW		 3784 if (strchr("fFdD", datumtype) ||
3785 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
79072805
LW		 3786 double modf();
3787 double trouble;
3788
3789 adouble = 1.0;
3790 while (checksum >= 16) {
3791 checksum -= 16;
3792 adouble *= 65536.0;
3793 }
3794 while (checksum >= 4) {
3795 checksum -= 4;
3796 adouble *= 16.0;
3797 }
3798 while (checksum--)
3799 adouble *= 2.0;
3800 along = (1 << checksum) - 1;
3801 while (cdouble < 0.0)
3802 cdouble += adouble;
3803 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3804 sv_setnv(sv, cdouble);
3805 }
3806 else {
3807 if (checksum < 32) {
3808 along = (1 << checksum) - 1;
3809 culong &= (U32)along;
3810 }
3811 sv_setnv(sv, (double)culong);
3812 }
3813 XPUSHs(sv_2mortal(sv));
3814 checksum = 0;
3815 }
3816 }
3817 RETURN;
3818}
3819
3820static void
3821doencodes(sv, s, len)
3822register SV *sv;
3823register char *s;
3824register I32 len;
3825{
3826 char hunk[5];
3827
3828 *hunk = len + ' ';
3829 sv_catpvn(sv, hunk, 1);
3830 hunk[4] = '\0';
3831 while (len > 0) {
3832 hunk[0] = ' ' + (077 & (*s >> 2));
3833 hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
3834 hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
3835 hunk[3] = ' ' + (077 & (s[2] & 077));
3836 sv_catpvn(sv, hunk, 4);
3837 s += 3;
3838 len -= 3;
3839 }
463ee0b2 3840 for (s = SvPVX(sv); *s; s++) {
79072805
LW		 3841 if (*s == ' ')
3842 *s = '`';
3843 }
3844 sv_catpvn(sv, "\n", 1);
3845}
3846
3847PP(pp_pack)
3848{
3849 dSP; dMARK; dORIGMARK; dTARGET;
3850 register SV *cat = TARG;
3851 register I32 items;
463ee0b2
LW		 3852 STRLEN fromlen;
3853 register char *pat = SvPVx(*++MARK, fromlen);
3854 register char *patend = pat + fromlen;
79072805
LW		 3855 register I32 len;
3856 I32 datumtype;
3857 SV *fromstr;
3858 /*SUPPRESS 442*/
463ee0b2 3859 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
79072805
LW		 3860 static char *space10 = " ";
3861
3862 /* These must not be in registers: */
3863 char achar;
3864 I16 ashort;
3865 int aint;
3866 unsigned int auint;
3867 I32 along;
3868 U32 aulong;
3869#ifdef QUAD
3870 quad aquad;
3871 unsigned quad auquad;
3872#endif
3873 char *aptr;
3874 float afloat;
3875 double adouble;
3876
3877 items = SP - MARK;
3878 MARK++;
3879 sv_setpvn(cat, "", 0);
3880 while (pat < patend) {
3881#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3882 datumtype = *pat++;
3883 if (*pat == '*') {
93a17b20 3884 len = strchr("@Xxu", datumtype) ? 0 : items;
79072805
LW		 3885 pat++;
3886 }
3887 else if (isDIGIT(*pat)) {
3888 len = *pat++ - '0';
3889 while (isDIGIT(*pat))
3890 len = (len * 10) + (*pat++ - '0');
3891 }
3892 else
3893 len = 1;
3894 switch(datumtype) {
3895 default:
3896 break;
3897 case '%':
3898 DIE("% may only be used in unpack");
3899 case '@':
3900 len -= SvCUR(cat);
3901 if (len > 0)
3902 goto grow;
3903 len = -len;
3904 if (len > 0)
3905 goto shrink;
3906 break;
3907 case 'X':
3908 shrink:
3909 if (SvCUR(cat) < len)
3910 DIE("X outside of string");
3911 SvCUR(cat) -= len;
3912 *SvEND(cat) = '\0';
3913 break;
3914 case 'x':
3915 grow:
3916 while (len >= 10) {
3917 sv_catpvn(cat, null10, 10);
3918 len -= 10;
3919 }
3920 sv_catpvn(cat, null10, len);
3921 break;
3922 case 'A':
3923 case 'a':
3924 fromstr = NEXTFROM;
463ee0b2 3925 aptr = SvPV(fromstr, fromlen);
79072805 3926 if (pat[-1] == '*')
93a17b20
LW		 3927 len = fromlen;
3928 if (fromlen > len)
79072805
LW		 3929 sv_catpvn(cat, aptr, len);
3930 else {
93a17b20
LW		 3931 sv_catpvn(cat, aptr, fromlen);
3932 len -= fromlen;
79072805
LW		 3933 if (datumtype == 'A') {
3934 while (len >= 10) {
3935 sv_catpvn(cat, space10, 10);
3936 len -= 10;
3937 }
3938 sv_catpvn(cat, space10, len);
3939 }
3940 else {
3941 while (len >= 10) {
3942 sv_catpvn(cat, null10, 10);
3943 len -= 10;
3944 }
3945 sv_catpvn(cat, null10, len);
3946 }
3947 }
3948 break;
3949 case 'B':
3950 case 'b':
3951 {
3952 char *savepat = pat;
3953 I32 saveitems;
3954
3955 fromstr = NEXTFROM;
3956 saveitems = items;
463ee0b2 3957 aptr = SvPV(fromstr, fromlen);
79072805 3958 if (pat[-1] == '*')
93a17b20 3959 len = fromlen;
79072805
LW		 3960 pat = aptr;
3961 aint = SvCUR(cat);
3962 SvCUR(cat) += (len+7)/8;
3963 SvGROW(cat, SvCUR(cat) + 1);
463ee0b2 3964 aptr = SvPVX(cat) + aint;
93a17b20
LW		 3965 if (len > fromlen)
3966 len = fromlen;
79072805
LW		 3967 aint = len;
3968 items = 0;
3969 if (datumtype == 'B') {
3970 for (len = 0; len++ < aint;) {
3971 items |= *pat++ & 1;
3972 if (len & 7)
3973 items <<= 1;
3974 else {
3975 *aptr++ = items & 0xff;
3976 items = 0;
3977 }
3978 }
3979 }
3980 else {
3981 for (len = 0; len++ < aint;) {
3982 if (*pat++ & 1)
3983 items |= 128;
3984 if (len & 7)
3985 items >>= 1;
3986 else {
3987 *aptr++ = items & 0xff;
3988 items = 0;
3989 }
3990 }
3991 }
3992 if (aint & 7) {
3993 if (datumtype == 'B')
3994 items <<= 7 - (aint & 7);
3995 else
3996 items >>= 7 - (aint & 7);
3997 *aptr++ = items & 0xff;
3998 }
463ee0b2 3999 pat = SvPVX(cat) + SvCUR(cat);
79072805
LW		 4000 while (aptr <= pat)
4001 *aptr++ = '\0';
4002
4003 pat = savepat;
4004 items = saveitems;
4005 }
4006 break;
4007 case 'H':
4008 case 'h':
4009 {
4010 char *savepat = pat;
4011 I32 saveitems;
4012
4013 fromstr = NEXTFROM;
4014 saveitems = items;
463ee0b2 4015 aptr = SvPV(fromstr, fromlen);
79072805 4016 if (pat[-1] == '*')
93a17b20 4017 len = fromlen;
79072805
LW		 4018 pat = aptr;
4019 aint = SvCUR(cat);
4020 SvCUR(cat) += (len+1)/2;
4021 SvGROW(cat, SvCUR(cat) + 1);
463ee0b2 4022 aptr = SvPVX(cat) + aint;
93a17b20
LW		 4023 if (len > fromlen)
4024 len = fromlen;
79072805
LW		 4025 aint = len;
4026 items = 0;
4027 if (datumtype == 'H') {
4028 for (len = 0; len++ < aint;) {
4029 if (isALPHA(*pat))
4030 items |= ((*pat++ & 15) + 9) & 15;
4031 else
4032 items |= *pat++ & 15;
4033 if (len & 1)
4034 items <<= 4;
4035 else {
4036 *aptr++ = items & 0xff;
4037 items = 0;
4038 }
4039 }
4040 }
4041 else {
4042 for (len = 0; len++ < aint;) {
4043 if (isALPHA(*pat))
4044 items |= (((*pat++ & 15) + 9) & 15) << 4;
4045 else
4046 items |= (*pat++ & 15) << 4;
4047 if (len & 1)
4048 items >>= 4;
4049 else {
4050 *aptr++ = items & 0xff;
4051 items = 0;
4052 }
4053 }
4054 }
4055 if (aint & 1)
4056 *aptr++ = items & 0xff;
463ee0b2 4057 pat = SvPVX(cat) + SvCUR(cat);
79072805
LW		 4058 while (aptr <= pat)
4059 *aptr++ = '\0';
4060
4061 pat = savepat;
4062 items = saveitems;
4063 }
4064 break;
4065 case 'C':
4066 case 'c':
4067 while (len-- > 0) {
4068 fromstr = NEXTFROM;
463ee0b2 4069 aint = SvIV(fromstr);
79072805
LW		 4070 achar = aint;
4071 sv_catpvn(cat, &achar, sizeof(char));
4072 }
4073 break;
4074 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4075 case 'f':
4076 case 'F':
4077 while (len-- > 0) {
4078 fromstr = NEXTFROM;
463ee0b2 4079 afloat = (float)SvNV(fromstr);
79072805
LW		 4080 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4081 }
4082 break;
4083 case 'd':
4084 case 'D':
4085 while (len-- > 0) {
4086 fromstr = NEXTFROM;
463ee0b2 4087 adouble = (double)SvNV(fromstr);
79072805
LW		 4088 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4089 }
4090 break;
4091 case 'n':
4092 while (len-- > 0) {
4093 fromstr = NEXTFROM;
463ee0b2 4094 ashort = (I16)SvIV(fromstr);
79072805
LW		 4095#ifdef HAS_HTONS
4096 ashort = htons(ashort);
4097#endif
4098 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4099 }
4100 break;
4101 case 'v':
4102 while (len-- > 0) {
4103 fromstr = NEXTFROM;
463ee0b2 4104 ashort = (I16)SvIV(fromstr);
79072805
LW		 4105#ifdef HAS_HTOVS
4106 ashort = htovs(ashort);
4107#endif
4108 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4109 }
4110 break;
4111 case 'S':
4112 case 's':
4113 while (len-- > 0) {
4114 fromstr = NEXTFROM;
463ee0b2 4115 ashort = (I16)SvIV(fromstr);
79072805
LW		 4116 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4117 }
4118 break;
4119 case 'I':
4120 while (len-- > 0) {
4121 fromstr = NEXTFROM;
463ee0b2 4122 auint = U_I(SvNV(fromstr));
79072805
LW		 4123 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4124 }
4125 break;
4126 case 'i':
4127 while (len-- > 0) {
4128 fromstr = NEXTFROM;
463ee0b2 4129 aint = SvIV(fromstr);
79072805
LW		 4130 sv_catpvn(cat, (char*)&aint, sizeof(int));
4131 }
4132 break;
4133 case 'N':
4134 while (len-- > 0) {
4135 fromstr = NEXTFROM;
463ee0b2 4136 aulong = U_L(SvNV(fromstr));
79072805
LW		 4137#ifdef HAS_HTONL
4138 aulong = htonl(aulong);
4139#endif
4140 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4141 }
4142 break;
4143 case 'V':
4144 while (len-- > 0) {
4145 fromstr = NEXTFROM;
463ee0b2 4146 aulong = U_L(SvNV(fromstr));
79072805
LW		 4147#ifdef HAS_HTOVL
4148 aulong = htovl(aulong);
4149#endif
4150 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4151 }
4152 break;
4153 case 'L':
4154 while (len-- > 0) {
4155 fromstr = NEXTFROM;
463ee0b2 4156 aulong = U_L(SvNV(fromstr));
79072805
LW		 4157 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4158 }
4159 break;
4160 case 'l':
4161 while (len-- > 0) {
4162 fromstr = NEXTFROM;
463ee0b2 4163 along = SvIV(fromstr);
79072805
LW		 4164 sv_catpvn(cat, (char*)&along, sizeof(I32));
4165 }
4166 break;
4167#ifdef QUAD
4168 case 'Q':
4169 while (len-- > 0) {
4170 fromstr = NEXTFROM;
463ee0b2 4171 auquad = (unsigned quad)SvNV(fromstr);
79072805
LW		 4172 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
4173 }
4174 break;
4175 case 'q':
4176 while (len-- > 0) {
4177 fromstr = NEXTFROM;
463ee0b2 4178 aquad = (quad)SvNV(fromstr);
79072805
LW		 4179 sv_catpvn(cat, (char*)&aquad, sizeof(quad));
4180 }
4181 break;
4182#endif /* QUAD */
463ee0b2
LW		 4183 case 'P':
4184 len = 1; /* assume SV is correct length */
4185 /* FALL THROUGH */
79072805
LW		 4186 case 'p':
4187 while (len-- > 0) {
4188 fromstr = NEXTFROM;
463ee0b2 4189 aptr = SvPV(fromstr, na);
79072805
LW		 4190 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4191 }
4192 break;
4193 case 'u':
4194 fromstr = NEXTFROM;
463ee0b2 4195 aptr = SvPV(fromstr, fromlen);
93a17b20 4196 SvGROW(cat, fromlen * 4 / 3);
79072805
LW		 4197 if (len <= 1)
4198 len = 45;
4199 else
4200 len = len / 3 * 3;
93a17b20 4201 while (fromlen > 0) {
79072805
LW		 4202 I32 todo;
4203
93a17b20 4204 if (fromlen > len)
79072805
LW		 4205 todo = len;
4206 else
93a17b20 4207 todo = fromlen;
79072805 4208 doencodes(cat, aptr, todo);
93a17b20 4209 fromlen -= todo;
79072805
LW		 4210 aptr += todo;
4211 }
4212 break;
4213 }
4214 }
4215 SvSETMAGIC(cat);
4216 SP = ORIGMARK;
4217 PUSHs(cat);
4218 RETURN;
4219}
4220#undef NEXTFROM
4221
4222PP(pp_split)
4223{
4224 dSP; dTARG;
4225 AV *ary;
93a17b20
LW		 4226 register I32 limit = POPi; /* note, negative is forever */
4227 SV *sv = POPs;
463ee0b2
LW		 4228 STRLEN len;
4229 register char *s = SvPV(sv, len);
4230 char *strend = s + len;
79072805
LW		 4231 register PMOP *pm = (PMOP*)POPs;
4232 register SV *dstr;
4233 register char *m;
4234 I32 iters = 0;
4235 I32 maxiters = (strend - s) + 10;
4236 I32 i;
4237 char *orig;
4238 I32 origlimit = limit;
4239 I32 realarray = 0;
4240 I32 base;
4241 AV *oldstack;
4242 register REGEXP *rx = pm->op_pmregexp;
4243 I32 gimme = GIMME;
4244
4245 if (!pm || !s)
4246 DIE("panic: do_split");
4247 if (pm->op_pmreplroot)
4248 ary = GvAVn((GV*)pm->op_pmreplroot);
4249 else
4250 ary = Nullav;
4251 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4252 realarray = 1;
4253 if (!AvREAL(ary)) {
4254 AvREAL_on(ary);
4255 for (i = AvFILL(ary); i >= 0; i--)
4256 AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */
4257 }
4258 av_fill(ary,0); /* force allocation */
4259 av_fill(ary,-1);
4260 /* temporarily switch stacks */
4261 oldstack = stack;
4262 SWITCHSTACK(stack, ary);
4263 }
4264 base = SP - stack_base + 1;
4265 orig = s;
4266 if (pm->op_pmflags & PMf_SKIPWHITE) {
4267 while (isSPACE(*s))
4268 s++;
4269 }
4270 if (!limit)
4271 limit = maxiters + 2;
4272 if (strEQ("\\s+", rx->precomp)) {
4273 while (--limit) {
4274 /*SUPPRESS 530*/
4275 for (m = s; m < strend && !isSPACE(*m); m++) ;
4276 if (m >= strend)
4277 break;
4278 dstr = NEWSV(30, m-s);
4279 sv_setpvn(dstr, s, m-s);
4280 if (!realarray)
4281 sv_2mortal(dstr);
4282 XPUSHs(dstr);
4283 /*SUPPRESS 530*/
4284 for (s = m + 1; s < strend && isSPACE(*s); s++) ;
4285 }
4286 }
4287 else if (strEQ("^", rx->precomp)) {
4288 while (--limit) {
4289 /*SUPPRESS 530*/
4290 for (m = s; m < strend && *m != '\n'; m++) ;
4291 m++;
4292 if (m >= strend)
4293 break;
4294 dstr = NEWSV(30, m-s);
4295 sv_setpvn(dstr, s, m-s);
4296 if (!realarray)
4297 sv_2mortal(dstr);
4298 XPUSHs(dstr);
4299 s = m;
4300 }
4301 }
4302 else if (pm->op_pmshort) {
4303 i = SvCUR(pm->op_pmshort);
4304 if (i == 1) {
4305 I32 fold = (pm->op_pmflags & PMf_FOLD);
463ee0b2 4306 i = *SvPVX(pm->op_pmshort);
79072805
LW		 4307 if (fold && isUPPER(i))
4308 i = tolower(i);
4309 while (--limit) {
4310 if (fold) {
4311 for ( m = s;
4312 m < strend && *m != i &&
4313 (!isUPPER(*m) || tolower(*m) != i);
4314 m++) /*SUPPRESS 530*/
4315 ;
4316 }
4317 else /*SUPPRESS 530*/
4318 for (m = s; m < strend && *m != i; m++) ;
4319 if (m >= strend)
4320 break;
4321 dstr = NEWSV(30, m-s);
4322 sv_setpvn(dstr, s, m-s);
4323 if (!realarray)
4324 sv_2mortal(dstr);
4325 XPUSHs(dstr);
4326 s = m + 1;
4327 }
4328 }
4329 else {
4330#ifndef lint
4331 while (s < strend && --limit &&
4332 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4333 pm->op_pmshort)) )
4334#endif
4335 {
4336 dstr = NEWSV(31, m-s);
4337 sv_setpvn(dstr, s, m-s);
4338 if (!realarray)
4339 sv_2mortal(dstr);
4340 XPUSHs(dstr);
4341 s = m + i;
4342 }
4343 }
4344 }
4345 else {
4346 maxiters += (strend - s) * rx->nparens;
4347 while (s < strend && --limit &&
4348 regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
4349 if (rx->subbase
4350 && rx->subbase != orig) {
4351 m = s;
4352 s = orig;
4353 orig = rx->subbase;
4354 s = orig + (m - s);
4355 strend = s + (strend - m);
4356 }
4357 m = rx->startp[0];
4358 dstr = NEWSV(32, m-s);
4359 sv_setpvn(dstr, s, m-s);
4360 if (!realarray)
4361 sv_2mortal(dstr);
4362 XPUSHs(dstr);
4363 if (rx->nparens) {
4364 for (i = 1; i <= rx->nparens; i++) {
4365 s = rx->startp[i];
4366 m = rx->endp[i];
4367 dstr = NEWSV(33, m-s);
4368 sv_setpvn(dstr, s, m-s);
4369 if (!realarray)
4370 sv_2mortal(dstr);
4371 XPUSHs(dstr);
4372 }
4373 }
4374 s = rx->endp[0];
4375 }
4376 }
4377 iters = (SP - stack_base) - base;
4378 if (iters > maxiters)
4379 DIE("Split loop");
4380 if (s < strend || origlimit) { /* keep field after final delim? */
4381 dstr = NEWSV(34, strend-s);
4382 sv_setpvn(dstr, s, strend-s);
4383 if (!realarray)
4384 sv_2mortal(dstr);
4385 XPUSHs(dstr);
4386 iters++;
4387 }
4388 else {
4389 while (iters > 0 && SvCUR(TOPs) == 0)
4390 iters--, SP--;
4391 }
4392 if (realarray) {
4393 SWITCHSTACK(ary, oldstack);
4394 if (gimme == G_ARRAY) {
4395 EXTEND(SP, iters);
4396 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4397 SP += iters;
4398 RETURN;
4399 }
4400 }
4401 else {
4402 if (gimme == G_ARRAY)
4403 RETURN;
4404 }
4405 SP = stack_base + base;
4406 GETTARGET;
4407 PUSHi(iters);
4408 RETURN;
4409}
4410
4411PP(pp_join)
4412{
4413 dSP; dMARK; dTARGET;
4414 MARK++;
4415 do_join(TARG, *MARK, MARK, SP);
4416 SP = MARK;
4417 SETs(TARG);
4418 RETURN;
4419}
4420
4421/* List operators. */
4422
4423PP(pp_list)
4424{
4425 dSP;
4426 if (GIMME != G_ARRAY) {
4427 dMARK;
4428 if (++MARK <= SP)
4429 *MARK = *SP; /* unwanted list, return last item */
4430 else
4431 *MARK = &sv_undef;
4432 SP = MARK;
4433 }
4434 RETURN;
4435}
4436
4437PP(pp_lslice)
4438{
4439 dSP;
4440 SV **lastrelem = stack_sp;
4441 SV **lastlelem = stack_base + POPMARK;
4442 SV **firstlelem = stack_base + POPMARK + 1;
4443 register SV **firstrelem = lastlelem + 1;
4444 I32 lval = op->op_flags & OPf_LVAL;
4445 I32 is_something_there = lval;
4446
4447 register I32 max = lastrelem - lastlelem;
4448 register SV **lelem;
4449 register I32 ix;
4450
4451 if (GIMME != G_ARRAY) {
463ee0b2 4452 ix = SvIVx(*lastlelem) - arybase;
79072805
LW		 4453 if (ix < 0 || ix >= max)
4454 *firstlelem = &sv_undef;
4455 else
4456 *firstlelem = firstrelem[ix];
4457 SP = firstlelem;
4458 RETURN;
4459 }
4460
4461 if (max == 0) {
463ee0b2 4462 SP = firstlelem - 1;
79072805
LW		 4463 RETURN;
4464 }
4465
4466 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
463ee0b2 4467 ix = SvIVx(*lelem) - arybase;
79072805
LW		 4468 if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
4469 *lelem = &sv_undef;
4470 if (!is_something_there && SvOK(*lelem))
4471 is_something_there = TRUE;
4472 }
4473 if (is_something_there)
4474 SP = lastlelem;
4475 else
463ee0b2 4476 SP = firstlelem - 1;
79072805
LW		 4477 RETURN;
4478}
4479
4480PP(pp_anonlist)
4481{
4482 dSP; dMARK;
4483 I32 items = SP - MARK;
4484 SP = MARK;
4485 XPUSHs((SV*)av_make(items, MARK+1));
4486 RETURN;
4487}
4488
4489PP(pp_anonhash)
4490{
4491 dSP; dMARK; dORIGMARK;
463ee0b2 4492 HV* hv = newHV();
79072805
LW		 4493 SvREFCNT(hv) = 0;
4494 while (MARK < SP) {
4495 SV* key = *++MARK;
79072805 4496 char *tmps;
93a17b20 4497 SV *val = NEWSV(46, 0);
79072805 4498 if (MARK < SP)
93a17b20 4499 sv_setsv(val, *++MARK);
463ee0b2 4500 tmps = SvPVX(key);
93a17b20 4501 (void)hv_store(hv,tmps,SvCUROK(key),val,0);
79072805
LW		 4502 }
4503 SP = ORIGMARK;
4504 XPUSHs((SV*)hv);
4505 RETURN;
4506}
4507
4508PP(pp_splice)
4509{
4510 dSP; dMARK; dORIGMARK;
4511 register AV *ary = (AV*)*++MARK;
4512 register SV **src;
4513 register SV **dst;
4514 register I32 i;
4515 register I32 offset;
4516 register I32 length;
4517 I32 newlen;
4518 I32 after;
4519 I32 diff;
4520 SV **tmparyval;
4521
4522 SP++;
4523
4524 if (++MARK < SP) {
463ee0b2 4525