source: trunk/third/perl/pp_hot.c @ 10724

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