This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix Errno.pm generation for gcc-5.0
[perl5.git] / ext / Errno / Errno_pm.PL
1 use ExtUtils::MakeMaker;
2 use Config;
3 use strict;
4
5 our $VERSION = "1.23";
6
7 my %err = ();
8
9 # Symbian cross-compiling environment.
10 my $IsSymbian = exists $ENV{SDK} && -d "$ENV{SDK}\\epoc32";
11
12 my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian;
13
14 unlink "Errno.pm" if -f "Errno.pm";
15 unlink "Errno.tmp" if -f "Errno.tmp";
16 open OUT, ">Errno.tmp" or die "Cannot open Errno.tmp: $!";
17 select OUT;
18 my $file;
19 my @files = get_files();
20 if ($Config{gccversion} ne '' && $^O eq 'MSWin32') {
21     # MinGW complains "warning: #pragma system_header ignored outside include
22     # file" if the header files are processed individually, so include them
23     # all in .c file and process that instead.
24     open INCS, '>includes.c' or
25         die "Cannot open includes.c";
26     foreach $file (@files) {
27         next if $file eq 'errno.c';
28         next unless -f $file;
29         print INCS qq[#include "$file"\n];
30     }
31     close INCS;
32     process_file('includes.c');
33     unlink 'includes.c';
34 }
35 else {
36     foreach $file (@files) {
37         process_file($file);
38     }
39 }
40 write_errno_pm();
41 unlink "errno.c" if -f "errno.c";
42 close OUT or die "Error closing Errno.tmp: $!";
43 select STDOUT;
44 rename "Errno.tmp", "Errno.pm" or die "Cannot rename Errno.tmp to Errno.pm: $!";
45
46 sub process_file {
47     my($file) = @_;
48
49     # for win32 perl under cygwin, we need to get a windows pathname
50     if ($^O eq 'MSWin32' && $Config{cc} =~ /\B-mno-cygwin\b/ &&
51         defined($file) && !-f $file) {
52         chomp($file = `cygpath -w "$file"`);
53     }
54
55     return unless defined $file and -f $file;
56 #    warn "Processing $file\n";
57
58     local *FH;
59     if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
60         unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
61             warn "Cannot open '$file'";
62             return;
63         }     
64     } elsif ($Config{gccversion} ne '' && $^O ne 'darwin' ) {
65         # With the -dM option, gcc outputs every #define it finds
66         unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
67             warn "Cannot open '$file'";
68             return;
69         }     
70     } else {
71         unless(open(FH,"< $file")) {
72             # This file could be a temporary file created by cppstdin
73             # so only warn under -w, and return
74             warn "Cannot open '$file'" if $^W;
75             return;
76         }
77     }
78     
79     while(<FH>) {
80         $err{$1} = 1
81             if /^\s*#\s*define\s+(E\w+)\s+/;
82     }
83
84     close(FH);
85 }
86
87 my $cppstdin;
88
89 sub default_cpp {
90     unless (defined $cppstdin) {
91         use File::Spec;
92         $cppstdin = $Config{cppstdin};
93         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
94                                                 File::Spec->updir,
95                                                 "cppstdin");
96         my $cppstdin_is_wrapper =
97             ($cppstdin eq 'cppstdin'
98                 and -f $upup_cppstdin
99                     and -x $upup_cppstdin);
100         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
101     }
102     return "$cppstdin $Config{cppflags} $Config{cppminus}";
103 }
104
105 sub get_files {
106     my %file = ();
107     # VMS keeps its include files in system libraries
108     if ($^O eq 'VMS') {
109         $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
110     } elsif ($^O eq 'os390') {
111         # OS/390 C compiler doesn't generate #file or #line directives
112         $file{'/usr/include/errno.h'} = 1;
113     } elsif ($Config{archname} eq 'arm-riscos') {
114         # Watch out for cross compiling for RISC OS
115         my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
116         if ($dep =~ /(\S+errno\.h)/) {
117              $file{$1} = 1;
118         }
119     } elsif ($^O eq 'linux' &&
120               $Config{gccversion} ne '' && 
121               $Config{gccversion} !~ /intel/i
122               # might be using, say, Intel's icc
123              ) {
124     # When cross-compiling we may store a path for gcc's "sysroot" option:
125     my $sysroot = $Config{sysroot} || '';
126         # Some Linuxes have weird errno.hs which generate
127         # no #file or #line directives
128         my ($linux_errno_h) = grep { -e $_ } map { "$_/errno.h" }
129             "$sysroot/usr/include", "$sysroot/usr/local/include",
130             split / / => $Config{locincpth} or
131                 die "Cannot find errno.h";
132         $file{$linux_errno_h} = 1;
133     } elsif ($^O eq 'haiku') {
134         # hidden in a special place
135         $file{'/boot/develop/headers/posix/errno.h'} = 1;
136
137     } elsif ($^O eq 'vos') {
138         # avoid problem where cpp returns non-POSIX pathnames
139         $file{'/system/include_library/errno.h'} = 1;
140     } elsif ($IsSymbian) {
141         my $SDK = $ENV{SDK};
142         $SDK =~ s!\\!/!g;
143         $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1;
144     } else {
145         open(CPPI,"> errno.c") or
146             die "Cannot open errno.c";
147
148         if ($^O eq 'NetWare') {
149             print CPPI "#include <nwerrno.h>\n";
150         } else {
151             print CPPI "#include <errno.h>\n";
152             if ($IsMSWin32) {
153                 print CPPI qq[#include "../../win32/include/sys/errno2.h"\n];
154             }
155         }
156
157         close(CPPI);
158
159         # invoke CPP and read the output
160         if ($IsMSWin32 || $^O eq 'NetWare') {
161             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
162                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
163         } else {
164             my $cpp = default_cpp();
165             open(CPPO,"$cpp < errno.c |") or
166                 die "Cannot exec $cpp";
167         }
168
169         my $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
170         while(<CPPO>) {
171             if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') {
172                 if (/$pat/o) {
173                    my $f = $1;
174                    $f =~ s,\\\\,/,g;
175                    $file{$f} = 1;
176                 }
177             }
178             else {
179                 $file{$1} = 1 if /$pat/o;
180             }
181         }
182         close(CPPO);
183     }
184     return keys %file;
185 }
186
187 sub write_errno_pm {
188     my $err;
189
190     # quick sanity check
191
192     die "No error definitions found" unless keys %err;
193
194     # create the CPP input
195
196     open(CPPI,"> errno.c") or
197         die "Cannot open errno.c";
198
199     if ($^O eq 'NetWare') {
200         print CPPI "#include <nwerrno.h>\n";
201         } 
202     else {
203         print CPPI "#include <errno.h>\n";
204     }
205     if ($IsMSWin32) {
206         print CPPI qq[#include "../../win32/include/sys/errno2.h"\n];
207     }
208  
209     foreach $err (keys %err) {
210         print CPPI '"',$err,'" [[',$err,']]',"\n";
211     }
212
213     close(CPPI);
214
215     {   # BeOS (support now removed) did not enter this block
216     # invoke CPP and read the output
217
218         my $inhibit_linemarkers = '';
219         if ($Config{gccversion} =~ /\A(\d+)\./ and $1 >= 5) {
220             # GCC 5.0 interleaves expanded macros with line numbers breaking
221             # each line into multiple lines. RT#123784
222             $inhibit_linemarkers = ' -P';
223         }
224
225         if ($^O eq 'VMS') {
226             my $cpp = "$Config{cppstdin} $Config{cppflags}" .
227                 $inhibit_linemarkers . " $Config{cppminus}";
228             $cpp =~ s/sys\$input//i;
229             open(CPPO,"$cpp  errno.c |") or
230                 die "Cannot exec $Config{cppstdin}";
231         } elsif ($IsMSWin32 || $^O eq 'NetWare') {
232             my $cpp = "$Config{cpprun} $Config{cppflags}" .
233                 $inhibit_linemarkers;
234             open(CPPO,"$cpp errno.c |") or
235                 die "Cannot run '$cpp errno.c'";
236         } elsif ($IsSymbian) {
237             my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc" .
238                 $inhibit_linemarkers ." -";
239             open(CPPO,"$cpp < errno.c |")
240                 or die "Cannot exec $cpp";
241         } else {
242             my $cpp = default_cpp() . $inhibit_linemarkers;
243             open(CPPO,"$cpp < errno.c |")
244                 or die "Cannot exec $cpp";
245         }
246
247         %err = ();
248
249         while(<CPPO>) {
250             my($name,$expr);
251             next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
252             next if $name eq $expr;
253             $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)\(?([^\)]+)\)?\)?/$1/i; # ((type)0xcafebabe) at alia
254             $expr =~ s/\b((?:0x)?[0-9a-f]+)[LU]+\b/$1/gi; # 2147483647L et alia
255             next if $expr =~ m/\b[a-z_]\w*\b/i; # skip expressions containing function names etc
256             if($expr =~ m/^0[xX]/) {
257                 $err{$name} = hex $expr;
258             }
259             else {
260                 $err{$name} = eval $expr;
261             }
262             delete $err{$name} unless defined $err{$name};
263         }
264         close(CPPO);
265     }
266
267     # escape $Config{'archname'}
268     my $archname = $Config{'archname'};
269     $archname =~ s/([@%\$])/\\$1/g;
270
271     # Write Errno.pm
272
273     print <<"EDQ";
274 # -*- buffer-read-only: t -*-
275 #
276 # This file is auto-generated. ***ANY*** changes here will be lost
277 #
278
279 package Errno;
280 require Exporter;
281 use Config;
282 use strict;
283
284 "\$Config{'archname'}-\$Config{'osvers'}" eq
285 "$archname-$Config{'osvers'}" or
286         die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
287
288 our \$VERSION = "$VERSION";
289 \$VERSION = eval \$VERSION;
290 our \@ISA = 'Exporter';
291
292 my %err;
293
294 BEGIN {
295     %err = (
296 EDQ
297
298     my @err = sort { $err{$a} <=> $err{$b} || $a cmp $b }
299         grep { $err{$_} =~ /-?\d+$/ } keys %err;
300
301     foreach $err (@err) {
302         print "\t$err => $err{$err},\n";
303     }
304
305 print <<'ESQ';
306     );
307     # Generate proxy constant subroutines for all the values.
308     # Well, almost all the values. Unfortunately we can't assume that at this
309     # point that our symbol table is empty, as code such as if the parser has
310     # seen code such as C<exists &Errno::EINVAL>, it will have created the
311     # typeglob.
312     # Doing this before defining @EXPORT_OK etc means that even if a platform is
313     # crazy enough to define EXPORT_OK as an error constant, everything will
314     # still work, because the parser will upgrade the PCS to a real typeglob.
315     # We rely on the subroutine definitions below to update the internal caches.
316     # Don't use %each, as we don't want a copy of the value.
317     foreach my $name (keys %err) {
318         if ($Errno::{$name}) {
319             # We expect this to be reached fairly rarely, so take an approach
320             # which uses the least compile time effort in the common case:
321             eval "sub $name() { $err{$name} }; 1" or die $@;
322         } else {
323             $Errno::{$name} = \$err{$name};
324         }
325     }
326 }
327
328 our @EXPORT_OK = keys %err;
329
330 our %EXPORT_TAGS = (
331     POSIX => [qw(
332 ESQ
333
334     my $k = join(" ", grep { exists $err{$_} } 
335         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
336         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
337         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
338         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
339         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
340         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
341         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
342         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
343         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
344         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
345         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
346         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
347         EUSERS EWOULDBLOCK EXDEV));
348
349     $k =~ s/(.{50,70})\s/$1\n\t/g;
350     print "\t",$k,"\n    )]\n);\n\n";
351
352     print <<'ESQ';
353 sub TIEHASH { bless \%err }
354
355 sub FETCH {
356     my (undef, $errname) = @_;
357     return "" unless exists $err{$errname};
358     my $errno = $err{$errname};
359     return $errno == $! ? $errno : 0;
360 }
361
362 sub STORE {
363     require Carp;
364     Carp::confess("ERRNO hash is read only!");
365 }
366
367 *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
368
369 sub NEXTKEY {
370     each %err;
371 }
372
373 sub FIRSTKEY {
374     my $s = scalar keys %err;   # initialize iterator
375     each %err;
376 }
377
378 sub EXISTS {
379     my (undef, $errname) = @_;
380     exists $err{$errname};
381 }
382
383 tie %!, __PACKAGE__; # Returns an object, objects are true.
384
385 __END__
386
387 =head1 NAME
388
389 Errno - System errno constants
390
391 =head1 SYNOPSIS
392
393     use Errno qw(EINTR EIO :POSIX);
394
395 =head1 DESCRIPTION
396
397 C<Errno> defines and conditionally exports all the error constants
398 defined in your system C<errno.h> include file. It has a single export
399 tag, C<:POSIX>, which will export all POSIX defined error numbers.
400
401 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
402 non-zero value only if C<$!> is set to that value. For example:
403
404     use Errno;
405
406     unless (open(FH, "/fangorn/spouse")) {
407         if ($!{ENOENT}) {
408             warn "Get a wife!\n";
409         } else {
410             warn "This path is barred: $!";
411         } 
412     } 
413
414 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
415 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
416 constant is available on the system.
417
418 =head1 CAVEATS
419
420 Importing a particular constant may not be very portable, because the
421 import will fail on platforms that do not have that constant.  A more
422 portable way to set C<$!> to a valid value is to use:
423
424     if (exists &Errno::EFOO) {
425         $! = &Errno::EFOO;
426     }
427
428 =head1 AUTHOR
429
430 Graham Barr <gbarr@pobox.com>
431
432 =head1 COPYRIGHT
433
434 Copyright (c) 1997-8 Graham Barr. All rights reserved.
435 This program is free software; you can redistribute it and/or modify it
436 under the same terms as Perl itself.
437
438 =cut
439
440 # ex: set ro:
441 ESQ
442
443 }