ext/Devel-PPPort/parts/inc/warn

   1 ################################################################################
   2 ##
   3 ##  $Revision: 7 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2009/01/18 14:10:52 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2009, 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 #if { VERSION >= 5.004 } && !defined(warner)
  87 #if { NEED warner }
  88
  89 void
  90 warner(U32 err, const char *pat, ...)
  91 {
  92   SV *sv;
  93   va_list args;
  94
  95   PERL_UNUSED_ARG(err);
  96
  97   va_start(args, pat);
  98   sv = vnewSVpvf(pat, &args);
  99   va_end(args);
 100   sv_2mortal(sv);
 101   warn("%s", SvPV_nolen(sv));
 102 }
 103
 104 #define warner  Perl_warner
 105
 106 #define Perl_warner_nocontext  Perl_warner
 107
 108 #endif
 109 #endif
 110
 111 =xsinit
 112
 113 #define NEED_warner
 114
 115 =xsubs
 116
 117 void
 118 warner()
 119         CODE:
 120 #if { VERSION >= 5.004 }
 121                 warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42);
 122 #endif
 123
 124 void
 125 Perl_warner()
 126         CODE:
 127 #if { VERSION >= 5.004 }
 128                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42);
 129 #endif
 130
 131 void
 132 Perl_warner_nocontext()
 133         CODE:
 134 #if { VERSION >= 5.004 }
 135                 Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42);
 136 #endif
 137
 138 void
 139 ckWARN()
 140         CODE:
 141 #if { VERSION >= 5.004 }
 142                 if (ckWARN(WARN_MISC))
 143                   Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42);
 144 #endif
 145
 146 =tests plan => 5
 147
 148 $^W = 0;
 149
 150 my $warning;
 151
 152 $SIG{'__WARN__'} = sub { $warning = $_[0] };
 153
 154 $warning = '';
 155 Devel::PPPort::warner();
 156 ok($] >= 5.004 ? $warning =~ /^warner bar:42/ : $warning eq '');
 157
 158 $warning = '';
 159 Devel::PPPort::Perl_warner();
 160 ok($] >= 5.004 ? $warning =~ /^Perl_warner bar:42/ : $warning eq '');
 161
 162 $warning = '';
 163 Devel::PPPort::Perl_warner_nocontext();
 164 ok($] >= 5.004 ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq '');
 165
 166 $warning = '';
 167 Devel::PPPort::ckWARN();
 168 ok($warning, '');
 169
 170 $^W = 1;
 171
 172 $warning = '';
 173 Devel::PPPort::ckWARN();
 174 ok($] >= 5.004 ? $warning =~ /^ckWARN bar:42/ : $warning eq '');
 175