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