This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
124b8fc8b46ec9e0d117ba89595582bde0f257b5
[perl5.git] / ext / Errno / Errno_pm.PL
1 use ExtUtils::MakeMaker;
2 use Config;
3 use strict;
4
5 our $VERSION = "1.11";
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,\%errno,\$AUTOLOAD);
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 $len = 0;
358     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
359     map { $len = length if length > $len } @err;
360
361     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
362     $j =~ s/(.{50,70})\s/$1\n\t/g;
363     print $j,"\n";
364
365 print <<'ESQ';
366 %EXPORT_TAGS = (
367     POSIX => [qw(
368 ESQ
369
370     my $k = join(" ", grep { exists $err{$_} } 
371         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
372         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
373         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
374         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
375         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
376         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
377         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
378         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
379         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
380         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
381         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
382         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
383         EUSERS EWOULDBLOCK EXDEV));
384
385     $k =~ s/(.{50,70})\s/$1\n\t/g;
386     print "\t",$k,"\n    )]\n);\n\n";
387
388     foreach $err (@err) {
389         printf "sub %s () { %d }\n",,$err,$err{$err};
390     }
391
392     print <<'ESQ';
393
394 sub TIEHASH { bless [] }
395
396 sub FETCH {
397     my ($self, $errname) = @_;
398     my $proto = prototype("Errno::$errname");
399     my $errno = "";
400     if (defined($proto) && $proto eq "") {
401         no strict 'refs';
402         $errno = &$errname;
403         $errno = 0 unless $! == $errno;
404     }
405     return $errno;
406 }
407
408 sub STORE {
409     require Carp;
410     Carp::confess("ERRNO hash is read only!");
411 }
412
413 *CLEAR = \&STORE;
414 *DELETE = \&STORE;
415
416 sub NEXTKEY {
417     my($k,$v);
418     while(($k,$v) = each %Errno::) {
419         my $proto = prototype("Errno::$k");
420         last if (defined($proto) && $proto eq "");
421     }
422     $k
423 }
424
425 sub FIRSTKEY {
426     my $s = scalar keys %Errno::;       # initialize iterator
427     goto &NEXTKEY;
428 }
429
430 sub EXISTS {
431     my ($self, $errname) = @_;
432     my $r = ref $errname;
433     my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef;
434     defined($proto) && $proto eq "";
435 }
436
437 tie %!, __PACKAGE__;
438
439 1;
440 __END__
441
442 =head1 NAME
443
444 Errno - System errno constants
445
446 =head1 SYNOPSIS
447
448     use Errno qw(EINTR EIO :POSIX);
449
450 =head1 DESCRIPTION
451
452 C<Errno> defines and conditionally exports all the error constants
453 defined in your system C<errno.h> include file. It has a single export
454 tag, C<:POSIX>, which will export all POSIX defined error numbers.
455
456 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
457 non-zero value only if C<$!> is set to that value. For example:
458
459     use Errno;
460
461     unless (open(FH, "/fangorn/spouse")) {
462         if ($!{ENOENT}) {
463             warn "Get a wife!\n";
464         } else {
465             warn "This path is barred: $!";
466         } 
467     } 
468
469 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
470 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
471 constant is available on the system.
472
473 =head1 CAVEATS
474
475 Importing a particular constant may not be very portable, because the
476 import will fail on platforms that do not have that constant.  A more
477 portable way to set C<$!> to a valid value is to use:
478
479     if (exists &Errno::EFOO) {
480         $! = &Errno::EFOO;
481     }
482
483 =head1 AUTHOR
484
485 Graham Barr <gbarr@pobox.com>
486
487 =head1 COPYRIGHT
488
489 Copyright (c) 1997-8 Graham Barr. All rights reserved.
490 This program is free software; you can redistribute it and/or modify it
491 under the same terms as Perl itself.
492
493 =cut
494
495 ESQ
496
497 }