Commit | Line | Data |
---|---|---|
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 | |
42 | extern 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 |
65 | static I32 dopoptosub P((I32 startingblock)); |
66 | ||
79072805 LW |
67 | /* Nothing. */ |
68 | ||
69 | PP(pp_null) | |
70 | { | |
71 | return NORMAL; | |
72 | } | |
73 | ||
93a17b20 LW |
74 | PP(pp_stub) |
75 | { | |
76 | dSP; | |
77 | if (GIMME != G_ARRAY) { | |
78 | XPUSHs(&sv_undef); | |
79 | } | |
80 | RETURN; | |
81 | } | |
82 | ||
79072805 LW |
83 | PP(pp_scalar) |
84 | { | |
85 | return NORMAL; | |
86 | } | |
87 | ||
88 | /* Pushy stuff. */ | |
89 | ||
90 | PP(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 | ||
104 | PP(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 |
120 | PP(pp_const) |
121 | { | |
122 | dSP; | |
123 | XPUSHs(cSVOP->op_sv); | |
124 | RETURN; | |
125 | } | |
126 | ||
127 | static void | |
128 | ucase(s,send) | |
129 | register char *s; | |
130 | register char *send; | |
131 | { | |
132 | while (s < send) { | |
133 | if (isLOWER(*s)) | |
134 | *s = toupper(*s); | |
135 | s++; | |
136 | } | |
137 | } | |
138 | ||
139 | static void | |
140 | lcase(s,send) | |
141 | register char *s; | |
142 | register char *send; | |
143 | { | |
144 | while (s < send) { | |
145 | if (isUPPER(*s)) | |
146 | *s = tolower(*s); | |
147 | s++; | |
148 | } | |
149 | } | |
150 | ||
151 | PP(pp_interp) | |
152 | { | |
153 | DIE("panic: pp_interp"); | |
154 | } | |
155 | ||
156 | PP(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 | ||
167 | PP(pp_gv) | |
168 | { | |
169 | dSP; | |
170 | XPUSHs((SV*)cGVOP->op_gv); | |
171 | RETURN; | |
172 | } | |
173 | ||
93a17b20 LW |
174 | PP(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 | ||
183 | PP(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 | ||
195 | PP(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 |
207 | PP(pp_pushre) |
208 | { | |
209 | dSP; | |
210 | XPUSHs((SV*)op); | |
211 | RETURN; | |
212 | } | |
213 | ||
214 | /* Translations. */ | |
215 | ||
216 | PP(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 | ||
255 | PP(pp_sv2len) | |
256 | { | |
257 | dSP; dTARGET; | |
258 | dPOPss; | |
259 | PUSHi(sv_len(sv)); | |
260 | RETURN; | |
261 | } | |
262 | ||
263 | PP(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 | ||
308 | PP(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 | ||
322 | PP(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 | ||
334 | PP(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 | ||
347 | PP(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 | ||
389 | PP(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 | ||
415 | PP(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 | ||
457 | OP * | |
458 | do_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 | ||
597 | PP(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 | ||
622 | PP(pp_readline) | |
623 | { | |
624 | last_in_gv = (GV*)(*stack_sp--); | |
625 | return do_readline(); | |
626 | } | |
627 | ||
628 | PP(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 | ||
634 | PP(pp_rcatline) | |
635 | { | |
636 | last_in_gv = cGVOP->op_gv; | |
637 | return do_readline(); | |
638 | } | |
639 | ||
463ee0b2 LW |
640 | PP(pp_regcmaybe) |
641 | { | |
642 | return NORMAL; | |
643 | } | |
644 | ||
79072805 LW |
645 | PP(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 | ||
676 | PP(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 |
725 | play_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 | ||
829 | yup: | |
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 | ||
854 | nope: | |
79072805 LW |
855 | if (pm->op_pmshort) |
856 | ++BmUSEFUL(pm->op_pmshort); | |
93a17b20 LW |
857 | |
858 | ret_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 | ||
873 | PP(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 | ||
1090 | nope: | |
1091 | ++BmUSEFUL(pm->op_pmshort); | |
1092 | PUSHs(&sv_no); | |
1093 | RETURN; | |
1094 | } | |
1095 | ||
1096 | PP(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 | ||
1146 | PP(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 | ||
1164 | PP(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 | ||
1176 | PP(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 | ||
1343 | PP(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 | ||
1357 | PP(pp_chop) | |
1358 | { | |
1359 | dSP; dMARK; dTARGET; | |
1360 | while (SP > MARK) | |
1361 | do_chop(TARG, POPs); | |
1362 | PUSHTARG; | |
1363 | RETURN; | |
1364 | } | |
1365 | ||
1366 | PP(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 | ||
1399 | PP(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 | ||
1445 | PP(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 | ||
1510 | PP(pp_preinc) | |
1511 | { | |
1512 | dSP; | |
1513 | sv_inc(TOPs); | |
1514 | SvSETMAGIC(TOPs); | |
1515 | return NORMAL; | |
1516 | } | |
1517 | ||
1518 | PP(pp_predec) | |
1519 | { | |
1520 | dSP; | |
1521 | sv_dec(TOPs); | |
1522 | SvSETMAGIC(TOPs); | |
1523 | return NORMAL; | |
1524 | } | |
1525 | ||
1526 | PP(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 | ||
1536 | PP(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 | ||
1548 | PP(pp_pow) | |
1549 | { | |
1550 | dSP; dATARGET; dPOPTOPnnrl; | |
1551 | SETn( pow( left, right) ); | |
1552 | RETURN; | |
1553 | } | |
1554 | ||
1555 | PP(pp_multiply) | |
1556 | { | |
1557 | dSP; dATARGET; dPOPTOPnnrl; | |
1558 | SETn( left * right ); | |
1559 | RETURN; | |
1560 | } | |
1561 | ||
1562 | PP(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 | ||
1588 | PP(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 | ||
1609 | PP(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 | ||
1661 | PP(pp_add) | |
1662 | { | |
1663 | dSP; dATARGET; dPOPTOPnnrl; | |
1664 | SETn( left + right ); | |
1665 | RETURN; | |
1666 | } | |
1667 | ||
1668 | PP(pp_intadd) | |
1669 | { | |
1670 | dSP; dATARGET; dPOPTOPiirl; | |
1671 | SETi( left + right ); | |
1672 | RETURN; | |
1673 | } | |
1674 | ||
1675 | PP(pp_subtract) | |
1676 | { | |
1677 | dSP; dATARGET; dPOPTOPnnrl; | |
1678 | SETn( left - right ); | |
1679 | RETURN; | |
1680 | } | |
1681 | ||
1682 | PP(pp_concat) | |
1683 | { | |
1684 | dSP; dATARGET; dPOPTOPssrl; | |
1685 | SvSetSV(TARG, lstr); | |
1686 | sv_catsv(TARG, rstr); | |
1687 | SETTARG; | |
1688 | RETURN; | |
1689 | } | |
1690 | ||
1691 | PP(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 | ||
1700 | PP(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 | ||
1709 | PP(pp_lt) | |
1710 | { | |
1711 | dSP; dPOPnv; | |
1712 | SETs((TOPn < value) ? &sv_yes : &sv_no); | |
1713 | RETURN; | |
1714 | } | |
1715 | ||
1716 | PP(pp_gt) | |
1717 | { | |
1718 | dSP; dPOPnv; | |
1719 | SETs((TOPn > value) ? &sv_yes : &sv_no); | |
1720 | RETURN; | |
1721 | } | |
1722 | ||
1723 | PP(pp_le) | |
1724 | { | |
1725 | dSP; dPOPnv; | |
1726 | SETs((TOPn <= value) ? &sv_yes : &sv_no); | |
1727 | RETURN; | |
1728 | } | |
1729 | ||
1730 | PP(pp_ge) | |
1731 | { | |
1732 | dSP; dPOPnv; | |
1733 | SETs((TOPn >= value) ? &sv_yes : &sv_no); | |
1734 | RETURN; | |
1735 | } | |
1736 | ||
1737 | PP(pp_eq) | |
1738 | { | |
93a17b20 | 1739 | dSP; dPOPnv; |
79072805 LW |
1740 | SETs((TOPn == value) ? &sv_yes : &sv_no); |
1741 | RETURN; | |
1742 | } | |
1743 | ||
1744 | PP(pp_ne) | |
1745 | { | |
1746 | dSP; dPOPnv; | |
1747 | SETs((TOPn != value) ? &sv_yes : &sv_no); | |
1748 | RETURN; | |
1749 | } | |
1750 | ||
1751 | PP(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 | ||
1766 | PP(pp_slt) | |
1767 | { | |
1768 | dSP; dPOPTOPssrl; | |
1769 | SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no ); | |
1770 | RETURN; | |
1771 | } | |
1772 | ||
1773 | PP(pp_sgt) | |
1774 | { | |
1775 | dSP; dPOPTOPssrl; | |
1776 | SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no ); | |
1777 | RETURN; | |
1778 | } | |
1779 | ||
1780 | PP(pp_sle) | |
1781 | { | |
1782 | dSP; dPOPTOPssrl; | |
1783 | SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no ); | |
1784 | RETURN; | |
1785 | } | |
1786 | ||
1787 | PP(pp_sge) | |
1788 | { | |
1789 | dSP; dPOPTOPssrl; | |
1790 | SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no ); | |
1791 | RETURN; | |
1792 | } | |
1793 | ||
1794 | PP(pp_seq) | |
1795 | { | |
1796 | dSP; dPOPTOPssrl; | |
1797 | SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no ); | |
1798 | RETURN; | |
1799 | } | |
1800 | ||
1801 | PP(pp_sne) | |
1802 | { | |
1803 | dSP; dPOPTOPssrl; | |
1804 | SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no ); | |
1805 | RETURN; | |
1806 | } | |
1807 | ||
1808 | PP(pp_scmp) | |
1809 | { | |
1810 | dSP; dTARGET; | |
1811 | dPOPTOPssrl; | |
1812 | SETi( sv_cmp(lstr, rstr) ); | |
1813 | RETURN; | |
1814 | } | |
1815 | ||
1816 | PP(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 | ||
1831 | PP(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 | ||
1846 | PP(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 | ||
1861 | PP(pp_negate) | |
1862 | { | |
1863 | dSP; dTARGET; | |
1864 | SETn(-TOPn); | |
1865 | RETURN; | |
1866 | } | |
1867 | ||
1868 | PP(pp_not) | |
1869 | { | |
1870 | *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes; | |
1871 | return NORMAL; | |
1872 | } | |
1873 | ||
1874 | PP(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 | ||
1908 | PP(pp_atan2) | |
1909 | { | |
1910 | dSP; dTARGET; dPOPTOPnnrl; | |
1911 | SETn(atan2(left, right)); | |
1912 | RETURN; | |
1913 | } | |
1914 | ||
1915 | PP(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 | ||
1928 | PP(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 | ||
1941 | PP(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 | ||
1968 | PP(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 | ||
1985 | PP(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 | ||
1998 | PP(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 | ||
2013 | PP(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 | ||
2028 | PP(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 |
2046 | PP(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 |
2062 | PP(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 | ||
2076 | PP(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 | ||
2099 | PP(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 | ||
2110 | PP(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 | ||
2153 | PP(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 | ||
2207 | PP(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 | ||
2238 | PP(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 | ||
2274 | PP(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 | ||
2283 | static void | |
2284 | doparseform(sv) | |
2285 | SV *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 | ||
2457 | PP(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 | ||
2733 | PP(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 |
2754 | PP(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 |
2774 | PP(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 | ||
2792 | PP(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 | ||
2811 | PP(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 | ||
2831 | PP(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 | ||
2855 | PP(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 | ||
2881 | PP(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 | ||
2936 | PP(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 | ||
2945 | PP(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 | ||
2979 | PP(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 | ||
3011 | PP(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 | ||
3042 | PP(pp_values) | |
3043 | { | |
3044 | return do_kv(ARGS); | |
3045 | } | |
3046 | ||
3047 | PP(pp_keys) | |
3048 | { | |
3049 | return do_kv(ARGS); | |
3050 | } | |
3051 | ||
3052 | PP(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 | ||
3071 | PP(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 | ||
3130 | PP(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 | ||
3166 | PP(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 | ||
3199 | PP(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 | ||
3820 | static void | |
3821 | doencodes(sv, s, len) | |
3822 | register SV *sv; | |
3823 | register char *s; | |
3824 | register 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 | ||
3847 | PP(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 | ||
4222 | PP(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 | ||
4411 | PP(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 | ||
4423 | PP(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 | ||
4437 | PP(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 | ||
4480 | PP(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 | ||
4489 | PP(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 | ||
4508 | PP(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 |