tmpstr = POPs;
if (SvROK(tmpstr)) {
- SV *sv = SvRV(tmpstr);
+ SV * const sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
mg = mg_find(sv, PERL_MAGIC_qr);
}
else {
STRLEN len;
const char *t = SvPV_const(tmpstr, len);
+ regexp * const re = PM_GETRE(pm);
/* Check against the last compiled regexp. */
- if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
- PM_GETRE(pm)->prelen != (I32)len ||
- memNE(PM_GETRE(pm)->precomp, t, len))
+ if (!re || !re->precomp || re->prelen != (I32)len ||
+ memNE(re->precomp, t, len))
{
- if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
+ if (re) {
+ ReREFCNT_dec(re);
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
if(old != rx) {
if(old)
ReREFCNT_dec(old);
- PM_SETRE(pm,rx);
+ PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
if (DO_UTF8(dstr))
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
- sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
PUSHs(sv_2mortal(newSViv(saviters - 1)));
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
- ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
- sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
+ my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%"SVf, err);
+ Perl_warn(aTHX_ "%"SVf, (void*)err);
++PL_error_count;
}
PUSHs(sv_2mortal(mask));
}
- PUSHs(cx->blk_oldcop->cop_hints ?
+ PUSHs(cx->blk_oldcop->cop_hints_hash ?
sv_2mortal(newRV_noinc(
- (SV*)Perl_refcounted_he_chain_2hv(aTHX_
- cx->blk_oldcop->cop_hints)))
+ (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+ cx->blk_oldcop->cop_hints_hash)))
: &PL_sv_undef);
RETURN;
}
TAINT_NOT;
if (gimme == G_VOID)
- /*EMPTY*/; /* do nothing */
+ NOOP;
else if (gimme == G_SCALAR) {
if (mark < SP)
*++newsp = sv_mortalcopy(*SP);
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+ DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
}
break;
case CXt_FORMAT:
goto retry;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
- DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
}
DIE(aTHX_ "Goto undefined subroutine");
}
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
- SvREFCNT_inc_void_NN(cv);
+ SvREFCNT_inc_simple_void_NN(cv);
else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
len = SvCUR(sv);
}
else
- len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+ (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
if (!PL_madskills)
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
+ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
CV * const cv = get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
{
Stat_t st;
const int st_rc = PerlLIO_stat(name, &st);
+
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
const I32 gimme = GIMME_V;
int filter_has_file = 0;
PerlIO *tryrsfp = NULL;
+ SV *filter_cache = NULL;
SV *filter_state = NULL;
SV *filter_sub = NULL;
SV *hook_sv = NULL;
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
- if ( vcmp(sv,PL_patchlevel) < 0 )
+ if ( vcmp(sv,PL_patchlevel) <= 0 )
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
}
else {
if ( vcmp(sv,PL_patchlevel) > 0 )
DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
}
RETPUSHYES;
{
namesv = newSV(0);
for (i = 0; i <= AvFILL(ar); i++) {
- SV *dirsv = *av_fetch(ar, i, TRUE);
+ SV * const dirsv = *av_fetch(ar, i, TRUE);
if (SvROK(dirsv)) {
int count;
SP -= count - 1;
arg = SP[i++];
+ if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
+ && !isGV_with_GP(SvRV(arg))) {
+ filter_cache = SvRV(arg);
+ SvREFCNT_inc_simple_void_NN(filter_cache);
+
+ if (i < count) {
+ arg = SP[i++];
+ }
+ }
+
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
arg = SvRV(arg);
}
if (SvTYPE(arg) == SVt_PVGV) {
- IO *io = GvIO((GV *)arg);
+ IO * const io = GvIO((GV *)arg);
++filter_has_file;
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
- SvREFCNT_inc_void_NN(filter_sub);
+ SvREFCNT_inc_simple_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
SvREFCNT_inc_simple_void(filter_state);
}
+ }
- if (!tryrsfp) {
- tryrsfp = PerlIO_open(BIT_BUCKET,
- PERL_SCRIPT_MODE);
- }
+ if (!tryrsfp && (filter_cache || filter_sub)) {
+ tryrsfp = PerlIO_open(BIT_BUCKET,
+ PERL_SCRIPT_MODE);
}
SP--;
}
}
filter_has_file = 0;
+ if (filter_cache) {
+ SvREFCNT_dec(filter_cache);
+ filter_cache = NULL;
+ }
if (filter_state) {
SvREFCNT_dec(filter_state);
filter_state = NULL;
tryname += 2;
break;
}
+ else if (errno == EMFILE)
+ /* no point in trying other paths if out of handles */
+ break;
}
}
}
}
else
PL_compiling.cop_warnings = pWARN_STD ;
- SAVESPTR(PL_compiling.cop_io);
- PL_compiling.cop_io = NULL;
- if (filter_sub) {
+ if (filter_sub || filter_cache) {
SV * const datasv = filter_add(S_run_user_filter, NULL);
IoLINES(datasv) = filter_has_file;
IoTOP_GV(datasv) = (GV *)filter_state;
IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+ IoFMT_GV(datasv) = (GV *)filter_cache;
}
/* switch to eval mode */
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
+ const char * const fakestr = "_<(eval )";
+#ifdef HAS_STRLCPY
+ const int fakelen = 9 + 1;
+#endif
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = (HV*) SvREFCNT_inc(POPs);
len = SvCUR(temp_sv);
}
else
- len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
GvHV(PL_hintgv) = saved_hh;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- SAVESPTR(PL_compiling.cop_io);
- if (specialCopIO(PL_curcop->cop_io))
- PL_compiling.cop_io = PL_curcop->cop_io;
- else {
- PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
- SAVEFREESV(PL_compiling.cop_io);
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
}
- if (PL_compiling.cop_hints) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
- }
- PL_compiling.cop_hints = PL_curcop->cop_hints;
- if (PL_compiling.cop_hints) {
+ PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (PL_compiling.cop_hints_hash) {
HINTS_REFCNT_LOCK;
- PL_compiling.cop_hints->refcounted_he_refcnt++;
+ PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
/* special case: an eval '' executed within the DB package gets lexically
ret = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
&& ret != PL_op->op_next) { /* Successive compilation. */
- strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ /* Copy in anything fake and short. */
+#ifdef HAS_STRLCPY
+ strlcpy(safestr, fakestr, fakelen);
+#else
+ strcpy(safestr, fakestr);
+#endif /* #ifdef HAS_STRLCPY */
}
return DOCATCH(ret);
}
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
/* die_where() did LEAVE, or we won't be here */
}
else {
PP(pp_entertry)
{
dVAR;
- PERL_CONTEXT *cx = create_eval_scope(0);
+ PERL_CONTEXT * const cx = create_eval_scope(0);
cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
return do_smartmatch(NULL, NULL);
}
-/* This version of do_smartmatch() implements the following
- table of smart matches:
-
- $a $b Type of Match Implied Matching Code
- ====== ===== ===================== =============
- (overloading trumps everything)
-
- Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
- Any Code[+] scalar sub truth match if $b->($a)
-
- Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
- Hash Array hash value slice truth match if $a->{any(@$b)}
- Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
- Hash Any hash entry existence match if exists $a->{$b}
-
- Array Array arrays are identical[*] match if $a È~~Ç $b
- Array Regex array grep match if any(@$a) =~ /$b/
- Array Num array contains number match if any($a) == $b
- Array Any array contains string match if any($a) eq $b
-
- Any undef undefined match if !defined $a
- Any Regex pattern match match if $a =~ /$b/
- Code() Code() results are equal match if $a->() eq $b->()
- Any Code() simple closure truth match if $b->() (ignoring $a)
- Num numish[!] numeric equality match if $a == $b
- Any Str string equality match if $a eq $b
- Any Num numeric equality match if $a == $b
-
- Any Any string equality match if $a eq $b
-
-
- + - this must be a code reference whose prototype (if present) is not ""
- (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
- * - if a circular reference is found, we fall back to referential equality
- ! - either a real number, or a string that looks_like_number()
-
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
*/
STATIC
OP *
if (c == 0)
PUSHs(&PL_sv_no);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
FREETMPS;
LEAVE;
RETURN;
if (c == 0)
PUSHs(&PL_sv_undef);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
if (SM_OTHER_REF(PVCV)) {
/* This one has to be null-proto'd too.
if (c == 0)
PUSHs(&PL_sv_undef);
else if (SvTEMP(TOPs))
- SvREFCNT_inc(TOPs);
+ SvREFCNT_inc_void(TOPs);
FREETMPS;
LEAVE;
PUTBACK;
SV * const filter_state = (SV *)IoTOP_GV(datasv);
SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
int status = 0;
- /* Filter API says that the filter appends to the contents of the buffer.
- Usually the buffer is "", so the details don't matter. But if it's not,
- then clearly what it contains is already filtered by this filter, so we
- don't want to pass it in a second time.
- I'm going to use a mortal in case the upstream filter croaks. */
SV *upstream;
STRLEN got_len;
- const char *got_p;
+ const char *got_p = NULL;
const char *prune_from = NULL;
+ bool read_from_cache = FALSE;
+ STRLEN umaxlen;
+
+ assert(maxlen >= 0);
+ umaxlen = maxlen;
/* I was having segfault trouble under Linux 2.2.5 after a
parse error occured. (Had to hack around it with a test
const char *cache_p = SvPV(cache, cache_len);
STRLEN take = 0;
- if (maxlen) {
+ if (umaxlen) {
/* Running in block mode and we have some cached data already.
*/
- if (cache_len >= maxlen) {
+ if (cache_len >= umaxlen) {
/* In fact, so much data we don't even need to call
filter_read. */
- take = maxlen;
+ take = umaxlen;
}
} else {
const char *const first_nl = memchr(cache_p, '\n', cache_len);
}
sv_catsv(buf_sv, cache);
- if (maxlen) {
- maxlen -= cache_len;
+ if (umaxlen) {
+ umaxlen -= cache_len;
}
SvOK_off(cache);
+ read_from_cache = TRUE;
}
}
+ /* Filter API says that the filter appends to the contents of the buffer.
+ Usually the buffer is "", so the details don't matter. But if it's not,
+ then clearly what it contains is already filtered by this filter, so we
+ don't want to pass it in a second time.
+ I'm going to use a mortal in case the upstream filter croaks. */
upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
? sv_newmortal() : buf_sv;
SvUPGRADE(upstream, SVt_PV);
if (filter_has_file) {
- status = FILTER_READ(idx+1, upstream, maxlen);
+ status = FILTER_READ(idx+1, upstream, 0);
}
- assert(filter_sub);
- if (status >= 0) {
+ if (filter_sub && status >= 0) {
dSP;
int count;
DEFSV = upstream;
PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(maxlen)));
+ PUSHs(sv_2mortal(newSViv(0)));
if (filter_state) {
PUSHs(filter_state);
}
if(SvOK(upstream)) {
got_p = SvPV(upstream, got_len);
- if (maxlen) {
- if (got_len > maxlen) {
- prune_from = got_p + maxlen;
+ if (umaxlen) {
+ if (got_len > umaxlen) {
+ prune_from = got_p + umaxlen;
}
} else {
const char *const first_nl = memchr(got_p, '\n', got_len);
SV *cache = (SV *)IoFMT_GV(datasv);
if (!cache) {
- IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - maxlen));
+ IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
} else if (SvOK(cache)) {
/* Cache should be empty. */
assert(!SvCUR(cache));
status = 1;
}
- if (upstream != buf_sv) {
+ /* If they are at EOF but buf_sv has something in it, then they may never
+ have touched the SV upstream, so it may be undefined. If we naively
+ concatenate it then we get a warning about use of uninitialised value.
+ */
+ if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
sv_catsv(buf_sv, upstream);
}
}
filter_del(S_run_user_filter);
}
+ if (status == 0 && read_from_cache) {
+ /* If we read some data from the cache (and by getting here it implies
+ that we emptied the cache) then we aren't yet at EOF, and mustn't
+ report that to our caller. */
+ return 1;
+ }
return status;
}
https://perl5.git.perl.org / perl5.git / blobdiff