o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}
+void
+Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
+ PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
+
+ if (strNE(fhname, "STDERR")
+ && strNE(fhname, "STDOUT")
+ && strNE(fhname, "STDIN")
+ && strNE(fhname, "_")
+ && strNE(fhname, "ARGV")
+ && strNE(fhname, "ARGVOUT")
+ && strNE(fhname, "DATA")) {
+ qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
+ }
+}
+
/* "register" allocation */
PADOFFSET
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
PADOFFSET off;
+ bool is_idfirst, is_default;
const bool is_our = (PL_parser->in_my == KEY_our);
PERL_ARGS_ASSERT_ALLOCMY;
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
(UV)flags);
+ is_idfirst = flags & SVf_UTF8
+ ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
+ : isIDFIRST_A(name[1]);
+
+ /* $_, @_, etc. */
+ is_default = len == 2 && name[1] == '_';
+
/* complain about "my $<special_var>" etc etc */
- if ( len
- && !( is_our
- || isALPHA(name[1])
- || ( (flags & SVf_UTF8)
- && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
- || (name[1] == '_' && len > 2)))
- {
+ if (!is_our && (!is_idfirst || is_default)) {
const char * const type =
PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
}
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
=for apidoc alloccopstash
Perl_op_refcnt_lock(pTHX)
PERL_TSA_ACQUIRE(PL_op_mutex)
{
-#ifdef USE_ITHREADS
-#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
}
Perl_op_refcnt_unlock(pTHX)
PERL_TSA_RELEASE(PL_op_mutex)
{
-#ifdef USE_ITHREADS
-#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_UNLOCK;
}
cmpop->op_private = 2;
cmpop = CHECKOP(cmpoptype, cmpop);
if(!cmpop->op_next && cmpop->op_type == cmpoptype)
- cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
+ cmpop = op_integerize(op_std_init(cmpop));
condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
cmpop;
if (!nextrightarg)
}
/*
-=head1 Compile-time scope hooks
+=for apidoc_section $scope
=for apidoc blockhook_register
PERL_ARGS_ASSERT_JMAYBE;
if (o->op_type == OP_LIST) {
- OP * const o2
- = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
- o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
+ OP * const o2
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
+ o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ }
+ else {
+ /* If the user disables this, then a warning might not be enough to alert
+ them to a possible change of behaviour here, so throw an exception.
+ */
+ yyerror("Multidimensional hash lookup is disabled");
+ }
}
return o;
}
}
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
*/
/* List constructors */
/*
-=head1 Optree construction
+=for apidoc_section $optree_construction
=for apidoc newNULLLIST
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
|| type == OP_SASSIGN
|| type == OP_ENTERTRY
+ || type == OP_ENTERTRYCATCH
|| type == OP_CUSTOM
|| type == OP_NULL );
UV* t_array;
SV* t_invlist;
UV* r_map;
- UV r_cp, t_cp;
+ UV r_cp = 0, t_cp = 0;
UV t_cp_end = (UV) -1;
UV r_cp_end;
Size_t len;
} else {
SV * const repointer = &PL_sv_undef;
av_push(PL_regex_padav, repointer);
- pmop->op_pmoffset = av_tindex(PL_regex_padav);
+ pmop->op_pmoffset = av_top_index(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
}
/*
-=head1 Embedding Functions
+=for apidoc_section $embedding
=for apidoc load_module
=for apidoc Amnh||PERL_LOADMOD_NOIMPORT
=for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
+=for apidoc vload_module
+Like C<L</load_module>> but the arguments are an encapsulated argument list.
+
+=for apidoc load_module_nocontext
+Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut */
void
}
/*
-=head1 Optree construction
+=for apidoc_section $optree_construction
=for apidoc newSLICEOP
}
/*
+=for apidoc newTRYCATCHOP
+
+Constructs and returns a conditional execution statement that implements
+the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
+inside a context that traps exceptions. If an exception occurs then the
+optree in C<catchblock> is executed, with the trapped exception set into the
+lexical variable given by C<catchvar> (which must be an op of type
+C<OP_PADSV>). All the optrees are consumed by this function and become part
+of the returned op tree.
+
+The C<flags> argument is currently ignored.
+
+=cut
+ */
+
+OP *
+Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
+{
+ OP *o, *catchop;
+
+ PERL_ARGS_ASSERT_NEWTRYCATCHOP;
+ assert(catchvar->op_type == OP_PADSV);
+
+ PERL_UNUSED_ARG(flags);
+
+ /* The returned optree is shaped as:
+ * LISTOP leavetrycatch
+ * LOGOP entertrycatch
+ * LISTOP poptry
+ * $tryblock here
+ * LOGOP catch
+ * $catchblock here
+ */
+
+ if(tryblock->op_type != OP_LINESEQ)
+ tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
+ OpTYPE_set(tryblock, OP_POPTRY);
+
+ /* Manually construct a naked LOGOP.
+ * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
+ * containing the LOGOP we wanted as its op_first */
+ catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
+ OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
+ OpLASTSIB_set(catchblock, catchop);
+
+ /* Inject the catchvar's pad offset into the OP_CATCH targ */
+ cLOGOPx(catchop)->op_targ = catchvar->op_targ;
+ op_free(catchvar);
+
+ /* Build the optree structure */
+ o = newLISTOP(OP_LIST, 0, tryblock, catchop);
+ o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
+
+ return o;
+}
+
+/*
=for apidoc newRANGE
Constructs and returns a C<range> op, with subordinate C<flip> and
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
=for apidoc cv_const_sv
If C<o_is_gv> is false and C<o> is null, then the subroutine will
be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
-must point to a C<const> op, which will be consumed by this function,
+must point to a C<const> OP, which will be consumed by this function,
and its string value supplies a name for the subroutine. The name may
be qualified or unqualified, and if it is unqualified then a default
stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
any use of the returned pointer. It is the caller's responsibility to
ensure that it knows which of these situations applies.
+=for apidoc newATTRSUB
+Construct a Perl subroutine, also performing some surrounding jobs.
+
+This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
+FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
+the name will be derived from C<o> in the way described (as with all other
+details) in L<perlintern/C<newATTRSUB_x>>.
+
+=for apidoc newSUB
+Like C<L</newATTRSUB>>, but without attributes.
+
=cut
*/
}
OP *
+Perl_ck_trycatch(pTHX_ OP *o)
+{
+ LOGOP *enter;
+ OP *to_free = NULL;
+ OP *trykid, *catchkid;
+ OP *catchroot, *catchstart;
+
+ PERL_ARGS_ASSERT_CK_TRYCATCH;
+
+ trykid = cUNOPo->op_first;
+ if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
+ to_free = trykid;
+ trykid = OpSIBLING(trykid);
+ }
+ catchkid = OpSIBLING(trykid);
+
+ assert(trykid->op_type == OP_POPTRY);
+ assert(catchkid->op_type == OP_CATCH);
+
+ /* cut whole sibling chain free from o */
+ op_sibling_splice(o, NULL, -1, NULL);
+ if(to_free)
+ op_free(to_free);
+ op_free(o);
+
+ enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
+
+ /* establish postfix order */
+ enter->op_next = (OP*)enter;
+
+ o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
+ op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
+
+ OpTYPE_set(o, OP_LEAVETRYCATCH);
+
+ /* The returned optree is actually threaded up slightly nonobviously in
+ * terms of its ->op_next pointers.
+ *
+ * This way, if the tryblock dies, its retop points at the OP_CATCH, but
+ * if it does not then its leavetry skips over that and continues
+ * execution past it.
+ */
+
+ /* First, link up the actual body of the catch block */
+ catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
+ catchstart = LINKLIST(catchroot);
+ cLOGOPx(catchkid)->op_other = catchstart;
+
+ o->op_next = LINKLIST(o);
+
+ /* die within try block should jump to the catch */
+ enter->op_other = catchkid;
+
+ /* after try block that doesn't die, just skip straight to leavetrycatch */
+ trykid->op_next = o;
+
+ /* after catch block, skip back up to the leavetrycatch */
+ catchroot->op_next = o;
+
+ return o;
+}
+
+OP *
Perl_ck_exec(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_EXEC;
{
OP * const newop = newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
+ /* a first argument is handled by toke.c, ideally we'd
+ just check here but several ops don't use ck_fun() */
+ if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) {
+ no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid)));
+ }
/* replace kid with newop in chain */
op_sibling_splice(o, prev_kid, 1, newop);
op_free(kid);
{
o->op_flags |= OPf_SPECIAL;
kid->op_private &= ~OPpCONST_STRICT;
+ if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
+ no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
+ }
}
}
return ck_fun(o);
goto do_next;
case OP_UNDEF:
- /* undef counts as a scalar on the RHS:
- * (undef, $x) = ...; # only 1 scalar on LHS: always safe
+ /* undef on LHS following a var is significant, e.g.
+ * my $x = 1;
+ * @a = (($x, undef) = (2 => $x));
+ * # @a shoul be (2,1) not (2,2)
+ *
+ * undef on RHS counts as a scalar:
* ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
*/
- if (rhs)
+ if ((!rhs && *scalars_p) || rhs)
(*scalars_p)++;
flags = AAS_SAFE_SCALAR;
break;
|| !r /* .... = (); */
|| !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
|| !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
- || (lscalars < 2) /* ($x, undef) = ... */
+ || (lscalars < 2) /* (undef, $x) = ... */
) {
NOOP; /* always safe */
}
}
/*
-=head1 Custom Operators
+=for apidoc_section $custom
=for apidoc Perl_custom_op_xop
Return the XOP structure for a given custom op. This macro should be
else
xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
}
+
{
XOPRETANY any;
if(field == XOPe_xop_ptr) {
any.xop_peep = xop->xop_peep;
break;
default:
- NOT_REACHED; /* NOTREACHED */
+ field_panic:
+ Perl_croak(aTHX_
+ "panic: custom_op_get_field(): invalid field %d\n",
+ (int)field);
break;
}
} else {
any.xop_peep = XOPd_xop_peep;
break;
default:
- NOT_REACHED; /* NOTREACHED */
+ goto field_panic;
break;
}
}
}
- /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
- * op.c: In function 'Perl_custom_op_get_field':
- * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
- * This is because on those platforms (with -DEBUGGING) NOT_REACHED
- * expands to assert(0), which expands to ((0) ? (void)0 :
- * __assert(...)), and gcc doesn't know that __assert can never return. */
return any;
}
}
}
/*
-=head1 Hook manipulation
+=for apidoc_section $hook
These functions provide convenient and thread-safe means of manipulating
hook variables.
https://perl5.git.perl.org / perl5.git / blobdiff