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__
15ckWARN
16ckWARN_d
17warner
18ck_warner
19ck_warner_d
20Perl_warner
21Perl_ck_warner
22Perl_ck_warner_d
23Perl_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
116void
117warner(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
135void
136ck_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
160void
161ck_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
192void
193warner()
194        CODE:
195#if { VERSION >= 5.004 }
196                warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42);
197#endif
198
199void
200Perl_warner()
201        CODE:
202#if { VERSION >= 5.004 }
203                Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42);
204#endif
205
206void
207Perl_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
213void
214Perl_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
220void
221Perl_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
227void
228ckWARN()
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
235void
236ckWARN_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
247my $warning;
248
249$SIG{'__WARN__'} = sub { $warning = $_[0] };
250
251$warning = '';
252Devel::PPPort::warner();
253ok(ivers($]) >= ivers("5.004") ? $warning =~ /^warner bar:42/ : $warning eq '');
254
255$warning = '';
256Devel::PPPort::Perl_warner();
257ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_warner bar:42/ : $warning eq '');
258
259$warning = '';
260Devel::PPPort::Perl_warner_nocontext();
261ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq '');
262
263$warning = '';
264Devel::PPPort::ckWARN();
265is($warning, '');
266
267$warning = '';
268Devel::PPPort::ckWARN_d();
269ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN_d bar:42/ : $warning eq '');
270
271$warning = '';
272Devel::PPPort::Perl_ck_warner();
273ok($warning eq '');
274
275$warning = '';
276Devel::PPPort::Perl_ck_warner_d();
277ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner_d bar:42/ : $warning eq '');
278
279$^W = 1;
280
281$warning = '';
282Devel::PPPort::ckWARN();
283ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN bar:42/ : $warning eq '');
284
285$warning = '';
286Devel::PPPort::ckWARN_d();
287ok(ivers($]) >= ivers("5.004") ? $warning =~ /^ckWARN_d bar:42/ : $warning eq '');
288
289$warning = '';
290Devel::PPPort::Perl_ck_warner();
291ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner bar:42/ : $warning eq '');
292
293$warning = '';
294Devel::PPPort::Perl_ck_warner_d();
295ok(ivers($]) >= ivers("5.004") ? $warning =~ /^Perl_ck_warner_d bar:42/ : $warning eq '');
296