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