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