| ################################################################################ |
| ## |
| ## $Revision: 8 $ |
| ## $Author: mhx $ |
| ## $Date: 2010/03/07 13:15:45 +0100 $ |
| ## |
| ################################################################################ |
| ## |
| ## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
| ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
| ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
| ## |
| ## This program is free software; you can redistribute it and/or |
| ## modify it under the same terms as Perl itself. |
| ## |
| ################################################################################ |
| |
| =provides |
| |
| __UNDEFINED__ |
| ckWARN |
| warner |
| Perl_warner |
| Perl_warner_nocontext |
| |
| =implementation |
| |
| __UNDEFINED__ WARN_ALL 0 |
| __UNDEFINED__ WARN_CLOSURE 1 |
| __UNDEFINED__ WARN_DEPRECATED 2 |
| __UNDEFINED__ WARN_EXITING 3 |
| __UNDEFINED__ WARN_GLOB 4 |
| __UNDEFINED__ WARN_IO 5 |
| __UNDEFINED__ WARN_CLOSED 6 |
| __UNDEFINED__ WARN_EXEC 7 |
| __UNDEFINED__ WARN_LAYER 8 |
| __UNDEFINED__ WARN_NEWLINE 9 |
| __UNDEFINED__ WARN_PIPE 10 |
| __UNDEFINED__ WARN_UNOPENED 11 |
| __UNDEFINED__ WARN_MISC 12 |
| __UNDEFINED__ WARN_NUMERIC 13 |
| __UNDEFINED__ WARN_ONCE 14 |
| __UNDEFINED__ WARN_OVERFLOW 15 |
| __UNDEFINED__ WARN_PACK 16 |
| __UNDEFINED__ WARN_PORTABLE 17 |
| __UNDEFINED__ WARN_RECURSION 18 |
| __UNDEFINED__ WARN_REDEFINE 19 |
| __UNDEFINED__ WARN_REGEXP 20 |
| __UNDEFINED__ WARN_SEVERE 21 |
| __UNDEFINED__ WARN_DEBUGGING 22 |
| __UNDEFINED__ WARN_INPLACE 23 |
| __UNDEFINED__ WARN_INTERNAL 24 |
| __UNDEFINED__ WARN_MALLOC 25 |
| __UNDEFINED__ WARN_SIGNAL 26 |
| __UNDEFINED__ WARN_SUBSTR 27 |
| __UNDEFINED__ WARN_SYNTAX 28 |
| __UNDEFINED__ WARN_AMBIGUOUS 29 |
| __UNDEFINED__ WARN_BAREWORD 30 |
| __UNDEFINED__ WARN_DIGIT 31 |
| __UNDEFINED__ WARN_PARENTHESIS 32 |
| __UNDEFINED__ WARN_PRECEDENCE 33 |
| __UNDEFINED__ WARN_PRINTF 34 |
| __UNDEFINED__ WARN_PROTOTYPE 35 |
| __UNDEFINED__ WARN_QW 36 |
| __UNDEFINED__ WARN_RESERVED 37 |
| __UNDEFINED__ WARN_SEMICOLON 38 |
| __UNDEFINED__ WARN_TAINT 39 |
| __UNDEFINED__ WARN_THREADS 40 |
| __UNDEFINED__ WARN_UNINITIALIZED 41 |
| __UNDEFINED__ WARN_UNPACK 42 |
| __UNDEFINED__ WARN_UNTIE 43 |
| __UNDEFINED__ WARN_UTF8 44 |
| __UNDEFINED__ WARN_VOID 45 |
| __UNDEFINED__ WARN_ASSERTIONS 46 |
| |
| __UNDEFINED__ packWARN(a) (a) |
| |
| #ifndef ckWARN |
| # ifdef G_WARN_ON |
| # define ckWARN(a) (PL_dowarn & G_WARN_ON) |
| # else |
| # define ckWARN(a) PL_dowarn |
| # endif |
| #endif |
| |
| #if { VERSION >= 5.004 } && !defined(warner) |
| #if { NEED warner } |
| |
| void |
| warner(U32 err, const char *pat, ...) |
| { |
| SV *sv; |
| va_list args; |
| |
| PERL_UNUSED_ARG(err); |
| |
| va_start(args, pat); |
| sv = vnewSVpvf(pat, &args); |
| va_end(args); |
| sv_2mortal(sv); |
| warn("%s", SvPV_nolen(sv)); |
| } |
| |
| #define warner Perl_warner |
| |
| #define Perl_warner_nocontext Perl_warner |
| |
| #endif |
| #endif |
| |
| =xsinit |
| |
| #define NEED_warner |
| |
| =xsubs |
| |
| void |
| warner() |
| CODE: |
| #if { VERSION >= 5.004 } |
| warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42); |
| #endif |
| |
| void |
| Perl_warner() |
| CODE: |
| #if { VERSION >= 5.004 } |
| Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42); |
| #endif |
| |
| void |
| Perl_warner_nocontext() |
| CODE: |
| #if { VERSION >= 5.004 } |
| Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42); |
| #endif |
| |
| void |
| ckWARN() |
| CODE: |
| #if { VERSION >= 5.004 } |
| if (ckWARN(WARN_MISC)) |
| Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42); |
| #endif |
| |
| =tests plan => 5 |
| |
| $^W = 0; |
| |
| my $warning; |
| |
| $SIG{'__WARN__'} = sub { $warning = $_[0] }; |
| |
| $warning = ''; |
| Devel::PPPort::warner(); |
| ok($] >= 5.004 ? $warning =~ /^warner bar:42/ : $warning eq ''); |
| |
| $warning = ''; |
| Devel::PPPort::Perl_warner(); |
| ok($] >= 5.004 ? $warning =~ /^Perl_warner bar:42/ : $warning eq ''); |
| |
| $warning = ''; |
| Devel::PPPort::Perl_warner_nocontext(); |
| ok($] >= 5.004 ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq ''); |
| |
| $warning = ''; |
| Devel::PPPort::ckWARN(); |
| ok($warning, ''); |
| |
| $^W = 1; |
| |
| $warning = ''; |
| Devel::PPPort::ckWARN(); |
| ok($] >= 5.004 ? $warning =~ /^ckWARN bar:42/ : $warning eq ''); |
| |