projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
bug in change#3602 (cpp conditionals not allowed inside macro args)
[p5sagit/p5-mst-13.2.git] / pp_hot.c
CommitLineData
a0d0e21e 1/* pp_hot.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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"
864dbfa3 19#define PERL_IN_PP_HOT_C
a0d0e21e 20#include "perl.h"
21
8ac85365 22#ifdef I_UNISTD
23#include <unistd.h>
24#endif
9d116dd7 25#ifdef I_FCNTL
26#include <fcntl.h>
27#endif
28#ifdef I_SYS_FILE
29#include <sys/file.h>
30#endif
8ac85365 31
a0ed51b3 32#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
33
a0d0e21e 34/* Hot code. */
35
11343788 36#ifdef USE_THREADS
864dbfa3 37STATIC void
cea2e8a9 38S_unset_cvowner(pTHX_ void *cvarg)
11343788 39{
40 register CV* cv = (CV *) cvarg;
41#ifdef DEBUGGING
42 dTHR;
43#endif /* DEBUGGING */
44
8b73bbec 45 DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
1fd28e87 46 thr, cv, SvPEEK((SV*)cv))));
11343788 47 MUTEX_LOCK(CvMUTEXP(cv));
8b73bbec 48 DEBUG_S(if (CvDEPTH(cv) != 0)
77a005ab 49 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
50 CvDEPTH(cv)););
11343788 51 assert(thr == CvOWNER(cv));
52 CvOWNER(cv) = 0;
11343788 53 MUTEX_UNLOCK(CvMUTEXP(cv));
54 SvREFCNT_dec(cv);
55}
11343788 56#endif /* USE_THREADS */
57
a0d0e21e 58PP(pp_const)
59{
4e35701f 60 djSP;
a0d0e21e 61 XPUSHs(cSVOP->op_sv);
62 RETURN;
63}
64
65PP(pp_nextstate)
66{
533c011a 67 PL_curcop = (COP*)PL_op;
a0d0e21e 68 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 69 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 70 FREETMPS;
71 return NORMAL;
72}
73
74PP(pp_gvsv)
75{
4e35701f 76 djSP;
924508f0 77 EXTEND(SP,1);
533c011a 78 if (PL_op->op_private & OPpLVAL_INTRO)
a0d0e21e 79 PUSHs(save_scalar(cGVOP->op_gv));
80 else
81 PUSHs(GvSV(cGVOP->op_gv));
82 RETURN;
83}
84
85PP(pp_null)
86{
87 return NORMAL;
88}
89
90PP(pp_pushmark)
91{
3280af22 92 PUSHMARK(PL_stack_sp);
a0d0e21e 93 return NORMAL;
94}
95
96PP(pp_stringify)
97{
4e35701f 98 djSP; dTARGET;
a0d0e21e 99 STRLEN len;
100 char *s;
101 s = SvPV(TOPs,len);
102 sv_setpvn(TARG,s,len);
103 SETTARG;
104 RETURN;
105}
106
107PP(pp_gv)
108{
4e35701f 109 djSP;
a0d0e21e 110 XPUSHs((SV*)cGVOP->op_gv);
111 RETURN;
112}
113
114PP(pp_and)
115{
4e35701f 116 djSP;
a0d0e21e 117 if (!SvTRUE(TOPs))
118 RETURN;
119 else {
120 --SP;
121 RETURNOP(cLOGOP->op_other);
122 }
123}
124
125PP(pp_sassign)
126{
4e35701f 127 djSP; dPOPTOPssrl;
748a9306 128 MAGIC *mg;
129
533c011a 130 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
a0d0e21e 131 SV *temp;
132 temp = left; left = right; right = temp;
133 }
3280af22 134 if (PL_tainting && PL_tainted && !SvTAINTED(left))
a0d0e21e 135 TAINT_NOT;
54310121 136 SvSetMagicSV(right, left);
a0d0e21e 137 SETs(right);
138 RETURN;
139}
140
141PP(pp_cond_expr)
142{
4e35701f 143 djSP;
a0d0e21e 144 if (SvTRUEx(POPs))
145 RETURNOP(cCONDOP->op_true);
146 else
147 RETURNOP(cCONDOP->op_false);
148}
149
150PP(pp_unstack)
151{
152 I32 oldsave;
153 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 154 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 155 FREETMPS;
3280af22 156 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 157 LEAVE_SCOPE(oldsave);
158 return NORMAL;
159}
160
a0d0e21e 161PP(pp_concat)
162{
4e35701f 163 djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
748a9306 164 {
165 dPOPTOPssrl;
a0d0e21e 166 STRLEN len;
167 char *s;
168 if (TARG != left) {
169 s = SvPV(left,len);
170 sv_setpvn(TARG,s,len);
171 }
c07a80fd 172 else if (SvGMAGICAL(TARG))
173 mg_get(TARG);
7a4c00b4 174 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
748a9306 175 sv_setpv(TARG, ""); /* Suppress warning. */
7a4c00b4 176 s = SvPV_force(TARG, len);
4633a7c4 177 }
a0d0e21e 178 s = SvPV(right,len);
68dc0745 179 if (SvOK(TARG))
180 sv_catpvn(TARG,s,len);
181 else
182 sv_setpvn(TARG,s,len); /* suppress warning */
a0d0e21e 183 SETTARG;
184 RETURN;
748a9306 185 }
a0d0e21e 186}
187
188PP(pp_padsv)
189{
4e35701f 190 djSP; dTARGET;
a0d0e21e 191 XPUSHs(TARG);
533c011a 192 if (PL_op->op_flags & OPf_MOD) {
193 if (PL_op->op_private & OPpLVAL_INTRO)
194 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
195 else if (PL_op->op_private & OPpDEREF) {
8ec5e241 196 PUTBACK;
533c011a 197 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
8ec5e241 198 SPAGAIN;
199 }
4633a7c4 200 }
a0d0e21e 201 RETURN;
202}
203
204PP(pp_readline)
205{
f5284f61 206 tryAMAGICunTARGET(iter, 0);
3280af22 207 PL_last_in_gv = (GV*)(*PL_stack_sp--);
8efb3254 208 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
209 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
f5284f61 210 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
8efb3254 211 else {
f5284f61 212 dSP;
213 XPUSHs((SV*)PL_last_in_gv);
214 PUTBACK;
cea2e8a9 215 pp_rv2gv();
f5284f61 216 PL_last_in_gv = (GV*)(*PL_stack_sp--);
f5284f61 217 }
218 }
a0d0e21e 219 return do_readline();
220}
221
222PP(pp_eq)
223{
4e35701f 224 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e 225 {
226 dPOPnv;
54310121 227 SETs(boolSV(TOPn == value));
a0d0e21e 228 RETURN;
229 }
230}
231
232PP(pp_preinc)
233{
4e35701f 234 djSP;
68dc0745 235 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
cea2e8a9 236 Perl_croak(aTHX_ PL_no_modify);
25da4f38 237 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 238 SvIVX(TOPs) != IV_MAX)
239 {
748a9306 240 ++SvIVX(TOPs);
55497cff 241 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 242 }
243 else
244 sv_inc(TOPs);
a0d0e21e 245 SvSETMAGIC(TOPs);
246 return NORMAL;
247}
248
249PP(pp_or)
250{
4e35701f 251 djSP;
a0d0e21e 252 if (SvTRUE(TOPs))
253 RETURN;
254 else {
255 --SP;
256 RETURNOP(cLOGOP->op_other);
257 }
258}
259
260PP(pp_add)
261{
4e35701f 262 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 263 {
7a4c00b4 264 dPOPTOPnnrl_ul;
a0d0e21e 265 SETn( left + right );
266 RETURN;
267 }
268}
269
270PP(pp_aelemfast)
271{
4e35701f 272 djSP;
a0d0e21e 273 AV *av = GvAV((GV*)cSVOP->op_sv);
533c011a 274 U32 lval = PL_op->op_flags & OPf_MOD;
275 SV** svp = av_fetch(av, PL_op->op_private, lval);
3280af22 276 SV *sv = (svp ? *svp : &PL_sv_undef);
6ff81951 277 EXTEND(SP, 1);
be6c24e0 278 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
279 sv = sv_mortalcopy(sv);
280 PUSHs(sv);
a0d0e21e 281 RETURN;
282}
283
284PP(pp_join)
285{
4e35701f 286 djSP; dMARK; dTARGET;
a0d0e21e 287 MARK++;
288 do_join(TARG, *MARK, MARK, SP);
289 SP = MARK;
290 SETs(TARG);
291 RETURN;
292}
293
294PP(pp_pushre)
295{
4e35701f 296 djSP;
44a8e56a 297#ifdef DEBUGGING
298 /*
299 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
300 * will be enough to hold an OP*.
301 */
302 SV* sv = sv_newmortal();
303 sv_upgrade(sv, SVt_PVLV);
304 LvTYPE(sv) = '/';
533c011a 305 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a 306 XPUSHs(sv);
307#else
6b88bc9c 308 XPUSHs((SV*)PL_op);
44a8e56a 309#endif
a0d0e21e 310 RETURN;
311}
312
313/* Oversized hot code. */
314
315PP(pp_print)
316{
4e35701f 317 djSP; dMARK; dORIGMARK;
a0d0e21e 318 GV *gv;
319 IO *io;
760ac839 320 register PerlIO *fp;
236988e4 321 MAGIC *mg;
2d8e6c8d 322 STRLEN n_a;
a0d0e21e 323
533c011a 324 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 325 gv = (GV*)*++MARK;
326 else
3280af22 327 gv = PL_defoutgv;
33c27489 328 if (mg = SvTIED_mg((SV*)gv, 'q')) {
68dc0745 329 if (MARK == ORIGMARK) {
a60c0954 330 /* If using default handle then we need to make space to
331 * pass object as 1st arg, so move other args up ...
332 */
4352c267 333 MEXTEND(SP, 1);
68dc0745 334 ++MARK;
335 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
336 ++SP;
337 }
338 PUSHMARK(MARK - 1);
33c27489 339 *MARK = SvTIED_obj((SV*)gv, mg);
68dc0745 340 PUTBACK;
236988e4 341 ENTER;
864dbfa3 342 call_method("PRINT", G_SCALAR);
236988e4 343 LEAVE;
344 SPAGAIN;
68dc0745 345 MARK = ORIGMARK + 1;
346 *MARK = *SP;
347 SP = MARK;
236988e4 348 RETURN;
349 }
a0d0e21e 350 if (!(io = GvIO(gv))) {
599cee73 351 if (ckWARN(WARN_UNOPENED)) {
748a9306 352 SV* sv = sv_newmortal();
4f732624 353 gv_fullname3(sv, gv, Nullch);
cea2e8a9 354 Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306 355 }
356
357 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e 358 goto just_say_no;
359 }
360 else if (!(fp = IoOFP(io))) {
599cee73 361 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
748a9306 362 SV* sv = sv_newmortal();
4f732624 363 gv_fullname3(sv, gv, Nullch);
a0d0e21e 364 if (IoIFP(io))
cea2e8a9 365 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 366 SvPV(sv,n_a));
599cee73 367 else if (ckWARN(WARN_CLOSED))
cea2e8a9 368 Perl_warner(aTHX_ WARN_CLOSED, "print on closed filehandle %s",
2d8e6c8d 369 SvPV(sv,n_a));
a0d0e21e 370 }
748a9306 371 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e 372 goto just_say_no;
373 }
374 else {
375 MARK++;
3280af22 376 if (PL_ofslen) {
a0d0e21e 377 while (MARK <= SP) {
378 if (!do_print(*MARK, fp))
379 break;
380 MARK++;
381 if (MARK <= SP) {
3280af22 382 if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
a0d0e21e 383 MARK--;
384 break;
385 }
386 }
387 }
388 }
389 else {
390 while (MARK <= SP) {
391 if (!do_print(*MARK, fp))
392 break;
393 MARK++;
394 }
395 }
396 if (MARK <= SP)
397 goto just_say_no;
398 else {
3280af22 399 if (PL_orslen)
400 if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
a0d0e21e 401 goto just_say_no;
402
403 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 404 if (PerlIO_flush(fp) == EOF)
a0d0e21e 405 goto just_say_no;
406 }
407 }
408 SP = ORIGMARK;
3280af22 409 PUSHs(&PL_sv_yes);
a0d0e21e 410 RETURN;
411
412 just_say_no:
413 SP = ORIGMARK;
3280af22 414 PUSHs(&PL_sv_undef);
a0d0e21e 415 RETURN;
416}
417
418PP(pp_rv2av)
419{
f5284f61 420 djSP; dTOPss;
a0d0e21e 421 AV *av;
422
423 if (SvROK(sv)) {
424 wasref:
f5284f61 425 tryAMAGICunDEREF(to_av);
426
a0d0e21e 427 av = (AV*)SvRV(sv);
428 if (SvTYPE(av) != SVt_PVAV)
cea2e8a9 429 DIE(aTHX_ "Not an ARRAY reference");
533c011a 430 if (PL_op->op_flags & OPf_REF) {
f5284f61 431 SETs((SV*)av);
a0d0e21e 432 RETURN;
433 }
434 }
435 else {
436 if (SvTYPE(sv) == SVt_PVAV) {
437 av = (AV*)sv;
533c011a 438 if (PL_op->op_flags & OPf_REF) {
f5284f61 439 SETs((SV*)av);
a0d0e21e 440 RETURN;
441 }
442 }
443 else {
67955e0c 444 GV *gv;
445
a0d0e21e 446 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 447 char *sym;
2d8e6c8d 448 STRLEN n_a;
748a9306 449
a0d0e21e 450 if (SvGMAGICAL(sv)) {
451 mg_get(sv);
452 if (SvROK(sv))
453 goto wasref;
454 }
455 if (!SvOK(sv)) {
533c011a 456 if (PL_op->op_flags & OPf_REF ||
457 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 458 DIE(aTHX_ PL_no_usym, "an ARRAY");
599cee73 459 if (ckWARN(WARN_UNINITIALIZED))
cea2e8a9 460 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
f5284f61 461 if (GIMME == G_ARRAY) {
c2444246 462 (void)POPs;
4633a7c4 463 RETURN;
f5284f61 464 }
465 RETSETUNDEF;
a0d0e21e 466 }
2d8e6c8d 467 sym = SvPV(sv,n_a);
35cd451c 468 if ((PL_op->op_flags & OPf_SPECIAL) &&
469 !(PL_op->op_flags & OPf_MOD))
470 {
471 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
472 if (!gv)
473 RETSETUNDEF;
474 }
475 else {
476 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 477 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
35cd451c 478 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
479 }
480 }
481 else {
67955e0c 482 gv = (GV*)sv;
a0d0e21e 483 }
67955e0c 484 av = GvAVn(gv);
533c011a 485 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 486 av = save_ary(gv);
533c011a 487 if (PL_op->op_flags & OPf_REF) {
f5284f61 488 SETs((SV*)av);
a0d0e21e 489 RETURN;
490 }
491 }
492 }
493
494 if (GIMME == G_ARRAY) {
495 I32 maxarg = AvFILL(av) + 1;
c2444246 496 (void)POPs; /* XXXX May be optimized away? */
93965878 497 EXTEND(SP, maxarg);
498 if (SvRMAGICAL(av)) {
499 U32 i;
500 for (i=0; i < maxarg; i++) {
501 SV **svp = av_fetch(av, i, FALSE);
3280af22 502 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878 503 }
504 }
505 else {
506 Copy(AvARRAY(av), SP+1, maxarg, SV*);
507 }
a0d0e21e 508 SP += maxarg;
509 }
510 else {
511 dTARGET;
512 I32 maxarg = AvFILL(av) + 1;
f5284f61 513 SETi(maxarg);
a0d0e21e 514 }
515 RETURN;
516}
517
518PP(pp_rv2hv)
519{
4e35701f 520 djSP; dTOPss;
a0d0e21e 521 HV *hv;
522
523 if (SvROK(sv)) {
524 wasref:
f5284f61 525 tryAMAGICunDEREF(to_hv);
526
a0d0e21e 527 hv = (HV*)SvRV(sv);
c750a3ec 528 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
cea2e8a9 529 DIE(aTHX_ "Not a HASH reference");
533c011a 530 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 531 SETs((SV*)hv);
532 RETURN;
533 }
534 }
535 else {
c750a3ec 536 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
a0d0e21e 537 hv = (HV*)sv;
533c011a 538 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 539 SETs((SV*)hv);
540 RETURN;
541 }
542 }
543 else {
67955e0c 544 GV *gv;
545
a0d0e21e 546 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 547 char *sym;
2d8e6c8d 548 STRLEN n_a;
748a9306 549
a0d0e21e 550 if (SvGMAGICAL(sv)) {
551 mg_get(sv);
552 if (SvROK(sv))
553 goto wasref;
554 }
555 if (!SvOK(sv)) {
533c011a 556 if (PL_op->op_flags & OPf_REF ||
557 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 558 DIE(aTHX_ PL_no_usym, "a HASH");
599cee73 559 if (ckWARN(WARN_UNINITIALIZED))
cea2e8a9 560 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
4633a7c4 561 if (GIMME == G_ARRAY) {
562 SP--;
563 RETURN;
564 }
a0d0e21e 565 RETSETUNDEF;
566 }
2d8e6c8d 567 sym = SvPV(sv,n_a);
35cd451c 568 if ((PL_op->op_flags & OPf_SPECIAL) &&
569 !(PL_op->op_flags & OPf_MOD))
570 {
571 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
572 if (!gv)
573 RETSETUNDEF;
574 }
575 else {
576 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 577 DIE(aTHX_ PL_no_symref, sym, "a HASH");
35cd451c 578 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
579 }
580 }
581 else {
67955e0c 582 gv = (GV*)sv;
a0d0e21e 583 }
67955e0c 584 hv = GvHVn(gv);
533c011a 585 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 586 hv = save_hash(gv);
533c011a 587 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 588 SETs((SV*)hv);
589 RETURN;
590 }
591 }
592 }
593
594 if (GIMME == G_ARRAY) { /* array wanted */
3280af22 595 *PL_stack_sp = (SV*)hv;
cea2e8a9 596 return do_kv();
a0d0e21e 597 }
598 else {
599 dTARGET;
4b154ab5 600 if (SvTYPE(hv) == SVt_PVAV)
601 hv = avhv_keys((AV*)hv);
46fc3d4c 602 if (HvFILL(hv))
cea2e8a9 603 Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
46fc3d4c 604 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
a0d0e21e 605 else
606 sv_setiv(TARG, 0);
c750a3ec 607
a0d0e21e 608 SETTARG;
609 RETURN;
610 }
611}
612
613PP(pp_aassign)
614{
4e35701f 615 djSP;
3280af22 616 SV **lastlelem = PL_stack_sp;
617 SV **lastrelem = PL_stack_base + POPMARK;
618 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e 619 SV **firstlelem = lastrelem + 1;
620
621 register SV **relem;
622 register SV **lelem;
623
624 register SV *sv;
625 register AV *ary;
626
54310121 627 I32 gimme;
a0d0e21e 628 HV *hash;
629 I32 i;
630 int magic;
631
3280af22 632 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e 633
634 /* If there's a common identifier on both sides we have to take
635 * special care that assigning the identifier on the left doesn't
636 * clobber a value on the right that's used later in the list.
637 */
533c011a 638 if (PL_op->op_private & OPpASSIGN_COMMON) {
cc5e57d2 639 EXTEND_MORTAL(lastrelem - firstrelem + 1);
a0d0e21e 640 for (relem = firstrelem; relem <= lastrelem; relem++) {
641 /*SUPPRESS 560*/
a1f49e72 642 if (sv = *relem) {
643 TAINT_NOT; /* Each item is independent */
a0d0e21e 644 *relem = sv_mortalcopy(sv);
a1f49e72 645 }
a0d0e21e 646 }
647 }
648
649 relem = firstrelem;
650 lelem = firstlelem;
651 ary = Null(AV*);
652 hash = Null(HV*);
653 while (lelem <= lastlelem) {
bbce6d69 654 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e 655 sv = *lelem++;
656 switch (SvTYPE(sv)) {
657 case SVt_PVAV:
658 ary = (AV*)sv;
748a9306 659 magic = SvMAGICAL(ary) != 0;
a0d0e21e 660
661 av_clear(ary);
7e42bd57 662 av_extend(ary, lastrelem - relem);
a0d0e21e 663 i = 0;
664 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 665 SV **didstore;
a0d0e21e 666 sv = NEWSV(28,0);
667 assert(*relem);
668 sv_setsv(sv,*relem);
669 *(relem++) = sv;
5117ca91 670 didstore = av_store(ary,i++,sv);
671 if (magic) {
fb73857a 672 if (SvSMAGICAL(sv))
673 mg_set(sv);
5117ca91 674 if (!didstore)
8127e0e3 675 sv_2mortal(sv);
5117ca91 676 }
bbce6d69 677 TAINT_NOT;
a0d0e21e 678 }
679 break;
680 case SVt_PVHV: {
a0d0e21e 681 SV *tmpstr;
682
683 hash = (HV*)sv;
748a9306 684 magic = SvMAGICAL(hash) != 0;
a0d0e21e 685 hv_clear(hash);
686
687 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 688 HE *didstore;
4633a7c4 689 if (*relem)
a0d0e21e 690 sv = *(relem++);
4633a7c4 691 else
3280af22 692 sv = &PL_sv_no, relem++;
a0d0e21e 693 tmpstr = NEWSV(29,0);
694 if (*relem)
695 sv_setsv(tmpstr,*relem); /* value */
696 *(relem++) = tmpstr;
5117ca91 697 didstore = hv_store_ent(hash,sv,tmpstr,0);
698 if (magic) {
fb73857a 699 if (SvSMAGICAL(tmpstr))
700 mg_set(tmpstr);
5117ca91 701 if (!didstore)
8127e0e3 702 sv_2mortal(tmpstr);
5117ca91 703 }
bbce6d69 704 TAINT_NOT;
8e07c86e 705 }
6a0deba8 706 if (relem == lastrelem) {
707 if (*relem) {
708 HE *didstore;
599cee73 709 if (ckWARN(WARN_UNSAFE)) {
6a0deba8 710 if (relem == firstrelem &&
711 SvROK(*relem) &&
712 ( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
713 SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
cea2e8a9 714 Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
6a0deba8 715 else
cea2e8a9 716 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
6a0deba8 717 }
718 tmpstr = NEWSV(29,0);
719 didstore = hv_store_ent(hash,*relem,tmpstr,0);
720 if (magic) {
721 if (SvSMAGICAL(tmpstr))
722 mg_set(tmpstr);
723 if (!didstore)
8127e0e3 724 sv_2mortal(tmpstr);
6a0deba8 725 }
726 TAINT_NOT;
727 }
728 relem++;
1930e939 729 }
a0d0e21e 730 }
731 break;
732 default:
6fc92669 733 if (SvIMMORTAL(sv)) {
734 if (relem <= lastrelem)
735 relem++;
736 break;
a0d0e21e 737 }
738 if (relem <= lastrelem) {
739 sv_setsv(sv, *relem);
740 *(relem++) = sv;
741 }
742 else
3280af22 743 sv_setsv(sv, &PL_sv_undef);
a0d0e21e 744 SvSETMAGIC(sv);
745 break;
746 }
747 }
3280af22 748 if (PL_delaymagic & ~DM_DELAY) {
749 if (PL_delaymagic & DM_UID) {
a0d0e21e 750#ifdef HAS_SETRESUID
b28d0864 751 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
56febc5e 752#else
753# ifdef HAS_SETREUID
3280af22 754 (void)setreuid(PL_uid,PL_euid);
56febc5e 755# else
756# ifdef HAS_SETRUID
b28d0864 757 if ((PL_delaymagic & DM_UID) == DM_RUID) {
758 (void)setruid(PL_uid);
759 PL_delaymagic &= ~DM_RUID;
a0d0e21e 760 }
56febc5e 761# endif /* HAS_SETRUID */
762# ifdef HAS_SETEUID
b28d0864 763 if ((PL_delaymagic & DM_UID) == DM_EUID) {
764 (void)seteuid(PL_uid);
765 PL_delaymagic &= ~DM_EUID;
a0d0e21e 766 }
56febc5e 767# endif /* HAS_SETEUID */
b28d0864 768 if (PL_delaymagic & DM_UID) {
769 if (PL_uid != PL_euid)
cea2e8a9 770 DIE(aTHX_ "No setreuid available");
b28d0864 771 (void)PerlProc_setuid(PL_uid);
a0d0e21e 772 }
56febc5e 773# endif /* HAS_SETREUID */
774#endif /* HAS_SETRESUID */
3280af22 775 PL_uid = (int)PerlProc_getuid();
776 PL_euid = (int)PerlProc_geteuid();
a0d0e21e 777 }
3280af22 778 if (PL_delaymagic & DM_GID) {
a0d0e21e 779#ifdef HAS_SETRESGID
b28d0864 780 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
56febc5e 781#else
782# ifdef HAS_SETREGID
3280af22 783 (void)setregid(PL_gid,PL_egid);
56febc5e 784# else
785# ifdef HAS_SETRGID
b28d0864 786 if ((PL_delaymagic & DM_GID) == DM_RGID) {
787 (void)setrgid(PL_gid);
788 PL_delaymagic &= ~DM_RGID;
a0d0e21e 789 }
56febc5e 790# endif /* HAS_SETRGID */
791# ifdef HAS_SETEGID
b28d0864 792 if ((PL_delaymagic & DM_GID) == DM_EGID) {
793 (void)setegid(PL_gid);
794 PL_delaymagic &= ~DM_EGID;
a0d0e21e 795 }
56febc5e 796# endif /* HAS_SETEGID */
b28d0864 797 if (PL_delaymagic & DM_GID) {
798 if (PL_gid != PL_egid)
cea2e8a9 799 DIE(aTHX_ "No setregid available");
b28d0864 800 (void)PerlProc_setgid(PL_gid);
a0d0e21e 801 }
56febc5e 802# endif /* HAS_SETREGID */
803#endif /* HAS_SETRESGID */
3280af22 804 PL_gid = (int)PerlProc_getgid();
805 PL_egid = (int)PerlProc_getegid();
a0d0e21e 806 }
3280af22 807 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 808 }
3280af22 809 PL_delaymagic = 0;
54310121 810
811 gimme = GIMME_V;
812 if (gimme == G_VOID)
813 SP = firstrelem - 1;
814 else if (gimme == G_SCALAR) {
815 dTARGET;
816 SP = firstrelem;
817 SETi(lastrelem - firstrelem + 1);
818 }
819 else {
a0d0e21e 820 if (ary || hash)
821 SP = lastrelem;
822 else
823 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 824 lelem = firstlelem + (relem - firstrelem);
5f05dabc 825 while (relem <= SP)
3280af22 826 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 827 }
54310121 828 RETURN;
a0d0e21e 829}
830
8782bef2 831PP(pp_qr)
832{
833 djSP;
834 register PMOP *pm = cPMOP;
835 SV *rv = sv_newmortal();
57668c4d 836 SV *sv = newSVrv(rv, "Regexp");
8782bef2 837 sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
838 RETURNX(PUSHs(rv));
839}
840
a0d0e21e 841PP(pp_match)
842{
4e35701f 843 djSP; dTARG;
a0d0e21e 844 register PMOP *pm = cPMOP;
845 register char *t;
846 register char *s;
847 char *strend;
848 I32 global;
0ef3e39e 849 I32 r_flags = 0;
cf93c79d 850 char *truebase; /* Start of string, may be
851 relocated if REx engine
852 copies the string. */
d9f97599 853 register REGEXP *rx = pm->op_pmregexp;
b3eb6a9b 854 bool rxtainted;
a0d0e21e 855 I32 gimme = GIMME;
856 STRLEN len;
748a9306 857 I32 minmatch = 0;
3280af22 858 I32 oldsave = PL_savestack_ix;
f86702cc 859 I32 update_minmatch = 1;
e60df1fa 860 I32 had_zerolen = 0;
a0d0e21e 861
533c011a 862 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 863 TARG = POPs;
864 else {
54b9620d 865 TARG = DEFSV;
a0d0e21e 866 EXTEND(SP,1);
867 }
c277df42 868 PUTBACK; /* EVAL blocks need stack_sp. */
a0d0e21e 869 s = SvPV(TARG, len);
870 strend = s + len;
871 if (!s)
cea2e8a9 872 DIE(aTHX_ "panic: do_match");
b3eb6a9b 873 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22 874 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 875 TAINT_NOT;
a0d0e21e 876
48c036b1 877 if (pm->op_pmdynflags & PMdf_USED) {
c277df42 878 failure:
a0d0e21e 879 if (gimme == G_ARRAY)
880 RETURN;
881 RETPUSHNO;
882 }
883
3280af22 884 if (!rx->prelen && PL_curpm) {
885 pm = PL_curpm;
d9f97599 886 rx = pm->op_pmregexp;
a0d0e21e 887 }
d9f97599 888 if (rx->minlen > len) goto failure;
c277df42 889
a0d0e21e 890 truebase = t = s;
ad94a511 891
892 /* XXXX What part of this is needed with true \G-support? */
a0d0e21e 893 if (global = pm->op_pmflags & PMf_GLOBAL) {
cf93c79d 894 rx->startp[0] = -1;
a0d0e21e 895 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
896 MAGIC* mg = mg_find(TARG, 'g');
565764a8 897 if (mg && mg->mg_len >= 0) {
b7a35066 898 if (!(rx->reganch & ROPT_GPOS_SEEN))
cf93c79d 899 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e 900 else if (rx->reganch & ROPT_ANCH_GPOS) {
901 r_flags |= REXEC_IGNOREPOS;
cf93c79d 902 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e 903 }
748a9306 904 minmatch = (mg->mg_flags & MGf_MINMATCH);
f86702cc 905 update_minmatch = 0;
748a9306 906 }
a0d0e21e 907 }
908 }
0ef3e39e 909 if ((gimme != G_ARRAY && !global && rx->nparens)
910 || SvTEMP(TARG) || PL_sawampersand)
911 r_flags |= REXEC_COPY_STR;
22e551b9 912 if (SvSCREAM(TARG) && rx->check_substr
913 && SvTYPE(rx->check_substr) == SVt_PVBM
914 && SvVALID(rx->check_substr))
915 r_flags |= REXEC_SCREAM;
916
a0d0e21e 917 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22 918 SAVEINT(PL_multiline);
919 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e 920 }
921
922play_it_again:
cf93c79d 923 if (global && rx->startp[0] != -1) {
924 t = s = rx->endp[0] + truebase;
d9f97599 925 if ((s + rx->minlen) > strend)
a0d0e21e 926 goto nope;
f86702cc 927 if (update_minmatch++)
e60df1fa 928 minmatch = had_zerolen;
a0d0e21e 929 }
d9f97599 930 if (rx->check_substr) {
931 if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
cf93c79d 932 SV *c = rx->check_substr;
933
22e551b9 934 if (r_flags & REXEC_SCREAM) {
c277df42 935 I32 p = -1;
a0ed51b3 936 char *b;
cf93c79d 937
938 if (PL_screamfirst[BmRARE(c)] < 0
939 && !( BmRARE(c) == '\n' && (BmPREVIOUS(c) == SvCUR(c) - 1)
940 && SvTAIL(c) ))
a0d0e21e 941 goto nope;
a0ed51b3 942
dfe13c55 943 b = (char*)HOP((U8*)s, rx->check_offset_min);
cf93c79d 944 if (!(s = screaminstr(TARG, c, b - s, 0, &p, 0)))
a0d0e21e 945 goto nope;
a0ed51b3 946
947 if ((rx->reganch & ROPT_CHECK_ALL)
cf93c79d 948 && !PL_sawampersand && !SvTAIL(c))
a0d0e21e 949 goto yup;
950 }
a0ed51b3 951 else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
cf93c79d 952 (unsigned char*)strend, c,
953 PL_multiline ? FBMrf_MULTILINE : 0)))
a0d0e21e 954 goto nope;
3280af22 955 else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
a0d0e21e 956 goto yup;
ee027f1d 957 if (s && rx->check_offset_max < s - t) {
cf93c79d 958 ++BmUSEFUL(c);
dfe13c55 959 s = (char*)HOP((U8*)s, -rx->check_offset_max);
a0d0e21e 960 }
961 else
962 s = t;
963 }
c277df42 964 /* Now checkstring is fixed, i.e. at fixed offset from the
965 beginning of match, and the match is anchored at s. */
3280af22 966 else if (!PL_multiline) { /* Anchored near beginning of string. */
c277df42 967 I32 slen;
dfe13c55 968 char *b = (char*)HOP((U8*)s, rx->check_offset_min);
cf93c79d 969
970 if (SvTAIL(rx->check_substr)) {
971 slen = SvCUR(rx->check_substr); /* >= 1 */
972
973 if ( strend - b > slen || strend - b < slen - 1 )
974 goto nope;
975 if ( strend - b == slen && strend[-1] != '\n')
976 goto nope;
977 /* Now should match b[0..slen-2] */
978 slen--;
979 if (slen && (*SvPVX(rx->check_substr) != *b
980 || (slen > 1
981 && memNE(SvPVX(rx->check_substr), b, slen))))
982 goto nope;
983 if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
984 goto yup;
985 } else { /* Assume len > 0 */
986 if (*SvPVX(rx->check_substr) != *b
987 || ((slen = SvCUR(rx->check_substr)) > 1
988 && memNE(SvPVX(rx->check_substr), b, slen)))
989 goto nope;
990 if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
991 goto yup;
992 }
a0d0e21e 993 }
a0ed51b3 994 if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
d9f97599 995 && rx->check_substr == rx->float_substr) {
996 SvREFCNT_dec(rx->check_substr);
997 rx->check_substr = Nullsv; /* opt is being useless */
998 rx->float_substr = Nullsv;
a0d0e21e 999 }
1000 }
cea2e8a9 1001 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
bbce6d69 1002 {
3280af22 1003 PL_curpm = pm;
a0d0e21e 1004 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1005 pm->op_pmdynflags |= PMdf_USED;
a0d0e21e 1006 goto gotcha;
1007 }
1008 else
1009 goto ret_no;
1010 /*NOTREACHED*/
1011
1012 gotcha:
72311751 1013 if (rxtainted)
1014 RX_MATCH_TAINTED_on(rx);
1015 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1016 if (gimme == G_ARRAY) {
1017 I32 iters, i, len;
1018
d9f97599 1019 iters = rx->nparens;
a0d0e21e 1020 if (global && !iters)
1021 i = 1;
1022 else
1023 i = 0;
c277df42 1024 SPAGAIN; /* EVAL blocks could move the stack. */
a0d0e21e 1025 EXTEND(SP, iters + i);
bbce6d69 1026 EXTEND_MORTAL(iters + i);
a0d0e21e 1027 for (i = !i; i <= iters; i++) {
1028 PUSHs(sv_newmortal());
1029 /*SUPPRESS 560*/
cf93c79d 1030 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1031 len = rx->endp[i] - rx->startp[i];
1032 s = rx->startp[i] + truebase;
a0d0e21e 1033 sv_setpvn(*SP, s, len);
1034 }
1035 }
1036 if (global) {
cf93c79d 1037 had_zerolen = (rx->startp[0] != -1
1038 && rx->startp[0] == rx->endp[0]);
c277df42 1039 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1040 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e 1041 goto play_it_again;
1042 }
f7e33566 1043 else if (!iters)
bde848c5 1044 XPUSHs(&PL_sv_yes);
4633a7c4 1045 LEAVE_SCOPE(oldsave);
a0d0e21e 1046 RETURN;
1047 }
1048 else {
1049 if (global) {
1050 MAGIC* mg = 0;
1051 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1052 mg = mg_find(TARG, 'g');
1053 if (!mg) {
1054 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1055 mg = mg_find(TARG, 'g');
1056 }
cf93c79d 1057 if (rx->startp[0] != -1) {
1058 mg->mg_len = rx->endp[0];
d9f97599 1059 if (rx->startp[0] == rx->endp[0])
748a9306 1060 mg->mg_flags |= MGf_MINMATCH;
1061 else
1062 mg->mg_flags &= ~MGf_MINMATCH;
1063 }
a0d0e21e 1064 }
4633a7c4 1065 LEAVE_SCOPE(oldsave);
a0d0e21e 1066 RETPUSHYES;
1067 }
1068
c277df42 1069yup: /* Confirmed by check_substr */
72311751 1070 if (rxtainted)
1071 RX_MATCH_TAINTED_on(rx);
1072 TAINT_IF(RX_MATCH_TAINTED(rx));
d9f97599 1073 ++BmUSEFUL(rx->check_substr);
3280af22 1074 PL_curpm = pm;
a0d0e21e 1075 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1076 pm->op_pmdynflags |= PMdf_USED;
cf93c79d 1077 if (RX_MATCH_COPIED(rx))
1078 Safefree(rx->subbeg);
1079 RX_MATCH_COPIED_off(rx);
1080 rx->subbeg = Nullch;
a0d0e21e 1081 if (global) {
d9f97599 1082 rx->subbeg = truebase;
cf93c79d 1083 rx->startp[0] = s - truebase;
1084 rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
1085 rx->sublen = strend - truebase;
a0d0e21e 1086 goto gotcha;
cf93c79d 1087 }
3280af22 1088 if (PL_sawampersand) {
cf93c79d 1089 I32 off;
a0d0e21e 1090
cf93c79d 1091 rx->subbeg = savepvn(t, strend - t);
1092 rx->sublen = strend - t;
1093 RX_MATCH_COPIED_on(rx);
1094 off = rx->startp[0] = s - t;
1095 rx->endp[0] = off + SvCUR(rx->check_substr);
1096 }
1097 else { /* startp/endp are used by @- @+. */
1098 rx->startp[0] = s - truebase;
1099 rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
a0d0e21e 1100 }
4633a7c4 1101 LEAVE_SCOPE(oldsave);
a0d0e21e 1102 RETPUSHYES;
1103
1104nope:
d9f97599 1105 if (rx->check_substr)
1106 ++BmUSEFUL(rx->check_substr);
a0d0e21e 1107
1108ret_no:
c90c0ff4 1109 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1110 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1111 MAGIC* mg = mg_find(TARG, 'g');
1112 if (mg)
565764a8 1113 mg->mg_len = -1;
a0d0e21e 1114 }
1115 }
4633a7c4 1116 LEAVE_SCOPE(oldsave);
a0d0e21e 1117 if (gimme == G_ARRAY)
1118 RETURN;
1119 RETPUSHNO;
1120}
1121
1122OP *
864dbfa3 1123Perl_do_readline(pTHX)
a0d0e21e 1124{
1125 dSP; dTARGETSTACKED;
1126 register SV *sv;
1127 STRLEN tmplen = 0;
1128 STRLEN offset;
760ac839 1129 PerlIO *fp;
3280af22 1130 register IO *io = GvIO(PL_last_in_gv);
533c011a 1131 register I32 type = PL_op->op_type;
54310121 1132 I32 gimme = GIMME_V;
e79b0511 1133 MAGIC *mg;
a0d0e21e 1134
33c27489 1135 if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
e79b0511 1136 PUSHMARK(SP);
33c27489 1137 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
e79b0511 1138 PUTBACK;
1139 ENTER;
864dbfa3 1140 call_method("READLINE", gimme);
e79b0511 1141 LEAVE;
1142 SPAGAIN;
54310121 1143 if (gimme == G_SCALAR)
1144 SvSetMagicSV_nosteal(TARG, TOPs);
e79b0511 1145 RETURN;
1146 }
a0d0e21e 1147 fp = Nullfp;
1148 if (io) {
1149 fp = IoIFP(io);
1150 if (!fp) {
1151 if (IoFLAGS(io) & IOf_ARGV) {
1152 if (IoFLAGS(io) & IOf_START) {
1153 IoFLAGS(io) &= ~IOf_START;
1154 IoLINES(io) = 0;
3280af22 1155 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
9d116dd7 1156 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
3280af22 1157 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1158 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d 1159 fp = IoIFP(io);
1160 goto have_fp;
a0d0e21e 1161 }
1162 }
3280af22 1163 fp = nextargv(PL_last_in_gv);
a0d0e21e 1164 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1165 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e 1166 IoFLAGS(io) |= IOf_START;
1167 }
1168 }
1169 else if (type == OP_GLOB) {
1170 SV *tmpcmd = NEWSV(55, 0);
1171 SV *tmpglob = POPs;
1172 ENTER;
1173 SAVEFREESV(tmpcmd);
1174#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1175 /* since spawning off a process is a real performance hit */
1176 {
1177#include <descrip.h>
1178#include <lib$routines.h>
1179#include <nam.h>
1180#include <rmsdef.h>
1181 char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1182 char vmsspec[NAM$C_MAXRSS+1];
1183 char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1184 char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1185 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
760ac839 1186 PerlIO *tmpfp;
a0d0e21e 1187 STRLEN i;
1188 struct dsc$descriptor_s wilddsc
1189 = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1190 struct dsc$descriptor_vs rsdsc
1191 = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1192 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1193
1194 /* We could find out if there's an explicit dev/dir or version
1195 by peeking into lib$find_file's internal context at
1196 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1197 but that's unsupported, so I don't want to do it now and
1198 have it bite someone in the future. */
6ad3d225 1199 strcat(tmpfnam,PerlLIO_tmpnam(NULL));
a0d0e21e 1200 cp = SvPV(tmpglob,i);
1201 for (; i; i--) {
1202 if (cp[i] == ';') hasver = 1;
1203 if (cp[i] == '.') {
1204 if (sts) hasver = 1;
1205 else sts = 1;
1206 }
1207 if (cp[i] == '/') {
1208 hasdir = isunix = 1;
1209 break;
748a9306 1210 }
a0d0e21e 1211 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1212 hasdir = 1;
1213 break;
1214 }
1215 }
760ac839 1216 if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
09b7f37c 1217 Stat_t st;
c6ed36e1 1218 if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
09b7f37c 1219 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
1220 else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
a0d0e21e 1221 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1222 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1223 &dfltdsc,NULL,NULL,NULL))&1)) {
1224 end = rstr + (unsigned long int) *rslt;
1225 if (!hasver) while (*end != ';') end--;
1226 *(end++) = '\n'; *end = '\0';
1227 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1228 if (hasdir) {
f86702cc 1229 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
a0d0e21e 1230 begin = rstr;
1231 }
1232 else {
1233 begin = end;
1234 while (*(--begin) != ']' && *begin != '>') ;
1235 ++begin;
1236 }
760ac839 1237 ok = (PerlIO_puts(tmpfp,begin) != EOF);
a0d0e21e 1238 }
1239 if (cxt) (void)lib$find_file_end(&cxt);
748a9306 1240 if (ok && sts != RMS$_NMF &&
1241 sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
a0d0e21e 1242 if (!ok) {
c07a80fd 1243 if (!(sts & 1)) {
1244 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1245 }
760ac839 1246 PerlIO_close(tmpfp);
a0d0e21e 1247 fp = NULL;
1248 }
1249 else {
760ac839 1250 PerlIO_rewind(tmpfp);
a0d0e21e 1251 IoTYPE(io) = '<';
1252 IoIFP(io) = fp = tmpfp;
1e422769 1253 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
a0d0e21e 1254 }
1255 }
1256 }
1257#else /* !VMS */
1258#ifdef DOSISH
67955e0c 1259#ifdef OS2
1260 sv_setpv(tmpcmd, "for a in ");
1261 sv_catsv(tmpcmd, tmpglob);
1262 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1263#else
39e571d4 1264#ifdef DJGPP
1265 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
1266 sv_catsv(tmpcmd, tmpglob);
1267#else
a0d0e21e 1268 sv_setpv(tmpcmd, "perlglob ");
1269 sv_catsv(tmpcmd, tmpglob);
1270 sv_catpv(tmpcmd, " |");
39e571d4 1271#endif /* !DJGPP */
67955e0c 1272#endif /* !OS2 */
1273#else /* !DOSISH */
1274#if defined(CSH)
3280af22 1275 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
a0d0e21e 1276 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1277 sv_catsv(tmpcmd, tmpglob);
16d20bd9 1278 sv_catpv(tmpcmd, "' 2>/dev/null |");
a0d0e21e 1279#else
1280 sv_setpv(tmpcmd, "echo ");
1281 sv_catsv(tmpcmd, tmpglob);
1282#if 'z' - 'a' == 25
1283 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1284#else
1285 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1286#endif
1287#endif /* !CSH */
67955e0c 1288#endif /* !DOSISH */
3280af22 1289 (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
9d116dd7 1290 FALSE, O_RDONLY, 0, Nullfp);
a0d0e21e 1291 fp = IoIFP(io);
1292#endif /* !VMS */
1293 LEAVE;
1294 }
1295 }
1296 else if (type == OP_GLOB)
1297 SP--;
1298 }
1299 if (!fp) {
3f4520fe 1300 if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
1301 if (type == OP_GLOB)
cea2e8a9 1302 Perl_warner(aTHX_ WARN_CLOSED, "glob failed (can't start child: %s)",
3f4520fe 1303 Strerror(errno));
1304 else
cea2e8a9 1305 Perl_warner(aTHX_ WARN_CLOSED, "Read on closed filehandle <%s>",
3f4520fe 1306 GvENAME(PL_last_in_gv));
1307 }
54310121 1308 if (gimme == G_SCALAR) {
a0d0e21e 1309 (void)SvOK_off(TARG);
1310 PUSHTARG;
1311 }
1312 RETURN;
1313 }
a2008d6d 1314 have_fp:
54310121 1315 if (gimme == G_SCALAR) {
a0d0e21e 1316 sv = TARG;
9607fc9c 1317 if (SvROK(sv))
1318 sv_unref(sv);
a0d0e21e 1319 (void)SvUPGRADE(sv, SVt_PV);
1320 tmplen = SvLEN(sv); /* remember if already alloced */
1321 if (!tmplen)
1322 Sv_Grow(sv, 80); /* try short-buffering it */
1323 if (type == OP_RCATLINE)
1324 offset = SvCUR(sv);
1325 else
1326 offset = 0;
1327 }
54310121 1328 else {
1329 sv = sv_2mortal(NEWSV(57, 80));
1330 offset = 0;
1331 }
fbad3eb5 1332
1333/* flip-flop EOF state for a snarfed empty file */
1334#define SNARF_EOF(gimme,rs,io,sv) \
1335 ((gimme != G_SCALAR || SvCUR(sv) \
1336 || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \
1337 ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \
1338 : ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
1339
a0d0e21e 1340 for (;;) {
fbad3eb5 1341 if (!sv_gets(sv, fp, offset)
1342 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1343 {
760ac839 1344 PerlIO_clearerr(fp);
a0d0e21e 1345 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1346 fp = nextargv(PL_last_in_gv);
a0d0e21e 1347 if (fp)
1348 continue;
3280af22 1349 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e 1350 IoFLAGS(io) |= IOf_START;
1351 }
1352 else if (type == OP_GLOB) {
4eb79ab5 1353 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
cea2e8a9 1354 Perl_warner(aTHX_ WARN_CLOSED,
4eb79ab5 1355 "glob failed (child exited with status %d%s)",
1356 STATUS_CURRENT >> 8,
cf494569 1357 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1358 }
a0d0e21e 1359 }
54310121 1360 if (gimme == G_SCALAR) {
a0d0e21e 1361 (void)SvOK_off(TARG);
1362 PUSHTARG;
1363 }
1364 RETURN;
1365 }
bbce6d69 1366 /* This should not be marked tainted if the fp is marked clean */
1367 if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1368 TAINT;
1369 SvTAINTED_on(sv);
1370 }
a0d0e21e 1371 IoLINES(io)++;
71be2cbc 1372 SvSETMAGIC(sv);
a0d0e21e 1373 XPUSHs(sv);
a0d0e21e 1374 if (type == OP_GLOB) {
1375 char *tmps;
1376
3280af22 1377 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1378 tmps = SvEND(sv) - 1;
3280af22 1379 if (*tmps == *SvPVX(PL_rs)) {
c07a80fd 1380 *tmps = '\0';
1381 SvCUR(sv)--;
1382 }
1383 }
a0d0e21e 1384 for (tmps = SvPVX(sv); *tmps; tmps++)
1385 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1386 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1387 break;
43384a1a 1388 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
a0d0e21e 1389 (void)POPs; /* Unmatched wildcard? Chuck it... */
1390 continue;
1391 }
1392 }
54310121 1393 if (gimme == G_ARRAY) {
a0d0e21e 1394 if (SvLEN(sv) - SvCUR(sv) > 20) {
1395 SvLEN_set(sv, SvCUR(sv)+1);
1396 Renew(SvPVX(sv), SvLEN(sv), char);
1397 }
1398 sv = sv_2mortal(NEWSV(58, 80));
1399 continue;
1400 }
54310121 1401 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e 1402 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1403 if (SvCUR(sv) < 60)
1404 SvLEN_set(sv, 80);
1405 else
1406 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1407 Renew(SvPVX(sv), SvLEN(sv), char);
1408 }
1409 RETURN;
1410 }
1411}
1412
1413PP(pp_enter)
1414{
4e35701f 1415 djSP;
c09156bb 1416 register PERL_CONTEXT *cx;
533c011a 1417 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1418
54310121 1419 if (gimme == -1) {
1420 if (cxstack_ix >= 0)
1421 gimme = cxstack[cxstack_ix].blk_gimme;
1422 else
1423 gimme = G_SCALAR;
1424 }
a0d0e21e 1425
1426 ENTER;
1427
1428 SAVETMPS;
924508f0 1429 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e 1430
1431 RETURN;
1432}
1433
1434PP(pp_helem)
1435{
4e35701f 1436 djSP;
760ac839 1437 HE* he;
ae77835f 1438 SV **svp;
a0d0e21e 1439 SV *keysv = POPs;
a0d0e21e 1440 HV *hv = (HV*)POPs;
533c011a 1441 U32 lval = PL_op->op_flags & OPf_MOD;
1442 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1443 SV *sv;
a0d0e21e 1444
ae77835f 1445 if (SvTYPE(hv) == SVt_PVHV) {
1446 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
97fcbf96 1447 svp = he ? &HeVAL(he) : 0;
ae77835f 1448 }
1449 else if (SvTYPE(hv) == SVt_PVAV) {
0ebe0038 1450 if (PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 1451 DIE(aTHX_ "Can't localize pseudo-hash element");
97fcbf96 1452 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
ae77835f 1453 }
c750a3ec 1454 else {
a0d0e21e 1455 RETPUSHUNDEF;
c750a3ec 1456 }
a0d0e21e 1457 if (lval) {
3280af22 1458 if (!svp || *svp == &PL_sv_undef) {
68dc0745 1459 SV* lv;
1460 SV* key2;
2d8e6c8d 1461 if (!defer) {
1462 STRLEN n_a;
cea2e8a9 1463 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 1464 }
68dc0745 1465 lv = sv_newmortal();
1466 sv_upgrade(lv, SVt_PVLV);
1467 LvTYPE(lv) = 'y';
1468 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1469 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1470 LvTARG(lv) = SvREFCNT_inc(hv);
1471 LvTARGLEN(lv) = 1;
1472 PUSHs(lv);
1473 RETURN;
1474 }
533c011a 1475 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1476 if (HvNAME(hv) && isGV(*svp))
533c011a 1477 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
5f05dabc 1478 else
161b7d16 1479 save_helem(hv, keysv, svp);
5f05dabc 1480 }
533c011a 1481 else if (PL_op->op_private & OPpDEREF)
1482 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1483 }
3280af22 1484 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0 1485 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1486 * Pushing the magical RHS on to the stack is useless, since
1487 * that magic is soon destined to be misled by the local(),
1488 * and thus the later pp_sassign() will fail to mg_get() the
1489 * old value. This should also cure problems with delayed
1490 * mg_get()s. GSAR 98-07-03 */
1491 if (!lval && SvGMAGICAL(sv))
1492 sv = sv_mortalcopy(sv);
1493 PUSHs(sv);
a0d0e21e 1494 RETURN;
1495}
1496
1497PP(pp_leave)
1498{
4e35701f 1499 djSP;
c09156bb 1500 register PERL_CONTEXT *cx;
a0d0e21e 1501 register SV **mark;
1502 SV **newsp;
1503 PMOP *newpm;
1504 I32 gimme;
1505
533c011a 1506 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1507 cx = &cxstack[cxstack_ix];
3280af22 1508 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e 1509 }
1510
1511 POPBLOCK(cx,newpm);
1512
533c011a 1513 gimme = OP_GIMME(PL_op, -1);
54310121 1514 if (gimme == -1) {
1515 if (cxstack_ix >= 0)
1516 gimme = cxstack[cxstack_ix].blk_gimme;
1517 else
1518 gimme = G_SCALAR;
1519 }
a0d0e21e 1520
a1f49e72 1521 TAINT_NOT;
54310121 1522 if (gimme == G_VOID)
1523 SP = newsp;
1524 else if (gimme == G_SCALAR) {
1525 MARK = newsp + 1;
1526 if (MARK <= SP)
1527 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1528 *MARK = TOPs;
1529 else
1530 *MARK = sv_mortalcopy(TOPs);
a0d0e21e 1531 else {
54310121 1532 MEXTEND(mark,0);
3280af22 1533 *MARK = &PL_sv_undef;
a0d0e21e 1534 }
54310121 1535 SP = MARK;
a0d0e21e 1536 }
54310121 1537 else if (gimme == G_ARRAY) {
a1f49e72 1538 /* in case LEAVE wipes old return values */
1539 for (mark = newsp + 1; mark <= SP; mark++) {
1540 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1541 *mark = sv_mortalcopy(*mark);
a1f49e72 1542 TAINT_NOT; /* Each item is independent */
1543 }
1544 }
a0d0e21e 1545 }
3280af22 1546 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 1547
1548 LEAVE;
1549
1550 RETURN;
1551}
1552
1553PP(pp_iter)
1554{
4e35701f 1555 djSP;
c09156bb 1556 register PERL_CONTEXT *cx;
5f05dabc 1557 SV* sv;
4633a7c4 1558 AV* av;
a0d0e21e 1559
924508f0 1560 EXTEND(SP, 1);
a0d0e21e 1561 cx = &cxstack[cxstack_ix];
6b35e009 1562 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1563 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1564
4633a7c4 1565 av = cx->blk_loop.iterary;
89ea2908 1566 if (SvTYPE(av) != SVt_PVAV) {
1567 /* iterate ($min .. $max) */
1568 if (cx->blk_loop.iterlval) {
1569 /* string increment */
1570 register SV* cur = cx->blk_loop.iterlval;
1571 STRLEN maxlen;
1572 char *max = SvPV((SV*)av, maxlen);
1573 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
eaa5c2d6 1574#ifndef USE_THREADS /* don't risk potential race */
39ca2bb7 1575 if (SvREFCNT(*cx->blk_loop.itervar) == 1
1576 && !SvMAGICAL(*cx->blk_loop.itervar))
1577 {
eaa5c2d6 1578 /* safe to reuse old SV */
1579 sv_setsv(*cx->blk_loop.itervar, cur);
1580 }
1581 else
1582#endif
1583 {
1584 /* we need a fresh SV every time so that loop body sees a
1585 * completely new SV for closures/references to work as
1586 * they used to */
1587 SvREFCNT_dec(*cx->blk_loop.itervar);
1588 *cx->blk_loop.itervar = newSVsv(cur);
1589 }
89ea2908 1590 if (strEQ(SvPVX(cur), max))
1591 sv_setiv(cur, 0); /* terminate next time */
1592 else
1593 sv_inc(cur);
1594 RETPUSHYES;
1595 }
1596 RETPUSHNO;
1597 }
1598 /* integer increment */
1599 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1600 RETPUSHNO;
7f61b687 1601
eaa5c2d6 1602#ifndef USE_THREADS /* don't risk potential race */
39ca2bb7 1603 if (SvREFCNT(*cx->blk_loop.itervar) == 1
1604 && !SvMAGICAL(*cx->blk_loop.itervar))
1605 {
eaa5c2d6 1606 /* safe to reuse old SV */
1607 sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
1608 }
1609 else
1610#endif
1611 {
1612 /* we need a fresh SV every time so that loop body sees a
1613 * completely new SV for closures/references to work as they
1614 * used to */
1615 SvREFCNT_dec(*cx->blk_loop.itervar);
1616 *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
1617 }
89ea2908 1618 RETPUSHYES;
1619 }
1620
1621 /* iterate array */
3280af22 1622 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
4633a7c4 1623 RETPUSHNO;
a0d0e21e 1624
7a4c00b4 1625 SvREFCNT_dec(*cx->blk_loop.itervar);
a0d0e21e 1626
93965878 1627 if (sv = (SvMAGICAL(av))
1628 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1629 : AvARRAY(av)[++cx->blk_loop.iterix])
a0d0e21e 1630 SvTEMP_off(sv);
a0d0e21e 1631 else
3280af22 1632 sv = &PL_sv_undef;
1633 if (av != PL_curstack && SvIMMORTAL(sv)) {
5f05dabc 1634 SV *lv = cx->blk_loop.iterlval;
71be2cbc 1635 if (lv && SvREFCNT(lv) > 1) {
1636 SvREFCNT_dec(lv);
1637 lv = Nullsv;
1638 }
5f05dabc 1639 if (lv)
1640 SvREFCNT_dec(LvTARG(lv));
1641 else {
68dc0745 1642 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1643 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1644 LvTYPE(lv) = 'y';
68dc0745 1645 sv_magic(lv, Nullsv, 'y', Nullch, 0);
5f05dabc 1646 }
1647 LvTARG(lv) = SvREFCNT_inc(av);
1648 LvTARGOFF(lv) = cx->blk_loop.iterix;
8ac85365 1649 LvTARGLEN(lv) = (UV) -1;
5f05dabc 1650 sv = (SV*)lv;
1651 }
a0d0e21e 1652
7a4c00b4 1653 *cx->blk_loop.itervar = SvREFCNT_inc(sv);
a0d0e21e 1654 RETPUSHYES;
1655}
1656
1657PP(pp_subst)
1658{
4e35701f 1659 djSP; dTARG;
a0d0e21e 1660 register PMOP *pm = cPMOP;
1661 PMOP *rpm = pm;
1662 register SV *dstr;
1663 register char *s;
1664 char *strend;
1665 register char *m;
1666 char *c;
1667 register char *d;
1668 STRLEN clen;
1669 I32 iters = 0;
1670 I32 maxiters;
1671 register I32 i;
1672 bool once;
71be2cbc 1673 bool rxtainted;
a0d0e21e 1674 char *orig;
22e551b9 1675 I32 r_flags;
d9f97599 1676 register REGEXP *rx = pm->op_pmregexp;
a0d0e21e 1677 STRLEN len;
1678 int force_on_match = 0;
3280af22 1679 I32 oldsave = PL_savestack_ix;
c277df42 1680 I32 update_minmatch = 1;
a0d0e21e 1681
5cd24f17 1682 /* known replacement string? */
1683 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1684 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 1685 TARG = POPs;
1686 else {
54b9620d 1687 TARG = DEFSV;
a0d0e21e 1688 EXTEND(SP,1);
8ec5e241 1689 }
68dc0745 1690 if (SvREADONLY(TARG)
1691 || (SvTYPE(TARG) > SVt_PVLV
1692 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
cea2e8a9 1693 Perl_croak(aTHX_ PL_no_modify);
8ec5e241 1694 PUTBACK;
1695
a0d0e21e 1696 s = SvPV(TARG, len);
68dc0745 1697 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1698 force_on_match = 1;
b3eb6a9b 1699 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22 1700 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1701 if (PL_tainted)
b3eb6a9b 1702 rxtainted |= 2;
9212bbba 1703 TAINT_NOT;
a0d0e21e 1704
1705 force_it:
1706 if (!pm || !s)
cea2e8a9 1707 DIE(aTHX_ "panic: do_subst");
a0d0e21e 1708
1709 strend = s + len;
2beec16e 1710 maxiters = 2*(strend - s) + 10; /* We can match twice at each
1711 position, once with zero-length,
1712 second time with non-zero. */
a0d0e21e 1713
3280af22 1714 if (!rx->prelen && PL_curpm) {
1715 pm = PL_curpm;
d9f97599 1716 rx = pm->op_pmregexp;
a0d0e21e 1717 }
22e551b9 1718 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1719 ? REXEC_COPY_STR : 0;
22e551b9 1720 if (SvSCREAM(TARG) && rx->check_substr
1721 && SvTYPE(rx->check_substr) == SVt_PVBM
1722 && SvVALID(rx->check_substr))
1723 r_flags |= REXEC_SCREAM;
a0d0e21e 1724 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22 1725 SAVEINT(PL_multiline);
1726 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e 1727 }
1728 orig = m = s;
d9f97599 1729 if (rx->check_substr) {
1730 if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
22e551b9 1731 if (r_flags & REXEC_SCREAM) {
c277df42 1732 I32 p = -1;
a0ed51b3 1733 char *b;
c277df42 1734
3280af22 1735 if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
a0d0e21e 1736 goto nope;
a0ed51b3 1737
dfe13c55 1738 b = (char*)HOP((U8*)s, rx->check_offset_min);
a0ed51b3 1739 if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
a0d0e21e 1740 goto nope;
1741 }
a0ed51b3 1742 else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
c277df42 1743 (unsigned char*)strend,
cf93c79d 1744 rx->check_substr,
1745 PL_multiline ? FBMrf_MULTILINE : 0)))
a0d0e21e 1746 goto nope;
d9f97599 1747 if (s && rx->check_offset_max < s - m) {
1748 ++BmUSEFUL(rx->check_substr);
dfe13c55 1749 s = (char*)HOP((U8*)s, -rx->check_offset_max);
a0d0e21e 1750 }
1751 else
1752 s = m;
1753 }
c277df42 1754 /* Now checkstring is fixed, i.e. at fixed offset from the
1755 beginning of match, and the match is anchored at s. */
3280af22 1756 else if (!PL_multiline) { /* Anchored at beginning of string. */
c277df42 1757 I32 slen;
dfe13c55 1758 char *b = (char*)HOP((U8*)s, rx->check_offset_min);
a0ed51b3 1759 if (*SvPVX(rx->check_substr) != *b
d9f97599 1760 || ((slen = SvCUR(rx->check_substr)) > 1
a0ed51b3 1761 && memNE(SvPVX(rx->check_substr), b, slen)))
bbce6d69 1762 goto nope;
a0d0e21e 1763 }
a0ed51b3 1764 if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
d9f97599 1765 && rx->check_substr == rx->float_substr) {
1766 SvREFCNT_dec(rx->check_substr);
1767 rx->check_substr = Nullsv; /* opt is being useless */
1768 rx->float_substr = Nullsv;
a0d0e21e 1769 }
1770 }
71be2cbc 1771
1772 /* only replace once? */
a0d0e21e 1773 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc 1774
1775 /* known replacement string? */
5cd24f17 1776 c = dstr ? SvPV(dstr, clen) : Nullch;
71be2cbc 1777
1778 /* can do inplace substitution? */
22e551b9 1779 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1780 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
cea2e8a9 1781 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
8ec5e241 1782 SPAGAIN;
3280af22 1783 PUSHs(&PL_sv_no);
71be2cbc 1784 LEAVE_SCOPE(oldsave);
1785 RETURN;
1786 }
1787 if (force_on_match) {
1788 force_on_match = 0;
1789 s = SvPV_force(TARG, len);
1790 goto force_it;
1791 }
71be2cbc 1792 d = s;
3280af22 1793 PL_curpm = pm;
71be2cbc 1794 SvSCREAM_off(TARG); /* disable possible screamer */
1795 if (once) {
48c036b1 1796 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 1797 m = orig + rx->startp[0];
1798 d = orig + rx->endp[0];
71be2cbc 1799 s = orig;
1800 if (m - s > strend - d) { /* faster to shorten from end */
1801 if (clen) {
1802 Copy(c, m, clen, char);
1803 m += clen;
a0d0e21e 1804 }
71be2cbc 1805 i = strend - d;
1806 if (i > 0) {
1807 Move(d, m, i, char);
1808 m += i;
a0d0e21e 1809 }
71be2cbc 1810 *m = '\0';
1811 SvCUR_set(TARG, m - s);
1812 }
1813 /*SUPPRESS 560*/
1814 else if (i = m - s) { /* faster from front */
1815 d -= clen;
1816 m = d;
1817 sv_chop(TARG, d-i);
1818 s += i;
1819 while (i--)
1820 *--d = *--s;
1821 if (clen)
1822 Copy(c, m, clen, char);
1823 }
1824 else if (clen) {
1825 d -= clen;
1826 sv_chop(TARG, d);
1827 Copy(c, d, clen, char);
1828 }
1829 else {
1830 sv_chop(TARG, d);
1831 }
48c036b1 1832 TAINT_IF(rxtainted & 1);
8ec5e241 1833 SPAGAIN;
3280af22 1834 PUSHs(&PL_sv_yes);
71be2cbc 1835 }
1836 else {
71be2cbc 1837 do {
1838 if (iters++ > maxiters)
cea2e8a9 1839 DIE(aTHX_ "Substitution loop");
d9f97599 1840 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 1841 m = rx->startp[0] + orig;
71be2cbc 1842 /*SUPPRESS 560*/
1843 if (i = m - s) {
1844 if (s != d)
1845 Move(s, d, i, char);
1846 d += i;
a0d0e21e 1847 }
71be2cbc 1848 if (clen) {
1849 Copy(c, d, clen, char);
1850 d += clen;
1851 }
cf93c79d 1852 s = rx->endp[0] + orig;
cea2e8a9 1853 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
cf93c79d 1854 Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */
71be2cbc 1855 if (s != d) {
1856 i = strend - s;
1857 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1858 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 1859 }
48c036b1 1860 TAINT_IF(rxtainted & 1);
8ec5e241 1861 SPAGAIN;
71be2cbc 1862 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 1863 }
71be2cbc 1864 (void)SvPOK_only(TARG);
48c036b1 1865 TAINT_IF(rxtainted);
8ec5e241 1866 if (SvSMAGICAL(TARG)) {
1867 PUTBACK;
1868 mg_set(TARG);
1869 SPAGAIN;
1870 }
9212bbba 1871 SvTAINT(TARG);
71be2cbc 1872 LEAVE_SCOPE(oldsave);
1873 RETURN;
a0d0e21e 1874 }
71be2cbc 1875
cea2e8a9 1876 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
a0d0e21e 1877 if (force_on_match) {
1878 force_on_match = 0;
1879 s = SvPV_force(TARG, len);
1880 goto force_it;
1881 }
48c036b1 1882 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 1883 dstr = NEWSV(25, len);
a0d0e21e 1884 sv_setpvn(dstr, m, s-m);
3280af22 1885 PL_curpm = pm;
a0d0e21e 1886 if (!c) {
c09156bb 1887 register PERL_CONTEXT *cx;
8ec5e241 1888 SPAGAIN;
a0d0e21e 1889 PUSHSUBST(cx);
1890 RETURNOP(cPMOP->op_pmreplroot);
1891 }
cf93c79d 1892 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e 1893 do {
1894 if (iters++ > maxiters)
cea2e8a9 1895 DIE(aTHX_ "Substitution loop");
d9f97599 1896 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 1897 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e 1898 m = s;
1899 s = orig;
cf93c79d 1900 orig = rx->subbeg;
a0d0e21e 1901 s = orig + (m - s);
1902 strend = s + (strend - m);
1903 }
cf93c79d 1904 m = rx->startp[0] + orig;
a0d0e21e 1905 sv_catpvn(dstr, s, m-s);
cf93c79d 1906 s = rx->endp[0] + orig;
a0d0e21e 1907 if (clen)
1908 sv_catpvn(dstr, c, clen);
1909 if (once)
1910 break;
cea2e8a9 1911 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
a0d0e21e 1912 sv_catpvn(dstr, s, strend - s);
748a9306 1913
4633a7c4 1914 (void)SvOOK_off(TARG);
cb0b1708 1915 Safefree(SvPVX(TARG));
748a9306 1916 SvPVX(TARG) = SvPVX(dstr);
1917 SvCUR_set(TARG, SvCUR(dstr));
1918 SvLEN_set(TARG, SvLEN(dstr));
1919 SvPVX(dstr) = 0;
1920 sv_free(dstr);
1921
48c036b1 1922 TAINT_IF(rxtainted & 1);
f878fbec 1923 SPAGAIN;
48c036b1 1924 PUSHs(sv_2mortal(newSViv((I32)iters)));
1925
a0d0e21e 1926 (void)SvPOK_only(TARG);
48c036b1 1927 TAINT_IF(rxtainted);
a0d0e21e 1928 SvSETMAGIC(TARG);
9212bbba 1929 SvTAINT(TARG);
4633a7c4 1930 LEAVE_SCOPE(oldsave);
a0d0e21e 1931 RETURN;
1932 }
5cd24f17 1933 goto ret_no;
a0d0e21e 1934
1935nope:
d9f97599 1936 ++BmUSEFUL(rx->check_substr);
5cd24f17 1937
8ec5e241 1938ret_no:
1939 SPAGAIN;
3280af22 1940 PUSHs(&PL_sv_no);
4633a7c4 1941 LEAVE_SCOPE(oldsave);
a0d0e21e 1942 RETURN;
1943}
1944
1945PP(pp_grepwhile)
1946{
4e35701f 1947 djSP;
a0d0e21e 1948
1949 if (SvTRUEx(POPs))
3280af22 1950 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
1951 ++*PL_markstack_ptr;
a0d0e21e 1952 LEAVE; /* exit inner scope */
1953
1954 /* All done yet? */
3280af22 1955 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 1956 I32 items;
54310121 1957 I32 gimme = GIMME_V;
a0d0e21e 1958
1959 LEAVE; /* exit outer scope */
1960 (void)POPMARK; /* pop src */
3280af22 1961 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1962 (void)POPMARK; /* pop dst */
3280af22 1963 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1964 if (gimme == G_SCALAR) {
a0d0e21e 1965 dTARGET;
1966 XPUSHi(items);
a0d0e21e 1967 }
54310121 1968 else if (gimme == G_ARRAY)
1969 SP += items;
a0d0e21e 1970 RETURN;
1971 }
1972 else {
1973 SV *src;
1974
1975 ENTER; /* enter inner scope */
3280af22 1976 SAVESPTR(PL_curpm);
a0d0e21e 1977
3280af22 1978 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 1979 SvTEMP_off(src);
54b9620d 1980 DEFSV = src;
a0d0e21e 1981
1982 RETURNOP(cLOGOP->op_other);
1983 }
1984}
1985
1986PP(pp_leavesub)
1987{
4e35701f 1988 djSP;
a0d0e21e 1989 SV **mark;
1990 SV **newsp;
1991 PMOP *newpm;
1992 I32 gimme;
c09156bb 1993 register PERL_CONTEXT *cx;
f86702cc 1994 struct block_sub cxsub;
a0d0e21e 1995
1996 POPBLOCK(cx,newpm);
f86702cc 1997 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1998
a1f49e72 1999 TAINT_NOT;
a0d0e21e 2000 if (gimme == G_SCALAR) {
2001 MARK = newsp + 1;
a29cdaf0 2002 if (MARK <= SP) {
2003 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
2004 if (SvTEMP(TOPs)) {
2005 *MARK = SvREFCNT_inc(TOPs);
2006 FREETMPS;
2007 sv_2mortal(*MARK);
2008 } else {
2009 FREETMPS;
2010 *MARK = sv_mortalcopy(TOPs);
2011 }
2012 } else
2013 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2014 } else {
f86702cc 2015 MEXTEND(MARK, 0);
3280af22 2016 *MARK = &PL_sv_undef;
a0d0e21e 2017 }
2018 SP = MARK;
2019 }
54310121 2020 else if (gimme == G_ARRAY) {
f86702cc 2021 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2022 if (!SvTEMP(*MARK)) {
f86702cc 2023 *MARK = sv_mortalcopy(*MARK);
a1f49e72 2024 TAINT_NOT; /* Each item is independent */
2025 }
f86702cc 2026 }
a0d0e21e 2027 }
f86702cc 2028 PUTBACK;
2029
2030 POPSUB2(); /* Stack values are safe: release CV and @_ ... */
3280af22 2031 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2032
2033 LEAVE;
a0d0e21e 2034 return pop_return();
2035}
2036
76e3520e 2037STATIC CV *
cea2e8a9 2038S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2039{
2040 dTHR;
3280af22 2041 SV *dbsv = GvSV(PL_DBsub);
491527d0 2042
2043 if (!PERLDB_SUB_NN) {
2044 GV *gv = CvGV(cv);
2045
2046 save_item(dbsv);
2047 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2048 || strEQ(GvNAME(gv), "END")
2049 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2050 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2051 && (gv = (GV*)*svp) ))) {
2052 /* Use GV from the stack as a fallback. */
2053 /* GV is potentially non-unique, or contain different CV. */
2054 sv_setsv(dbsv, newRV((SV*)cv));
2055 }
2056 else {
2057 gv_efullname3(dbsv, gv, Nullch);
2058 }
3de9ffa1 2059 }
2060 else {
491527d0 2061 SvUPGRADE(dbsv, SVt_PVIV);
2062 SvIOK_on(dbsv);
2063 SAVEIV(SvIVX(dbsv));
2064 SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */
3de9ffa1 2065 }
491527d0 2066
3de9ffa1 2067 if (CvXSUB(cv))
3280af22 2068 PL_curcopdb = PL_curcop;
2069 cv = GvCV(PL_DBsub);
3de9ffa1 2070 return cv;
2071}
2072
a0d0e21e 2073PP(pp_entersub)
2074{
4e35701f 2075 djSP; dPOPss;
a0d0e21e 2076 GV *gv;
2077 HV *stash;
2078 register CV *cv;
c09156bb 2079 register PERL_CONTEXT *cx;
5d94fbed 2080 I32 gimme;
533c011a 2081 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e 2082
2083 if (!sv)
cea2e8a9 2084 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2085 switch (SvTYPE(sv)) {
2086 default:
2087 if (!SvROK(sv)) {
748a9306 2088 char *sym;
2d8e6c8d 2089 STRLEN n_a;
748a9306 2090
3280af22 2091 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2092 if (hasargs)
3280af22 2093 SP = PL_stack_base + POPMARK;
a0d0e21e 2094 RETURN;
fb73857a 2095 }
15ff848f 2096 if (SvGMAGICAL(sv)) {
2097 mg_get(sv);
2098 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2099 }
2100 else
2d8e6c8d 2101 sym = SvPV(sv, n_a);
15ff848f 2102 if (!sym)
cea2e8a9 2103 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2104 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2105 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2106 cv = get_cv(sym, TRUE);
a0d0e21e 2107 break;
2108 }
f5284f61 2109 {
2110 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2111 tryAMAGICunDEREF(to_cv);
2112 }
a0d0e21e 2113 cv = (CV*)SvRV(sv);
2114 if (SvTYPE(cv) == SVt_PVCV)
2115 break;
2116 /* FALL THROUGH */
2117 case SVt_PVHV:
2118 case SVt_PVAV:
cea2e8a9 2119 DIE(aTHX_ "Not a CODE reference");
a0d0e21e 2120 case SVt_PVCV:
2121 cv = (CV*)sv;
2122 break;
2123 case SVt_PVGV:
8ebc5c01 2124 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7 2125 cv = sv_2cv(sv, &stash, &gv, FALSE);
2126 if (!cv) {
2127 ENTER;
2128 SAVETMPS;
2129 goto try_autoload;
2130 }
2131 break;
a0d0e21e 2132 }
2133
2134 ENTER;
2135 SAVETMPS;
2136
2137 retry:
a0d0e21e 2138 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2139 GV* autogv;
22239a37 2140 SV* sub_name;
44a8e56a 2141
2142 /* anonymous or undef'd function leaves us no recourse */
2143 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2144 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2145
44a8e56a 2146 /* autoloaded stub? */
2147 if (cv != GvCV(gv)) {
2148 cv = GvCV(gv);
a0d0e21e 2149 }
44a8e56a 2150 /* should call AUTOLOAD now? */
67caa1fe 2151 else {
f6ec51f7 2152try_autoload:
2153 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2154 FALSE)))
2155 {
2156 cv = GvCV(autogv);
2157 }
2158 /* sorry */
2159 else {
2160 sub_name = sv_newmortal();
2161 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2162 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2163 }
67caa1fe 2164 }
2165 if (!cv)
cea2e8a9 2166 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2167 goto retry;
a0d0e21e 2168 }
2169
54310121 2170 gimme = GIMME_V;
67caa1fe 2171 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2172 cv = get_db_sub(&sv, cv);
67caa1fe 2173 if (!cv)
cea2e8a9 2174 DIE(aTHX_ "No DBsub routine");
67caa1fe 2175 }
a0d0e21e 2176
11343788 2177#ifdef USE_THREADS
3de9ffa1 2178 /*
2179 * First we need to check if the sub or method requires locking.
458fb581 2180 * If so, we gain a lock on the CV, the first argument or the
2181 * stash (for static methods), as appropriate. This has to be
2182 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2183 * reschedule by returning a new op.
3de9ffa1 2184 */
11343788 2185 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab 2186 if (CvFLAGS(cv) & CVf_LOCKED) {
2187 MAGIC *mg;
2188 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a 2189 if (SP > PL_stack_base + TOPMARK)
2190 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2191 else {
13e08037 2192 AV *av = (AV*)PL_curpad[0];
2193 if (hasargs || !av || AvFILLp(av) < 0
2194 || !(sv = AvARRAY(av)[0]))
2195 {
2196 MUTEX_UNLOCK(CvMUTEXP(cv));
cea2e8a9 2197 Perl_croak(aTHX_ "no argument for locked method call");
13e08037 2198 }
77a005ab 2199 }
2200 if (SvROK(sv))
2201 sv = SvRV(sv);
458fb581 2202 else {
2203 STRLEN len;
2204 char *stashname = SvPV(sv, len);
2205 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2206 }
77a005ab 2207 }
2208 else {
2209 sv = (SV*)cv;
2210 }
2211 MUTEX_UNLOCK(CvMUTEXP(cv));
2212 mg = condpair_magic(sv);
2213 MUTEX_LOCK(MgMUTEXP(mg));
2214 if (MgOWNER(mg) == thr)
2215 MUTEX_UNLOCK(MgMUTEXP(mg));
2216 else {
2217 while (MgOWNER(mg))
2218 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2219 MgOWNER(mg) = thr;
8b73bbec 2220 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
1fd28e87 2221 thr, sv);)
77a005ab 2222 MUTEX_UNLOCK(MgMUTEXP(mg));
cea2e8a9 2223 save_destructor(Perl_unlock_condpair, sv);
11343788 2224 }
77a005ab 2225 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2226 }
3de9ffa1 2227 /*
2228 * Now we have permission to enter the sub, we must distinguish
2229 * four cases. (0) It's an XSUB (in which case we don't care
2230 * about ownership); (1) it's ours already (and we're recursing);
2231 * (2) it's free (but we may already be using a cached clone);
2232 * (3) another thread owns it. Case (1) is easy: we just use it.
2233 * Case (2) means we look for a clone--if we have one, use it
2234 * otherwise grab ownership of cv. Case (3) means we look for a
2235 * clone (for non-XSUBs) and have to create one if we don't
2236 * already have one.
2237 * Why look for a clone in case (2) when we could just grab
2238 * ownership of cv straight away? Well, we could be recursing,
2239 * i.e. we originally tried to enter cv while another thread
2240 * owned it (hence we used a clone) but it has been freed up
2241 * and we're now recursing into it. It may or may not be "better"
2242 * to use the clone but at least CvDEPTH can be trusted.
2243 */
2244 if (CvOWNER(cv) == thr || CvXSUB(cv))
2245 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2246 else {
3de9ffa1 2247 /* Case (2) or (3) */
2248 SV **svp;
2249
11343788 2250 /*
3de9ffa1 2251 * XXX Might it be better to release CvMUTEXP(cv) while we
2252 * do the hv_fetch? We might find someone has pinched it
2253 * when we look again, in which case we would be in case
2254 * (3) instead of (2) so we'd have to clone. Would the fact
2255 * that we released the mutex more quickly make up for this?
2256 */
b099ddc0 2257 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2258 {
3de9ffa1 2259 /* We already have a clone to use */
11343788 2260 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2261 cv = *(CV**)svp;
8b73bbec 2262 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
1fd28e87 2263 "entersub: %p already has clone %p:%s\n",
2264 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1 2265 CvOWNER(cv) = thr;
2266 SvREFCNT_inc(cv);
2267 if (CvDEPTH(cv) == 0)
cea2e8a9 2268 SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
3de9ffa1 2269 }
11343788 2270 else {
3de9ffa1 2271 /* (2) => grab ownership of cv. (3) => make clone */
2272 if (!CvOWNER(cv)) {
2273 CvOWNER(cv) = thr;
2274 SvREFCNT_inc(cv);
11343788 2275 MUTEX_UNLOCK(CvMUTEXP(cv));
8b73bbec 2276 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
1fd28e87 2277 "entersub: %p grabbing %p:%s in stash %s\n",
2278 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2279 HvNAME(CvSTASH(cv)) : "(none)"));
2280 } else {
2281 /* Make a new clone. */
2282 CV *clonecv;
2283 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2284 MUTEX_UNLOCK(CvMUTEXP(cv));
8b73bbec 2285 DEBUG_S((PerlIO_printf(PerlIO_stderr(),
1fd28e87 2286 "entersub: %p cloning %p:%s\n",
2287 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1 2288 /*
2289 * We're creating a new clone so there's no race
2290 * between the original MUTEX_UNLOCK and the
2291 * SvREFCNT_inc since no one will be trying to undef
2292 * it out from underneath us. At least, I don't think
2293 * there's a race...
2294 */
2295 clonecv = cv_clone(cv);
2296 SvREFCNT_dec(cv); /* finished with this */
199100c8 2297 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1 2298 CvOWNER(clonecv) = thr;
2299 cv = clonecv;
11343788 2300 SvREFCNT_inc(cv);
11343788 2301 }
8b73bbec 2302 DEBUG_S(if (CvDEPTH(cv) != 0)
3de9ffa1 2303 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
2304 CvDEPTH(cv)););
cea2e8a9 2305 SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
11343788 2306 }
3de9ffa1 2307 }
11343788 2308#endif /* USE_THREADS */
2309
a0d0e21e 2310 if (CvXSUB(cv)) {
67caa1fe 2311#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2312 if (CvOLDSTYLE(cv)) {
20ce7b12 2313 I32 (*fp3)(int,int,int);
a0d0e21e 2314 dMARK;
2315 register I32 items = SP - MARK;
67955e0c 2316 /* We dont worry to copy from @_. */
924508f0 2317 while (SP > mark) {
2318 SP[1] = SP[0];
2319 SP--;
a0d0e21e 2320 }
3280af22 2321 PL_stack_sp = mark + 1;
20ce7b12 2322 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
ecfc5424 2323 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2324 MARK - PL_stack_base + 1,
ecfc5424 2325 items);
3280af22 2326 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2327 }
67caa1fe 2328 else
2329#endif /* PERL_XSUB_OLDSTYLE */
2330 {
748a9306 2331 I32 markix = TOPMARK;
2332
a0d0e21e 2333 PUTBACK;
67955e0c 2334
2335 if (!hasargs) {
2336 /* Need to copy @_ to stack. Alternative may be to
2337 * switch stack to @_, and copy return values
2338 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2 2339 AV* av;
2340 I32 items;
2341#ifdef USE_THREADS
533c011a 2342 av = (AV*)PL_curpad[0];
6d4ff0d2 2343#else
3280af22 2344 av = GvAV(PL_defgv);
6d4ff0d2 2345#endif /* USE_THREADS */
93965878 2346 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c 2347
2348 if (items) {
2349 /* Mark is at the end of the stack. */
924508f0 2350 EXTEND(SP, items);
2351 Copy(AvARRAY(av), SP + 1, items, SV*);
2352 SP += items;
67955e0c 2353 PUTBACK ;
2354 }
2355 }
67caa1fe 2356 /* We assume first XSUB in &DB::sub is the called one. */
2357 if (PL_curcopdb) {
3280af22 2358 SAVESPTR(PL_curcop);
2359 PL_curcop = PL_curcopdb;
2360 PL_curcopdb = NULL;
67955e0c 2361 }
2362 /* Do we need to open block here? XXXX */
0cb96387 2363 (void)(*CvXSUB(cv))(aTHXo_ cv);
748a9306 2364
2365 /* Enforce some sanity in scalar context. */
3280af22 2366 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2367 if (markix > PL_stack_sp - PL_stack_base)
2368 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2369 else
3280af22 2370 *(PL_stack_base + markix) = *PL_stack_sp;
2371 PL_stack_sp = PL_stack_base + markix;
748a9306 2372 }
a0d0e21e 2373 }
2374 LEAVE;
2375 return NORMAL;
2376 }
2377 else {
2378 dMARK;
2379 register I32 items = SP - MARK;
a0d0e21e 2380 AV* padlist = CvPADLIST(cv);
2381 SV** svp = AvARRAY(padlist);
533c011a 2382 push_return(PL_op->op_next);
a0d0e21e 2383 PUSHBLOCK(cx, CXt_SUB, MARK);
2384 PUSHSUB(cx);
2385 CvDEPTH(cv)++;
6b35e009 2386 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2387 * that eval'' ops within this sub know the correct lexical space.
2388 * Owing the speed considerations, we choose to search for the cv
2389 * in doeval() instead.
2390 */
a0d0e21e 2391 if (CvDEPTH(cv) < 2)
2392 (void)SvREFCNT_inc(cv);
2393 else { /* save temporaries on recursion? */
93965878 2394 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2395 AV *av;
2396 AV *newpad = newAV();
4aa0a1f7 2397 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2398 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2399 svp = AvARRAY(svp[0]);
748a9306 2400 for ( ;ix > 0; ix--) {
3280af22 2401 if (svp[ix] != &PL_sv_undef) {
748a9306 2402 char *name = SvPVX(svp[ix]);
5f05dabc 2403 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2404 || *name == '&') /* anonymous code? */
2405 {
2406 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306 2407 }
2408 else { /* our own lexical */
2409 if (*name == '@')
2410 av_store(newpad, ix, sv = (SV*)newAV());
2411 else if (*name == '%')
2412 av_store(newpad, ix, sv = (SV*)newHV());
2413 else
2414 av_store(newpad, ix, sv = NEWSV(0,0));
2415 SvPADMY_on(sv);
2416 }
a0d0e21e 2417 }
2418 else {
748a9306 2419 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e 2420 SvPADTMP_on(sv);
2421 }
2422 }
2423 av = newAV(); /* will be @_ */
2424 av_extend(av, 0);
2425 av_store(newpad, 0, (SV*)av);
2426 AvFLAGS(av) = AVf_REIFY;
2427 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2428 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e 2429 svp = AvARRAY(padlist);
2430 }
2431 }
6d4ff0d2 2432#ifdef USE_THREADS
2433 if (!hasargs) {
533c011a 2434 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2435
93965878 2436 items = AvFILLp(av) + 1;
6d4ff0d2 2437 if (items) {
2438 /* Mark is at the end of the stack. */
924508f0 2439 EXTEND(SP, items);
2440 Copy(AvARRAY(av), SP + 1, items, SV*);
2441 SP += items;
6d4ff0d2 2442 PUTBACK ;
2443 }
2444 }
2445#endif /* USE_THREADS */
3280af22 2446 SAVESPTR(PL_curpad);
2447 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2 2448#ifndef USE_THREADS
2449 if (hasargs)
2450#endif /* USE_THREADS */
2451 {
2452 AV* av;
a0d0e21e 2453 SV** ary;
2454
77a005ab 2455#if 0
8b73bbec 2456 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
0f15f207 2457 "%p entersub preparing @_\n", thr));
77a005ab 2458#endif
3280af22 2459 av = (AV*)PL_curpad[0];
a0d0e21e 2460 if (AvREAL(av)) {
2461 av_clear(av);
2462 AvREAL_off(av);
2463 }
6d4ff0d2 2464#ifndef USE_THREADS
3280af22 2465 cx->blk_sub.savearray = GvAV(PL_defgv);
2466 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2 2467#endif /* USE_THREADS */
2468 cx->blk_sub.argarray = av;
a0d0e21e 2469 ++MARK;
2470
2471 if (items > AvMAX(av) + 1) {
2472 ary = AvALLOC(av);
2473 if (AvARRAY(av) != ary) {
2474 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2475 SvPVX(av) = (char*)ary;
2476 }
2477 if (items > AvMAX(av) + 1) {
2478 AvMAX(av) = items - 1;
2479 Renew(ary,items,SV*);
2480 AvALLOC(av) = ary;
2481 SvPVX(av) = (char*)ary;
2482 }
2483 }
2484 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2485 AvFILLp(av) = items - 1;
a0d0e21e 2486
2487 while (items--) {
2488 if (*MARK)
2489 SvTEMP_off(*MARK);
2490 MARK++;
2491 }
2492 }
4a925ff6 2493 /* warning must come *after* we fully set up the context
2494 * stuff so that __WARN__ handlers can safely dounwind()
2495 * if they want to
2496 */
2497 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2498 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2499 sub_crush_depth(cv);
77a005ab 2500#if 0
8b73bbec 2501 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
0f15f207 2502 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2503#endif
a0d0e21e 2504 RETURNOP(CvSTART(cv));
2505 }
2506}
2507
44a8e56a 2508void
864dbfa3 2509Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a 2510{
2511 if (CvANON(cv))
cea2e8a9 2512 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
44a8e56a 2513 else {
2514 SV* tmpstr = sv_newmortal();
2515 gv_efullname3(tmpstr, CvGV(cv), Nullch);
cea2e8a9 2516 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
599cee73 2517 SvPVX(tmpstr));
44a8e56a 2518 }
2519}
2520
a0d0e21e 2521PP(pp_aelem)
2522{
4e35701f 2523 djSP;
a0d0e21e 2524 SV** svp;
748a9306 2525 I32 elem = POPi;
68dc0745 2526 AV* av = (AV*)POPs;
533c011a 2527 U32 lval = PL_op->op_flags & OPf_MOD;
2528 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2529 SV *sv;
a0d0e21e 2530
748a9306 2531 if (elem > 0)
3280af22 2532 elem -= PL_curcop->cop_arybase;
a0d0e21e 2533 if (SvTYPE(av) != SVt_PVAV)
2534 RETPUSHUNDEF;
68dc0745 2535 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2536 if (lval) {
3280af22 2537 if (!svp || *svp == &PL_sv_undef) {
68dc0745 2538 SV* lv;
2539 if (!defer)
cea2e8a9 2540 DIE(aTHX_ PL_no_aelem, elem);
68dc0745 2541 lv = sv_newmortal();
2542 sv_upgrade(lv, SVt_PVLV);
2543 LvTYPE(lv) = 'y';
2544 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2545 LvTARG(lv) = SvREFCNT_inc(av);
2546 LvTARGOFF(lv) = elem;
2547 LvTARGLEN(lv) = 1;
2548 PUSHs(lv);
2549 RETURN;
2550 }
533c011a 2551 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2552 save_aelem(av, elem, svp);
533c011a 2553 else if (PL_op->op_private & OPpDEREF)
2554 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2555 }
3280af22 2556 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0 2557 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2558 sv = sv_mortalcopy(sv);
2559 PUSHs(sv);
a0d0e21e 2560 RETURN;
2561}
2562
02a9e968 2563void
864dbfa3 2564Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968 2565{
2566 if (SvGMAGICAL(sv))
2567 mg_get(sv);
2568 if (!SvOK(sv)) {
2569 if (SvREADONLY(sv))
cea2e8a9 2570 Perl_croak(aTHX_ PL_no_modify);
5f05dabc 2571 if (SvTYPE(sv) < SVt_RV)
2572 sv_upgrade(sv, SVt_RV);
2573 else if (SvTYPE(sv) >= SVt_PV) {
2574 (void)SvOOK_off(sv);
2575 Safefree(SvPVX(sv));
2576 SvLEN(sv) = SvCUR(sv) = 0;
2577 }
68dc0745 2578 switch (to_what) {
5f05dabc 2579 case OPpDEREF_SV:
8c52afec 2580 SvRV(sv) = NEWSV(355,0);
5f05dabc 2581 break;
2582 case OPpDEREF_AV:
2583 SvRV(sv) = (SV*)newAV();
2584 break;
2585 case OPpDEREF_HV:
2586 SvRV(sv) = (SV*)newHV();
2587 break;
2588 }
02a9e968 2589 SvROK_on(sv);
2590 SvSETMAGIC(sv);
2591 }
2592}
2593
a0d0e21e 2594PP(pp_method)
2595{
4e35701f 2596 djSP;
a0d0e21e 2597 SV* sv;
2598 SV* ob;
2599 GV* gv;
56304f61 2600 HV* stash;
2601 char* name;
ac91690f 2602 char* packname;
2603 STRLEN packlen;
a0d0e21e 2604
fb73857a 2605 if (SvROK(TOPs)) {
2606 sv = SvRV(TOPs);
2607 if (SvTYPE(sv) == SVt_PVCV) {
2608 SETs(sv);
2609 RETURN;
2610 }
2611 }
2612
2d8e6c8d 2613 name = SvPV(TOPs, packlen);
3280af22 2614 sv = *(PL_stack_base + TOPMARK + 1);
a0d0e21e 2615
16d20bd9 2616 if (SvGMAGICAL(sv))
2617 mg_get(sv);
a0d0e21e 2618 if (SvROK(sv))
16d20bd9 2619 ob = (SV*)SvRV(sv);
a0d0e21e 2620 else {
2621 GV* iogv;
a0d0e21e 2622
56304f61 2623 packname = Nullch;
a0d0e21e 2624 if (!SvOK(sv) ||
56304f61 2625 !(packname = SvPV(sv, packlen)) ||
a0d0e21e 2626 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2627 !(ob=(SV*)GvIO(iogv)))
2628 {
834a4ddd 2629 if (!packname ||
2630 ((*(U8*)packname >= 0xc0 && IN_UTF8)
b86a2fa7 2631 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd 2632 : !isIDFIRST(*packname)
2633 ))
2634 {
cea2e8a9 2635 DIE(aTHX_ "Can't call method \"%s\" %s", name,
72b5445b 2636 SvOK(sv)? "without a package or object reference"
2637 : "on an undefined value");
834a4ddd 2638 }
56304f61 2639 stash = gv_stashpvn(packname, packlen, TRUE);
ac91690f 2640 goto fetch;
a0d0e21e 2641 }
3280af22 2642 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e 2643 }
2644
ac91690f 2645 if (!ob || !SvOBJECT(ob))
cea2e8a9 2646 DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
a0d0e21e 2647
56304f61 2648 stash = SvSTASH(ob);
a0d0e21e 2649
ac91690f 2650 fetch:
ac91690f 2651 gv = gv_fetchmethod(stash, name);
56304f61 2652 if (!gv) {
2653 char* leaf = name;
2654 char* sep = Nullch;
2655 char* p;
2656
2657 for (p = name; *p; p++) {
2658 if (*p == '\'')
2659 sep = p, leaf = p + 1;
2660 else if (*p == ':' && *(p + 1) == ':')
2661 sep = p, leaf = p + 2;
2662 }
2663 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3280af22 2664 packname = HvNAME(sep ? PL_curcop->cop_stash : stash);
56304f61 2665 packlen = strlen(packname);
2666 }
2667 else {
2668 packname = name;
2669 packlen = sep - name;
2670 }
cea2e8a9 2671 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
56304f61 2672 leaf, (int)packlen, packname);
2673 }
8ebc5c01 2674 SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
a0d0e21e 2675 RETURN;
2676}
22239a37 2677
Unnamed repository; edit this file to name it for gitweb.