pod/perlipc.pod patch
[p5sagit/p5-mst-13.2.git] / pp_hot.c
CommitLineData
a0d0e21e 1/* pp_hot.c
2 *
3 * Copyright (c) 1991-1994, Larry Wall
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
12 * shaking the air.
13 *
14 * Awake! Awake! Fear, Fire, Foes! Awake!
15 * Fire, Foes! Awake!
16 */
17
18#include "EXTERN.h"
19#include "perl.h"
20
21/* Hot code. */
22
23PP(pp_const)
24{
25 dSP;
26 XPUSHs(cSVOP->op_sv);
27 RETURN;
28}
29
30PP(pp_nextstate)
31{
32 curcop = (COP*)op;
33 TAINT_NOT; /* Each statement is presumed innocent */
34 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
35 FREETMPS;
36 return NORMAL;
37}
38
39PP(pp_gvsv)
40{
41 dSP;
42 EXTEND(sp,1);
43 if (op->op_private & OPpLVAL_INTRO)
44 PUSHs(save_scalar(cGVOP->op_gv));
45 else
46 PUSHs(GvSV(cGVOP->op_gv));
47 RETURN;
48}
49
50PP(pp_null)
51{
52 return NORMAL;
53}
54
55PP(pp_pushmark)
56{
57 PUSHMARK(stack_sp);
58 return NORMAL;
59}
60
61PP(pp_stringify)
62{
63 dSP; dTARGET;
64 STRLEN len;
65 char *s;
66 s = SvPV(TOPs,len);
67 sv_setpvn(TARG,s,len);
68 SETTARG;
69 RETURN;
70}
71
72PP(pp_gv)
73{
74 dSP;
75 XPUSHs((SV*)cGVOP->op_gv);
76 RETURN;
77}
78
c07a80fd 79PP(pp_gelem)
80{
81 GV *gv;
82 SV *sv;
83 SV *ref;
84 char *elem;
85 dSP;
86
87 sv = POPs;
88 elem = SvPV(sv, na);
89 gv = (GV*)POPs;
90 ref = Nullsv;
91 sv = Nullsv;
92 switch (elem ? *elem : '\0')
93 {
94 case 'A':
95 if (strEQ(elem, "ARRAY"))
96 ref = (SV*)GvAV(gv);
97 break;
98 case 'C':
99 if (strEQ(elem, "CODE"))
100 ref = (SV*)GvCV(gv);
101 break;
102 case 'F':
36477c24 103 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
c07a80fd 104 ref = (SV*)GvIOp(gv);
105 break;
106 case 'G':
107 if (strEQ(elem, "GLOB"))
108 ref = (SV*)gv;
109 break;
110 case 'H':
111 if (strEQ(elem, "HASH"))
112 ref = (SV*)GvHV(gv);
113 break;
36477c24 114 case 'I':
115 if (strEQ(elem, "IO"))
116 ref = (SV*)GvIOp(gv);
117 break;
c07a80fd 118 case 'N':
119 if (strEQ(elem, "NAME"))
120 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
121 break;
122 case 'P':
123 if (strEQ(elem, "PACKAGE"))
124 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
125 break;
126 case 'S':
127 if (strEQ(elem, "SCALAR"))
128 ref = GvSV(gv);
129 break;
130 }
131 if (ref)
132 sv = newRV(ref);
133 if (sv)
134 sv_2mortal(sv);
135 else
136 sv = &sv_undef;
137 XPUSHs(sv);
138 RETURN;
139}
140
a0d0e21e 141PP(pp_and)
142{
143 dSP;
144 if (!SvTRUE(TOPs))
145 RETURN;
146 else {
147 --SP;
148 RETURNOP(cLOGOP->op_other);
149 }
150}
151
152PP(pp_sassign)
153{
154 dSP; dPOPTOPssrl;
748a9306 155 MAGIC *mg;
156
a0d0e21e 157 if (op->op_private & OPpASSIGN_BACKWARDS) {
158 SV *temp;
159 temp = left; left = right; right = temp;
160 }
bbce6d69 161 if (tainting && tainted && !SvTAINTED(left))
a0d0e21e 162 TAINT_NOT;
a0d0e21e 163 SvSetSV(right, left);
164 SvSETMAGIC(right);
165 SETs(right);
166 RETURN;
167}
168
169PP(pp_cond_expr)
170{
171 dSP;
172 if (SvTRUEx(POPs))
173 RETURNOP(cCONDOP->op_true);
174 else
175 RETURNOP(cCONDOP->op_false);
176}
177
178PP(pp_unstack)
179{
180 I32 oldsave;
181 TAINT_NOT; /* Each statement is presumed innocent */
182 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
183 FREETMPS;
184 oldsave = scopestack[scopestack_ix - 1];
185 LEAVE_SCOPE(oldsave);
186 return NORMAL;
187}
188
a0d0e21e 189PP(pp_concat)
190{
748a9306 191 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
192 {
193 dPOPTOPssrl;
a0d0e21e 194 STRLEN len;
195 char *s;
196 if (TARG != left) {
197 s = SvPV(left,len);
198 sv_setpvn(TARG,s,len);
199 }
c07a80fd 200 else if (SvGMAGICAL(TARG))
201 mg_get(TARG);
4633a7c4 202 else if (!SvOK(TARG)) {
203 s = SvPV_force(TARG, len);
748a9306 204 sv_setpv(TARG, ""); /* Suppress warning. */
4633a7c4 205 }
a0d0e21e 206 s = SvPV(right,len);
207 sv_catpvn(TARG,s,len);
208 SETTARG;
209 RETURN;
748a9306 210 }
a0d0e21e 211}
212
213PP(pp_padsv)
214{
215 dSP; dTARGET;
216 XPUSHs(TARG);
4633a7c4 217 if (op->op_flags & OPf_MOD) {
218 if (op->op_private & OPpLVAL_INTRO)
219 SAVECLEARSV(curpad[op->op_targ]);
02a9e968 220 else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
221 provide_ref(op, curpad[op->op_targ]);
4633a7c4 222 }
a0d0e21e 223 RETURN;
224}
225
226PP(pp_readline)
227{
228 last_in_gv = (GV*)(*stack_sp--);
229 return do_readline();
230}
231
232PP(pp_eq)
233{
234 dSP; tryAMAGICbinSET(eq,0);
235 {
236 dPOPnv;
237 SETs((TOPn == value) ? &sv_yes : &sv_no);
238 RETURN;
239 }
240}
241
242PP(pp_preinc)
243{
244 dSP;
55497cff 245 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
246 SvIVX(TOPs) != IV_MAX)
247 {
248 ++SvIVX(TOPs);
249 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 250 }
251 else
252 sv_inc(TOPs);
a0d0e21e 253 SvSETMAGIC(TOPs);
254 return NORMAL;
255}
256
257PP(pp_or)
258{
259 dSP;
260 if (SvTRUE(TOPs))
261 RETURN;
262 else {
263 --SP;
264 RETURNOP(cLOGOP->op_other);
265 }
266}
267
268PP(pp_add)
269{
270 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
271 {
272 dPOPTOPnnrl;
273 SETn( left + right );
274 RETURN;
275 }
276}
277
278PP(pp_aelemfast)
279{
280 dSP;
281 AV *av = GvAV((GV*)cSVOP->op_sv);
282 SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
283 PUSHs(svp ? *svp : &sv_undef);
284 RETURN;
285}
286
287PP(pp_join)
288{
289 dSP; dMARK; dTARGET;
290 MARK++;
291 do_join(TARG, *MARK, MARK, SP);
292 SP = MARK;
293 SETs(TARG);
294 RETURN;
295}
296
297PP(pp_pushre)
298{
299 dSP;
300 XPUSHs((SV*)op);
301 RETURN;
302}
303
304/* Oversized hot code. */
305
306PP(pp_print)
307{
308 dSP; dMARK; dORIGMARK;
309 GV *gv;
310 IO *io;
760ac839 311 register PerlIO *fp;
236988e4 312 MAGIC *mg;
a0d0e21e 313
314 if (op->op_flags & OPf_STACKED)
315 gv = (GV*)*++MARK;
316 else
317 gv = defoutgv;
236988e4 318 if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
319 SV *sv;
320
321 PUSHMARK(MARK-1);
322 *MARK = mg->mg_obj;
323 ENTER;
324 perl_call_method("PRINT", G_SCALAR);
325 LEAVE;
326 SPAGAIN;
327 sv = POPs;
328 SP = ORIGMARK;
329 PUSHs(sv);
330 RETURN;
331 }
a0d0e21e 332 if (!(io = GvIO(gv))) {
748a9306 333 if (dowarn) {
334 SV* sv = sv_newmortal();
4f732624 335 gv_fullname3(sv, gv, Nullch);
748a9306 336 warn("Filehandle %s never opened", SvPV(sv,na));
337 }
338
339 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e 340 goto just_say_no;
341 }
342 else if (!(fp = IoOFP(io))) {
343 if (dowarn) {
748a9306 344 SV* sv = sv_newmortal();
4f732624 345 gv_fullname3(sv, gv, Nullch);
a0d0e21e 346 if (IoIFP(io))
748a9306 347 warn("Filehandle %s opened only for input", SvPV(sv,na));
a0d0e21e 348 else
748a9306 349 warn("print on closed filehandle %s", SvPV(sv,na));
a0d0e21e 350 }
748a9306 351 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e 352 goto just_say_no;
353 }
354 else {
355 MARK++;
356 if (ofslen) {
357 while (MARK <= SP) {
358 if (!do_print(*MARK, fp))
359 break;
360 MARK++;
361 if (MARK <= SP) {
760ac839 362 if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) {
a0d0e21e 363 MARK--;
364 break;
365 }
366 }
367 }
368 }
369 else {
370 while (MARK <= SP) {
371 if (!do_print(*MARK, fp))
372 break;
373 MARK++;
374 }
375 }
376 if (MARK <= SP)
377 goto just_say_no;
378 else {
379 if (orslen)
760ac839 380 if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp))
a0d0e21e 381 goto just_say_no;
382
383 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 384 if (PerlIO_flush(fp) == EOF)
a0d0e21e 385 goto just_say_no;
386 }
387 }
388 SP = ORIGMARK;
389 PUSHs(&sv_yes);
390 RETURN;
391
392 just_say_no:
393 SP = ORIGMARK;
394 PUSHs(&sv_undef);
395 RETURN;
396}
397
398PP(pp_rv2av)
399{
400 dSP; dPOPss;
401
402 AV *av;
403
404 if (SvROK(sv)) {
405 wasref:
406 av = (AV*)SvRV(sv);
407 if (SvTYPE(av) != SVt_PVAV)
408 DIE("Not an ARRAY reference");
409 if (op->op_private & OPpLVAL_INTRO)
410 av = (AV*)save_svref((SV**)sv);
411 if (op->op_flags & OPf_REF) {
412 PUSHs((SV*)av);
413 RETURN;
414 }
415 }
416 else {
417 if (SvTYPE(sv) == SVt_PVAV) {
418 av = (AV*)sv;
419 if (op->op_flags & OPf_REF) {
420 PUSHs((SV*)av);
421 RETURN;
422 }
423 }
424 else {
67955e0c 425 GV *gv;
426
a0d0e21e 427 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 428 char *sym;
429
a0d0e21e 430 if (SvGMAGICAL(sv)) {
431 mg_get(sv);
432 if (SvROK(sv))
433 goto wasref;
434 }
435 if (!SvOK(sv)) {
436 if (op->op_flags & OPf_REF ||
437 op->op_private & HINT_STRICT_REFS)
438 DIE(no_usym, "an ARRAY");
4633a7c4 439 if (GIMME == G_ARRAY)
440 RETURN;
a0d0e21e 441 RETPUSHUNDEF;
442 }
748a9306 443 sym = SvPV(sv,na);
a0d0e21e 444 if (op->op_private & HINT_STRICT_REFS)
748a9306 445 DIE(no_symref, sym, "an ARRAY");
67955e0c 446 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
447 } else {
448 gv = (GV*)sv;
a0d0e21e 449 }
67955e0c 450 av = GvAVn(gv);
a0d0e21e 451 if (op->op_private & OPpLVAL_INTRO)
67955e0c 452 av = save_ary(gv);
a0d0e21e 453 if (op->op_flags & OPf_REF) {
454 PUSHs((SV*)av);
455 RETURN;
456 }
457 }
458 }
459
460 if (GIMME == G_ARRAY) {
461 I32 maxarg = AvFILL(av) + 1;
462 EXTEND(SP, maxarg);
463 Copy(AvARRAY(av), SP+1, maxarg, SV*);
464 SP += maxarg;
465 }
466 else {
467 dTARGET;
468 I32 maxarg = AvFILL(av) + 1;
469 PUSHi(maxarg);
470 }
471 RETURN;
472}
473
474PP(pp_rv2hv)
475{
476
477 dSP; dTOPss;
478
479 HV *hv;
480
481 if (SvROK(sv)) {
482 wasref:
483 hv = (HV*)SvRV(sv);
484 if (SvTYPE(hv) != SVt_PVHV)
485 DIE("Not a HASH reference");
486 if (op->op_private & OPpLVAL_INTRO)
487 hv = (HV*)save_svref((SV**)sv);
488 if (op->op_flags & OPf_REF) {
489 SETs((SV*)hv);
490 RETURN;
491 }
492 }
493 else {
494 if (SvTYPE(sv) == SVt_PVHV) {
495 hv = (HV*)sv;
496 if (op->op_flags & OPf_REF) {
497 SETs((SV*)hv);
498 RETURN;
499 }
500 }
501 else {
67955e0c 502 GV *gv;
503
a0d0e21e 504 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 505 char *sym;
506
a0d0e21e 507 if (SvGMAGICAL(sv)) {
508 mg_get(sv);
509 if (SvROK(sv))
510 goto wasref;
511 }
512 if (!SvOK(sv)) {
513 if (op->op_flags & OPf_REF ||
514 op->op_private & HINT_STRICT_REFS)
515 DIE(no_usym, "a HASH");
4633a7c4 516 if (GIMME == G_ARRAY) {
517 SP--;
518 RETURN;
519 }
a0d0e21e 520 RETSETUNDEF;
521 }
748a9306 522 sym = SvPV(sv,na);
a0d0e21e 523 if (op->op_private & HINT_STRICT_REFS)
748a9306 524 DIE(no_symref, sym, "a HASH");
67955e0c 525 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
526 } else {
527 gv = (GV*)sv;
a0d0e21e 528 }
67955e0c 529 hv = GvHVn(gv);
a0d0e21e 530 if (op->op_private & OPpLVAL_INTRO)
67955e0c 531 hv = save_hash(gv);
a0d0e21e 532 if (op->op_flags & OPf_REF) {
533 SETs((SV*)hv);
534 RETURN;
535 }
536 }
537 }
538
539 if (GIMME == G_ARRAY) { /* array wanted */
540 *stack_sp = (SV*)hv;
541 return do_kv(ARGS);
542 }
543 else {
544 dTARGET;
545 if (HvFILL(hv)) {
546 sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
547 sv_setpv(TARG, buf);
548 }
549 else
550 sv_setiv(TARG, 0);
551 SETTARG;
552 RETURN;
553 }
554}
555
556PP(pp_aassign)
557{
558 dSP;
559 SV **lastlelem = stack_sp;
560 SV **lastrelem = stack_base + POPMARK;
561 SV **firstrelem = stack_base + POPMARK + 1;
562 SV **firstlelem = lastrelem + 1;
563
564 register SV **relem;
565 register SV **lelem;
566
567 register SV *sv;
568 register AV *ary;
569
570 HV *hash;
571 I32 i;
572 int magic;
573
574 delaymagic = DM_DELAY; /* catch simultaneous items */
575
576 /* If there's a common identifier on both sides we have to take
577 * special care that assigning the identifier on the left doesn't
578 * clobber a value on the right that's used later in the list.
579 */
580 if (op->op_private & OPpASSIGN_COMMON) {
581 for (relem = firstrelem; relem <= lastrelem; relem++) {
582 /*SUPPRESS 560*/
583 if (sv = *relem)
584 *relem = sv_mortalcopy(sv);
585 }
586 }
587
588 relem = firstrelem;
589 lelem = firstlelem;
590 ary = Null(AV*);
591 hash = Null(HV*);
592 while (lelem <= lastlelem) {
bbce6d69 593 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e 594 sv = *lelem++;
595 switch (SvTYPE(sv)) {
596 case SVt_PVAV:
597 ary = (AV*)sv;
748a9306 598 magic = SvMAGICAL(ary) != 0;
a0d0e21e 599
600 av_clear(ary);
601 i = 0;
602 while (relem <= lastrelem) { /* gobble up all the rest */
603 sv = NEWSV(28,0);
604 assert(*relem);
605 sv_setsv(sv,*relem);
606 *(relem++) = sv;
607 (void)av_store(ary,i++,sv);
608 if (magic)
609 mg_set(sv);
bbce6d69 610 TAINT_NOT;
a0d0e21e 611 }
612 break;
613 case SVt_PVHV: {
a0d0e21e 614 SV *tmpstr;
615
616 hash = (HV*)sv;
748a9306 617 magic = SvMAGICAL(hash) != 0;
a0d0e21e 618 hv_clear(hash);
619
620 while (relem < lastrelem) { /* gobble up all the rest */
621 STRLEN len;
4633a7c4 622 if (*relem)
a0d0e21e 623 sv = *(relem++);
4633a7c4 624 else
a0d0e21e 625 sv = &sv_no, relem++;
a0d0e21e 626 tmpstr = NEWSV(29,0);
627 if (*relem)
628 sv_setsv(tmpstr,*relem); /* value */
629 *(relem++) = tmpstr;
760ac839 630 (void)hv_store_ent(hash,sv,tmpstr,0);
a0d0e21e 631 if (magic)
632 mg_set(tmpstr);
bbce6d69 633 TAINT_NOT;
8e07c86e 634 }
760ac839 635 if (relem == lastrelem)
636 warn("Odd number of elements in hash list");
a0d0e21e 637 }
638 break;
639 default:
640 if (SvTHINKFIRST(sv)) {
641 if (SvREADONLY(sv) && curcop != &compiling) {
642 if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
643 DIE(no_modify);
644 if (relem <= lastrelem)
645 relem++;
646 break;
647 }
648 if (SvROK(sv))
649 sv_unref(sv);
650 }
651 if (relem <= lastrelem) {
652 sv_setsv(sv, *relem);
653 *(relem++) = sv;
654 }
655 else
656 sv_setsv(sv, &sv_undef);
657 SvSETMAGIC(sv);
658 break;
659 }
660 }
661 if (delaymagic & ~DM_DELAY) {
662 if (delaymagic & DM_UID) {
663#ifdef HAS_SETRESUID
664 (void)setresuid(uid,euid,(Uid_t)-1);
56febc5e 665#else
666# ifdef HAS_SETREUID
a0d0e21e 667 (void)setreuid(uid,euid);
56febc5e 668# else
669# ifdef HAS_SETRUID
a0d0e21e 670 if ((delaymagic & DM_UID) == DM_RUID) {
671 (void)setruid(uid);
748a9306 672 delaymagic &= ~DM_RUID;
a0d0e21e 673 }
56febc5e 674# endif /* HAS_SETRUID */
675# ifdef HAS_SETEUID
a0d0e21e 676 if ((delaymagic & DM_UID) == DM_EUID) {
677 (void)seteuid(uid);
748a9306 678 delaymagic &= ~DM_EUID;
a0d0e21e 679 }
56febc5e 680# endif /* HAS_SETEUID */
a0d0e21e 681 if (delaymagic & DM_UID) {
682 if (uid != euid)
683 DIE("No setreuid available");
684 (void)setuid(uid);
685 }
56febc5e 686# endif /* HAS_SETREUID */
687#endif /* HAS_SETRESUID */
a0d0e21e 688 uid = (int)getuid();
689 euid = (int)geteuid();
690 }
691 if (delaymagic & DM_GID) {
692#ifdef HAS_SETRESGID
693 (void)setresgid(gid,egid,(Gid_t)-1);
56febc5e 694#else
695# ifdef HAS_SETREGID
a0d0e21e 696 (void)setregid(gid,egid);
56febc5e 697# else
698# ifdef HAS_SETRGID
a0d0e21e 699 if ((delaymagic & DM_GID) == DM_RGID) {
700 (void)setrgid(gid);
748a9306 701 delaymagic &= ~DM_RGID;
a0d0e21e 702 }
56febc5e 703# endif /* HAS_SETRGID */
704# ifdef HAS_SETEGID
a0d0e21e 705 if ((delaymagic & DM_GID) == DM_EGID) {
706 (void)setegid(gid);
748a9306 707 delaymagic &= ~DM_EGID;
a0d0e21e 708 }
56febc5e 709# endif /* HAS_SETEGID */
a0d0e21e 710 if (delaymagic & DM_GID) {
711 if (gid != egid)
712 DIE("No setregid available");
713 (void)setgid(gid);
714 }
56febc5e 715# endif /* HAS_SETREGID */
716#endif /* HAS_SETRESGID */
a0d0e21e 717 gid = (int)getgid();
718 egid = (int)getegid();
719 }
4633a7c4 720 tainting |= (uid && (euid != uid || egid != gid));
a0d0e21e 721 }
722 delaymagic = 0;
723 if (GIMME == G_ARRAY) {
724 if (ary || hash)
725 SP = lastrelem;
726 else
727 SP = firstrelem + (lastlelem - firstlelem);
728 RETURN;
729 }
730 else {
4633a7c4 731 dTARGET;
a0d0e21e 732 SP = firstrelem;
a0d0e21e 733
4633a7c4 734 SETi(lastrelem - firstrelem + 1);
735 RETURN;
a0d0e21e 736 }
737}
738
739PP(pp_match)
740{
741 dSP; dTARG;
742 register PMOP *pm = cPMOP;
743 register char *t;
744 register char *s;
745 char *strend;
746 I32 global;
747 I32 safebase;
748 char *truebase;
749 register REGEXP *rx = pm->op_pmregexp;
750 I32 gimme = GIMME;
751 STRLEN len;
748a9306 752 I32 minmatch = 0;
4633a7c4 753 I32 oldsave = savestack_ix;
a0d0e21e 754
755 if (op->op_flags & OPf_STACKED)
756 TARG = POPs;
757 else {
758 TARG = GvSV(defgv);
759 EXTEND(SP,1);
760 }
761 s = SvPV(TARG, len);
762 strend = s + len;
763 if (!s)
764 DIE("panic: do_match");
765
766 if (pm->op_pmflags & PMf_USED) {
767 if (gimme == G_ARRAY)
768 RETURN;
769 RETPUSHNO;
770 }
771
772 if (!rx->prelen && curpm) {
773 pm = curpm;
774 rx = pm->op_pmregexp;
775 }
776 truebase = t = s;
777 if (global = pm->op_pmflags & PMf_GLOBAL) {
778 rx->startp[0] = 0;
779 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
780 MAGIC* mg = mg_find(TARG, 'g');
748a9306 781 if (mg && mg->mg_len >= 0) {
a0d0e21e 782 rx->endp[0] = rx->startp[0] = s + mg->mg_len;
748a9306 783 minmatch = (mg->mg_flags & MGf_MINMATCH);
784 }
a0d0e21e 785 }
786 }
748a9306 787 if (!rx->nparens && !global)
788 gimme = G_SCALAR; /* accidental array context? */
a0d0e21e 789 safebase = (gimme == G_ARRAY) || global;
790 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
791 SAVEINT(multiline);
792 multiline = pm->op_pmflags & PMf_MULTILINE;
793 }
794
795play_it_again:
796 if (global && rx->startp[0]) {
797 t = s = rx->endp[0];
798 if (s > strend)
799 goto nope;
748a9306 800 minmatch = (s == rx->startp[0]);
a0d0e21e 801 }
802 if (pm->op_pmshort) {
803 if (pm->op_pmflags & PMf_SCANFIRST) {
804 if (SvSCREAM(TARG)) {
805 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
806 goto nope;
807 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
808 goto nope;
809 else if (pm->op_pmflags & PMf_ALL)
810 goto yup;
811 }
812 else if (!(s = fbm_instr((unsigned char*)s,
813 (unsigned char*)strend, pm->op_pmshort)))
814 goto nope;
815 else if (pm->op_pmflags & PMf_ALL)
816 goto yup;
817 if (s && rx->regback >= 0) {
818 ++BmUSEFUL(pm->op_pmshort);
819 s -= rx->regback;
820 if (s < t)
821 s = t;
822 }
823 else
824 s = t;
825 }
826 else if (!multiline) {
bbce6d69 827 if (*SvPVX(pm->op_pmshort) != *s
828 || (pm->op_pmslen > 1
36477c24 829 && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
bbce6d69 830 goto nope;
a0d0e21e 831 }
832 if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
833 SvREFCNT_dec(pm->op_pmshort);
834 pm->op_pmshort = Nullsv; /* opt is being useless */
835 }
836 }
e50aee73 837 if (pregexec(rx, s, strend, truebase, minmatch,
bbce6d69 838 SvSCREAM(TARG) ? TARG : Nullsv, safebase))
839 {
a0d0e21e 840 curpm = pm;
841 if (pm->op_pmflags & PMf_ONCE)
842 pm->op_pmflags |= PMf_USED;
843 goto gotcha;
844 }
845 else
846 goto ret_no;
847 /*NOTREACHED*/
848
849 gotcha:
850 if (gimme == G_ARRAY) {
851 I32 iters, i, len;
852
bbce6d69 853 TAINT_IF(rx->exec_tainted);
a0d0e21e 854 iters = rx->nparens;
855 if (global && !iters)
856 i = 1;
857 else
858 i = 0;
859 EXTEND(SP, iters + i);
bbce6d69 860 EXTEND_MORTAL(iters + i);
a0d0e21e 861 for (i = !i; i <= iters; i++) {
862 PUSHs(sv_newmortal());
863 /*SUPPRESS 560*/
864 if ((s = rx->startp[i]) && rx->endp[i] ) {
865 len = rx->endp[i] - s;
866 sv_setpvn(*SP, s, len);
867 }
868 }
869 if (global) {
870 truebase = rx->subbeg;
871 if (rx->startp[0] && rx->startp[0] == rx->endp[0])
872 ++rx->endp[0];
873 goto play_it_again;
874 }
4633a7c4 875 LEAVE_SCOPE(oldsave);
a0d0e21e 876 RETURN;
877 }
878 else {
879 if (global) {
880 MAGIC* mg = 0;
881 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
882 mg = mg_find(TARG, 'g');
883 if (!mg) {
884 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
885 mg = mg_find(TARG, 'g');
886 }
748a9306 887 if (rx->startp[0]) {
888 mg->mg_len = rx->endp[0] - truebase;
889 if (rx->startp[0] == rx->endp[0])
890 mg->mg_flags |= MGf_MINMATCH;
891 else
892 mg->mg_flags &= ~MGf_MINMATCH;
893 }
894 else
895 mg->mg_len = -1;
a0d0e21e 896 }
4633a7c4 897 LEAVE_SCOPE(oldsave);
a0d0e21e 898 RETPUSHYES;
899 }
900
901yup:
902 ++BmUSEFUL(pm->op_pmshort);
903 curpm = pm;
904 if (pm->op_pmflags & PMf_ONCE)
905 pm->op_pmflags |= PMf_USED;
906 if (global) {
907 rx->subbeg = truebase;
908 rx->subend = strend;
909 rx->startp[0] = s;
910 rx->endp[0] = s + SvCUR(pm->op_pmshort);
911 goto gotcha;
912 }
913 if (sawampersand) {
914 char *tmps;
915
916 if (rx->subbase)
917 Safefree(rx->subbase);
918 tmps = rx->subbase = savepvn(t, strend-t);
919 rx->subbeg = tmps;
920 rx->subend = tmps + (strend-t);
921 tmps = rx->startp[0] = tmps + (s - t);
922 rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
923 }
4633a7c4 924 LEAVE_SCOPE(oldsave);
a0d0e21e 925 RETPUSHYES;
926
927nope:
928 if (pm->op_pmshort)
929 ++BmUSEFUL(pm->op_pmshort);
930
931ret_no:
932 if (global) {
933 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
934 MAGIC* mg = mg_find(TARG, 'g');
935 if (mg)
936 mg->mg_len = -1;
937 }
938 }
4633a7c4 939 LEAVE_SCOPE(oldsave);
a0d0e21e 940 if (gimme == G_ARRAY)
941 RETURN;
942 RETPUSHNO;
943}
944
945OP *
946do_readline()
947{
948 dSP; dTARGETSTACKED;
949 register SV *sv;
950 STRLEN tmplen = 0;
951 STRLEN offset;
760ac839 952 PerlIO *fp;
a0d0e21e 953 register IO *io = GvIO(last_in_gv);
954 register I32 type = op->op_type;
e79b0511 955 MAGIC *mg;
a0d0e21e 956
e79b0511 957 if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) {
958 PUSHMARK(SP);
959 XPUSHs(mg->mg_obj);
960 PUTBACK;
961 ENTER;
962 perl_call_method("READLINE", GIMME);
963 LEAVE;
964 SPAGAIN;
965 if (GIMME == G_SCALAR) sv_setsv(TARG, TOPs);
966 RETURN;
967 }
a0d0e21e 968 fp = Nullfp;
969 if (io) {
970 fp = IoIFP(io);
971 if (!fp) {
972 if (IoFLAGS(io) & IOf_ARGV) {
973 if (IoFLAGS(io) & IOf_START) {
974 IoFLAGS(io) &= ~IOf_START;
975 IoLINES(io) = 0;
976 if (av_len(GvAVn(last_in_gv)) < 0) {
977 SV *tmpstr = newSVpv("-", 1); /* assume stdin */
978 av_push(GvAVn(last_in_gv), tmpstr);
979 }
980 }
981 fp = nextargv(last_in_gv);
982 if (!fp) { /* Note: fp != IoIFP(io) */
983 (void)do_close(last_in_gv, FALSE); /* now it does*/
984 IoFLAGS(io) |= IOf_START;
985 }
986 }
987 else if (type == OP_GLOB) {
988 SV *tmpcmd = NEWSV(55, 0);
989 SV *tmpglob = POPs;
990 ENTER;
991 SAVEFREESV(tmpcmd);
992#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
993 /* since spawning off a process is a real performance hit */
994 {
995#include <descrip.h>
996#include <lib$routines.h>
997#include <nam.h>
998#include <rmsdef.h>
999 char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1000 char vmsspec[NAM$C_MAXRSS+1];
1001 char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1002 char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1003 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
760ac839 1004 PerlIO *tmpfp;
a0d0e21e 1005 STRLEN i;
1006 struct dsc$descriptor_s wilddsc
1007 = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1008 struct dsc$descriptor_vs rsdsc
1009 = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1010 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1011
1012 /* We could find out if there's an explicit dev/dir or version
1013 by peeking into lib$find_file's internal context at
1014 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1015 but that's unsupported, so I don't want to do it now and
1016 have it bite someone in the future. */
1017 strcat(tmpfnam,tmpnam(NULL));
1018 cp = SvPV(tmpglob,i);
1019 for (; i; i--) {
1020 if (cp[i] == ';') hasver = 1;
1021 if (cp[i] == '.') {
1022 if (sts) hasver = 1;
1023 else sts = 1;
1024 }
1025 if (cp[i] == '/') {
1026 hasdir = isunix = 1;
1027 break;
748a9306 1028 }
a0d0e21e 1029 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1030 hasdir = 1;
1031 break;
1032 }
1033 }
760ac839 1034 if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
a0d0e21e 1035 ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1036 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1037 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1038 &dfltdsc,NULL,NULL,NULL))&1)) {
1039 end = rstr + (unsigned long int) *rslt;
1040 if (!hasver) while (*end != ';') end--;
1041 *(end++) = '\n'; *end = '\0';
1042 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1043 if (hasdir) {
271c2963 1044 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
a0d0e21e 1045 begin = rstr;
1046 }
1047 else {
1048 begin = end;
1049 while (*(--begin) != ']' && *begin != '>') ;
1050 ++begin;
1051 }
760ac839 1052 ok = (PerlIO_puts(tmpfp,begin) != EOF);
a0d0e21e 1053 }
1054 if (cxt) (void)lib$find_file_end(&cxt);
748a9306 1055 if (ok && sts != RMS$_NMF &&
1056 sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
a0d0e21e 1057 if (!ok) {
c07a80fd 1058 if (!(sts & 1)) {
1059 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1060 }
760ac839 1061 PerlIO_close(tmpfp);
a0d0e21e 1062 fp = NULL;
1063 }
1064 else {
760ac839 1065 PerlIO_rewind(tmpfp);
a0d0e21e 1066 IoTYPE(io) = '<';
1067 IoIFP(io) = fp = tmpfp;
1068 }
1069 }
1070 }
1071#else /* !VMS */
1072#ifdef DOSISH
67955e0c 1073#ifdef OS2
1074 sv_setpv(tmpcmd, "for a in ");
1075 sv_catsv(tmpcmd, tmpglob);
1076 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1077#else
a0d0e21e 1078 sv_setpv(tmpcmd, "perlglob ");
1079 sv_catsv(tmpcmd, tmpglob);
1080 sv_catpv(tmpcmd, " |");
67955e0c 1081#endif /* !OS2 */
1082#else /* !DOSISH */
1083#if defined(CSH)
a0d0e21e 1084 sv_setpvn(tmpcmd, cshname, cshlen);
1085 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1086 sv_catsv(tmpcmd, tmpglob);
16d20bd9 1087 sv_catpv(tmpcmd, "' 2>/dev/null |");
a0d0e21e 1088#else
1089 sv_setpv(tmpcmd, "echo ");
1090 sv_catsv(tmpcmd, tmpglob);
1091#if 'z' - 'a' == 25
1092 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1093#else
1094 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1095#endif
1096#endif /* !CSH */
67955e0c 1097#endif /* !DOSISH */
c07a80fd 1098 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1099 FALSE, 0, 0, Nullfp);
a0d0e21e 1100 fp = IoIFP(io);
1101#endif /* !VMS */
1102 LEAVE;
1103 }
1104 }
1105 else if (type == OP_GLOB)
1106 SP--;
1107 }
1108 if (!fp) {
4633a7c4 1109 if (dowarn && io && !(IoFLAGS(io) & IOf_START))
a0d0e21e 1110 warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
1111 if (GIMME == G_SCALAR) {
1112 (void)SvOK_off(TARG);
1113 PUSHTARG;
1114 }
1115 RETURN;
1116 }
1117 if (GIMME == G_ARRAY) {
1118 sv = sv_2mortal(NEWSV(57, 80));
1119 offset = 0;
1120 }
1121 else {
1122 sv = TARG;
1123 (void)SvUPGRADE(sv, SVt_PV);
1124 tmplen = SvLEN(sv); /* remember if already alloced */
1125 if (!tmplen)
1126 Sv_Grow(sv, 80); /* try short-buffering it */
1127 if (type == OP_RCATLINE)
1128 offset = SvCUR(sv);
1129 else
1130 offset = 0;
1131 }
1132 for (;;) {
1133 if (!sv_gets(sv, fp, offset)) {
760ac839 1134 PerlIO_clearerr(fp);
a0d0e21e 1135 if (IoFLAGS(io) & IOf_ARGV) {
1136 fp = nextargv(last_in_gv);
1137 if (fp)
1138 continue;
1139 (void)do_close(last_in_gv, FALSE);
1140 IoFLAGS(io) |= IOf_START;
1141 }
1142 else if (type == OP_GLOB) {
1143 (void)do_close(last_in_gv, FALSE);
1144 }
1145 if (GIMME == G_SCALAR) {
1146 (void)SvOK_off(TARG);
1147 PUSHTARG;
1148 }
1149 RETURN;
1150 }
bbce6d69 1151 /* This should not be marked tainted if the fp is marked clean */
1152 if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1153 TAINT;
1154 SvTAINTED_on(sv);
1155 }
a0d0e21e 1156 IoLINES(io)++;
1157 XPUSHs(sv);
a0d0e21e 1158 if (type == OP_GLOB) {
1159 char *tmps;
1160
c07a80fd 1161 if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
1162 tmps = SvEND(sv) - 1;
1163 if (*tmps == *SvPVX(rs)) {
1164 *tmps = '\0';
1165 SvCUR(sv)--;
1166 }
1167 }
a0d0e21e 1168 for (tmps = SvPVX(sv); *tmps; tmps++)
1169 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1170 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1171 break;
1172 if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
1173 (void)POPs; /* Unmatched wildcard? Chuck it... */
1174 continue;
1175 }
1176 }
1177 if (GIMME == G_ARRAY) {
1178 if (SvLEN(sv) - SvCUR(sv) > 20) {
1179 SvLEN_set(sv, SvCUR(sv)+1);
1180 Renew(SvPVX(sv), SvLEN(sv), char);
1181 }
1182 sv = sv_2mortal(NEWSV(58, 80));
1183 continue;
1184 }
1185 else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1186 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1187 if (SvCUR(sv) < 60)
1188 SvLEN_set(sv, 80);
1189 else
1190 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1191 Renew(SvPVX(sv), SvLEN(sv), char);
1192 }
1193 RETURN;
1194 }
1195}
1196
1197PP(pp_enter)
1198{
1199 dSP;
1200 register CONTEXT *cx;
1201 I32 gimme;
1202
1203 /*
1204 * We don't just use the GIMME macro here because it assumes there's
1205 * already a context, which ain't necessarily so at initial startup.
1206 */
1207
1208 if (op->op_flags & OPf_KNOW)
1209 gimme = op->op_flags & OPf_LIST;
1210 else if (cxstack_ix >= 0)
1211 gimme = cxstack[cxstack_ix].blk_gimme;
1212 else
1213 gimme = G_SCALAR;
1214
1215 ENTER;
1216
1217 SAVETMPS;
1218 PUSHBLOCK(cx, CXt_BLOCK, sp);
1219
1220 RETURN;
1221}
1222
1223PP(pp_helem)
1224{
1225 dSP;
760ac839 1226 HE* he;
a0d0e21e 1227 SV *keysv = POPs;
a0d0e21e 1228 HV *hv = (HV*)POPs;
1229 I32 lval = op->op_flags & OPf_MOD;
1230
1231 if (SvTYPE(hv) != SVt_PVHV)
1232 RETPUSHUNDEF;
760ac839 1233 he = hv_fetch_ent(hv, keysv, lval, 0);
a0d0e21e 1234 if (lval) {
760ac839 1235 if (!he || HeVAL(he) == &sv_undef)
1236 DIE(no_helem, SvPV(keysv, na));
a0d0e21e 1237 if (op->op_private & OPpLVAL_INTRO)
760ac839 1238 save_svref(&HeVAL(he));
02a9e968 1239 else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
760ac839 1240 provide_ref(op, HeVAL(he));
a0d0e21e 1241 }
760ac839 1242 PUSHs(he ? HeVAL(he) : &sv_undef);
a0d0e21e 1243 RETURN;
1244}
1245
1246PP(pp_leave)
1247{
1248 dSP;
1249 register CONTEXT *cx;
1250 register SV **mark;
1251 SV **newsp;
1252 PMOP *newpm;
1253 I32 gimme;
1254
1255 if (op->op_flags & OPf_SPECIAL) {
1256 cx = &cxstack[cxstack_ix];
1257 cx->blk_oldpm = curpm; /* fake block should preserve $1 et al */
1258 }
1259
1260 POPBLOCK(cx,newpm);
1261
1262 if (op->op_flags & OPf_KNOW)
1263 gimme = op->op_flags & OPf_LIST;
1264 else if (cxstack_ix >= 0)
1265 gimme = cxstack[cxstack_ix].blk_gimme;
1266 else
1267 gimme = G_SCALAR;
1268
1269 if (gimme == G_SCALAR) {
1270 if (op->op_private & OPpLEAVE_VOID)
1271 SP = newsp;
1272 else {
1273 MARK = newsp + 1;
1274 if (MARK <= SP)
1275 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1276 *MARK = TOPs;
1277 else
1278 *MARK = sv_mortalcopy(TOPs);
1279 else {
1280 MEXTEND(mark,0);
1281 *MARK = &sv_undef;
1282 }
1283 SP = MARK;
1284 }
1285 }
1286 else {
1287 for (mark = newsp + 1; mark <= SP; mark++)
1288 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
1289 *mark = sv_mortalcopy(*mark);
1290 /* in case LEAVE wipes old return values */
1291 }
1292 curpm = newpm; /* Don't pop $1 et al till now */
1293
1294 LEAVE;
1295
1296 RETURN;
1297}
1298
1299PP(pp_iter)
1300{
1301 dSP;
1302 register CONTEXT *cx;
1303 SV *sv;
4633a7c4 1304 AV* av;
a0d0e21e 1305
1306 EXTEND(sp, 1);
1307 cx = &cxstack[cxstack_ix];
1308 if (cx->cx_type != CXt_LOOP)
1309 DIE("panic: pp_iter");
4633a7c4 1310 av = cx->blk_loop.iterary;
67955e0c 1311 if (av == curstack && cx->blk_loop.iterix >= cx->blk_oldsp)
4633a7c4 1312 RETPUSHNO;
a0d0e21e 1313
4633a7c4 1314 if (cx->blk_loop.iterix >= AvFILL(av))
a0d0e21e 1315 RETPUSHNO;
1316
4633a7c4 1317 if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) {
a0d0e21e 1318 SvTEMP_off(sv);
1319 *cx->blk_loop.itervar = sv;
1320 }
1321 else
1322 *cx->blk_loop.itervar = &sv_undef;
1323
1324 RETPUSHYES;
1325}
1326
1327PP(pp_subst)
1328{
1329 dSP; dTARG;
1330 register PMOP *pm = cPMOP;
1331 PMOP *rpm = pm;
1332 register SV *dstr;
1333 register char *s;
1334 char *strend;
1335 register char *m;
1336 char *c;
1337 register char *d;
1338 STRLEN clen;
1339 I32 iters = 0;
1340 I32 maxiters;
1341 register I32 i;
1342 bool once;
1343 char *orig;
1344 I32 safebase;
1345 register REGEXP *rx = pm->op_pmregexp;
1346 STRLEN len;
1347 int force_on_match = 0;
4633a7c4 1348 I32 oldsave = savestack_ix;
a0d0e21e 1349
1350 if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
1351 dstr = POPs;
1352 if (op->op_flags & OPf_STACKED)
1353 TARG = POPs;
1354 else {
1355 TARG = GvSV(defgv);
1356 EXTEND(SP,1);
1357 }
1358 s = SvPV(TARG, len);
8e07c86e 1359 if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV))
a0d0e21e 1360 force_on_match = 1;
1361
1362 force_it:
1363 if (!pm || !s)
1364 DIE("panic: do_subst");
1365
1366 strend = s + len;
1367 maxiters = (strend - s) + 10;
1368
1369 if (!rx->prelen && curpm) {
1370 pm = curpm;
1371 rx = pm->op_pmregexp;
1372 }
1373 safebase = ((!rx || !rx->nparens) && !sawampersand);
1374 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1375 SAVEINT(multiline);
1376 multiline = pm->op_pmflags & PMf_MULTILINE;
1377 }
1378 orig = m = s;
1379 if (pm->op_pmshort) {
1380 if (pm->op_pmflags & PMf_SCANFIRST) {
1381 if (SvSCREAM(TARG)) {
1382 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
1383 goto nope;
1384 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
1385 goto nope;
1386 }
1387 else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
1388 pm->op_pmshort)))
1389 goto nope;
1390 if (s && rx->regback >= 0) {
1391 ++BmUSEFUL(pm->op_pmshort);
1392 s -= rx->regback;
1393 if (s < m)
1394 s = m;
1395 }
1396 else
1397 s = m;
1398 }
1399 else if (!multiline) {
bbce6d69 1400 if (*SvPVX(pm->op_pmshort) != *s
1401 || (pm->op_pmslen > 1
36477c24 1402 && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
bbce6d69 1403 goto nope;
a0d0e21e 1404 }
1405 if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
1406 SvREFCNT_dec(pm->op_pmshort);
1407 pm->op_pmshort = Nullsv; /* opt is being useless */
1408 }
1409 }
1410 once = !(rpm->op_pmflags & PMf_GLOBAL);
1411 if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
1412 c = SvPV(dstr, clen);
1413 if (clen <= rx->minlen) {
1414 /* can do inplace substitution */
e50aee73 1415 if (pregexec(rx, s, strend, orig, 0,
a0d0e21e 1416 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1417 if (force_on_match) {
1418 force_on_match = 0;
1419 s = SvPV_force(TARG, len);
1420 goto force_it;
1421 }
1422 if (rx->subbase) /* oops, no we can't */
1423 goto long_way;
1424 d = s;
1425 curpm = pm;
1426 SvSCREAM_off(TARG); /* disable possible screamer */
1427 if (once) {
1428 m = rx->startp[0];
1429 d = rx->endp[0];
1430 s = orig;
1431 if (m - s > strend - d) { /* faster to shorten from end */
1432 if (clen) {
1433 Copy(c, m, clen, char);
1434 m += clen;
1435 }
1436 i = strend - d;
1437 if (i > 0) {
1438 Move(d, m, i, char);
1439 m += i;
1440 }
1441 *m = '\0';
1442 SvCUR_set(TARG, m - s);
1443 (void)SvPOK_only(TARG);
1444 SvSETMAGIC(TARG);
1445 PUSHs(&sv_yes);
4633a7c4 1446 LEAVE_SCOPE(oldsave);
a0d0e21e 1447 RETURN;
1448 }
1449 /*SUPPRESS 560*/
1450 else if (i = m - s) { /* faster from front */
1451 d -= clen;
1452 m = d;
1453 sv_chop(TARG, d-i);
1454 s += i;
1455 while (i--)
1456 *--d = *--s;
1457 if (clen)
1458 Copy(c, m, clen, char);
1459 (void)SvPOK_only(TARG);
1460 SvSETMAGIC(TARG);
1461 PUSHs(&sv_yes);
4633a7c4 1462 LEAVE_SCOPE(oldsave);
a0d0e21e 1463 RETURN;
1464 }
1465 else if (clen) {
1466 d -= clen;
1467 sv_chop(TARG, d);
1468 Copy(c, d, clen, char);
1469 (void)SvPOK_only(TARG);
1470 SvSETMAGIC(TARG);
1471 PUSHs(&sv_yes);
4633a7c4 1472 LEAVE_SCOPE(oldsave);
a0d0e21e 1473 RETURN;
1474 }
1475 else {
1476 sv_chop(TARG, d);
1477 (void)SvPOK_only(TARG);
1478 SvSETMAGIC(TARG);
1479 PUSHs(&sv_yes);
4633a7c4 1480 LEAVE_SCOPE(oldsave);
a0d0e21e 1481 RETURN;
1482 }
1483 /* NOTREACHED */
1484 }
1485 do {
1486 if (iters++ > maxiters)
1487 DIE("Substitution loop");
1488 m = rx->startp[0];
1489 /*SUPPRESS 560*/
1490 if (i = m - s) {
1491 if (s != d)
1492 Move(s, d, i, char);
1493 d += i;
1494 }
1495 if (clen) {
1496 Copy(c, d, clen, char);
1497 d += clen;
1498 }
1499 s = rx->endp[0];
e50aee73 1500 } while (pregexec(rx, s, strend, orig, s == m,
a0d0e21e 1501 Nullsv, TRUE)); /* (don't match same null twice) */
1502 if (s != d) {
1503 i = strend - s;
1504 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1505 Move(s, d, i+1, char); /* include the Null */
1506 }
1507 (void)SvPOK_only(TARG);
1508 SvSETMAGIC(TARG);
1509 PUSHs(sv_2mortal(newSViv((I32)iters)));
4633a7c4 1510 LEAVE_SCOPE(oldsave);
a0d0e21e 1511 RETURN;
1512 }
1513 PUSHs(&sv_no);
4633a7c4 1514 LEAVE_SCOPE(oldsave);
a0d0e21e 1515 RETURN;
1516 }
1517 }
1518 else
1519 c = Nullch;
e50aee73 1520 if (pregexec(rx, s, strend, orig, 0,
a0d0e21e 1521 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1522 long_way:
1523 if (force_on_match) {
1524 force_on_match = 0;
1525 s = SvPV_force(TARG, len);
1526 goto force_it;
1527 }
1528 dstr = NEWSV(25, sv_len(TARG));
1529 sv_setpvn(dstr, m, s-m);
1530 curpm = pm;
1531 if (!c) {
1532 register CONTEXT *cx;
1533 PUSHSUBST(cx);
1534 RETURNOP(cPMOP->op_pmreplroot);
1535 }
1536 do {
1537 if (iters++ > maxiters)
1538 DIE("Substitution loop");
1539 if (rx->subbase && rx->subbase != orig) {
1540 m = s;
1541 s = orig;
1542 orig = rx->subbase;
1543 s = orig + (m - s);
1544 strend = s + (strend - m);
1545 }
1546 m = rx->startp[0];
1547 sv_catpvn(dstr, s, m-s);
1548 s = rx->endp[0];
1549 if (clen)
1550 sv_catpvn(dstr, c, clen);
1551 if (once)
1552 break;
e50aee73 1553 } while (pregexec(rx, s, strend, orig, s == m, Nullsv,
a0d0e21e 1554 safebase));
1555 sv_catpvn(dstr, s, strend - s);
748a9306 1556
4633a7c4 1557 (void)SvOOK_off(TARG);
cb0b1708 1558 Safefree(SvPVX(TARG));
748a9306 1559 SvPVX(TARG) = SvPVX(dstr);
1560 SvCUR_set(TARG, SvCUR(dstr));
1561 SvLEN_set(TARG, SvLEN(dstr));
1562 SvPVX(dstr) = 0;
1563 sv_free(dstr);
1564
a0d0e21e 1565 (void)SvPOK_only(TARG);
1566 SvSETMAGIC(TARG);
1567 PUSHs(sv_2mortal(newSViv((I32)iters)));
4633a7c4 1568 LEAVE_SCOPE(oldsave);
a0d0e21e 1569 RETURN;
1570 }
1571 PUSHs(&sv_no);
4633a7c4 1572 LEAVE_SCOPE(oldsave);
a0d0e21e 1573 RETURN;
1574
1575nope:
1576 ++BmUSEFUL(pm->op_pmshort);
1577 PUSHs(&sv_no);
4633a7c4 1578 LEAVE_SCOPE(oldsave);
a0d0e21e 1579 RETURN;
1580}
1581
1582PP(pp_grepwhile)
1583{
1584 dSP;
1585
1586 if (SvTRUEx(POPs))
1587 stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
1588 ++*markstack_ptr;
1589 LEAVE; /* exit inner scope */
1590
1591 /* All done yet? */
1592 if (stack_base + *markstack_ptr > sp) {
1593 I32 items;
1594
1595 LEAVE; /* exit outer scope */
1596 (void)POPMARK; /* pop src */
1597 items = --*markstack_ptr - markstack_ptr[-1];
1598 (void)POPMARK; /* pop dst */
1599 SP = stack_base + POPMARK; /* pop original mark */
1600 if (GIMME != G_ARRAY) {
1601 dTARGET;
1602 XPUSHi(items);
1603 RETURN;
1604 }
1605 SP += items;
1606 RETURN;
1607 }
1608 else {
1609 SV *src;
1610
1611 ENTER; /* enter inner scope */
1612 SAVESPTR(curpm);
1613
1614 src = stack_base[*markstack_ptr];
1615 SvTEMP_off(src);
1616 GvSV(defgv) = src;
1617
1618 RETURNOP(cLOGOP->op_other);
1619 }
1620}
1621
1622PP(pp_leavesub)
1623{
1624 dSP;
1625 SV **mark;
1626 SV **newsp;
1627 PMOP *newpm;
1628 I32 gimme;
1629 register CONTEXT *cx;
1630
1631 POPBLOCK(cx,newpm);
1632 POPSUB(cx);
1633
1634 if (gimme == G_SCALAR) {
1635 MARK = newsp + 1;
1636 if (MARK <= SP)
1637 if (SvFLAGS(TOPs) & SVs_TEMP)
1638 *MARK = TOPs;
1639 else
1640 *MARK = sv_mortalcopy(TOPs);
1641 else {
1642 MEXTEND(mark,0);
1643 *MARK = &sv_undef;
1644 }
1645 SP = MARK;
1646 }
1647 else {
1648 for (mark = newsp + 1; mark <= SP; mark++)
1649 if (!(SvFLAGS(*mark) & SVs_TEMP))
1650 *mark = sv_mortalcopy(*mark);
1651 /* in case LEAVE wipes old return values */
1652 }
1653
1654 if (cx->blk_sub.hasargs) { /* You don't exist; go away. */
1655 AV* av = cx->blk_sub.argarray;
1656
1657 av_clear(av);
1658 AvREAL_off(av);
1659 }
1660 curpm = newpm; /* Don't pop $1 et al till now */
1661
1662 LEAVE;
1663 PUTBACK;
1664 return pop_return();
1665}
1666
1667PP(pp_entersub)
1668{
1669 dSP; dPOPss;
1670 GV *gv;
1671 HV *stash;
1672 register CV *cv;
1673 register CONTEXT *cx;
5d94fbed 1674 I32 gimme;
67955e0c 1675 I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
a0d0e21e 1676
1677 if (!sv)
1678 DIE("Not a CODE reference");
1679 switch (SvTYPE(sv)) {
1680 default:
1681 if (!SvROK(sv)) {
748a9306 1682 char *sym;
1683
a0d0e21e 1684 if (sv == &sv_yes) /* unfound import, ignore */
1685 RETURN;
1686 if (!SvOK(sv))
1687 DIE(no_usym, "a subroutine");
748a9306 1688 sym = SvPV(sv,na);
a0d0e21e 1689 if (op->op_private & HINT_STRICT_REFS)
748a9306 1690 DIE(no_symref, sym, "a subroutine");
1691 cv = perl_get_cv(sym, TRUE);
a0d0e21e 1692 break;
1693 }
1694 cv = (CV*)SvRV(sv);
1695 if (SvTYPE(cv) == SVt_PVCV)
1696 break;
1697 /* FALL THROUGH */
1698 case SVt_PVHV:
1699 case SVt_PVAV:
1700 DIE("Not a CODE reference");
1701 case SVt_PVCV:
1702 cv = (CV*)sv;
1703 break;
1704 case SVt_PVGV:
1705 if (!(cv = GvCV((GV*)sv)))
1706 cv = sv_2cv(sv, &stash, &gv, TRUE);
1707 break;
1708 }
1709
1710 ENTER;
1711 SAVETMPS;
1712
1713 retry:
1714 if (!cv)
1715 DIE("Not a CODE reference");
1716
1717 if (!CvROOT(cv) && !CvXSUB(cv)) {
1718 if (gv = CvGV(cv)) {
4633a7c4 1719 SV *tmpstr;
a0d0e21e 1720 GV *ngv;
4633a7c4 1721 if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */
1722 cv = GvCV(gv);
1723 if (SvTYPE(sv) == SVt_PVGV) {
1724 SvREFCNT_dec(GvCV((GV*)sv));
1725 GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv);
1726 }
1727 goto retry;
1728 }
1729 tmpstr = sv_newmortal();
4f732624 1730 gv_efullname3(tmpstr, gv, Nullch);
a0d0e21e 1731 ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
1732 if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
1733 gv = ngv;
1734 sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */
bbce6d69 1735 SvTAINTED_off(GvSV(CvGV(cv)));
a0d0e21e 1736 goto retry;
1737 }
1738 else
1739 DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
1740 }
1741 DIE("Undefined subroutine called");
1742 }
1743
4633a7c4 1744 gimme = GIMME;
67955e0c 1745 if ((op->op_private & OPpENTERSUB_DB)) {
a0d0e21e 1746 sv = GvSV(DBsub);
1747 save_item(sv);
67955e0c 1748 gv = CvGV(cv);
1749 if ( CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)
1750 || strEQ(GvNAME(gv), "END") ) {
a5f75d66 1751 /* GV is potentially non-unique */
748a9306 1752 sv_setsv(sv, newRV((SV*)cv));
a5f75d66 1753 }
748a9306 1754 else {
4f732624 1755 gv_efullname3(sv, gv, Nullch);
748a9306 1756 }
a0d0e21e 1757 cv = GvCV(DBsub);
67955e0c 1758 if (CvXSUB(cv)) curcopdb = curcop;
a0d0e21e 1759 if (!cv)
1760 DIE("No DBsub routine");
1761 }
1762
1763 if (CvXSUB(cv)) {
1764 if (CvOLDSTYLE(cv)) {
ecfc5424 1765 I32 (*fp3)_((int,int,int));
a0d0e21e 1766 dMARK;
1767 register I32 items = SP - MARK;
67955e0c 1768 /* We dont worry to copy from @_. */
a0d0e21e 1769 while (sp > mark) {
1770 sp[1] = sp[0];
1771 sp--;
1772 }
1773 stack_sp = mark + 1;
ecfc5424 1774 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1775 items = (*fp3)(CvXSUBANY(cv).any_i32,
1776 MARK - stack_base + 1,
1777 items);
a0d0e21e 1778 stack_sp = stack_base + items;
1779 }
1780 else {
748a9306 1781 I32 markix = TOPMARK;
1782
a0d0e21e 1783 PUTBACK;
67955e0c 1784
1785 if (!hasargs) {
1786 /* Need to copy @_ to stack. Alternative may be to
1787 * switch stack to @_, and copy return values
1788 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
1789 AV* av = GvAV(defgv);
1790 I32 items = AvFILL(av) + 1;
1791
1792 if (items) {
1793 /* Mark is at the end of the stack. */
1794 EXTEND(sp, items);
1795 Copy(AvARRAY(av), sp + 1, items, SV*);
1796 sp += items;
1797 PUTBACK ;
1798 }
1799 }
1800 if (curcopdb) { /* We assume that the first
1801 XSUB in &DB::sub is the
1802 called one. */
1803 SAVESPTR(curcop);
1804 curcop = curcopdb;
1805 curcopdb = NULL;
1806 }
1807 /* Do we need to open block here? XXXX */
a0d0e21e 1808 (void)(*CvXSUB(cv))(cv);
748a9306 1809
1810 /* Enforce some sanity in scalar context. */
5d94fbed 1811 if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
748a9306 1812 if (markix > stack_sp - stack_base)
1813 *(stack_base + markix) = &sv_undef;
1814 else
1815 *(stack_base + markix) = *stack_sp;
1816 stack_sp = stack_base + markix;
1817 }
a0d0e21e 1818 }
1819 LEAVE;
1820 return NORMAL;
1821 }
1822 else {
1823 dMARK;
1824 register I32 items = SP - MARK;
a0d0e21e 1825 AV* padlist = CvPADLIST(cv);
1826 SV** svp = AvARRAY(padlist);
1827 push_return(op->op_next);
1828 PUSHBLOCK(cx, CXt_SUB, MARK);
1829 PUSHSUB(cx);
1830 CvDEPTH(cv)++;
1831 if (CvDEPTH(cv) < 2)
1832 (void)SvREFCNT_inc(cv);
1833 else { /* save temporaries on recursion? */
1834 if (CvDEPTH(cv) == 100 && dowarn)
1835 warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
1836 if (CvDEPTH(cv) > AvFILL(padlist)) {
1837 AV *av;
1838 AV *newpad = newAV();
4aa0a1f7 1839 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
a0d0e21e 1840 I32 ix = AvFILL((AV*)svp[1]);
1841 svp = AvARRAY(svp[0]);
748a9306 1842 for ( ;ix > 0; ix--) {
a0d0e21e 1843 if (svp[ix] != &sv_undef) {
748a9306 1844 char *name = SvPVX(svp[ix]);
1845 if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */
1846 av_store(newpad, ix,
4aa0a1f7 1847 SvREFCNT_inc(oldpad[ix]) );
748a9306 1848 }
1849 else { /* our own lexical */
1850 if (*name == '@')
1851 av_store(newpad, ix, sv = (SV*)newAV());
1852 else if (*name == '%')
1853 av_store(newpad, ix, sv = (SV*)newHV());
1854 else
1855 av_store(newpad, ix, sv = NEWSV(0,0));
1856 SvPADMY_on(sv);
1857 }
a0d0e21e 1858 }
1859 else {
748a9306 1860 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e 1861 SvPADTMP_on(sv);
1862 }
1863 }
1864 av = newAV(); /* will be @_ */
1865 av_extend(av, 0);
1866 av_store(newpad, 0, (SV*)av);
1867 AvFLAGS(av) = AVf_REIFY;
1868 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1869 AvFILL(padlist) = CvDEPTH(cv);
1870 svp = AvARRAY(padlist);
1871 }
1872 }
1873 SAVESPTR(curpad);
1874 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1875 if (hasargs) {
1876 AV* av = (AV*)curpad[0];
1877 SV** ary;
1878
1879 if (AvREAL(av)) {
1880 av_clear(av);
1881 AvREAL_off(av);
1882 }
1883 cx->blk_sub.savearray = GvAV(defgv);
1884 cx->blk_sub.argarray = av;
1885 GvAV(defgv) = cx->blk_sub.argarray;
1886 ++MARK;
1887
1888 if (items > AvMAX(av) + 1) {
1889 ary = AvALLOC(av);
1890 if (AvARRAY(av) != ary) {
1891 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1892 SvPVX(av) = (char*)ary;
1893 }
1894 if (items > AvMAX(av) + 1) {
1895 AvMAX(av) = items - 1;
1896 Renew(ary,items,SV*);
1897 AvALLOC(av) = ary;
1898 SvPVX(av) = (char*)ary;
1899 }
1900 }
1901 Copy(MARK,AvARRAY(av),items,SV*);
1902 AvFILL(av) = items - 1;
1903
1904 while (items--) {
1905 if (*MARK)
1906 SvTEMP_off(*MARK);
1907 MARK++;
1908 }
1909 }
1910 RETURNOP(CvSTART(cv));
1911 }
1912}
1913
1914PP(pp_aelem)
1915{
1916 dSP;
1917 SV** svp;
748a9306 1918 I32 elem = POPi;
a0d0e21e 1919 AV *av = (AV*)POPs;
1920 I32 lval = op->op_flags & OPf_MOD;
1921
748a9306 1922 if (elem > 0)
1923 elem -= curcop->cop_arybase;
a0d0e21e 1924 if (SvTYPE(av) != SVt_PVAV)
1925 RETPUSHUNDEF;
1926 svp = av_fetch(av, elem, lval);
1927 if (lval) {
1928 if (!svp || *svp == &sv_undef)
1929 DIE(no_aelem, elem);
1930 if (op->op_private & OPpLVAL_INTRO)
1931 save_svref(svp);
02a9e968 1932 else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
1933 provide_ref(op, *svp);
a0d0e21e 1934 }
1935 PUSHs(svp ? *svp : &sv_undef);
1936 RETURN;
1937}
1938
02a9e968 1939void
1940provide_ref(op, sv)
1941OP* op;
1942SV* sv;
1943{
1944 if (SvGMAGICAL(sv))
1945 mg_get(sv);
1946 if (!SvOK(sv)) {
1947 if (SvREADONLY(sv))
1948 croak(no_modify);
1949 (void)SvUPGRADE(sv, SVt_RV);
1950 SvRV(sv) = (op->op_private & OPpDEREF_HV ?
1951 (SV*)newHV() : (SV*)newAV());
1952 SvROK_on(sv);
1953 SvSETMAGIC(sv);
1954 }
1955}
1956
a0d0e21e 1957PP(pp_method)
1958{
1959 dSP;
1960 SV* sv;
1961 SV* ob;
1962 GV* gv;
1963 SV* nm;
1964
1965 nm = TOPs;
1966 sv = *(stack_base + TOPMARK + 1);
1967
1968 gv = 0;
16d20bd9 1969 if (SvGMAGICAL(sv))
1970 mg_get(sv);
a0d0e21e 1971 if (SvROK(sv))
16d20bd9 1972 ob = (SV*)SvRV(sv);
a0d0e21e 1973 else {
1974 GV* iogv;
1975 char* packname = 0;
67955e0c 1976 STRLEN packlen;
a0d0e21e 1977
1978 if (!SvOK(sv) ||
67955e0c 1979 !(packname = SvPV(sv, packlen)) ||
a0d0e21e 1980 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
1981 !(ob=(SV*)GvIO(iogv)))
1982 {
1983 char *name = SvPV(nm, na);
1984 HV *stash;
1985 if (!packname || !isALPHA(*packname))
1986DIE("Can't call method \"%s\" without a package or object reference", name);
67955e0c 1987 if (!(stash = gv_stashpvn(packname, packlen, FALSE))) {
1988 if (gv_stashpvn("UNIVERSAL", 9, FALSE))
1989 stash = gv_stashpvn(packname, packlen, TRUE);
a0d0e21e 1990 else
1991 DIE("Can't call method \"%s\" in empty package \"%s\"",
1992 name, packname);
1993 }
1994 gv = gv_fetchmethod(stash,name);
1995 if (!gv)
1996 DIE("Can't locate object method \"%s\" via package \"%s\"",
1997 name, packname);
67955e0c 1998 SETs((SV*)gv);
a0d0e21e 1999 RETURN;
2000 }
67955e0c 2001 *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e 2002 }
2003
2004 if (!ob || !SvOBJECT(ob)) {
2005 char *name = SvPV(nm, na);
2006 DIE("Can't call method \"%s\" on unblessed reference", name);
2007 }
2008
2009 if (!gv) { /* nothing cached */
2010 char *name = SvPV(nm, na);
2011 gv = gv_fetchmethod(SvSTASH(ob),name);
2012 if (!gv)
2013 DIE("Can't locate object method \"%s\" via package \"%s\"",
2014 name, HvNAME(SvSTASH(ob)));
2015 }
2016
67955e0c 2017 SETs((SV*)gv);
a0d0e21e 2018 RETURN;
2019}
2020