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