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