ext/Devel/PPPort/parts/inc/warn

   1 ################################################################################
   2 ##
   3 ##  $Revision: 2 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2006/05/20 10:57:02 +0200 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
  10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
  11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  12 ##
  13 ##  This program is free software; you can redistribute it and/or
  14 ##  modify it under the same terms as Perl itself.
  15 ##
  16 ################################################################################
  17
  18 =provides
  19
  20 __UNDEFINED__
  21 ckWARN
  22 warner
  23 Perl_warner
  24 Perl_warner_nocontext
  25
  26 =implementation
  27
  28 __UNDEFINED__  WARN_ALL                 0
  29 __UNDEFINED__  WARN_CLOSURE             1
  30 __UNDEFINED__  WARN_DEPRECATED          2
  31 __UNDEFINED__  WARN_EXITING             3
  32 __UNDEFINED__  WARN_GLOB                4
  33 __UNDEFINED__  WARN_IO                  5
  34 __UNDEFINED__  WARN_CLOSED              6
  35 __UNDEFINED__  WARN_EXEC                7
  36 __UNDEFINED__  WARN_LAYER               8
  37 __UNDEFINED__  WARN_NEWLINE             9
  38 __UNDEFINED__  WARN_PIPE                10
  39 __UNDEFINED__  WARN_UNOPENED            11
  40 __UNDEFINED__  WARN_MISC                12
  41 __UNDEFINED__  WARN_NUMERIC             13
  42 __UNDEFINED__  WARN_ONCE                14
  43 __UNDEFINED__  WARN_OVERFLOW            15
  44 __UNDEFINED__  WARN_PACK                16
  45 __UNDEFINED__  WARN_PORTABLE            17
  46 __UNDEFINED__  WARN_RECURSION           18
  47 __UNDEFINED__  WARN_REDEFINE            19
  48 __UNDEFINED__  WARN_REGEXP              20
  49 __UNDEFINED__  WARN_SEVERE              21
  50 __UNDEFINED__  WARN_DEBUGGING           22
  51 __UNDEFINED__  WARN_INPLACE             23
  52 __UNDEFINED__  WARN_INTERNAL            24
  53 __UNDEFINED__  WARN_MALLOC              25
  54 __UNDEFINED__  WARN_SIGNAL              26
  55 __UNDEFINED__  WARN_SUBSTR              27
  56 __UNDEFINED__  WARN_SYNTAX              28
  57 __UNDEFINED__  WARN_AMBIGUOUS           29
  58 __UNDEFINED__  WARN_BAREWORD            30
  59 __UNDEFINED__  WARN_DIGIT               31
  60 __UNDEFINED__  WARN_PARENTHESIS         32
  61 __UNDEFINED__  WARN_PRECEDENCE          33
  62 __UNDEFINED__  WARN_PRINTF              34
  63 __UNDEFINED__  WARN_PROTOTYPE           35
  64 __UNDEFINED__  WARN_QW                  36
  65 __UNDEFINED__  WARN_RESERVED            37
  66 __UNDEFINED__  WARN_SEMICOLON           38
  67 __UNDEFINED__  WARN_TAINT               39
  68 __UNDEFINED__  WARN_THREADS             40
  69 __UNDEFINED__  WARN_UNINITIALIZED       41
  70 __UNDEFINED__  WARN_UNPACK              42
  71 __UNDEFINED__  WARN_UNTIE               43
  72 __UNDEFINED__  WARN_UTF8                44
  73 __UNDEFINED__  WARN_VOID                45
  74 __UNDEFINED__  WARN_ASSERTIONS          46
  75
  76 __UNDEFINED__  packWARN(a)              (a)
  77
  78 #ifndef ckWARN
  79 #  ifdef G_WARN_ON
  80 #    define  ckWARN(a)                  (PL_dowarn & G_WARN_ON)
  81 #  else
  82 #    define  ckWARN(a)                  PL_dowarn
  83 #  endif
  84 #endif
  85
  86 /* warner depends on vnewSVpvf */
  87 #if { VERSION >= 5.004 } && !defined(warner)
  88 #if { NEED warner }
  89
  90 void
  91 warner(U32 err, const char *pat, ...)
  92 {
  93   SV *sv;
  94   va_list args;
  95
  96   PERL_UNUSED_ARG(err);
  97
  98   va_start(args, pat);
  99   sv = vnewSVpvf(pat, &args);
 100   va_end(args);
 101   sv_2mortal(sv);
 102   warn("%s", SvPV_nolen(sv));
 103 }
 104
 105 #define warner  Perl_warner
 106
 107 /* Perl_warner_nocontext depends on warner */
 108 #define Perl_warner_nocontext  Perl_warner
 109
 110 #endif
 111 #endif
 112
 113 =xsinit
 114
 115 #define NEED_warner
 116
 117 =xsubs
 118
 119 void
 120 warner()
 121         CODE:
 122 #if { VERSION >= 5.004 }
 123                 warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42);
 124 #endif
 125
 126 void
 127 Perl_warner()
 128         CODE:
 129 #if { VERSION >= 5.004 }
 130                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42);
 131 #endif
 132
 133 void
 134 Perl_warner_nocontext()
 135         CODE:
 136 #if { VERSION >= 5.004 }
 137                 Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42);
 138 #endif
 139
 140 void
 141 ckWARN()
 142         CODE:
 143 #if { VERSION >= 5.004 }
 144                 if (ckWARN(WARN_MISC))
 145                   Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42);
 146 #endif
 147
 148 =tests plan => 5
 149
 150 $^W = 0;
 151
 152 my $warning;
 153
 154 $SIG{'__WARN__'} = sub { $warning = $_[0] };
 155
 156 $warning = '';
 157 Devel::PPPort::warner();
 158 ok($] >= 5.004 ? $warning =~ /^warner bar:42/ : $warning eq '');
 159
 160 $warning = '';
 161 Devel::PPPort::Perl_warner();
 162 ok($] >= 5.004 ? $warning =~ /^Perl_warner bar:42/ : $warning eq '');
 163
 164 $warning = '';
 165 Devel::PPPort::Perl_warner_nocontext();
 166 ok($] >= 5.004 ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq '');
 167
 168 $warning = '';
 169 Devel::PPPort::ckWARN();
 170 ok($warning, '');
 171
 172 $^W = 1;
 173
 174 $warning = '';
 175 Devel::PPPort::ckWARN();
 176 ok($] >= 5.004 ? $warning =~ /^ckWARN bar:42/ : $warning eq '');
 177