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