dist/Devel-PPPort/parts/inc/warn

   1 ################################################################################
   2 ##
   3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
   5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
   6 ##
   7 ##  This program is free software; you can redistribute it and/or
   8 ##  modify it under the same terms as Perl itself.
   9 ##
  10 ################################################################################
  11
  12 =provides
  13
  14 __UNDEFINED__
  15 ckWARN
  16 ckWARN_d
  17 warner
  18 ck_warner
  19 ck_warner_d
  20 Perl_warner
  21 Perl_ck_warner
  22 Perl_ck_warner_d
  23 Perl_warner_nocontext
  24
  25 =implementation
  26
  27 __UNDEFINED__  WARN_ALL                 0
  28 __UNDEFINED__  WARN_CLOSURE             1
  29 __UNDEFINED__  WARN_DEPRECATED          2
  30 __UNDEFINED__  WARN_EXITING             3
  31 __UNDEFINED__  WARN_GLOB                4
  32 __UNDEFINED__  WARN_IO                  5
  33 __UNDEFINED__  WARN_CLOSED              6
  34 __UNDEFINED__  WARN_EXEC                7
  35 __UNDEFINED__  WARN_LAYER               8
  36 __UNDEFINED__  WARN_NEWLINE             9
  37 __UNDEFINED__  WARN_PIPE                10
  38 __UNDEFINED__  WARN_UNOPENED            11
  39 __UNDEFINED__  WARN_MISC                12
  40 __UNDEFINED__  WARN_NUMERIC             13
  41 __UNDEFINED__  WARN_ONCE                14
  42 __UNDEFINED__  WARN_OVERFLOW            15
  43 __UNDEFINED__  WARN_PACK                16
  44 __UNDEFINED__  WARN_PORTABLE            17
  45 __UNDEFINED__  WARN_RECURSION           18
  46 __UNDEFINED__  WARN_REDEFINE            19
  47 __UNDEFINED__  WARN_REGEXP              20
  48 __UNDEFINED__  WARN_SEVERE              21
  49 __UNDEFINED__  WARN_DEBUGGING           22
  50 __UNDEFINED__  WARN_INPLACE             23
  51 __UNDEFINED__  WARN_INTERNAL            24
  52 __UNDEFINED__  WARN_MALLOC              25
  53 __UNDEFINED__  WARN_SIGNAL              26
  54 __UNDEFINED__  WARN_SUBSTR              27
  55 __UNDEFINED__  WARN_SYNTAX              28
  56 __UNDEFINED__  WARN_AMBIGUOUS           29
  57 __UNDEFINED__  WARN_BAREWORD            30
  58 __UNDEFINED__  WARN_DIGIT               31
  59 __UNDEFINED__  WARN_PARENTHESIS         32
  60 __UNDEFINED__  WARN_PRECEDENCE          33
  61 __UNDEFINED__  WARN_PRINTF              34
  62 __UNDEFINED__  WARN_PROTOTYPE           35
  63 __UNDEFINED__  WARN_QW                  36
  64 __UNDEFINED__  WARN_RESERVED            37
  65 __UNDEFINED__  WARN_SEMICOLON           38
  66 __UNDEFINED__  WARN_TAINT               39
  67 __UNDEFINED__  WARN_THREADS             40
  68 __UNDEFINED__  WARN_UNINITIALIZED       41
  69 __UNDEFINED__  WARN_UNPACK              42
  70 __UNDEFINED__  WARN_UNTIE               43
  71 __UNDEFINED__  WARN_UTF8                44
  72 __UNDEFINED__  WARN_VOID                45
  73 __UNDEFINED__  WARN_ASSERTIONS          46
  74
  75 __UNDEFINED__  packWARN(a)         (a)
  76 __UNDEFINED__  packWARN2(a,b)      (packWARN(a)      << 8 | (b))
  77 __UNDEFINED__  packWARN3(a,b,c)    (packWARN2(a,b)   << 8 | (c))
  78 __UNDEFINED__  packWARN4(a,b,c,d)  (packWARN3(a,b,c) << 8 | (d))
  79
  80 #ifndef ckWARN
  81 #  ifdef G_WARN_ON
  82 #    define  ckWARN(a)                  (PL_dowarn & G_WARN_ON)
  83 #  else
  84 #    define  ckWARN(a)                  PL_dowarn
  85 #  endif
  86 #endif
  87
  88 __UNDEFINED__ ckWARN2(a,b)      (ckWARN(a) || ckWARN(b))
  89 __UNDEFINED__ ckWARN3(a,b,c)    (ckWARN(c) || ckWARN2(a,b))
  90 __UNDEFINED__ ckWARN4(a,b,c,d)  (ckWARN(d) || ckWARN3(a,b,c))
  91
  92 #ifndef ckWARN_d
  93 #  ifdef isLEXWARN_off
  94 #    define ckWARN_d(a)  (isLEXWARN_off || ckWARN(a))
  95 #  else
  96 #    define ckWARN_d(a)  1
  97 #  endif
  98 #endif
  99
 100 __UNDEFINED__ ckWARN2_d(a,b)     (ckWARN_d(a) || ckWARN_d(b))
 101 __UNDEFINED__ ckWARN3_d(a,b,c)   (ckWARN_d(c) || ckWARN2_d(a,b))
 102 __UNDEFINED__ ckWARN4_d(a,b,c,d) (ckWARN_d(d) || ckWARN3_d(a,b,c))
 103
 104 __UNDEFINED__ vwarner(err, pat, argsp)                      \
 105         STMT_START {    SV *sv;                             \
 106                         PERL_UNUSED_ARG(err);               \
 107                         sv = vnewSVpvf(pat, argsp);         \
 108                         sv_2mortal(sv);                     \
 109                         warn("%s", SvPV_nolen(sv));         \
 110         } STMT_END
 111
 112
 113 #if { VERSION >= 5.004 } && !defined(warner)
 114 #  if { NEED warner }
 115
 116 void
 117 warner(U32 err, const char *pat, ...)
 118 {
 119   va_list args;
 120   va_start(args, pat);
 121   vwarner(err, pat, &args);
 122   va_end(args);
 123 }
 124
 125 #    define warner  Perl_warner
 126
 127 #    define Perl_warner_nocontext  Perl_warner
 128
 129 #  endif
 130 #endif
 131
 132 #if { VERSION >= 5.004 } && !defined(ck_warner)
 133 #  if { NEED ck_warner }
 134
 135 void
 136 ck_warner(pTHX_ U32 err, const char *pat, ...)
 137 {
 138     va_list args;
 139
 140     if (   ! ckWARN((err      ) & 0xFF)
 141         && ! ckWARN((err >>  8) & 0xFF)
 142         && ! ckWARN((err >> 16) & 0xFF)
 143         && ! ckWARN((err >> 24) & 0xFF))
 144     {
 145         return;
 146     }
 147
 148     va_start(args, pat);
 149     vwarner(err, pat, &args);
 150     va_end(args);
 151 }
 152
 153 #    define ck_warner  Perl_ck_warner
 154 #  endif
 155 #endif
 156
 157 #if { VERSION >= 5.004 } && !defined(ck_warner_d)
 158 #  if { NEED ck_warner_d }
 159
 160 void
 161 ck_warner_d(pTHX_ U32 err, const char *pat, ...)
 162 {
 163     va_list args;
 164
 165     if (   ! ckWARN_d((err      ) & 0xFF)
 166         && ! ckWARN_d((err >>  8) & 0xFF)
 167         && ! ckWARN_d((err >> 16) & 0xFF)
 168         && ! ckWARN_d((err >> 24) & 0xFF))
 169     {
 170         return;
 171     }
 172
 173     va_start(args, pat);
 174     vwarner(err, pat, &args);
 175     va_end(args);
 176 }
 177
 178 #    define ck_warner_d  Perl_ck_warner_d
 179
 180
 181 #  endif
 182 #endif
 183
 184 =xsinit
 185
 186 #define NEED_warner
 187 #define NEED_ck_warner
 188 #define NEED_ck_warner_d
 189
 190 =xsubs
 191
 192 void
 193 warner()
 194         CODE:
 195 #if { VERSION >= 5.004 }
 196                 warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42);
 197 #endif
 198
 199 void
 200 Perl_warner()
 201         CODE:
 202 #if { VERSION >= 5.004 }
 203                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42);
 204 #endif
 205
 206 void
 207 Perl_ck_warner()
 208         CODE:
 209 #if { VERSION >= 5.004 }
 210                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Perl_ck_warner %s:%d", "bar", 42);
 211 #endif
 212
 213 void
 214 Perl_ck_warner_d()
 215         CODE:
 216 #if { VERSION >= 5.004 }
 217                 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), "Perl_ck_warner_d %s:%d", "bar", 42);
 218 #endif
 219
 220 void
 221 Perl_warner_nocontext()
 222         CODE:
 223 #if { VERSION >= 5.004 }
 224                 Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42);
 225 #endif
 226
 227 void
 228 ckWARN()
 229         CODE:
 230 #if { VERSION >= 5.004 }
 231                 if (ckWARN(WARN_MISC))
 232                   Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42);
 233 #endif
 234
 235 void
 236 ckWARN_d()
 237         CODE:
 238 #if { VERSION >= 5.004 }
 239                 if (ckWARN_d(WARN_MISC))
 240                   Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN_d %s:%d", "bar", 42);
 241 #endif
 242
 243 =tests plan => 11
 244
 245 $^W = 0;
 246
 247 my $warning;
 248
 249 $SIG{'__WARN__'} = sub { $warning = $_[0] };
 250
 251 $warning = '';
 252 Devel::PPPort::warner();
 253 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^warner bar:42/ : $warning eq '');
 254
 255 $warning = '';
 256 Devel::PPPort::Perl_warner();
 257 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_warner bar:42/ : $warning eq '');
 258
 259 $warning = '';
 260 Devel::PPPort::Perl_warner_nocontext();
 261 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq '');
 262
 263 $warning = '';
 264 Devel::PPPort::ckWARN();
 265 is($warning, '');
 266
 267 $warning = '';
 268 Devel::PPPort::ckWARN_d();
 269 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN_d bar:42/ : $warning eq '');
 270
 271 $warning = '';
 272 Devel::PPPort::Perl_ck_warner();
 273 ok($warning eq '');
 274
 275 $warning = '';
 276 Devel::PPPort::Perl_ck_warner_d();
 277 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner_d bar:42/ : $warning eq '');
 278
 279 $^W = 1;
 280
 281 $warning = '';
 282 Devel::PPPort::ckWARN();
 283 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN bar:42/ : $warning eq '');
 284
 285 $warning = '';
 286 Devel::PPPort::ckWARN_d();
 287 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN_d bar:42/ : $warning eq '');
 288
 289 $warning = '';
 290 Devel::PPPort::Perl_ck_warner();
 291 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner bar:42/ : $warning eq '');
 292
 293 $warning = '';
 294 Devel::PPPort::Perl_ck_warner_d();
 295 ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner_d bar:42/ : $warning eq '');