*/
/*
- * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
- * our Mr. Bilbo's first cousin on the mother's side (her mother being the
- * youngest of the Old Took's daughters); and Mr. Drogo was his second
- * cousin. So Mr. Frodo is his first *and* second cousin, once removed
- * either way, as the saying is, if you follow me." --the Gaffer
+ * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
+ * our Mr. Bilbo's first cousin on the mother's side (her mother being the
+ * youngest of the Old Took's daughters); and Mr. Drogo was his second
+ * cousin. So Mr. Frodo is his first *and* second cousin, once removed
+ * either way, as the saying is, if you follow me.' --the Gaffer
+ *
+ * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* This file contains the functions that create, manipulate and optimize
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
-OP *
-Perl_linklist(pTHX_ OP *o)
+static OP *
+S_linklist(pTHX_ OP *o)
{
OP *first;
return o->op_next;
}
-OP *
-Perl_scalarkids(pTHX_ OP *o)
+static OP *
+S_scalarkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
return o;
}
-OP *
-Perl_listkids(pTHX_ OP *o)
+static OP *
+S_listkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
return o;
}
-OP *
-Perl_scalarseq(pTHX_ OP *o)
+static OP *
+S_scalarseq(pTHX_ OP *o)
{
dVAR;
if (o) {
}
}
-OP *
-Perl_refkids(pTHX_ OP *o, I32 type)
+static OP *
+S_refkids(pTHX_ OP *o, I32 type)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
}
OP *
-Perl_my(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_MY;
-
- return my_attrs(o, NULL);
-}
-
-OP *
Perl_sawparens(pTHX_ OP *o)
{
PERL_UNUSED_CONTEXT;
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv
- = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
return o;
}
-OP *
-Perl_fold_constants(pTHX_ register OP *o)
+static OP *
+S_fold_constants(pTHX_ register OP *o)
{
dVAR;
register OP * VOL curop;
return o;
}
-OP *
-Perl_gen_constant_list(pTHX_ register OP *o)
+static OP *
+S_gen_constant_list(pTHX_ register OP *o)
{
dVAR;
register OP *curop;
return newOP(OP_STUB, 0);
}
-OP *
-Perl_force_list(pTHX_ OP *o)
+static OP *
+S_force_list(pTHX_ OP *o)
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
return 0;
}
-OP *
-Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
+static OP *
+S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
}
}
}
+
+ if(ckWARN(WARN_MISC)) {
+ if(del && rlen == tlen) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
+ } else if(rlen > tlen) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
+ }
+ }
+
if (grows)
o->op_private |= OPpTRANS_GROWS;
#ifdef PERL_MAD
#endif
CopSTASH_set(cop, PL_curstash);
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
+ /* this line can have a breakpoint - store the cop in IV */
AV *av = CopFILEAVx(PL_curcop);
if (av) {
SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
if (!block)
goto done;
+ /* If we assign an optree to a PVCV, then we've defined a subroutine that
+ the debugger could be able to set a breakpoint in, so signal to
+ pp_entereval that it should not throw away any saved lines at scope
+ exit. */
+
+ PL_breakable_sub_gen++;
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
dVAR;
CV* cv;
#ifdef USE_ITHREADS
- const char *const temp_p = CopFILE(PL_curcop);
- const STRLEN len = temp_p ? strlen(temp_p) : 0;
+ const char *const file = CopFILE(PL_curcop);
#else
SV *const temp_sv = CopFILESV(PL_curcop);
- STRLEN len;
- const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+ const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
#endif
- char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
+ cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
+ XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- Safefree(file);
#ifdef USE_ITHREADS
if (stash)
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling)
+ if ((kid->op_type == OP_NULL)
+ && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
+ /* This is a do block */
+ OP *op = kUNOP->op_first;
+ if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
+ op = cUNOPx(op)->op_first;
+ assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+ /* Force the use of the caller's context */
+ op->op_flags |= OPf_SPECIAL;
+ }
+ }
}
+
return o;
}
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
+ const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
const STRLEN len = re ? RX_PRELEN(re) : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%.*s/ should probably be written as \"%.*s\"",
https://perl5.git.perl.org / perl5.git / blobdiff