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