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