This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b865b7c77e36032a2769b3bab8ca740db0a9df26
[perl5.git] / ext / Errno / Errno_pm.PL
1 use ExtUtils::MakeMaker;
2 use Config;
3 use strict;
4
5 our $VERSION = "1.12";
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     if ($^O eq 'MacOS') {
85         while(<FH>) {
86             $err{$1} = $2
87                 if /^\s*#\s*define\s+(E\w+)\s+(\d+)/;
88         }
89     } else {
90         while(<FH>) {
91             $err{$1} = 1
92                 if /^\s*#\s*define\s+(E\w+)\s+/;
93             if ($IsMSWin32) {
94                 $wsa{$1} = 1
95                     if /^\s*#\s*define\s+WSA(E\w+)\s+/;
96             }
97         }
98     }
99
100     close(FH);
101 }
102
103 my $cppstdin;
104
105 sub default_cpp {
106     unless (defined $cppstdin) {
107         use File::Spec;
108         $cppstdin = $Config{cppstdin};
109         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
110                                                 File::Spec->updir,
111                                                 "cppstdin");
112         my $cppstdin_is_wrapper =
113             ($cppstdin eq 'cppstdin'
114                 and -f $upup_cppstdin
115                     and -x $upup_cppstdin);
116         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
117     }
118     return "$cppstdin $Config{cppflags} $Config{cppminus}";
119 }
120
121 sub get_files {
122     my %file = ();
123     # VMS keeps its include files in system libraries (well, except for Gcc)
124     if ($^O eq 'VMS') {
125         if ($Config{vms_cc_type} eq 'decc') {
126             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
127         } elsif ($Config{vms_cc_type} eq 'vaxc') {
128             $file{'Sys$Library:vaxcdef.tlb'} = 1;
129         } elsif ($Config{vms_cc_type} eq 'gcc') {
130             $file{'gnu_cc_include:[000000]errno.h'} = 1;
131         }
132     } elsif ($^O eq 'os390') {
133         # OS/390 C compiler doesn't generate #file or #line directives
134         $file{'/usr/include/errno.h'} = 1;
135     } elsif ($^O eq 'vmesa') {
136         # OS/390 C compiler doesn't generate #file or #line directives
137         $file{'../../vmesa/errno.h'} = 1;
138     } elsif ($Config{archname} eq 'epoc') {
139         # Watch out for cross compiling for EPOC (usually done on linux)
140         $file{'/usr/local/epocemx/epocsdk/include/libc/sys/errno.h'} = 1;
141     } elsif ($Config{archname} eq 'arm-riscos') {
142         # Watch out for cross compiling for RISC OS
143         my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
144         if ($dep =~ /(\S+errno\.h)/) {
145              $file{$1} = 1;
146         }
147     } elsif ($^O eq 'linux' &&
148               $Config{gccversion} ne '' && 
149               $Config{gccversion} !~ /intel/i
150               # might be using, say, Intel's icc
151              ) {
152         # Some Linuxes have weird errno.hs which generate
153         # no #file or #line directives
154         my $linux_errno_h = -e '/usr/include/errno.h' ?
155             '/usr/include/errno.h' : '/usr/local/include/errno.h';
156         $file{$linux_errno_h} = 1;
157     } elsif ($^O eq 'MacOS') {
158         # note that we are only getting the GUSI errno's here ...
159         # we might miss out on compiler-specific ones
160         $file{"$ENV{GUSI}include:sys:errno.h"} = 1;
161
162     } elsif ($^O eq 'beos' || $^O eq 'haiku') {
163         # hidden in a special place
164         $file{'/boot/develop/headers/posix/errno.h'} = 1;
165
166     } elsif ($^O eq 'vos') {
167         # avoid problem where cpp returns non-POSIX pathnames
168         $file{'/system/include_library/errno.h'} = 1;
169     } elsif ($IsSymbian) {
170         my $SDK = $ENV{SDK};
171         $SDK =~ s!\\!/!g;
172         $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1;
173     } else {
174         open(CPPI,"> errno.c") or
175             die "Cannot open errno.c";
176
177         if ($^O eq 'NetWare') {
178             print CPPI "#include <nwerrno.h>\n";
179         } else {
180             print CPPI "#include <errno.h>\n";
181             if ($IsMSWin32) {
182                 print CPPI "#define _WINSOCKAPI_\n"; # don't drag in everything
183                 print CPPI "#include <winsock.h>\n";
184             }
185         }
186
187         close(CPPI);
188
189         # invoke CPP and read the output
190         if ($IsMSWin32 || $^O eq 'NetWare') {
191             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
192                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
193         } else {
194             my $cpp = default_cpp();
195             open(CPPO,"$cpp < errno.c |") or
196                 die "Cannot exec $cpp";
197         }
198
199         my $pat;
200         if (($IsMSWin32 || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) {
201             $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
202         }
203         else {
204             $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
205         }
206         while(<CPPO>) {
207             if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') {
208                 if (/$pat/o) {
209                    my $f = $1;
210                    $f =~ s,\\\\,/,g;
211                    $file{$f} = 1;
212                 }
213             }
214             else {
215                 $file{$1} = 1 if /$pat/o;
216             }
217         }
218         close(CPPO);
219     }
220     return keys %file;
221 }
222
223 sub write_errno_pm {
224     my $err;
225
226     # quick sanity check
227
228     die "No error definitions found" unless keys %err;
229
230     # create the CPP input
231
232     open(CPPI,"> errno.c") or
233         die "Cannot open errno.c";
234
235     if ($^O eq 'NetWare') {
236         print CPPI "#include <nwerrno.h>\n";
237         } 
238     else {
239         print CPPI "#include <errno.h>\n";
240     }
241     if ($IsMSWin32) {
242         print CPPI "#include <winsock.h>\n";
243         foreach $err (keys %wsa) {
244             print CPPI "#ifndef $err\n";
245             print CPPI "#define $err WSA$err\n";
246             print CPPI "#endif\n";
247             $err{$err} = 1;
248         }
249     }
250  
251     foreach $err (keys %err) {
252         print CPPI '"',$err,'" [[',$err,']]',"\n";
253     }
254
255     close(CPPI);
256
257     unless ($^O eq 'MacOS' || $^O eq 'beos') {  # trust what we have / get later
258     # invoke CPP and read the output
259
260         if ($^O eq 'VMS') {
261             my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
262             $cpp =~ s/sys\$input//i;
263             open(CPPO,"$cpp  errno.c |") or
264                 die "Cannot exec $Config{cppstdin}";
265         } elsif ($IsMSWin32 || $^O eq 'NetWare') {
266             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
267                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
268         } elsif ($IsSymbian) {
269             my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc -";
270             open(CPPO,"$cpp < errno.c |")
271                 or die "Cannot exec $cpp";
272         } else {
273             my $cpp = default_cpp();
274             open(CPPO,"$cpp < errno.c |")
275                 or die "Cannot exec $cpp";
276         }
277
278         %err = ();
279
280         while(<CPPO>) {
281             my($name,$expr);
282             next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
283             next if $name eq $expr;
284             $expr =~ s/\(?\([a-z_]\w*\)([^\)]*)\)?/$1/i; # ((type)0xcafebabe) at alia
285             $expr =~ s/((?:0x)?[0-9a-fA-F]+)[LU]+\b/$1/g; # 2147483647L et alia
286             next if $expr =~ m/^[a-zA-Z]+$/; # skip some Win32 functions
287             if($expr =~ m/^0[xX]/) {
288                 $err{$name} = hex $expr;
289             }
290             else {
291             $err{$name} = eval $expr;
292         }
293             delete $err{$name} unless defined $err{$name};
294         }
295         close(CPPO);
296     }
297
298     # Many of the E constants (including ENOENT, which is being
299     # used in the Perl test suite a lot), are available only as
300     # enums in BeOS, so compiling and executing some code is about
301     # only way to find out what the numeric Evalues are. In fact above, we
302     # didn't even bother to get the values of the ones that have numeric
303     # values, since we can get all of them here, anyway.
304
305     if ($^O eq 'beos') {
306         if (open(C, ">errno.c")) {
307             my @allerrs = keys %err;
308             print C <<EOF;
309 #include <errno.h>
310 #include <stdio.h>
311 int main() {
312 EOF
313             for (@allerrs) {
314                 print C qq[printf("$_ %d\n", $_);]
315             }
316             print C "}\n";
317             close C;
318             system("cc -o errno errno.c");
319             unlink("errno.c");
320             if (open(C, "./errno|")) {
321                 while (<C>) {
322                     if (/^(\w+) (-?\d+)$/) { $err{$1} = $2 }
323                 }
324                 close(C);
325             } else {
326                 die "failed to execute ./errno: $!\n";
327             }
328             unlink("errno");
329         } else {
330             die "failed to create errno.c: $!\n";
331         }
332     }
333
334     # Write Errno.pm
335
336     print <<"EDQ";
337 #
338 # This file is auto-generated. ***ANY*** changes here will be lost
339 #
340
341 package Errno;
342 our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION);
343 use Exporter ();
344 use Config;
345 use strict;
346
347 "\$Config{'archname'}-\$Config{'osvers'}" eq
348 "$Config{'archname'}-$Config{'osvers'}" or
349         die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
350
351 \$VERSION = "$VERSION";
352 \$VERSION = eval \$VERSION;
353 \@ISA = qw(Exporter);
354
355 EDQ
356    
357     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
358
359     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
360     $j =~ s/(.{50,70})\s/$1\n\t/g;
361     print $j,"\n";
362
363 print <<'ESQ';
364 %EXPORT_TAGS = (
365     POSIX => [qw(
366 ESQ
367
368     my $k = join(" ", grep { exists $err{$_} } 
369         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
370         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
371         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
372         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
373         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
374         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
375         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
376         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
377         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
378         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
379         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
380         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
381         EUSERS EWOULDBLOCK EXDEV));
382
383     $k =~ s/(.{50,70})\s/$1\n\t/g;
384     print "\t",$k,"\n    )]\n);\n\n";
385
386     foreach $err (@err) {
387         printf "sub %s () { %d }\n",,$err,$err{$err};
388     }
389
390     print <<'ESQ';
391
392 sub TIEHASH { bless [] }
393
394 sub FETCH {
395     my ($self, $errname) = @_;
396     my $proto = prototype("Errno::$errname");
397     my $errno = "";
398     if (defined($proto) && $proto eq "") {
399         no strict 'refs';
400         $errno = &$errname;
401         $errno = 0 unless $! == $errno;
402     }
403     return $errno;
404 }
405
406 sub STORE {
407     require Carp;
408     Carp::confess("ERRNO hash is read only!");
409 }
410
411 *CLEAR = \&STORE;
412 *DELETE = \&STORE;
413
414 sub NEXTKEY {
415     my($k,$v);
416     while(($k,$v) = each %Errno::) {
417         my $proto = prototype("Errno::$k");
418         last if (defined($proto) && $proto eq "");
419     }
420     $k
421 }
422
423 sub FIRSTKEY {
424     my $s = scalar keys %Errno::;       # initialize iterator
425     goto &NEXTKEY;
426 }
427
428 sub EXISTS {
429     my ($self, $errname) = @_;
430     my $r = ref $errname;
431     my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef;
432     defined($proto) && $proto eq "";
433 }
434
435 tie %!, __PACKAGE__;
436
437 1;
438 __END__
439
440 =head1 NAME
441
442 Errno - System errno constants
443
444 =head1 SYNOPSIS
445
446     use Errno qw(EINTR EIO :POSIX);
447
448 =head1 DESCRIPTION
449
450 C<Errno> defines and conditionally exports all the error constants
451 defined in your system C<errno.h> include file. It has a single export
452 tag, C<:POSIX>, which will export all POSIX defined error numbers.
453
454 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
455 non-zero value only if C<$!> is set to that value. For example:
456
457     use Errno;
458
459     unless (open(FH, "/fangorn/spouse")) {
460         if ($!{ENOENT}) {
461             warn "Get a wife!\n";
462         } else {
463             warn "This path is barred: $!";
464         } 
465     } 
466
467 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
468 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
469 constant is available on the system.
470
471 =head1 CAVEATS
472
473 Importing a particular constant may not be very portable, because the
474 import will fail on platforms that do not have that constant.  A more
475 portable way to set C<$!> to a valid value is to use:
476
477     if (exists &Errno::EFOO) {
478         $! = &Errno::EFOO;
479     }
480
481 =head1 AUTHOR
482
483 Graham Barr <gbarr@pobox.com>
484
485 =head1 COPYRIGHT
486
487 Copyright (c) 1997-8 Graham Barr. All rights reserved.
488 This program is free software; you can redistribute it and/or modify it
489 under the same terms as Perl itself.
490
491 =cut
492
493 ESQ
494
495 }