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