# See README.warning for information of what the patch does. # # Apply with patch -p0 ",GvENAME(gv)); return FALSE; } retval = io_close(io); --- 575,582 ---- } io = GvIO(gv); if (!io) { /* never opened */ ! if (ckWARN(WARN_UNOPENED) && not_implicit) ! warner(WARN_UNOPENED, "Close on unopened file <%s>",GvENAME(gv)); return FALSE; } retval = io_close(io); *************** *** 668,675 **** #endif return PerlIO_tell(fp); } ! if (dowarn) ! warn("tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 668,675 ---- #endif return PerlIO_tell(fp); } ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 687,694 **** #endif return PerlIO_seek(fp, pos, whence) >= 0; } ! if (dowarn) ! warn("seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } --- 687,694 ---- #endif return PerlIO_seek(fp, pos, whence) >= 0; } ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } *************** *** 701,708 **** if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return lseek(PerlIO_fileno(fp), pos, whence); ! if (dowarn) ! warn("sysseek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 701,708 ---- if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return lseek(PerlIO_fileno(fp), pos, whence); ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "sysseek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 782,789 **** } switch (SvTYPE(sv)) { case SVt_NULL: ! if (dowarn) ! warn(warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { --- 782,789 ---- } switch (SvTYPE(sv)) { case SVt_NULL: ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { *************** *** 823,830 **** else { if (tmpgv == defgv) return laststatval; ! if (dowarn) ! warn("Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); --- 823,830 ---- else { if (tmpgv == defgv) return laststatval; ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); *************** *** 847,854 **** sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; laststatval = Stat(SvPV(sv, na),&statcache); ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "stat"); return laststatval; } } --- 847,854 ---- sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; laststatval = Stat(SvPV(sv, na),&statcache); ! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "stat"); return laststatval; } } *************** *** 878,885 **** #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "lstat"); return laststatval; } --- 878,885 ---- #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "lstat"); return laststatval; } *************** *** 906,913 **** execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 906,914 ---- execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (ckWARN(WARN_EXEC)) ! warner(WARN_EXEC, "Can't exec \"%s\": %s", ! Argv[0], Strerror(errno)); } do_execfree(); return FALSE; *************** *** 1009,1016 **** do_execfree(); goto doshell; } ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 1010,1018 ---- do_execfree(); goto doshell; } ! if (ckWARN(WARN_EXEC)) ! warner(WARN_EXEC, "Can't exec \"%s\": %s", Argv[0], ! Strerror(errno)); } do_execfree(); return FALSE; *** global.sym.orig Wed Dec 10 10:35:45 1997 --- global.sym Tue Jan 6 09:55:04 1998 *************** *** 1037,1042 **** --- 1037,1043 ---- utilize wait4pid warn + warner watch whichsig yyerror *** gv.c.orig Tue Nov 25 14:50:20 1997 --- gv.c Tue Jan 6 09:55:05 1998 *************** *** 188,195 **** SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (dowarn) ! warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } --- 188,195 ---- SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (ckWARN(WARN_MISC)) ! warner(WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } *************** *** 319,326 **** /* * Inheriting AUTOLOAD for non-methods works ... for now. */ ! if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) ! warn( "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); --- 319,327 ---- /* * Inheriting AUTOLOAD for non-methods works ... for now. */ ! if (ckWARN(WARN_DEPRECATED) && !method && ! (GvCVGEN(gv) || GvSTASH(gv) != stash)) ! warner(WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); *************** *** 668,675 **** case '#': case '*': ! if (dowarn && len == 1 && sv_type == SVt_PV) ! warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': --- 669,676 ---- case '#': case '*': ! if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) ! warner(WARN_DEPRECATED, "Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': *************** *** 688,693 **** --- 689,695 ---- case '/': case '|': case '\001': + case '\002': case '\004': case '\005': case '\006': *************** *** 826,832 **** curcop->cop_filegv = filegv; if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; ! warn("Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } --- 828,835 ---- curcop->cop_filegv = filegv; if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; ! warner(WARN_ONCE, ! "Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } *** interp.sym.orig Wed Dec 10 10:04:16 1997 --- interp.sym Tue Jan 6 09:55:05 1998 *************** *** 67,72 **** --- 67,73 ---- laststatval laststype leftgv + lexwarn lineary localizing localpatches *** lib/diagnostics.pm.orig Tue Nov 25 14:52:48 1997 --- lib/diagnostics.pm Tue Jan 6 09:55:05 1998 *************** *** 274,280 **** $transmo = < + + This generates a runtime error if you use deprecated + + use warning 'deprecated'; + + =back + + See L. + + + =cut + + use Carp ; + + %Bits = ( + 'all' => "\x55\x55\x55\x55\x55\x55\x55", # [0..27] + 'ambiguous' => "\x00\x00\x00\x00\x01\x00\x00", # [16] + 'closed' => "\x00\x00\x00\x00\x00\x04\x00", # [21] + 'closure' => "\x00\x04\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x01\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x10\x00", # [22] + 'io' => "\x00\x00\x00\x00\x40\x55\x01", # [19..24] + 'misc' => "\x00\x00\x00\x00\x00\x00\x40", # [27] + 'newline' => "\x00\x00\x00\x00\x00\x01\x00", # [20] + 'numeric' => "\x00\x00\x01\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x40\x00\x00\x00", # [15] + 'once' => "\x00\x00\x04\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x04\x00\x00", # [17] + 'pipe' => "\x00\x00\x00\x00\x00\x00\x01", # [24] + 'precedence' => "\x00\x00\x00\x00\x10\x00\x00", # [18] + 'printf' => "\x00\x00\x00\x10\x00\x00\x00", # [14] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x10", # [26] + 'redefine' => "\x01\x00\x00\x00\x00\x00\x00", # [0] + 'reserved' => "\x00\x00\x40\x00\x00\x00\x00", # [11] + 'semicolon' => "\x00\x00\x00\x04\x00\x00\x00", # [13] + 'signal' => "\x00\x40\x00\x00\x00\x00\x00", # [7] + 'substr' => "\x00\x01\x00\x00\x00\x00\x00", # [4] + 'syntax' => "\x00\x00\x50\x55\x15\x00\x00", # [10..18] + 'taint' => "\x40\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x04", # [25] + 'unopened' => "\x00\x00\x00\x00\x00\x40\x00", # [23] + 'unsafe' => "\x50\x55\x00\x00\x00\x00\x00", # [2..7] + 'untie' => "\x00\x10\x00\x00\x00\x00\x00", # [6] + 'void' => "\x04\x00\x00\x00\x00\x00\x00", # [1] + ); + + %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..27] + 'ambiguous' => "\x00\x00\x00\x00\x02\x00\x00", # [16] + 'closed' => "\x00\x00\x00\x00\x00\x08\x00", # [21] + 'closure' => "\x00\x08\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x02\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x20\x00", # [22] + 'io' => "\x00\x00\x00\x00\x80\xaa\x02", # [19..24] + 'misc' => "\x00\x00\x00\x00\x00\x00\x80", # [27] + 'newline' => "\x00\x00\x00\x00\x00\x02\x00", # [20] + 'numeric' => "\x00\x00\x02\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x80\x00\x00\x00", # [15] + 'once' => "\x00\x00\x08\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x08\x00\x00", # [17] + 'pipe' => "\x00\x00\x00\x00\x00\x00\x02", # [24] + 'precedence' => "\x00\x00\x00\x00\x20\x00\x00", # [18] + 'printf' => "\x00\x00\x00\x20\x00\x00\x00", # [14] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x20", # [26] + 'redefine' => "\x02\x00\x00\x00\x00\x00\x00", # [0] + 'reserved' => "\x00\x00\x80\x00\x00\x00\x00", # [11] + 'semicolon' => "\x00\x00\x00\x08\x00\x00\x00", # [13] + 'signal' => "\x00\x80\x00\x00\x00\x00\x00", # [7] + 'substr' => "\x00\x02\x00\x00\x00\x00\x00", # [4] + 'syntax' => "\x00\x00\xa0\xaa\x2a\x00\x00", # [10..18] + 'taint' => "\x80\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x08", # [25] + 'unopened' => "\x00\x00\x00\x00\x00\x80\x00", # [23] + 'unsafe' => "\xa0\xaa\x00\x00\x00\x00\x00", # [2..7] + 'untie' => "\x00\x20\x00\x00\x00\x00\x00", # [6] + 'void' => "\x08\x00\x00\x00\x00\x00\x00", # [1] + ); + + + sub bits { + my $mask ; + my $catmask ; + my $fatal = 0 ; + foreach my $word (@_) { + if ($word eq 'FATAL') + { $fatal = 1 } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + } + else + { croak "unknown warning category '$word'" } + } + + return $mask ; + } + + sub import { + shift; + $^B |= bits(@_ ? @_ : 'all') ; + } + + sub unimport { + shift; + $^B &= ~ bits(@_ ? @_ : 'all') ; + } + + + sub make_fatal + { + my $self = shift ; + my $bitmask = $self->bits(@_) ; + $SIG{__WARN__} = + sub + { + die @_ if $^B & $bitmask ; + warn @_ + } ; + } + + sub bitmask + { + return $^B ; + } + + sub enabled + { + my $string = shift ; + + return 1 + if $bits{$string} && $^B & $bits{$string} ; + + return 0 ; + } + + 1; *** mg.c.orig Wed Dec 17 13:30:40 1997 --- mg.c Tue Jan 6 09:57:21 1998 *************** *** 308,313 **** --- 308,339 ---- return 0; } + static char * + printW(sv) + SV * sv ; + { + #if 1 + return "" ; + + #else + int i ; + static char buffer[50] ; + char buf1[20] ; + char * p ; + + + sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ; + p = SvPVX(sv) ; + for (i = 0; i < SvCUR(sv) ; ++ i) { + sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ; + strcat(buffer, buf1) ; + } + + return buffer ; + + #endif + } + int magic_get(SV *sv, MAGIC *mg) { *************** *** 322,327 **** --- 348,365 ---- case '\001': /* ^A */ sv_setsv(sv, bodytarget); break; + case '\002': /* ^B */ + /* printf("magic_get $^B: ") ; */ + if (curcop->cop_warnings == WARN_NONE) + /* printf("WARN_NONE\n"), */ + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + else if (curcop->cop_warnings == WARN_ALL) + /* printf("WARN_ALL\n"), */ + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + else + /* printf("some %s\n", printW(curcop->cop_warnings)), */ + sv_setsv(sv, curcop->cop_warnings); + break; case '\004': /* ^D */ sv_setiv(sv, (IV)(debug & 32767)); break; *************** *** 393,399 **** #endif break; case '\027': /* ^W */ ! sv_setiv(sv, (IV)dowarn); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': --- 431,437 ---- #endif break; case '\027': /* ^W */ ! sv_setiv(sv, (IV)(dowarn != 0)); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': *************** *** 788,795 **** else { i = whichsig(s); /* ...no, a brick */ if (!i) { ! if (dowarn || strEQ(s,"ALARM")) ! warn("No such signal: SIG%s", s); return 0; } SvREFCNT_dec(psig_name[i]); --- 826,833 ---- else { i = whichsig(s); /* ...no, a brick */ if (!i) { ! if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM")) ! warner(WARN_SIGNAL, "No such signal: SIG%s", s); return 0; } SvREFCNT_dec(psig_name[i]); *************** *** 859,866 **** HV *basestash = gv_stashsv(*svp, FALSE); if (!basestash) { ! if (dowarn) ! warn("No such package \"%_\" in @ISA assignment", *svp); continue; } gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE); --- 897,905 ---- HV *basestash = gv_stashsv(*svp, FALSE); if (!basestash) { ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, ! "No such package \"%_\" in @ISA assignment", *svp); continue; } gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE); *************** *** 1341,1346 **** --- 1380,1397 ---- case '\001': /* ^A */ sv_setsv(bodytarget, sv); break; + case '\002': /* ^B */ + if ((dowarn & G_WARN_FLAG) || memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) + compiling.cop_warnings = WARN_ALL; + else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) + compiling.cop_warnings = WARN_NONE; + else { + if (compiling.cop_warnings != WARN_NONE && compiling.cop_warnings != WARN_ALL) + sv_setsv(compiling.cop_warnings, sv); + else + compiling.cop_warnings = newSVsv(sv) ; + } + break; case '\004': /* ^D */ debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; DEBUG_x(dump_all()); *************** *** 1386,1392 **** #endif break; case '\027': /* ^W */ ! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '.': if (localizing) { --- 1437,1444 ---- #endif break; case '\027': /* ^W */ ! i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); ! dowarn = (dowarn & G_WARN_FLAG) | (i ? G_WARN_ON : G_WARN_OFF) ; break; case '.': if (localizing) { *************** *** 1786,1793 **** cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { ! if (dowarn) ! warn("SIG%s handler \"%s\" not defined.\n", sig_name[sig], (gv ? GvENAME(gv) : ((cv && CvGV(cv)) ? GvENAME(CvGV(cv)) --- 1838,1845 ---- cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { ! if (ckWARN(WARN_SIGNAL)) ! warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n", sig_name[sig], (gv ? GvENAME(gv) : ((cv && CvGV(cv)) ? GvENAME(CvGV(cv)) *** op.c.orig Thu Dec 11 15:43:00 1997 --- op.c Tue Jan 6 09:55:06 1998 *************** *** 108,114 **** } croak("Can't use global %s in \"my\"",name); } ! if (dowarn && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) --- 108,114 ---- } croak("Can't use global %s in \"my\"",name); } ! if (ckWARN(WARN_UNSAFE) && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) *************** *** 116,122 **** && SvIVX(sv) == 999999999 /* var is in open scope */ && strEQ(name, SvPVX(sv))) { ! warn("\"my\" variable %s masks earlier declaration in same scope", name); break; } } --- 116,124 ---- && SvIVX(sv) == 999999999 /* var is in open scope */ && strEQ(name, SvPVX(sv))) { ! warner(WARN_UNSAFE, ! "\"my\" variable %s masks earlier declaration in same scope", ! name); break; } } *************** *** 222,229 **** if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (dowarn && !CvUNIQUE(cv)) ! warn( "Variable \"%s\" may be unavailable", name); break; --- 224,231 ---- if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, "Variable \"%s\" may be unavailable", name); break; *************** *** 232,239 **** } } else if (!CvUNIQUE(compcv)) { ! if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv)) ! warn("Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); --- 234,243 ---- } } else if (!CvUNIQUE(compcv)) { ! if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) ! && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, ! "Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); *************** *** 586,591 **** --- 590,597 ---- case OP_DBSTATE: Safefree(cCOPo->cop_label); SvREFCNT_dec(cCOPo->cop_filegv); + if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL) + SvREFCNT_dec(cCOPo->cop_warnings); break; case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); *************** *** 667,680 **** static OP * scalarboolean(OP *o) { ! if (dowarn && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) curcop->cop_line = copline; ! warn("Found = in conditional, should be =="); curcop->cop_line = oldline; } return scalar(o); --- 673,686 ---- static OP * scalarboolean(OP *o) { ! if (ckWARN(WARN_SYNTAX) && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) curcop->cop_line = copline; ! warner(WARN_SYNTAX, "Found = in conditional, should be =="); curcop->cop_line = oldline; } return scalar(o); *************** *** 857,863 **** case OP_CONST: sv = cSVOPo->op_sv; ! if (dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; --- 863,869 ---- case OP_CONST: sv = cSVOPo->op_sv; ! if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; *************** *** 924,931 **** } break; } ! if (useless && dowarn) ! warn("Useless use of %s in void context", useless); return o; } --- 930,937 ---- } break; } ! if (useless && ckWARN(WARN_VOID)) ! warner(WARN_VOID, "Useless use of %s in void context", useless); return o; } *************** *** 1426,1443 **** { OP *o; ! if (dowarn && ! (left->op_type == OP_RV2AV || ! left->op_type == OP_RV2HV || ! left->op_type == OP_PADAV || ! left->op_type == OP_PADHV)) { ! char *desc = op_desc[(right->op_type == OP_SUBST || ! right->op_type == OP_TRANS) ! ? right->op_type : OP_MATCH]; ! char *sample = ((left->op_type == OP_RV2AV || ! left->op_type == OP_PADAV) ! ? "@array" : "%hash"); ! warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample); } if (right->op_type == OP_MATCH || --- 1432,1451 ---- { OP *o; ! if (ckWARN(WARN_UNSAFE) && ! (left->op_type == OP_RV2AV || ! left->op_type == OP_RV2HV || ! left->op_type == OP_PADAV || ! left->op_type == OP_PADHV)) { ! char *desc = op_desc[(right->op_type == OP_SUBST || ! right->op_type == OP_TRANS) ! ? right->op_type : OP_MATCH]; ! char *sample = ((left->op_type == OP_RV2AV || ! left->op_type == OP_PADAV) ! ? "@array" : "%hash"); ! warner(WARN_UNSAFE, ! "Applying %s to %s will act on scalar(%s)", ! desc, sample, sample); } if (right->op_type == OP_MATCH || *************** *** 1516,1521 **** --- 1524,1535 ---- pad_reset_pending = FALSE; SAVEI32(hints); hints &= ~HINT_BLOCK_SCOPE; + SAVEPPTR(compiling.cop_warnings); + if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE) { + compiling.cop_warnings = newSVsv(compiling.cop_warnings) ; + SAVEFREESV(compiling.cop_warnings) ; + } + return retval; } *************** *** 1587,1597 **** list(o); else { scalar(o); ! if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') ! warn("Parens missing around \"%s\" list", lex ? "my" : "local"); } } in_my = FALSE; --- 1601,1612 ---- list(o); else { scalar(o); ! if (ckWARN(WARN_PARENTHESIS) && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') ! warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list", ! lex ? "my" : "local"); } } in_my = FALSE; *************** *** 2554,2559 **** --- 2569,2578 ---- } cop->cop_seq = seq; cop->cop_arybase = curcop->cop_arybase; + if (curcop->cop_warnings == WARN_NONE || curcop->cop_warnings == WARN_ALL) + cop->cop_warnings = curcop->cop_warnings ; + else + cop->cop_warnings = newSVsv(curcop->cop_warnings) ; if (copline == NOLINE) cop->cop_line = curcop->cop_line; *************** *** 2626,2633 **** } } if (first->op_type == OP_CONST) { ! if (dowarn && (first->op_private & OPpCONST_BARE)) ! warn("Probable precedence problem on %s", op_desc[type]); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); return other; --- 2645,2653 ---- } } if (first->op_type == OP_CONST) { ! if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE)) ! warner(WARN_PRECEDENCE, "Probable precedence problem on %s", ! op_desc[type]); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); return other; *************** *** 2643,2649 **** else scalar(other); } ! else if (dowarn && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; --- 2663,2669 ---- else scalar(other); } ! else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; *************** *** 2666,2672 **** if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Value of %s%s can be \"0\"; test with defined()", op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); --- 2686,2693 ---- if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_UNSAFE, ! "Value of %s%s can be \"0\"; test with defined()", op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); *************** *** 3319,3329 **** if (curstack == sortstack && sortcop == CvSTART(cv)) croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); ! if (const_sv || dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn(const_sv ? "Constant subroutine %s redefined" ! : "Subroutine %s redefined", name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3340,3351 ---- if (curstack == sortstack && sortcop == CvSTART(cv)) croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); ! if (const_sv || ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, ! const_sv ? "Constant subroutine %s redefined" ! : "Subroutine %s redefined", name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 3514,3523 **** } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ ! if (dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3536,3545 ---- } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ ! if (ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 3592,3602 **** gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); if (cv = GvFORM(gv)) { ! if (dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Format %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3614,3624 ---- gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); if (cv = GvFORM(gv)) { ! if (ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, "Format %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 4060,4067 **** char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); ! if (dowarn) ! warn("Array @%s missing the @ in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; --- 4082,4090 ---- char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, ! "Array @%s missing the @ in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; *************** *** 4078,4085 **** char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); ! if (dowarn) ! warn("Hash %%%s missing the %% in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; --- 4101,4109 ---- char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, ! "Hash %%%s missing the %% in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; *************** *** 4821,4834 **** case OP_EXEC: o->op_seq = op_seqmax++; ! if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_DIE) { line_t oldline = curcop->cop_line; curcop->cop_line = ((COP*)o->op_next)->cop_line; ! warn("Statement unlikely to be reached"); ! warn("(Maybe you meant system() when you said exec()?)\n"); curcop->cop_line = oldline; } } --- 4845,4859 ---- case OP_EXEC: o->op_seq = op_seqmax++; ! if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_DIE) { line_t oldline = curcop->cop_line; curcop->cop_line = ((COP*)o->op_next)->cop_line; ! warner(WARN_SYNTAX, "Statement unlikely to be reached"); ! warner(WARN_SYNTAX, ! "(Maybe you meant system() when you said exec()?)\n"); curcop->cop_line = oldline; } } *** op.h.orig Thu Dec 11 10:40:11 1997 --- op.h Tue Jan 6 09:55:06 1998 *************** *** 119,124 **** --- 119,125 ---- #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ #define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */ #define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ + #define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */ /* Private for OP_FLIP/FLOP */ #define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */ *** perl.c.orig Wed Dec 17 14:16:34 1997 --- perl.c Tue Jan 6 09:55:07 1998 *************** *** 618,623 **** --- 618,624 ---- time(&basetime); oldscope = scopestack_ix; + dowarn = FALSE ; JMPENV_PUSH(ret); switch (ret) { *************** *** 674,679 **** --- 675,681 ---- case 'u': case 'U': case 'v': + case 'W': case 'w': if (s = moreswitches(s)) goto reswitch; *************** *** 943,949 **** if (do_undump) my_unexec(); ! if (dowarn) gv_check(defstash); LEAVE; --- 945,951 ---- if (do_undump) my_unexec(); ! if (ckWARN(WARN_ONCE)) gv_check(defstash); LEAVE; *************** *** 1676,1682 **** GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); exit(0); case 'w': ! dowarn = TRUE; s++; return s; case '*': --- 1678,1689 ---- GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); exit(0); case 'w': ! dowarn |= G_WARN_ON; ! s++; ! return s; ! case 'W': ! dowarn |= G_WARN_FLAG|G_WARN_ON; ! compiling.cop_warnings = WARN_ALL ; s++; return s; case '*': *** perl.h.orig Thu Dec 18 13:27:28 1997 --- perl.h Tue Jan 6 09:55:07 1998 *************** *** 1094,1099 **** --- 1094,1100 ---- #include "hv.h" #include "mg.h" #include "scope.h" + #include "warning.h" /* work around some libPW problems */ #ifdef DOINIT *** pp.c.orig Wed Dec 17 14:16:35 1997 --- pp.c Tue Jan 6 09:55:07 1998 *************** *** 215,222 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); ! if (dowarn) ! warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); --- 215,222 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); *************** *** 259,266 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); ! if (dowarn) ! warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); --- 259,266 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); *************** *** 1753,1760 **** rem -= pos; } if (fail < 0) { ! if (dowarn || lvalue) ! warn("substr outside of string"); RETPUSHUNDEF; } else { --- 1753,1760 ---- rem -= pos; } if (fail < 0) { ! if (lvalue || ckWARN(WARN_SUBSTR)) ! warner(WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { *************** *** 1764,1771 **** if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force(sv,na); ! if (dowarn) ! warn("Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only(sv); --- 1764,1772 ---- if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force(sv,na); ! if (ckWARN(WARN_SUBSTR)) ! warner(WARN_SUBSTR, ! "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only(sv); *************** *** 2424,2431 **** SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); ! else if (dowarn) ! warn("Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; --- 2425,2432 ---- SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); ! else if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; *************** *** 2833,2840 **** default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && dowarn) ! warn("Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') --- 2834,2841 ---- default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') *************** *** 3608,3615 **** default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && dowarn) ! warn("Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); --- 3609,3616 ---- default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); *************** *** 3981,3988 **** * of pack() (and all copies of the result) are * gone. */ ! if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) ! warn("Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,na); else --- 3982,3990 ---- * of pack() (and all copies of the result) are * gone. */ ! if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) ! warner(WARN_UNSAFE, ! "Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,na); else *** pp_ctl.c.orig Thu Nov 27 15:12:20 1997 --- pp_ctl.c Tue Jan 6 09:55:08 1998 *************** *** 326,333 **** sv = *++MARK; else { sv = &sv_no; ! if (dowarn) ! warn("Not enough format arguments"); } break; --- 326,333 ---- sv = *++MARK; else { sv = &sv_no; ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, "Not enough format arguments"); } break; *************** *** 869,888 **** cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (dowarn) ! warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: ! if (dowarn) ! warn("Exiting subroutine via %s", op_name[op->op_type]); break; case CXt_EVAL: ! if (dowarn) ! warn("Exiting eval via %s", op_name[op->op_type]); break; case CXt_NULL: ! if (dowarn) ! warn("Exiting pseudo-block via %s", op_name[op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || --- 869,892 ---- cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting substitution via %s", ! op_name[op->op_type]); break; case CXt_SUB: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting subroutine via %s", ! op_name[op->op_type]); break; case CXt_EVAL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting eval via %s", ! op_name[op->op_type]); break; case CXt_NULL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting pseudo-block via %s", ! op_name[op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || *************** *** 976,995 **** cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (dowarn) ! warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: ! if (dowarn) ! warn("Exiting subroutine via %s", op_name[op->op_type]); break; case CXt_EVAL: ! if (dowarn) ! warn("Exiting eval via %s", op_name[op->op_type]); break; case CXt_NULL: ! if (dowarn) ! warn("Exiting pseudo-block via %s", op_name[op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%ld)\n", (long)i)); --- 980,1003 ---- cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting substitution via %s", ! op_name[op->op_type]); break; case CXt_SUB: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting subroutine via %s", ! op_name[op->op_type]); break; case CXt_EVAL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting eval via %s", ! op_name[op->op_type]); break; case CXt_NULL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting pseudo-block via %s", ! op_name[op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%ld)\n", (long)i)); *************** *** 1777,1783 **** if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && dowarn) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); --- 1785,1791 ---- if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); *************** *** 2458,2463 **** --- 2466,2473 ---- SAVEFREEPV(name); SAVEI32(hints); hints = 0; + SAVEPPTR(compiling.cop_warnings); + compiling.cop_warnings = ((dowarn & G_WARN_FLAG) ? WARN_ALL : WARN_NONE) ; /* switch to eval mode */ *************** *** 2518,2523 **** --- 2528,2538 ---- SAVEDELETE(defstash, safestr, strlen(safestr)); SAVEI32(hints); hints = op->op_targ; + SAVEPPTR(compiling.cop_warnings); + if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE){ + compiling.cop_warnings = newSVsv(compiling.cop_warnings) ; + SAVEFREESV(compiling.cop_warnings) ; + } push_return(op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); *** pp_hot.c.orig Wed Dec 17 13:30:41 1997 --- pp_hot.c Tue Jan 6 09:55:08 1998 *************** *** 315,337 **** RETURN; } if (!(io = GvIO(gv))) { ! if (dowarn) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); ! warn("Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (dowarn) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warn("Filehandle %s opened only for input", SvPV(sv,na)); ! else ! warn("print on closed filehandle %s", SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; --- 315,339 ---- RETURN; } if (!(io = GvIO(gv))) { ! if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); ! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warner(WARN_IO, "Filehandle %s opened only for input", ! SvPV(sv,na)); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "print on closed filehandle %s", ! SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; *************** *** 418,425 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); ! if (dowarn) ! warn(warn_uninit); if (GIMME == G_ARRAY) RETURN; RETPUSHUNDEF; --- 420,427 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); if (GIMME == G_ARRAY) RETURN; RETPUSHUNDEF; *************** *** 493,500 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); ! if (dowarn) ! warn(warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; --- 495,502 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; *************** *** 629,636 **** } TAINT_NOT; } ! if (relem == lastrelem && dowarn) ! warn("Odd number of elements in hash list"); } break; default: --- 631,638 ---- } TAINT_NOT; } ! if (relem == lastrelem && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Odd number of elements in hash list"); } break; default: *************** *** 1142,1149 **** SP--; } if (!fp) { ! if (dowarn && io && !(IoFLAGS(io) & IOf_START)) ! warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; --- 1144,1152 ---- SP--; } if (!fp) { ! if (io && ckWARN(WARN_CLOSED) && !(IoFLAGS(io) & IOf_START)) ! warner(WARN_CLOSED, ! "Read on closed filehandle <%s>", GvENAME(last_in_gv)); if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; *************** *** 2082,2088 **** if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && dowarn && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { --- 2085,2091 ---- if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { *************** *** 2196,2206 **** sub_crush_depth(CV *cv) { if (CvANON(cv)) ! warn("Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); ! warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } --- 2199,2210 ---- sub_crush_depth(CV *cv) { if (CvANON(cv)) ! warner(WARN_RECURSION, "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); ! warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", ! SvPVX(tmpstr)); } } *** pp_sys.c.orig Fri Dec 12 16:18:15 1997 --- pp_sys.c Tue Jan 6 09:55:08 1998 *************** *** 586,592 **** sv = POPs; ! if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) --- 586,592 ---- sv = POPs; ! if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) *************** *** 595,602 **** mg = mg_find(sv, 'q') ; if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) ! warn("untie attempted while %lu inner references still exist", ! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } --- 595,603 ---- mg = mg_find(sv, 'q') ; if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) ! warner(WARN_UNTIE, ! "untie attempted while %lu inner references still exist", ! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } *************** *** 1101,1118 **** fp = IoOFP(io); if (!fp) { ! if (dowarn) { if (IoIFP(io)) ! warn("Filehandle only opened for input"); ! else ! warn("Write on closed filehandle"); } PUSHs(&sv_no); } else { if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { ! if (dowarn) ! warn("page overflow"); } if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) || PerlIO_error(fp)) --- 1102,1119 ---- fp = IoOFP(io); if (!fp) { ! if (ckWARN2(WARN_CLOSED,WARN_IO)) { if (IoIFP(io)) ! warner(WARN_IO, "Filehandle only opened for input"); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "Write on closed filehandle"); } PUSHs(&sv_no); } else { if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { ! if (ckWARN(WARN_IO)) ! warner(WARN_IO, "page overflow"); } if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) || PerlIO_error(fp)) *************** *** 1167,1186 **** sv = NEWSV(0,0); if (!(io = GvIO(gv))) { ! if (dowarn) { gv_fullname3(sv, gv, Nullch); ! warn("Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (dowarn) { gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warn("Filehandle %s opened only for input", SvPV(sv,na)); ! else ! warn("printf on closed filehandle %s", SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; --- 1168,1189 ---- sv = NEWSV(0,0); if (!(io = GvIO(gv))) { ! if (ckWARN(WARN_UNOPENED)) { gv_fullname3(sv, gv, Nullch); ! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (ckWARN2(WARN_CLOSED,WARN_IO)) { gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warner(WARN_IO, "Filehandle %s opened only for input", ! SvPV(sv,na)); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "printf on closed filehandle %s", ! SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; *************** *** 1392,1402 **** io = GvIO(gv); if (!io || !IoIFP(io)) { length = -1; ! if (dowarn) { if (op->op_type == OP_SYSWRITE) ! warn("Syswrite on closed filehandle"); else ! warn("Send on closed socket"); } } else if (op->op_type == OP_SYSWRITE) { --- 1395,1405 ---- io = GvIO(gv); if (!io || !IoIFP(io)) { length = -1; ! if (ckWARN(WARN_CLOSED)) { if (op->op_type == OP_SYSWRITE) ! warner(WARN_CLOSED, "Syswrite on closed filehandle"); else ! warner(WARN_CLOSED, "Send on closed socket"); } } else if (op->op_type == OP_SYSWRITE) { *************** *** 1780,1787 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1783,1790 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1810,1817 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1813,1820 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1836,1843 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1839,1846 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1890,1897 **** RETURN; nuts: ! if (dowarn) ! warn("accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: --- 1893,1900 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: *************** *** 1917,1924 **** RETURN; nuts: ! if (dowarn) ! warn("shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1920,1927 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1995,2002 **** RETURN; nuts: ! if (dowarn) ! warn("[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 1998,2005 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2068,2075 **** RETURN; nuts: ! if (dowarn) ! warn("get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 2071,2078 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2126,2133 **** #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (dowarn && strchr(SvPV(statname, na), '\n')) ! warn(warn_nl, "stat"); max = 0; } } --- 2129,2136 ---- #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(statname, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "stat"); max = 0; } } *************** *** 2531,2538 **** len = 512; } else { ! if (dowarn) ! warn("Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; --- 2534,2541 ---- len = 512; } else { ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; *************** *** 2550,2557 **** i = open(SvPV(sv, na), 0); #endif if (i < 0) { ! if (dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "open"); RETPUSHUNDEF; } laststatval = Fstat(i, &statcache); --- 2553,2560 ---- i = open(SvPV(sv, na), 0); #endif if (i < 0) { ! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "open"); RETPUSHUNDEF; } laststatval = Fstat(i, &statcache); *** proto.h.orig Wed Dec 17 14:16:35 1997 --- proto.h Tue Jan 6 09:55:09 1998 *************** *** 565,570 **** --- 565,571 ---- void vivify_ref _((SV* sv, U32 to_what)); I32 wait4pid _((int pid, int* statusp, int flags)); void warn _((const char* pat,...)); + void warner _((U32 err, const char* pat,...)); void watch _((char** addr)); I32 whichsig _((char* sig)); int yyerror _((char* s)); *** regcomp.c.orig Wed Dec 10 10:04:27 1997 --- regcomp.c Tue Jan 6 09:55:09 1998 *************** *** 436,444 **** ? (flags & ~SCF_DO_SUBSTR) : flags); if (!scan) /* It was not CURLYX, but CURLY. */ scan = next; ! if (dowarn && (minnext + deltanext == 0) && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))) ! warn("Strange *+?{} on zero-length expression"); min += minnext * mincount; is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0 || deltanext == I32_MAX); --- 436,444 ---- ? (flags & ~SCF_DO_SUBSTR) : flags); if (!scan) /* It was not CURLYX, but CURLY. */ scan = next; ! if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0) && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))) ! warner(WARN_UNSAFE, "Strange *+?{} on zero-length expression"); min += minnext * mincount; is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0 || deltanext == I32_MAX); *************** *** 1447,1454 **** goto do_curly; } nest_check: ! if (dowarn && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) { ! warn("%.*s matches null string many times", regparse - origparse, origparse); } --- 1447,1454 ---- goto do_curly; } nest_check: ! if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) { ! warner(WARN_UNSAFE, "%.*s matches null string many times", regparse - origparse, origparse); } *** regexec.c.orig Tue Nov 25 14:55:16 1997 --- regexec.c Tue Jan 6 09:55:09 1998 *************** *** 1176,1185 **** regcc = cc; if (n >= cc->max) { /* Maximum greed exceeded? */ ! if (dowarn && n >= REG_INFTY && !(reg_flags & RF_warned)) { reg_flags |= RF_warned; ! warn("count exceeded %d", REG_INFTY - 1); } sayNO; } --- 1176,1185 ---- regcc = cc; if (n >= cc->max) { /* Maximum greed exceeded? */ ! if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY && !(reg_flags & RF_warned)) { reg_flags |= RF_warned; ! warner(WARN_UNSAFE, "count exceeded %d", REG_INFTY - 1); } sayNO; } *************** *** 1225,1233 **** PerlIO_printf(Perl_debug_log, "%*s failed, try continuation...\n", REPORT_CODE_OFF+regindent*2, "") ); } ! if (dowarn && n >= REG_INFTY && !(reg_flags & RF_warned)) { reg_flags |= RF_warned; ! warn("count exceeded %d", REG_INFTY - 1); } /* Failed deeper matches of scan, so see if this one works. */ --- 1225,1233 ---- PerlIO_printf(Perl_debug_log, "%*s failed, try continuation...\n", REPORT_CODE_OFF+regindent*2, "") ); } ! if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY && !(reg_flags & RF_warned)) { reg_flags |= RF_warned; ! warner(WARN_UNSAFE, "count exceeded %d", REG_INFTY - 1); } /* Failed deeper matches of scan, so see if this one works. */ *** sv.c.orig Wed Dec 10 11:11:05 1997 --- sv.c Tue Jan 6 10:01:49 1998 *************** *** 1221,1230 **** *d = '\0'; if (op) ! warn("Argument \"%s\" isn't numeric in %s", tmpbuf, op_name[op->op_type]); else ! warn("Argument \"%s\" isn't numeric", tmpbuf); } IV --- 1221,1230 ---- *d = '\0'; if (op) ! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, op_name[op->op_type]); else ! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } IV *************** *** 1245,1254 **** if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { ! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warn(warn_uninit); } return 0; } --- 1245,1254 ---- if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } *************** *** 1271,1278 **** } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1271,1278 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1300,1307 **** } else { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", --- 1300,1307 ---- } else { dTHR; ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", *************** *** 1323,1332 **** if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { ! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warn(warn_uninit); } return 0; } --- 1323,1332 ---- if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } *************** *** 1346,1353 **** } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1346,1353 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1371,1380 **** SvUVX(sv) = asUV(sv); } else { ! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warn(warn_uninit); } return 0; } --- 1371,1380 ---- SvUVX(sv) = asUV(sv); } else { ! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } *************** *** 1393,1399 **** if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); --- 1393,1399 ---- if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { ! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); *************** *** 1401,1410 **** if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { ! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warn(warn_uninit); } return 0; } --- 1401,1410 ---- if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } *************** *** 1420,1434 **** } if (SvREADONLY(sv)) { if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) return (double)SvIVX(sv); ! if (dowarn) ! warn(warn_uninit); return 0.0; } } --- 1420,1434 ---- } if (SvREADONLY(sv)) { if (SvPOKp(sv) && SvLEN(sv)) { ! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) return (double)SvIVX(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } } *************** *** 1449,1463 **** SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0.0; } SvNOK_on(sv); --- 1449,1463 ---- SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { ! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { dTHR; ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } SvNOK_on(sv); *************** *** 1475,1481 **** if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); --- 1475,1481 ---- if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); *************** *** 1494,1500 **** if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); --- 1494,1500 ---- if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); *************** *** 1609,1618 **** goto tokensave; } if (!SvROK(sv)) { ! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warn(warn_uninit); } *lp = 0; return ""; --- 1609,1618 ---- goto tokensave; } if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (!localizing) ! warner(WARN_UNINITIALIZED, warn_uninit); } *lp = 0; return ""; *************** *** 1671,1678 **** tsv = Nullsv; goto tokensave; } ! if (dowarn) ! warn(warn_uninit); *lp = 0; return ""; } --- 1671,1678 ---- tsv = Nullsv; goto tokensave; } ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1720,1727 **** } else { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1720,1727 ---- } else { dTHR; ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 2019,2027 **** if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); ! else if (dowarn) ! warn("Subroutine %s redefined", ! GvENAME((GV*)dstr)); } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); --- 2019,2028 ---- if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); ! else if (ckWARN(WARN_REDEFINE)) ! warner(WARN_REDEFINE, ! "Subroutine %s redefined", ! GvENAME((GV*)dstr)); } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); *************** *** 4530,4536 **** default: unknown: ! if (!args && dowarn && (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", --- 4531,4537 ---- default: unknown: ! if (!args && ckWARN(WARN_PRINTF) && (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", *************** *** 4540,4546 **** c & 0xFF); else sv_catpv(msg, "end of string"); ! warn("%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ --- 4541,4547 ---- c & 0xFF); else sv_catpv(msg, "end of string"); ! warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ *** t/op/tie.t.orig Tue Nov 25 14:55:47 1997 --- t/op/tie.t Tue Jan 6 09:55:10 1998 *************** *** 77,84 **** ######## # strict behaviour, without any extra references ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; --- 77,84 ---- ######## # strict behaviour, without any extra references ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; *************** *** 86,93 **** ######## # strict behaviour, with 1 extra references generating an error ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; --- 86,93 ---- ######## # strict behaviour, with 1 extra references generating an error ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; *************** *** 96,103 **** ######## # strict behaviour, with 1 extra references via tied generating an error ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; --- 96,103 ---- ######## # strict behaviour, with 1 extra references via tied generating an error ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; *************** *** 107,114 **** ######## # strict behaviour, with 1 extra references which are destroyed ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; --- 107,114 ---- ######## # strict behaviour, with 1 extra references which are destroyed ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; *************** *** 117,124 **** ######## # strict behaviour, with extra 1 references via tied which are destroyed ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; --- 117,124 ---- ######## # strict behaviour, with extra 1 references via tied which are destroyed ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; *************** *** 128,135 **** ######## # strict error behaviour, with 2 extra references ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; --- 128,135 ---- ######## # strict error behaviour, with 2 extra references ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; *************** *** 139,152 **** ######## # strict behaviour, check scope of strictness. ! #no warning 'untie'; ! local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; --- 139,152 ---- ######## # strict behaviour, check scope of strictness. ! no warning 'untie'; ! #local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; *** t/pragma/warn-1global.orig Tue Nov 25 14:55:51 1997 --- t/pragma/warn-1global Tue Jan 6 09:55:10 1998 *************** *** 1,5 **** --- 1,6 ---- Check existing $^W functionality + __END__ # warnable code, warnings disabled *************** *** 110,131 **** ######## $^W = 1; ! eval "my $b ; chop $b ;" ; EXPECT ! Use of uninitialized value at - line 3. ! Use of uninitialized value at - line 3. ######## ! eval "$^W = 1;" ; my $b ; chop $b ; EXPECT ! ######## eval {$^W = 1;} ; my $b ; chop $b ; EXPECT ! Use of uninitialized value at - line 3. ######## { --- 111,134 ---- ######## $^W = 1; ! eval 'my $b ; chop $b ;' ; ! print $@ ; EXPECT ! Use of uninitialized value at (eval 1) line 1. ######## ! eval '$^W = 1;' ; ! print $@ ; my $b ; chop $b ; EXPECT ! Use of uninitialized value at - line 4. ######## eval {$^W = 1;} ; + print $@ ; my $b ; chop $b ; EXPECT ! Use of uninitialized value at - line 4. ######## { *************** *** 144,146 **** --- 147,181 ---- my $c ; chop $c ; EXPECT Use of uninitialized value at - line 5. + ######## + + $^W = 1 + 2 ; + EXPECT + + ######## + + $^W = $a ; + EXPECT + + ######## + + sub fred {} + $^W = fred() ; + EXPECT + + ######## + + sub fred { my $b ; chop $b ;} + { local $^W = 0 ; + fred() ; + } + EXPECT + + ######## + + sub fred { my $b ; chop $b ;} + { local $^W = 1 ; + fred() ; + } + EXPECT + Use of uninitialized value at - line 2. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-2use Tue Jan 6 09:55:10 1998 *************** *** 0 **** --- 1,291 ---- + Check lexical warning functionality + + TODO + check that the hierarchy works. + + __END__ + + # check illegal category is caught + use warning 'blah' ; + EXPECT + unknown warning category 'blah' at - line 3 + BEGIN failed--compilation aborted at - line 3. + ######## + + # Check compile time scope of pragma + use warning 'deprecated' ; + { + no warning ; + 1 if $a EQ $b ; + } + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. + ######## + + # Check compile time scope of pragma + no warning; + { + use warning 'deprecated' ; + 1 if $a EQ $b ; + } + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 6. + ######## + + # Check runtime scope of pragma + use warning 'uninitialized' ; + { + no warning ; + my $b ; chop $b ; + } + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check runtime scope of pragma + no warning ; + { + use warning 'uninitialized' ; + my $b ; chop $b ; + } + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check runtime scope of pragma + no warning ; + { + use warning 'uninitialized' ; + $a = sub { my $b ; chop $b ; } + } + &$a ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + use warning 'deprecated' ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 3. + ######## + + --FILE-- abc + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'deprecated' ; + require "./abc"; + EXPECT + + ######## + + --FILE-- abc + use warning 'deprecated' ; + 1; + --FILE-- + require "./abc"; + 1 if $a EQ $b ; + EXPECT + + ######## + + --FILE-- abc + use warning 'deprecated' ; + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'uninitialized' ; + require "./abc"; + my $a ; chop $a ; + EXPECT + Use of EQ is deprecated at ./abc line 2. + Use of uninitialized value at - line 3. + ######## + + --FILE-- abc.pm + use warning 'deprecated' ; + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'uninitialized' ; + use abc; + my $a ; chop $a ; + EXPECT + Use of EQ is deprecated at abc.pm line 2. + Use of uninitialized value at - line 3. + ######## + + # Check scope of pragma with eval + no warning ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval { + use warning 'uninitialized' ; + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 5. + Use of uninitialized value at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval { + no warning ; + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval { + use warning 'deprecated' ; + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 6. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 5. + Use of EQ is deprecated at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval { + no warning ; + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval q[ + use warning 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at (eval 1) line 3. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at (eval 1) line 2. + Use of uninitialized value at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval ' + no warning ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval q[ + use warning 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at (eval 1) line 3. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 7. + Use of EQ is deprecated at (eval 1) line 2. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval ' + no warning ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-3both Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,66 ---- + Check interaction of $^W and lexical + + __END__ + + # Check interaction of $^W and use warning + sub fred { + use warning ; + my $b ; + chop $b ; + } + { local $^W = 0 ; + fred() ; + } + + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check interaction of $^W and use warning + sub fred { + no warning ; + my $b ; + chop $b ; + } + { local $^W = 1 ; + fred() ; + } + + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check interaction of $^W and use warning + use warning ; + $^W = 1 ; + my $b ; + chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check interaction of $^W and use warning + $^W = 1 ; + use warning ; + my $b ; + chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check interaction of $^W and use warning + $^W = 1 ; + no warning ; + my $b ; + chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check interaction of $^W and use warning + no warning ; + $^W = 1 ; + my $b ; + chop $b ; + EXPECT + Use of uninitialized value at - line 6. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-4lint Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,60 ---- + Check lint + + TODO + check that -W will override both $^W and no warning. + check that any required/used files also have warnings enabled. + + __END__ + -W + # lint: check compile time $^W is zapped + BEGIN { $^W = 0 ;} + $a = $b = 1 ; + $a = 1 if $a EQ $b ; + close STDIN ; print STDIN "abc" ; + EXPECT + Use of EQ is deprecated at - line 5. + print on closed filehandle main::STDIN at - line 6. + ######## + -W + # lint: check runtime $^W is zapped + $^W = 0 ; + close STDIN ; print STDIN "abc" ; + EXPECT + print on closed filehandle main::STDIN at - line 4. + ######## + -W + # lint: check runtime $^W is zapped + { + $^W = 0 ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. + ######## + -W + # lint: check "no warning" is zapped + no warning ; + $a = $b = 1 ; + $a = 1 if $a EQ $b ; + close STDIN ; print STDIN "abc" ; + EXPECT + Use of EQ is deprecated at - line 5. + print on closed filehandle main::STDIN at - line 6. + ######## + -W + # lint: check "no warning" is zapped + { + no warning ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. + ######## + -Ww + # lint: check combination of -w and -W + { + $^W = 0 ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-doio Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,94 ---- + doio.c AOK + + Can't do bidirectional pipe + open(F, "| true |"); + + warn(warn_nl, "open"); + open(F, "true\ncd") + + Close on unopened file <%s> + $a = "fred";close($a) + + tell() on unopened file + $a = "fred";$a = tell($a) + + seek() on unopened file + $a = "fred";$a = seek($a,1,1) + + sysseek() on unopened file + $a = "fred";$a = seek($a,1,1) + + warn(warn_uninit); + print $a ; + + Stat on unopened file <%s> + close STDIN ; -x STDIN ; + + warn(warn_nl, "stat"); + stat "ab\ncd" + + warn(warn_nl, "lstat"); + lstat "ab\ncd" + + Can't exec \"%s\": %s + + Can't exec \"%s\": %s + + + __END__ + # doio.c + use warning 'io' ; + open(F, "|true|") + EXPECT + Can't do bidirectional pipe at - line 3. + ######## + # doio.c + use warning 'io' ; + open(F, " at - line 7. + ######## + # doio.c + use warning 'uninitialized' ; + print $a ; + EXPECT + Use of uninitialized value at - line 3. + ######## + # doio.c + use warning 'io' ; + + EXPECT + + ######## + # doio.c + use warning 'io' ; + stat "ab\ncd"; + lstat "ab\ncd"; + EXPECT + Unsuccessful stat on filename containing newline at - line 3. + Unsuccessful stat on filename containing newline at - line 4. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls", "abc" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-gv Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,40 ---- + gv.c AOK + + Can't locate package %s for @%s::ISA + @ISA = qw(Fred); joe() + + Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + fred() ; + + Use of $# is deprecated + Use of $* is deprecated + + $a = ${"#"} ; + $a = ${"*"} ; + + + __END__ + # gv.c + use warning 'misc' ; + @ISA = qw(Fred); joe() + EXPECT + Can't locate package Fred for @main::ISA at - line 3. + Undefined subroutine &main::joe called at - line 3. + ######## + # gv.c + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + use warning 'deprecated' ; + fred() ; + EXPECT + Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. + ######## + # gv.c + use warning 'deprecated' ; + $a = ${"#"}; + $a = ${"*"}; + EXPECT + Use of $# is deprecated at - line 3. + Use of $* is deprecated at - line 4. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-mg Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,30 ---- + mg.c AOK + + No such signal: SIG%s + $SIG{FRED} = sub {} + + No such package "%_" in @ISA assignment + @ISA = 'fred' ; + + SIG%s handler \"%s\" not defined. + $SIG{"INT"} = "ok3"; kill "INT",$$; + + + __END__ + # mg.c + use warning 'signal' ; + $SIG{FRED} = sub {}; + EXPECT + No such signal: SIGFRED at - line 3. + ######## + # mg.c + use warning 'unsafe' ; + @ISA = 'fred' ; + EXPECT + No such package "fred" in @ISA assignment at - line 3. + ######## + # mg.c + use warning 'signal' ; + $SIG{"INT"} = "fred"; kill "INT",$$; + EXPECT + SIGINT handler "fred" not defined. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-op Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,552 ---- + op.c AOK + + "my" variable %s masks earlier declaration in same scope + my $x; + my $x ; + + Variable "%s" may be unavailable + sub x { + my $x; + sub y { + $x + } + } + + Variable "%s" will not stay shared + sub x { + my $x; + sub y { + sub { $x } + } + } + + Found = in conditional, should be == + 1 if $a = 1 ; + + Use of implicit split to @_ is deprecated + split ; + + Use of implicit split to @_ is deprecated + $a = split ; + + Useless use of time in void context + Useless use of a variable in void context + Useless use of a constant in void context + time ; + $a ; + "abc" + + Applying %s to %s will act on scalar(%s) + my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; + @a =~ /abc/ ; + @a =~ s/a/b/ ; + @a =~ tr/a/b/ ; + @$b =~ /abc/ ; + @$b =~ s/a/b/ ; + @$b =~ tr/a/b/ ; + %a =~ /abc/ ; + %a =~ s/a/b/ ; + %a =~ tr/a/b/ ; + %$c =~ /abc/ ; + %$c =~ s/a/b/ ; + %$c =~ tr/a/b/ ; + + + Parens missing around "my" list at -e line 1. + my $a, $b = (1,2); + + Parens missing around "local" list at -e line 1. + local $a, $b = (1,2); + + Probable precedence problem on logical or at -e line 1. + use warning 'syntax'; my $x = print(ABC || 1); + + Value of %s may be \"0\"; use \"defined\" + $x = 1 if $x = ; + $x = 1 while $x = ; + + Subroutine fred redefined at -e line 1. + sub fred{1;} sub fred{1;} + + Constant subroutine %s redefined + sub fred() {1;} sub fred() {1;} + + Format FRED redefined at /tmp/x line 5. + format FRED = + . + format FRED = + . + + Array @%s missing the @ in argument %d of %s() + push fred ; + + Hash %%%s missing the %% in argument %d of %s() + keys joe ; + + Statement unlikely to be reached + (Maybe you meant system() when you said exec()? + exec "true" ; my $a + + + __END__ + # op.c + use warning 'unsafe' ; + my $x ; + my $x ; + EXPECT + "my" variable $x masks earlier declaration in same scope at - line 4. + ######## + # op.c + use warning 'unsafe' ; + sub x { + my $x; + sub y { + $x + } + } + EXPECT + Variable "$x" will not stay shared at - line 7. + ######## + # op.c + use warning 'unsafe' ; + sub x { + my $x; + sub y { + sub { $x } + } + } + EXPECT + Variable "$x" may be unavailable at - line 6. + ######## + # op.c + use warning 'syntax' ; + 1 if $a = 1 ; + EXPECT + Found = in conditional, should be == at - line 3. + ######## + # op.c + use warning 'deprecated' ; + split ; + EXPECT + Use of implicit split to @_ is deprecated at - line 3. + ######## + # op.c + use warning 'deprecated' ; + $a = split ; + EXPECT + Use of implicit split to @_ is deprecated at - line 3. + ######## + # op.c + use warning 'void' ; close STDIN ; + 1 x 3 ; # OP_REPEAT + # OP_GVSV + wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN + ref ; # OP_REF + \@a ; # OP_REFGEN + \$a ; # OP_SREFGEN + defined $a ; # OP_DEFINED + hex $a ; # OP_HEX + oct $a ; # OP_OCT + length $a ; # OP_LENGTH + substr $a,1 ; # OP_SUBSTR + vec $a,1,2 ; # OP_VEC + index $a,1,2 ; # OP_INDEX + rindex $a,1,2 ; # OP_RINDEX + sprintf $a ; # OP_SPRINTF + $a[0] ; # OP_AELEM + # OP_AELEMFAST + @a[0] ; # OP_ASLICE + #values %a ; # OP_VALUES + #keys %a ; # OP_KEYS + $a{0} ; # OP_HELEM + @a{0} ; # OP_HSLICE + unpack "a", "a" ; # OP_UNPACK + pack $a,"" ; # OP_PACK + join "" ; # OP_JOIN + (@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH + sort(1,2) ; # OP_SORT + reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP + (1 ..2) ; # OP_FLOP + caller ; # OP_CALLER + fileno STDIN ; # OP_FILENO + eof STDIN ; # OP_EOF + tell STDIN ; # OP_TELL + readlink 1; # OP_READLINK + time ; # OP_TIME + localtime ; # OP_LOCALTIME + gmtime ; # OP_GMTIME + getgrnam 1; # OP_GGRNAM + getgrgid 1 ; # OP_GGRGID + getpwnam 1; # OP_GPWNAM + getpwuid 1; # OP_GPWUID + EXPECT + Useless use of repeat in void context at - line 3. + Useless use of wantarray in void context at - line 5. + Useless use of reference-type operator in void context at - line 12. + Useless use of reference constructor in void context at - line 13. + Useless use of scalar ref constructor in void context at - line 14. + Useless use of defined operator in void context at - line 15. + Useless use of hex in void context at - line 16. + Useless use of oct in void context at - line 17. + Useless use of length in void context at - line 18. + Useless use of substr in void context at - line 19. + Useless use of vec in void context at - line 20. + Useless use of index in void context at - line 21. + Useless use of rindex in void context at - line 22. + Useless use of sprintf in void context at - line 23. + Useless use of array element in void context at - line 24. + Useless use of array slice in void context at - line 26. + Useless use of hash elem in void context at - line 29. + Useless use of hash slice in void context at - line 30. + Useless use of unpack in void context at - line 31. + Useless use of pack in void context at - line 32. + Useless use of join in void context at - line 33. + Useless use of list slice in void context at - line 34. + Useless use of sort in void context at - line 37. + Useless use of reverse in void context at - line 38. + Useless use of range (or flop) in void context at - line 41. + Useless use of caller in void context at - line 42. + Useless use of fileno in void context at - line 43. + Useless use of eof in void context at - line 44. + Useless use of tell in void context at - line 45. + Useless use of readlink in void context at - line 46. + Useless use of time in void context at - line 47. + Useless use of localtime in void context at - line 48. + Useless use of gmtime in void context at - line 49. + Useless use of getgrnam in void context at - line 50. + Useless use of getgrgid in void context at - line 51. + Useless use of getpwnam in void context at - line 52. + Useless use of getpwuid in void context at - line 53. + ######## + # op.c + use warning 'void' ; + use Config ; + BEGIN { + if ( ! $Config{d_telldir}) { + print < ; + EXPECT + Value of construct can be "0"; test with defined() at - line 4. + ######## + --FILE-- abc + + --FILE-- + # op.c + use warning 'unsafe' ; + open FH, " ; + EXPECT + Value of construct can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + opendir FH, "." ; + $x = 1 if $x = readdir FH ; + closedir FH ; + EXPECT + Value of readdir() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + $x = 1 if $x = <*> ; + EXPECT + Value of glob construct can be "0"; test with defined() at - line 3. + ######## + # op.c + use warning 'unsafe' ; + %a = (1,2,3,4) ; + $x = 1 if $x = each %a ; + EXPECT + Value of each() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + %a = (1,2,3,4) ; + $x = 1 while $x = each %a ; + EXPECT + Value of each() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + $x = 1 while $x = <*> and 0 ; + EXPECT + Value of glob construct can be "0"; test with defined() at - line 3. + ######## + # op.c + use warning 'unsafe' ; + opendir FH, "." ; + $x = 1 while $x = readdir FH and 0 ; + closedir FH ; + EXPECT + Value of readdir() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred {} + sub fred {} + EXPECT + Subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred () { 1 } + sub fred () { 1 } + EXPECT + Constant subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + format FRED = + . + format FRED = + . + EXPECT + Format FRED redefined at - line 5. + ######## + # op.c + use warning 'syntax' ; + push FRED; + EXPECT + Array @FRED missing the @ in argument 1 of push() at - line 3. + ######## + # op.c + use warning 'syntax' ; + @a = keys FRED ; + EXPECT + Hash %FRED missing the % in argument 1 of keys() at - line 3. + ######## + # op.c + use warning 'syntax' ; + exec "true" ; + my $a + EXPECT + Statement unlikely to be reached at - line 4. + (Maybe you meant system() when you said exec()?) *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-perl Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,12 ---- + perl.c AOK + + gv_check(defstash) + Name \"%s::%s\" used only once: possible typo + + + __END__ + # perl.c + use warning 'once' ; + $x = 3 ; + EXPECT + Name "main::x" used only once: possible typo at - line 3. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-perly Tue Jan 6 09:55:11 1998 *************** *** 0 **** --- 1,25 ---- + perly.y AOK + + dep() => deprecate("\"do\" to call subroutines") + Use of "do" to call subroutines is deprecated + + sub fred {} do fred() + sub fred {} do fred(1) + sub fred {} $a = "fred" ; do $a() + sub fred {} $a = "fred" ; do $a(1) + + + __END__ + # perly.y + use warning 'deprecated' ; + sub fred {} + do fred() ; + do fred(1) ; + $a = "fred" ; + do $a() ; + do $a(1) ; + EXPECT + Use of "do" to call subroutines is deprecated at - line 4. + Use of "do" to call subroutines is deprecated at - line 5. + Use of "do" to call subroutines is deprecated at - line 7. + Use of "do" to call subroutines is deprecated at - line 8. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-pp Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,72 ---- + pp.c AOK + + substr outside of string + $a = "ab" ; $a = substr($a, 4,5) + + Attempt to use reference as lvalue in substr + $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b + + uninitialized << + close STDIN ; $a = ; + + Deep recursion on subroutine \"%s\" + sub fred { fred() if $a++ < 200} fred() + + Deep recursion on anonymous subroutine + $a = sub { &$a if $a++ < 200} &$a + + __END__ + # pp_hot.c + use warning 'unopened' ; + $f = $a = "abc" ; + print $f $a + EXPECT + Filehandle main::abc never opened at - line 4. + ######## + # pp_hot.c + use warning 'io' ; + print STDIN "anc"; + EXPECT + Filehandle main::STDIN opened only for input at - line 3. + ######## + # pp_hot.c + use warning 'closed' ; + close STDIN ; + print STDIN "anc"; + EXPECT + print on closed filehandle main::STDIN at - line 4. + ######## + # pp_hot.c + use warning 'uninitialized' ; + my $a = undef ; + my @b = @$a + EXPECT + Use of uninitialized value at - line 4. + ######## + # pp_hot.c + use warning 'uninitialized' ; + my $a = undef ; + my %b = %$a + EXPECT + Use of uninitialized value at - line 4. + ######## + # pp_hot.c + use warning 'unsafe' ; + my %X ; %X = (1,2,3) ; + EXPECT + Odd number of elements in hash list at - line 3. + ######## + # pp_hot.c + use warning 'closed' ; + close STDIN ; $a = ; + EXPECT + Read on closed filehandle at - line 3. + ######## + # pp_hot.c + use warning 'recursion' ; + sub fred + { + fred() if $a++ < 200 + } + + fred() + EXPECT + Deep recursion on subroutine "main::fred" at - line 5. + ######## + # pp_hot.c + use warning 'recursion' ; + $b = sub + { + &$b if $a++ < 200 + } ; + + &$b ; + EXPECT + Deep recursion on anonymous subroutine at - line 5. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-pp_sys Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,208 ---- + pp_sys.c AOK + + untie attempted while %d inner references still exist + sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; + + Filehandle only opened for input + format STDIN = + . + write STDIN; + + Write on closed filehandle + format STDIN = + . + close STDIN; + write STDIN ; + + page overflow + + Filehandle %s never opened + $a = "abc"; printf $a "fred" + + Filehandle %s opened only for input + $a = "abc"; + printf $a "fred" + + printf on closed filehandle %s + close STDIN ; + printf STDIN "fred" + + Syswrite on closed filehandle + close STDIN; + syswrite STDIN, "fred", 1; + + Send on closed socket + close STDIN; + send STDIN, "fred", 1 + + bind() on closed fd + close STDIN; + bind STDIN, "fred" ; + + + connect() on closed fd + close STDIN; + connect STDIN, "fred" ; + + listen() on closed fd + close STDIN; + listen STDIN, 2; + + accept() on closed fd + close STDIN; + accept STDIN, "fred" ; + + shutdown() on closed fd + close STDIN; + shutdown STDIN, 0; + + [gs]etsockopt() on closed fd + close STDIN; + setsockopt STDIN, 1,2,3; + getsockopt STDIN, 1,2; + + get{sock, peer}name() on closed fd + close STDIN; + getsockname STDIN; + getpeername STDIN; + + warn(warn_nl, "stat"); + + Test on unopened file <%s> + close STDIN ; -T STDIN ; + + warn(warn_nl, "open"); + -T "abc\ndef" ; + + + + __END__ + # pp_sys.c + use warning 'untie' ; + sub TIESCALAR { bless [] } ; + $b = tie $a, 'main'; + untie $a ; + EXPECT + untie attempted while 1 inner references still exist at - line 5. + ######## + # pp_sys.c + use warning 'io' ; + format STDIN = + . + write STDIN; + EXPECT + Filehandle only opened for input at - line 5. + ######## + # pp_sys.c + use warning 'closed' ; + format STDIN = + . + close STDIN; + write STDIN; + EXPECT + Write on closed filehandle at - line 6. + ######## + # pp_sys.c + use warning 'io' ; + format STDOUT_TOP = + abc + . + format STDOUT = + def + ghi + . + $= = 1 ; + $- =1 ; + open STDOUT, ">/dev/null" ; + write ; + EXPECT + page overflow at - line 13. + ######## + # pp_sys.c + use warning 'unopened' ; + $a = "abc"; + printf $a "fred" + EXPECT + Filehandle main::abc never opened at - line 4. + ######## + # pp_sys.c + use warning 'closed' ; + close STDIN ; + printf STDIN "fred" + EXPECT + printf on closed filehandle main::STDIN at - line 4. + ######## + # pp_sys.c + use warning 'io' ; + printf STDIN "fred" + EXPECT + Filehandle main::STDIN opened only for input at - line 3. + ######## + # pp_sys.c + use warning 'closed' ; + close STDIN; + syswrite STDIN, "fred", 1; + EXPECT + Syswrite on closed filehandle at - line 4. + ######## + # pp_sys.c + use warning 'io' ; + use Config; + BEGIN { + if ( $^O ne 'VMS' and ! $Config{d_socket}) { + print < at - line 4. + ######## + # pp_sys.c + use warning 'newline' ; + -T "abc\ndef" ; + EXPECT + Unsuccessful open on filename containing newline at - line 3. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-regcomp Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,24 ---- + regcomp.c TODO + + %.*s matches null string many times + + $a = "ABC123" ; $a =~ /(C*)*/' + + Strange *+?{} on zero-length expression + + /(?=a)?/ + + __END__ + # regcomp.c + use warning 'unsafe' ; + my $a = "ABC123" ; + $a =~ /(C*)*/ ; + EXPECT + (C*)* matches null string many times at - line 4. + ######## + # regcomp.c + use warning 'unsafe' ; + $_ = "" ; + /(?=a)?/; + EXPECT + Strange *+?{} on zero-length expression at - line 4. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-regexec Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,24 ---- + regexec.c + + count exceeded %d + + $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; + count exceeded %d + + $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; + + + __END__ + # regexec.c + use warning 'unsafe' ; + $_ = 'a' x (2**15+1); + /^()(a\1)*$/ ; + EXPECT + count exceeded 32766 at - line 4. + ######## + # regexec.c + use warning 'unsafe' ; + $_ = 'a' x (2**15+1); + /^()(a\1)*?$/ ; + EXPECT + count exceeded 32766 at - line 4. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-sv Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,195 ---- + sv.c AOK + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + warn(warn_uninit); + + Subroutine %s redefined + + Invalid conversion in %s: <<< TODO + + + __END__ + # sv.c + use integer ; + use warning 'uninitialized' ; + $x = 1 + $a[0] ; # a + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c (sv_2iv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use integer ; + use warning 'uninitialized' ; + $A *= 2 ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use integer ; + use warning 'uninitialized' ; + my $x *= 2 ; #b + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c (sv_2uv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $B = 0 ; + $B |= $A ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use warning 'uninitialized' ; + my $Y = 1 ; + my $x = 1 | $a[$Y] + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c + use warning 'uninitialized' ; + my $x *= 1 ; # d + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = 1 + $a[0] ; # e + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c (sv_2nv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $A *= 2 ; + EXPECT + Use of uninitialized value at - line 9. + ######## + # sv.c + use warning 'uninitialized' ; + $x = $y + 1 ; # f + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = chop undef ; # g + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = chop $y ; # h + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c (sv_2pv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $B = "" ; + $B .= $A ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use warning 'numeric' ; + sub TIESCALAR{bless[]} ; + sub FETCH {"def"} ; + tie $a,"main" ; + my $b = 1 + $a + EXPECT + Argument "def" isn't numeric in add at - line 6. + ######## + # sv.c + use warning 'numeric' ; + my $x = 1 + "def" ; + EXPECT + Argument "def" isn't numeric in add at - line 3. + ######## + # sv.c + use warning 'numeric' ; + my $a = "def" ; + my $x = 1 + $a ; + EXPECT + Argument "def" isn't numeric in add at - line 4. + ######## + # sv.c + use warning 'numeric' ; use integer ; + my $a = "def" ; + my $x = 1 + $a ; + EXPECT + Argument "def" isn't numeric in i_add at - line 4. + ######## + # sv.c + use warning 'numeric' ; + my $x = 1 & "def" ; + EXPECT + Argument "def" isn't numeric in bit_and at - line 3. + ######## + # sv.c + use warning 'redefine' ; + sub fred {} + sub joe {} + *fred = \&joe ; + EXPECT + Subroutine fred redefined at - line 5. + ######## + # sv.c + use warning 'printf' ; + open F, ">/dev/null" ; + printf F "%q\n" ; + my $a = sprintf "%q" ; + printf F "%" ; + $a = sprintf "%" ; + printf F "%\x02" ; + $a = sprintf "%\x02" ; + EXPECT + Invalid conversion in sprintf: "%q" at - line 5. + Invalid conversion in sprintf: end of string at - line 7. + Invalid conversion in sprintf: "%\002" at - line 9. + Invalid conversion in printf: "%q" at - line 4. + Invalid conversion in printf: end of string at - line 6. + Invalid conversion in printf: "%\002" at - line 8. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-taint Tue Jan 6 09:55:12 1998 *************** *** 0 **** --- 1,25 ---- + taint.c TODO + + Insecure %s%s while running setuid + Insecure %s%s while running setgid + Insecure %s%s while running with -T switch + + + Insecure directory in %s%s while running setuid + Insecure directory in %s%s while running setgid + Insecure directory in %s%s while running with -T switch + + + + __END__ + # taint.c + use warning 'misc' ; + + EXPECT + + ######## + # taint.c + use warning 'misc' ; + + EXPECT + *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-toke Tue Jan 6 09:55:13 1998 *************** *** 0 **** --- 1,308 ---- + toke.c AOK + + 1 if $a EQ $b ; + 1 if $a NE $b ; + 1 if $a LT $b ; + 1 if $a GT $b ; + 1 if $a GE $b ; + 1 if $a LE $b ; + $a = <<; + Use of comma-less variable list is deprecated + (called 3 times via depcom) + + \1 better written as $1 + use warning 'syntax' ; + s/(abc)/\1/; + + Ambiguous use of -%c => resolved to \"-%c\" =>" + -a => 2; + + Ambiguous use of {%s} resolved to {\"%s\"} + $a = $a{time} ; + sub fred {} $a = $a{fred} ; + + warn(warn_nosemi) + Semicolon seems to be missing + $a = 1 + &time ; + + + Reversed %c= operator + my $a =+ 2 ; + $a =- 2 ; + $a =* 2 ; + $a =% 2 ; + $a =& 2 ; + $a =. 2 ; + $a =^ 2 ; + $a =| 2 ; + $a =< 2 ; + $a =/ 2 ; + + Multidimensional syntax %.*s not supported + my $a = $a[1,2] ; + + You need to quote \"%s\"" + sub fred {} ; $SIG{TERM} = fred; + + Scalar value %.*s better written as $%.*s" + @a[3] = 2; + @a{3} = 2; + + Can't use \\%c to mean $%c in expression + $_ = "ab" ; s/(ab)/\1/e; + + Ambiguous use of %s => resolved to \"%s\" => + $a = { print => 1}; + sub fred{} $a = { fred => 1}; + + + Unquoted string "abc" may clash with future reserved word at - line 3. + warn(warn_reserved + $a = abc; + + chmod: mode argument is missing initial 0 + chmod 3; + + Possible attempt to separate words with commas + @a = qw(a, b, c) ; + + Possible attempt to put comments in qw() list + @a = qw(a b # c) ; + + umask: argument is missing initial 0 + umask 3; + + %s (...) interpreted as function + print ("") + printf ("") + sort ("") + + Ambiguous use of %c{%s%s} resolved to %c%s%s + $a = ${time[2]} + $a = ${time{2}} + + + Ambiguous use of %c{%s} resolved to %c%s + $a = ${time} + sub fred {} $a = ${fred} + + Misplaced _ in number + $a = 1_2; + $a = 1_2345_6; + + + + __END__ + # toke.c + use warning 'deprecated' ; + 1 if $a EQ $b ; + 1 if $a NE $b ; + 1 if $a GT $b ; + 1 if $a LT $b ; + 1 if $a GE $b ; + 1 if $a LE $b ; + EXPECT + Use of EQ is deprecated at - line 3. + Use of NE is deprecated at - line 4. + Use of GT is deprecated at - line 5. + Use of LT is deprecated at - line 6. + Use of GE is deprecated at - line 7. + Use of LE is deprecated at - line 8. + ######## + # toke.c + use warning 'deprecated' ; + format STDOUT = + @<<< @||| @>>> @>>> + $a $b "abc" 'def' + . + ($a, $b) = (1,2,3); + write; + EXPECT + Use of comma-less variable list is deprecated at - line 5. + Use of comma-less variable list is deprecated at - line 5. + Use of comma-less variable list is deprecated at - line 5. + 1 2 abc def + ######## + # toke.c + use warning 'deprecated' ; + $a = <<; + + EXPECT + Use of bare << to mean <<"" is deprecated at - line 3. + ######## + # toke.c + use warning 'syntax' ; + s/(abc)/\1/; + EXPECT + \1 better written as $1 at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + $a = $a{time} ; + sub fred {} $a = $a{fred} ; + EXPECT + Ambiguous use of {time} resolved to {"time"} at - line 3. + Ambiguous use of {fred} resolved to {"fred"} at - line 4. + ######## + # toke.c + use warning 'ambiguous' ; + -a => 2; + EXPECT + Ambiguous use of -a => resolved to "-a" => at - line 3. + ######## + # toke.c + use warning 'semicolon' ; + $a = 1 + &time ; + EXPECT + Semicolon seems to be missing at - line 3. + ######## + # toke.c + use warning 'syntax' ; + my $a =+ 2 ; + $a =- 2 ; + $a =* 2 ; + $a =% 2 ; + $a =& 2 ; + $a =. 2 ; + $a =^ 2 ; + $a =| 2 ; + $a =< 2 ; + $a =/ 2 ; + EXPECT + Reversed += operator at - line 3. + Reversed -= operator at - line 4. + Reversed *= operator at - line 5. + Reversed %= operator at - line 6. + Reversed &= operator at - line 7. + Reversed .= operator at - line 8. + syntax error at - line 8, near "=." + Reversed ^= operator at - line 9. + syntax error at - line 9, near "=^" + Reversed |= operator at - line 10. + syntax error at - line 10, near "=|" + Reversed <= operator at - line 11. + Unterminated <> operator at - line 11. + ######## + # toke.c + use warning 'syntax' ; + my $a = $a[1,2] ; + EXPECT + Multidimensional syntax $a[1,2] not supported at - line 3. + ######## + # toke.c + use warning 'syntax' ; + sub fred {} ; $SIG{TERM} = fred; + EXPECT + You need to quote "fred" at - line 3. + ######## + # toke.c + use warning 'syntax' ; + @a[3] = 2; + @a{3} = 2; + EXPECT + Scalar value @a[3] better written as $a[3] at - line 3. + Scalar value @a{3} better written as $a{3} at - line 4. + ######## + # toke.c + use warning 'syntax' ; + $_ = "ab" ; + s/(ab)/\1/e; + EXPECT + Can't use \1 to mean $1 in expression at - line 4. + ######## + # toke.c + use warning 'reserved' ; + $a = abc; + EXPECT + Unquoted string "abc" may clash with future reserved word at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + sub fred {} + $a = { fred => 1}; + EXPECT + Ambiguous use of fred => resolved to "fred" => at - line 4. + ######## + # toke.c + use warning 'ambiguous' ; + $a = { print => 1}; + EXPECT + Ambiguous use of print => resolved to "print" => at - line 3. + ######## + # toke.c + use warning 'octal' ; + chmod 3; + EXPECT + chmod: mode argument is missing initial 0 at - line 3, at end of line + ######## + # toke.c + use warning 'syntax' ; + @a = qw(a, b, c) ; + EXPECT + Possible attempt to separate words with commas at - line 3. + ######## + # toke.c + use warning 'syntax' ; + @a = qw(a b #) ; + EXPECT + Possible attempt to put comments in qw() list at - line 3. + ######## + # toke.c + use warning 'octal' ; + umask 3; + EXPECT + umask: argument is missing initial 0 at - line 3, at end of line + ######## + # toke.c + use warning 'syntax' ; + print ("") + EXPECT + print (...) interpreted as function at - line 3. + ######## + # toke.c + use warning 'syntax' ; + printf ("") + EXPECT + printf (...) interpreted as function at - line 3. + ######## + # toke.c + use warning 'syntax' ; + sort ("") + EXPECT + sort (...) interpreted as function at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + $a = ${time[2]}; + EXPECT + Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + $a = ${time{2}}; + EXPECT + Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + $a = ${time} ; + EXPECT + Ambiguous use of ${time} resolved to $time at - line 3. + ######## + # toke.c + use warning 'ambiguous' ; + sub fred {} + $a = ${fred} ; + EXPECT + Ambiguous use of ${fred} resolved to $fred at - line 4. + ######## + # toke.c + use warning 'syntax' ; + $a = 1_2; + $a = 1_2345_6; + EXPECT + Misplaced _ in number at - line 3. + Misplaced _ in number at - line 4. + Misplaced _ in number at - line 4. *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-universal Tue Jan 6 09:55:13 1998 *************** *** 0 **** --- 1,11 ---- + universal.c + + Can't locate package %s for @%s::ISA + + + __END__ + # universal.c + use warning 'misc' ; + + EXPECT + *** /dev/null Tue Jan 6 09:13:40 1998 --- t/pragma/warn-util Tue Jan 6 09:55:13 1998 *************** *** 0 **** --- 1,12 ---- + util.c AOK + + Illegal octal digit ignored + my $a = oct "029" ; + + + __END__ + # util.c + use warning 'octal' ; + my $a = oct "029" ; + EXPECT + Illegal octal digit ignored at - line 3. *** t/pragma/warning.t.orig Tue Nov 25 14:55:51 1997 --- t/pragma/warning.t Tue Jan 6 09:55:13 1998 *************** *** 16,23 **** END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; ! foreach (sort glob("pragma/warn-*")) { next if /(~|\.orig)$/; --- 16,31 ---- END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; + my @w_files = () ; ! if (@ARGV) ! { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn-#; $_ } @ARGV } ! else ! { @w_files = sort glob("pragma/warn-*") } ! ! foreach (@w_files) { ! ! next if /\.orig$/ ; next if /(~|\.orig)$/; *** taint.c.orig Wed Dec 17 14:28:12 1997 --- taint.c Tue Jan 6 09:55:13 1998 *************** *** 25,32 **** ug = " while running with -T switch"; if (!unsafe) croak(f, s, ug); ! else if (dowarn) ! warn(f, s, ug); } } --- 25,32 ---- ug = " while running with -T switch"; if (!unsafe) croak(f, s, ug); ! else if (ckWARN(WARN_TAINT)) ! warner(WARN_TAINT, f, s, ug); } } *** toke.c.orig Wed Dec 17 14:16:51 1997 --- toke.c Tue Jan 6 09:55:14 1998 *************** *** 209,216 **** void deprecate(char *s) { ! if (dowarn) ! warn("Use of %s is deprecated", s); } static void --- 209,216 ---- void deprecate(char *s) { ! if (ckWARN(WARN_DEPRECATED)) ! warner(WARN_DEPRECATED, "Use of %s is deprecated", s); } static void *************** *** 810,817 **** if (lex_inwhat == OP_SUBST && !lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { ! if (dowarn) ! warn("\\%c better written as $%c", *s, *s); *--s = '$'; break; } --- 810,817 ---- if (lex_inwhat == OP_SUBST && !lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; break; } *************** *** 1783,1790 **** s++; if (strnEQ(s,"=>",2)) { ! if (dowarn) ! warn("Ambiguous use of -%c => resolved to \"-%c\" =>", (int)tmp, (int)tmp); s = force_word(bufptr,WORD,FALSE,FALSE,FALSE); OPERATOR('-'); /* unary minus */ --- 1783,1791 ---- s++; if (strnEQ(s,"=>",2)) { ! if (ckWARN(WARN_AMBIGUOUS)) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of -%c => resolved to \"-%c\" =>", (int)tmp, (int)tmp); s = force_word(bufptr,WORD,FALSE,FALSE,FALSE); OPERATOR('-'); /* unary minus */ *************** *** 1987,1997 **** d++; if (*d == '}') { char minus = (tokenbuf[0] == '-'); ! if (dowarn && (keyword(tokenbuf + 1, len) || (minus && len == 1 && isALPHA(tokenbuf[1])) || perl_get_cv(tokenbuf + 1, FALSE) )) ! warn("Ambiguous use of {%s} resolved to {\"%s\"}", tokenbuf + !minus, tokenbuf + !minus); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) --- 1988,1999 ---- d++; if (*d == '}') { char minus = (tokenbuf[0] == '-'); ! if (ckWARN(WARN_AMBIGUOUS) && (keyword(tokenbuf + 1, len) || (minus && len == 1 && isALPHA(tokenbuf[1])) || perl_get_cv(tokenbuf + 1, FALSE) )) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of {%s} resolved to {\"%s\"}", tokenbuf + !minus, tokenbuf + !minus); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) *************** *** 2133,2141 **** AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { ! if (dowarn && isALPHA(*s) && bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } BAop(OP_BIT_AND); --- 2135,2143 ---- AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { ! if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } BAop(OP_BIT_AND); *************** *** 2167,2174 **** OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); ! if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) ! warn("Reversed %c= operator",(int)tmp); s--; if (expect == XSTATE && isALPHA(tmp) && (s == linestart+1 || s[-2] == '\n') ) --- 2169,2176 ---- OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); ! if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) ! warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp); s--; if (expect == XSTATE && isALPHA(tmp) && (s == linestart+1 || s[-2] == '\n') ) *************** *** 2298,2304 **** char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (dowarn) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; --- 2300,2306 ---- char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (ckWARN(WARN_SYNTAX)) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; *************** *** 2306,2319 **** bufptr = skipspace(bufptr); while (t < bufend && *t != ']') t++; ! warn("Multidimensional syntax %.*s not supported", (t - bufptr) + 1, bufptr); } } } else if (*s == '{') { tokenbuf[0] = '%'; ! if (dowarn && strEQ(tokenbuf+1, "SIG") && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[sizeof tokenbuf]; --- 2308,2322 ---- bufptr = skipspace(bufptr); while (t < bufend && *t != ']') t++; ! warner(WARN_SYNTAX, ! "Multidimensional syntax %.*s not supported", (t - bufptr) + 1, bufptr); } } } else if (*s == '{') { tokenbuf[0] = '%'; ! if (ckWARN(WARN_SYNTAX) && strEQ(tokenbuf+1, "SIG") && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[sizeof tokenbuf]; *************** *** 2322,2328 **** if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warn("You need to quote \"%s\"", tmpbuf); } } } --- 2325,2332 ---- if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warner(WARN_SYNTAX, ! "You need to quote \"%s\"", tmpbuf); } } } *************** *** 2392,2398 **** tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (dowarn) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) --- 2396,2402 ---- tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (ckWARN(WARN_SYNTAX)) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) *************** *** 2400,2406 **** if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warn("Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } --- 2404,2411 ---- if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warner(WARN_SYNTAX, ! "Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } *************** *** 2506,2513 **** case '\\': s++; ! if (dowarn && lex_inwhat && isDIGIT(*s)) ! warn("Can't use \\%c to mean $%c in expression", *s, *s); if (expect == XOPERATOR) no_op("Backslash",s); OPERATOR(REFGEN); --- 2511,2519 ---- case '\\': s++; ! if (ckWARN(WARN_SYNTAX) && lex_inwhat && isDIGIT(*s)) ! warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression", ! *s, *s); if (expect == XOPERATOR) no_op("Backslash",s); OPERATOR(REFGEN); *************** *** 2583,2590 **** /* Is this a word before a => operator? */ if (strnEQ(d,"=>",2)) { CLINE; ! if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE))) ! warn("Ambiguous use of %s => resolved to \"%s\" =>", tokenbuf, tokenbuf); yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; --- 2589,2597 ---- /* Is this a word before a => operator? */ if (strnEQ(d,"=>",2)) { CLINE; ! if (ckWARN(WARN_AMBIGUOUS) && (tmp || perl_get_cv(tokenbuf, FALSE))) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %s => resolved to \"%s\" =>", tokenbuf, tokenbuf); yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; *************** *** 2632,2638 **** if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } else --- 2639,2645 ---- if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } else *************** *** 2777,2787 **** /* Call it a bare word */ bareword: ! if (dowarn) { if (lastchar != '-') { for (d = tokenbuf; *d && isLOWER(*d); d++) ; if (!*d) ! warn(warn_reserved, tokenbuf); } } if (lastchar && strchr("*%&", lastchar)) { --- 2784,2794 ---- /* Call it a bare word */ bareword: ! if (ckWARN(WARN_RESERVED)) { if (lastchar != '-') { for (d = tokenbuf; *d && isLOWER(*d); d++) ; if (!*d) ! warner(WARN_RESERVED, warn_reserved, tokenbuf); } } if (lastchar && strchr("*%&", lastchar)) { *************** *** 2920,2926 **** LOP(OP_CRYPT,XTERM); case KEY_chmod: ! if (dowarn) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("chmod: mode argument is missing initial 0"); --- 2927,2933 ---- LOP(OP_CRYPT,XTERM); case KEY_chmod: ! if (ckWARN(WARN_OCTAL)) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("chmod: mode argument is missing initial 0"); *************** *** 3340,3354 **** s = scan_str(s); if (!s) missingterm((char*)0); ! if (dowarn && SvLEN(lex_stuff)) { d = SvPV_force(lex_stuff, len); for (; len; --len, ++d) { if (*d == ',') { ! warn("Possible attempt to separate words with commas"); break; } if (*d == '#') { ! warn("Possible attempt to put comments in qw() list"); break; } } --- 3347,3363 ---- s = scan_str(s); if (!s) missingterm((char*)0); ! if (ckWARN(WARN_SYNTAX) && SvLEN(lex_stuff)) { d = SvPV_force(lex_stuff, len); for (; len; --len, ++d) { if (*d == ',') { ! warner(WARN_SYNTAX, ! "Possible attempt to separate words with commas"); break; } if (*d == '#') { ! warner(WARN_SYNTAX, ! "Possible attempt to put comments in qw() list"); break; } } *************** *** 3719,3725 **** LOP(OP_UTIME,XTERM); case KEY_umask: ! if (dowarn) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("umask: argument is missing initial 0"); --- 3728,3734 ---- LOP(OP_UTIME,XTERM); case KEY_umask: ! if (ckWARN(WARN_OCTAL)) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("umask: argument is missing initial 0"); *************** *** 4413,4419 **** { char *w; ! if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ int level = 1; for (w = s+2; *w && level; w++) { if (*w == '(') --- 4422,4428 ---- { char *w; ! if (ckWARN(WARN_SYNTAX) && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ int level = 1; for (w = s+2; *w && level; w++) { if (*w == '(') *************** *** 4424,4430 **** if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ ! warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; --- 4433,4439 ---- if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ ! warner(WARN_SYNTAX, "%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; *************** *** 4562,4570 **** *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { ! if (dowarn && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; ! warn("Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } lex_fakebrack = lex_brackets+1; --- 4571,4580 ---- *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { ! if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } lex_fakebrack = lex_brackets+1; *************** *** 4579,4587 **** lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (dowarn && lex_state == LEX_NORMAL && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) ! warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } else { --- 4589,4598 ---- lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (ckWARN(WARN_AMBIGUOUS) && lex_state == LEX_NORMAL && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } else { *************** *** 5111,5118 **** floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); lastub = ++s; } else { --- 5122,5129 ---- floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) ! warner(WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; } else { *************** *** 5121,5128 **** *d++ = *s++; } } ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; --- 5132,5139 ---- *d++ = *s++; } } ! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) ! warner(WARN_SYNTAX, "Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; *** universal.c.orig Tue Nov 25 14:55:53 1997 --- universal.c Tue Jan 6 09:55:14 1998 *************** *** 53,60 **** SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (dowarn) ! warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } --- 53,61 ---- SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (ckWARN(WARN_MISC)) ! warner(WARN_SYNTAX, ! "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } *** util.c.orig Wed Dec 10 18:36:38 1997 --- util.c Tue Jan 6 09:55:14 1998 *************** *** 1250,1261 **** return restartop; } - #ifdef I_STDARG void croak(const char* pat, ...) #else /*VARARGS0*/ - void croak(pat, va_alist) char *pat; va_dcl --- 1250,1260 ---- return restartop; } void + #ifdef I_STDARG croak(const char* pat, ...) #else /*VARARGS0*/ croak(pat, va_alist) char *pat; va_dcl *************** *** 1314,1320 **** void #ifdef I_STDARG ! warn(const char* pat,...) #else /*VARARGS0*/ warn(pat,va_alist) --- 1313,1319 ---- void #ifdef I_STDARG ! warn(const char *pat,...) #else /*VARARGS0*/ warn(pat,va_alist) *************** *** 1370,1375 **** --- 1369,1473 ---- (void)PerlIO_flush(PerlIO_stderr()); } + void + #ifdef I_STDARG + warner(U32 err, const char* pat,...) + #else + /*VARARGS0*/ + warner(err,pat,va_alist) + U32 err; + const char *pat; + va_dcl + #endif + { + va_list args; + char *message; + HV *stash; + GV *gv; + CV *cv; + + #ifdef I_STDARG + va_start(args, pat); + #else + va_start(args); + #endif + message = mess(pat, &args); + va_end(args); + + if (ckDEAD(err)) { + #ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); + #endif /* USE_THREADS */ + if (diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = diehook; + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + } + } + if (in_eval) { + restartop = die_where(message); + JMPENV_JUMP(3); + } + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); + my_failure_exit(); + + } + else { + if (warnhook) { + /* sv_2cv might call warn() */ + dTHR; + SV *oldwarnhook = warnhook; + ENTER; + SAVESPTR(warnhook); + warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); + #ifdef LEAKTEST + DEBUG_L(xstat()); + #endif + (void)PerlIO_flush(PerlIO_stderr()); + } + } + #ifndef VMS /* VMS' my_setenv() is in VMS.c */ #ifndef WIN32 void *************** *** 2304,2311 **** retval = n | (*s++ - '0'); len--; } ! if (dowarn && len && (*s == '8' || *s == '9')) ! warn("Illegal octal digit ignored"); *retlen = s - start; return retval; } --- 2402,2409 ---- retval = n | (*s++ - '0'); len--; } ! if (len && (*s == '8' || *s == '9') && ckWARN(WARN_OCTAL)) ! warner(WARN_OCTAL, "Illegal octal digit ignored"); *retlen = s - start; return retval; } *** /dev/null Tue Jan 6 09:13:40 1998 --- warning.h Tue Jan 6 09:55:15 1998 *************** *** 0 **** --- 1,95 ---- + /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file is built by warning.pl + Any changes made here will be lost! + */ + + + #define Off(x) ((x) / 8) + #define Bit(x) (1 << ((x) % 8)) + #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + + /* #define G_WARN_DISABLE 1 */ + #define G_WARN_OFF 0 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #if 1 + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + IsSet(SvPVX(curcop->cop_warnings), 2*x+1)) + + #define ckWARN(x) \ + ( (curcop->cop_warnings && \ + (curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #define ckWARN2(x,y) \ + ( (curcop->cop_warnings && \ + (curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #else + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) + + #define ckWARN(x) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) + + #define ckWARN2(x,y) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ + SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) + + #endif + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + #define WARN_REDEFINE 0 + #define WARN_VOID 1 + #define WARN_UNSAFE 2 + #define WARN_TAINT 3 + #define WARN_SUBSTR 4 + #define WARN_CLOSURE 5 + #define WARN_UNTIE 6 + #define WARN_SIGNAL 7 + #define WARN_NUMERIC 8 + #define WARN_ONCE 9 + #define WARN_SYNTAX 10 + #define WARN_RESERVED 11 + #define WARN_DEPRECATED 12 + #define WARN_SEMICOLON 13 + #define WARN_PRINTF 14 + #define WARN_OCTAL 15 + #define WARN_AMBIGUOUS 16 + #define WARN_PARENTHESIS 17 + #define WARN_PRECEDENCE 18 + #define WARN_IO 19 + #define WARN_NEWLINE 20 + #define WARN_CLOSED 21 + #define WARN_EXEC 22 + #define WARN_UNOPENED 23 + #define WARN_PIPE 24 + #define WARN_UNINITIALIZED 25 + #define WARN_RECURSION 26 + #define WARN_MISC 27 + + #define WARNsize 7 + #define WARN_ALLstring "\125\125\125\125\125\125\125" + #define WARN_NONEstring "\0\0\0\0\0\0\0" + + /* end of file warning.h */ + *** /dev/null Tue Jan 6 09:13:40 1998 --- warning.pl Tue Jan 6 09:55:15 1998 *************** *** 0 **** --- 1,347 ---- + #!/usr/bin/perl + + $tree = { + 'unsafe' => { 'untie' => 1, + 'substr' => 1, + 'taint' => 1, + 'signal' => 1, + 'closure' => 1, + } , + 'io' => { 'pipe' => 1, + 'unopened' => 1, + 'closed' => 1, + 'newline' => 1, + 'exec' => 1, + #'wr in in file'=> 1, + }, + 'syntax' => { 'ambiguous' => 1, + 'semicolon' => 1, + 'precedence' => 1, + 'reserved' => 1, + 'octal' => 1, + 'parenthesis' => 1, + 'deprecated' => 1, + 'printf' => 1, + }, + 'void' => 1, + 'recursion' => 1, + 'redefine' => 1, + 'numeric' => 1, + 'uninitialized'=> 1, + 'once' => 1, + 'misc' => 1, + } ; + + + ########################################################################### + sub tab { + local($l, $t) = @_; + $t .= "\t" x ($l - (length($t) + 1) / 8); + $t; + } + + ########################################################################### + + sub walk + { + my $tre = shift ; + my @list = () ; + my ($k, $v) ; + + while (($k, $v) = each %$tre) { + + die "duplicate key $k\n" if defined $list{$k} ; + $Value{$index} = uc $k ; + push @{ $list{$k} }, $index ++ ; + if (ref $v) + { push (@{ $list{$k} }, walk ($v)) } + push @list, @{ $list{$k} } ; + } + + return @list ; + + } + + ########################################################################### + + sub mkRange + { + my @a = @_ ; + my @out = @a ; + my $i ; + + + for ($i = 1 ; $i < @a; ++ $i) { + $out[$i] = ".." + if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ; + } + + my $out = join(",",@out); + + $out =~ s/,(\.\.,)+/../g ; + return $out; + } + + ########################################################################### + + sub mkHex + { + my ($max, @a) = @_ ; + my $mask = "\x00" x $max ; + my $string = "" ; + + foreach (@a) { + vec($mask, $_, 1) = 1 ; + } + + #$string = unpack("H$max", $mask) ; + #$string =~ s/(..)/\x$1/g; + foreach (unpack("C*", $mask)) { + $string .= '\x' . sprintf("%2.2x", $_) ; + } + return $string ; + } + + ########################################################################### + + + #unlink "warning.h"; + #unlink "lib/warning.pm"; + open(WARN, ">warning.h") || die "Can't create warning.h: $!\n"; + open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n"; + + print WARN <<'EOM' ; + /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file is built by warning.pl + Any changes made here will be lost! + */ + + + /* sWarning is used for "(S) A severe warning (mandatory)." + #define sWarning warning + + #define Off(x) ((x) / 8) + #define Bit(x) (1 << ((x) % 8)) + #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + + /* #define G_WARN_DISABLE 1 */ + #define G_WARN_OFF 0 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #if 1 + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + IsSet(SvPVX(curcop->cop_warnings), 2*x+1)) + + #define ckWARN(x) \ + ( (curcop->cop_warnings && \ + (curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #define ckWARN2(x,y) \ + ( (curcop->cop_warnings && \ + (curcop->cop_warnings == WARN_ALL || \ + IsSet(SvPVX(curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #else + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) + + #define ckWARN(x) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) + + #define ckWARN2(x,y) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ + SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) + + #endif + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + EOM + + + $index = 0 ; + @{ $list{"all"} } = walk ($tree) ; + + $index *= 2 ; + $warn_size = int($index / 8) + ($index % 8 != 0) ; + + foreach $k (sort { $a <=> $b } keys %Value) { + print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ; + } + print WARN "\n" ; + + print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; + #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; + print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; + print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; + + print WARN <<'EOM'; + + /* end of file warning.h */ + + EOM + + close WARN ; + + while () { + last if /^KEYWORDS$/ ; + print PM $_ ; + } + + $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; + print PM "%Bits = (\n" ; + foreach $k (sort keys %list) { + + $v = $list{$k} ; + my @list = sort { $a <=> $b } @$v ; + + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 , @list), + '", # [', mkRange(@list), "]\n" ; + } + + print PM " );\n\n" ; + + print PM "%DeadBits = (\n" ; + foreach $k (sort keys %list) { + + $v = $list{$k} ; + my @list = sort { $a <=> $b } @$v ; + + print PM tab(4, " '$k'"), '=> "', + # mkHex($warn_size, @list), + mkHex($warn_size, map $_ * 2 + 1 , @list), + '", # [', mkRange(@list), "]\n" ; + } + + print PM " );\n\n" ; + while () { + print PM $_ ; + } + + close PM ; + + __END__ + + # This file was created by warning.pl + # Any changes made here will be lost. + # + + package warning; + + =head1 NAME + + warning - Perl pragma to control + + =head1 SYNOPSIS + + use warning; + + use warning "all"; + use warning "deprecated"; + + use warning; + no warning "unsafe"; + + =head1 DESCRIPTION + + If no import list is supplied, all possible restrictions are assumed. + (This is the safest mode to operate in, but is sometimes too strict for + casual programming.) Currently, there are three possible things to be + strict about: + + =over 6 + + =item C + + This generates a runtime error if you use deprecated + + use warning 'deprecated'; + + =back + + See L. + + + =cut + + use Carp ; + + KEYWORDS + + sub bits { + my $mask ; + my $catmask ; + my $fatal = 0 ; + foreach my $word (@_) { + if ($word eq 'FATAL') + { $fatal = 1 } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + } + else + { croak "unknown warning category '$word'" } + } + + return $mask ; + } + + sub import { + shift; + $^B |= bits(@_ ? @_ : 'all') ; + } + + sub unimport { + shift; + $^B &= ~ bits(@_ ? @_ : 'all') ; + } + + + sub make_fatal + { + my $self = shift ; + my $bitmask = $self->bits(@_) ; + $SIG{__WARN__} = + sub + { + die @_ if $^B & $bitmask ; + warn @_ + } ; + } + + sub bitmask + { + return $^B ; + } + + sub enabled + { + my $string = shift ; + + return 1 + if $bits{$string} && $^B & $bits{$string} ; + + return 0 ; + } + + 1;