/* util.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- dTHR;
register unsigned char *s, *x;
register unsigned char *big;
register I32 pos;
STATIC SV *
S_mess_alloc(pTHX)
{
- dTHR;
SV *sv;
XPVMG *any;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
- dTHR;
if (CopLINE(PL_curcop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
int was_in_eval = PL_in_eval;
HV *stash;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
void
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
else {
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
PerlLIO_close(pp[0]);
did_pipes = 0;
if (n) { /* Error */
+ int pid2, status;
if (n != sizeof(int))
Perl_croak(aTHX_ "panic: kid popen errno read");
+ do {
+ pid2 = wait4pid(pid, &status, 0);
+ } while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
return Nullfp;
}
LOCK_FDPID_MUTEX;
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
UNLOCK_FDPID_MUTEX;
- pid = SvIVX(*svp);
+ pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
#ifdef OS2
continue;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal binary digit '%c' ignored", *s);
register UV xuv = ruv << 1;
if ((xuv >> 1) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Binary number > 0b11111111111111111111111111111111 non-portable");
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (*s == '8' || *s == '9') {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal octal digit '%c' ignored", *s);
register UV xuv = ruv << 3;
if ((xuv >> 3) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Octal number > 037777777777 non-portable");
++s;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal hexadecimal digit '%c' ignored", *s);
register UV xuv = ruv << 4;
if ((xuv >> 4) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Hexadecimal number > 0xffffffff non-portable");
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
- dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
PL_tainted = t->Ttainted;
PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
PL_nrs = newSVsv(t->Tnrs);
- PL_rs = SvREFCNT_inc(PL_nrs);
+ PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv;
PL_last_in_gv = Nullgv;
- PL_ofslen = t->Tofslen;
- PL_ofs = savepvn(t->Tofs, PL_ofslen);
+ PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
PL_chopset = t->Tchopset;
PL_bodytarget = newSVsv(t->Tbodytarget);
name = SvPVX(sv);
}
- if (name && *name) {
+ if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
+ if (name && *name)
+ Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput",
+ name,
+ (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+ else
+ Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput",
+ (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+ } else if (name && *name) {
Perl_warner(aTHX_ warn_type,
"%s%s on %s %s %s", func, pars, vile, type, name);
if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))