This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix for ID 20010306.008, UTF-8 and \w without 'use utf8' coredump.
[perl5.git] / ext / Errno / Errno_pm.PL
CommitLineData
eab60bb1
GS
1use ExtUtils::MakeMaker;
2use Config;
3use strict;
4
f168a5e7 5our $VERSION = "1.111";
eab60bb1
GS
6
7my %err = ();
8
9unlink "Errno.pm" if -f "Errno.pm";
10open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
11select OUT;
12my $file;
13foreach $file (get_files()) {
14 process_file($file);
15}
16write_errno_pm();
17unlink "errno.c" if -f "errno.c";
18
19sub process_file {
20 my($file) = @_;
21
6683669a 22 return unless defined $file and -f $file;
eab60bb1
GS
23
24 local *FH;
25 if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
26 unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
27 warn "Cannot open '$file'";
28 return;
29 }
9ae2e8df
P
30 } elsif ($Config{gccversion} ne '') {
31 # With the -dM option, gcc outputs every #define it finds
32 unless(open(FH,"$Config{cc} -E -dM $file |")) {
33 warn "Cannot open '$file'";
34 return;
35 }
eab60bb1
GS
36 } else {
37 unless(open(FH,"< $file")) {
def887e8 38 # This file could be a temporary file created by cppstdin
6ad8d9a8
GB
39 # so only warn under -w, and return
40 warn "Cannot open '$file'" if $^W;
eab60bb1
GS
41 return;
42 }
43 }
44 while(<FH>) {
45 $err{$1} = 1
dcbf900d 46 if /^\s*#\s*define\s+(E\w+)\s+/;
eab60bb1
GS
47 }
48 close(FH);
49}
50
def887e8
JH
51my $cppstdin;
52
53sub default_cpp {
54 unless (defined $cppstdin) {
55 use File::Spec;
56 $cppstdin = $Config{cppstdin};
57 my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
58 File::Spec->updir,
59 "cppstdin");
60 my $cppstdin_is_wrapper =
61 ($cppstdin eq 'cppstdin'
62 and -f $upup_cppstdin
63 and -x $upup_cppstdin);
64 $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
65 }
66 return "$cppstdin $Config{cppflags} $Config{cppminus}";
67}
68
eab60bb1
GS
69sub get_files {
70 my %file = ();
71 # VMS keeps its include files in system libraries (well, except for Gcc)
72 if ($^O eq 'VMS') {
73 if ($Config{vms_cc_type} eq 'decc') {
74 $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
75 } elsif ($Config{vms_cc_type} eq 'vaxc') {
76 $file{'Sys$Library:vaxcdef.tlb'} = 1;
77 } elsif ($Config{vms_cc_type} eq 'gcc') {
78 $file{'gnu_cc_include:[000000]errno.h'} = 1;
79 }
9d116dd7
JH
80 } elsif ($^O eq 'os390') {
81 # OS/390 C compiler doesn't generate #file or #line directives
82 $file{'/usr/include/errno.h'} = 1;
092bebab
JH
83 } elsif ($^O eq 'vmesa') {
84 # OS/390 C compiler doesn't generate #file or #line directives
85 $file{'../../vmesa/errno.h'} = 1;
a367e475
OF
86 } elsif ($Config{archname} eq 'epoc') {
87 # Watch out for cross compiling for EPOC (usually done on linux)
88 $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1;
9ae2e8df
P
89 } elsif ($^O eq 'linux') {
90 # Some Linuxes have weird errno.hs which generate
91 # no #file or #line directives
92 $file{'/usr/include/errno.h'} = 1;
eab60bb1
GS
93 } else {
94 open(CPPI,"> errno.c") or
95 die "Cannot open errno.c";
96
97 print CPPI "#include <errno.h>\n";
98
99 close(CPPI);
100
101 # invoke CPP and read the output
6ad8d9a8
GB
102 if ($^O eq 'MSWin32') {
103 open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
104 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
105 } else {
def887e8 106 my $cpp = default_cpp();
6ad8d9a8
GB
107 open(CPPO,"$cpp < errno.c |") or
108 die "Cannot exec $cpp";
109 }
eab60bb1
GS
110
111 my $pat;
112 if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
113 $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
114 }
115 else {
d0d1d9b9 116 $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
eab60bb1
GS
117 }
118 while(<CPPO>) {
2449e420 119 if ($^O eq 'os2' or $^O eq 'MSWin32') {
0196e43b
IZ
120 if (/$pat/o) {
121 my $f = $1;
122 $f =~ s,\\\\,/,g;
123 $file{$f} = 1;
124 }
125 }
126 else {
127 $file{$1} = 1 if /$pat/o;
128 }
eab60bb1
GS
129 }
130 close(CPPO);
131 }
132 return keys %file;
133}
134
135sub write_errno_pm {
136 my $err;
137
def887e8
JH
138 # quick sanity check
139
140 die "No error definitions found" unless keys %err;
141
eab60bb1
GS
142 # create the CPP input
143
144 open(CPPI,"> errno.c") or
145 die "Cannot open errno.c";
146
147 print CPPI "#include <errno.h>\n";
148
149 foreach $err (keys %err) {
150 print CPPI '"',$err,'" [[',$err,']]',"\n";
151 }
152
153 close(CPPI);
154
155 # invoke CPP and read the output
dcbf900d 156
eab60bb1
GS
157 if ($^O eq 'VMS') {
158 my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
159 $cpp =~ s/sys\$input//i;
160 open(CPPO,"$cpp errno.c |") or
161 die "Cannot exec $Config{cppstdin}";
6ad8d9a8
GB
162 } elsif ($^O eq 'MSWin32') {
163 open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
164 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
165 } else {
def887e8 166 my $cpp = default_cpp();
dcbf900d
GS
167 open(CPPO,"$cpp < errno.c |")
168 or die "Cannot exec $cpp";
eab60bb1
GS
169 }
170
171 %err = ();
172
173 while(<CPPO>) {
174 my($name,$expr);
175 next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
176 next if $name eq $expr;
177 $err{$name} = eval $expr;
178 }
179 close(CPPO);
180
181 # Write Errno.pm
182
183 print <<"EDQ";
184#
185# This file is auto-generated. ***ANY*** changes here will be lost
186#
187
188package Errno;
f168a5e7 189our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD);
eab60bb1
GS
190use Exporter ();
191use Config;
192use strict;
193
8bc9d590
JH
194"\$Config{'archname'}-\$Config{'osvers'}" eq
195"$Config{'archname'}-$Config{'osvers'}" or
81be85b8 196 die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
eab60bb1
GS
197
198\$VERSION = "$VERSION";
199\@ISA = qw(Exporter);
200
201EDQ
202
203 my $len = 0;
204 my @err = sort { $err{$a} <=> $err{$b} } keys %err;
205 map { $len = length if length > $len } @err;
206
207 my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
208 $j =~ s/(.{50,70})\s/$1\n\t/g;
209 print $j,"\n";
210
211print <<'ESQ';
212%EXPORT_TAGS = (
213 POSIX => [qw(
214ESQ
215
216 my $k = join(" ", grep { exists $err{$_} }
217 qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
218 EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
219 ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
220 EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
221 EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
222 EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
223 ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
224 ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
225 ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
226 EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
227 ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
228 ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
229 EUSERS EWOULDBLOCK EXDEV));
230
231 $k =~ s/(.{50,70})\s/$1\n\t/g;
232 print "\t",$k,"\n )]\n);\n\n";
233
234 foreach $err (@err) {
235 printf "sub %s () { %d }\n",,$err,$err{$err};
236 }
237
238 print <<'ESQ';
239
240sub TIEHASH { bless [] }
241
242sub FETCH {
243 my ($self, $errname) = @_;
244 my $proto = prototype("Errno::$errname");
68301627 245 my $errno = "";
eab60bb1
GS
246 if (defined($proto) && $proto eq "") {
247 no strict 'refs';
68301627
GS
248 $errno = &$errname;
249 $errno = 0 unless $! == $errno;
eab60bb1 250 }
68301627 251 return $errno;
93014de6 252}
eab60bb1
GS
253
254sub STORE {
255 require Carp;
256 Carp::confess("ERRNO hash is read only!");
257}
258
259*CLEAR = \&STORE;
260*DELETE = \&STORE;
261
262sub NEXTKEY {
263 my($k,$v);
264 while(($k,$v) = each %Errno::) {
265 my $proto = prototype("Errno::$k");
266 last if (defined($proto) && $proto eq "");
eab60bb1
GS
267 }
268 $k
269}
270
271sub FIRSTKEY {
68301627 272 my $s = scalar keys %Errno::; # initialize iterator
eab60bb1
GS
273 goto &NEXTKEY;
274}
275
276sub EXISTS {
277 my ($self, $errname) = @_;
278 my $proto = prototype($errname);
279 defined($proto) && $proto eq "";
280}
281
282tie %!, __PACKAGE__;
283
2841;
285__END__
286
287=head1 NAME
288
289Errno - System errno constants
290
291=head1 SYNOPSIS
292
293 use Errno qw(EINTR EIO :POSIX);
294
295=head1 DESCRIPTION
296
297C<Errno> defines and conditionally exports all the error constants
298defined in your system C<errno.h> include file. It has a single export
299tag, C<:POSIX>, which will export all POSIX defined error numbers.
300
93014de6 301C<Errno> also makes C<%!> magic such that each element of C<%!> has a
68301627 302non-zero value only if C<$!> is set to that value. For example:
eab60bb1
GS
303
304 use Errno;
3cb6de81 305
eab60bb1
GS
306 unless (open(FH, "/fangorn/spouse")) {
307 if ($!{ENOENT}) {
308 warn "Get a wife!\n";
309 } else {
310 warn "This path is barred: $!";
311 }
312 }
313
68301627
GS
314If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
315returns C<"">. You may use C<exists $!{EFOO}> to check whether the
93014de6
GS
316constant is available on the system.
317
68301627
GS
318=head1 CAVEATS
319
320Importing a particular constant may not be very portable, because the
321import will fail on platforms that do not have that constant. A more
322portable way to set C<$!> to a valid value is to use:
323
324 if (exists &Errno::EFOO) {
325 $! = &Errno::EFOO;
326 }
327
eab60bb1
GS
328=head1 AUTHOR
329
330Graham Barr <gbarr@pobox.com>
331
332=head1 COPYRIGHT
333
334Copyright (c) 1997-8 Graham Barr. All rights reserved.
335This program is free software; you can redistribute it and/or modify it
336under the same terms as Perl itself.
337
338=cut
339
340ESQ
341
342}