This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate mainline changes
[perl5.git] / ext / Errno / Errno_pm.PL
1 use ExtUtils::MakeMaker;
2 use Config;
3 use strict;
4
5 use vars qw($VERSION);
6
7 $VERSION = "1.111";
8
9 my %err = ();
10
11 unlink "Errno.pm" if -f "Errno.pm";
12 open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
13 select OUT;
14 my $file;
15 foreach $file (get_files()) {
16     process_file($file);
17 }
18 write_errno_pm();
19 unlink "errno.c" if -f "errno.c";
20
21 sub process_file {
22     my($file) = @_;
23
24     return unless defined $file and -f $file;
25
26     local *FH;
27     if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
28         unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
29             warn "Cannot open '$file'";
30             return;
31         }     
32     } else {
33         unless(open(FH,"< $file")) {
34             # This file could be a temporary file created by cppstdin
35             # so only warn under -w, and return
36             warn "Cannot open '$file'" if $^W;
37             return;
38         }
39     }
40     while(<FH>) {
41         $err{$1} = 1
42             if /^\s*#\s*define\s+(E\w+)\s+/;
43    }
44    close(FH);
45 }
46
47 my $cppstdin;
48
49 sub default_cpp {
50     unless (defined $cppstdin) {
51         use File::Spec;
52         $cppstdin = $Config{cppstdin};
53         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
54                                                 File::Spec->updir,
55                                                 "cppstdin");
56         my $cppstdin_is_wrapper =
57             ($cppstdin eq 'cppstdin'
58                 and -f $upup_cppstdin
59                     and -x $upup_cppstdin);
60         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
61     }
62     return "$cppstdin $Config{cppflags} $Config{cppminus}";
63 }
64
65 sub get_files {
66     my %file = ();
67     # VMS keeps its include files in system libraries (well, except for Gcc)
68     if ($^O eq 'VMS') {
69         if ($Config{vms_cc_type} eq 'decc') {
70             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
71         } elsif ($Config{vms_cc_type} eq 'vaxc') {
72             $file{'Sys$Library:vaxcdef.tlb'} = 1;
73         } elsif ($Config{vms_cc_type} eq 'gcc') {
74             $file{'gnu_cc_include:[000000]errno.h'} = 1;
75         }
76     } elsif ($^O eq 'os390') {
77         # OS/390 C compiler doesn't generate #file or #line directives
78         $file{'/usr/include/errno.h'} = 1;
79     } elsif ($^O eq 'vmesa') {
80         # OS/390 C compiler doesn't generate #file or #line directives
81         $file{'../../vmesa/errno.h'} = 1;
82     } else {
83         open(CPPI,"> errno.c") or
84             die "Cannot open errno.c";
85
86         print CPPI "#include <errno.h>\n";
87
88         close(CPPI);
89
90         # invoke CPP and read the output
91         if ($^O eq 'MSWin32') {
92             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
93                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
94         } else {
95             my $cpp = default_cpp();
96             open(CPPO,"$cpp < errno.c |") or
97                 die "Cannot exec $cpp";
98         }
99
100         my $pat;
101         if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
102             $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
103         }
104         else {
105             $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
106         }
107         while(<CPPO>) {
108             if ($^O eq 'os2' or $^O eq 'MSWin32') {
109                 if (/$pat/o) {
110                    my $f = $1;
111                    $f =~ s,\\\\,/,g;
112                    $file{$f} = 1;
113                 }
114             }
115             else {
116                 $file{$1} = 1 if /$pat/o;
117             }
118         }
119         close(CPPO);
120     }
121     return keys %file;
122 }
123
124 sub write_errno_pm {
125     my $err;
126
127     # quick sanity check
128
129     die "No error definitions found" unless keys %err;
130
131     # create the CPP input
132
133     open(CPPI,"> errno.c") or
134         die "Cannot open errno.c";
135
136     print CPPI "#include <errno.h>\n";
137
138     foreach $err (keys %err) {
139         print CPPI '"',$err,'" [[',$err,']]',"\n";
140     }
141
142     close(CPPI);
143
144     # invoke CPP and read the output
145
146     if ($^O eq 'VMS') {
147         my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
148         $cpp =~ s/sys\$input//i;
149         open(CPPO,"$cpp  errno.c |") or
150           die "Cannot exec $Config{cppstdin}";
151     } elsif ($^O eq 'MSWin32') {
152         open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
153             die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
154     } else {
155         my $cpp = default_cpp();
156         open(CPPO,"$cpp < errno.c |")
157             or die "Cannot exec $cpp";
158     }
159
160     %err = ();
161
162     while(<CPPO>) {
163         my($name,$expr);
164         next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
165         next if $name eq $expr;
166         $err{$name} = eval $expr;
167     }
168     close(CPPO);
169
170     # Write Errno.pm
171
172     print <<"EDQ";
173 #
174 # This file is auto-generated. ***ANY*** changes here will be lost
175 #
176
177 package Errno;
178 use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
179 use Exporter ();
180 use Config;
181 use strict;
182
183 "\$Config{'archname'}-\$Config{'osvers'}" eq
184 "$Config{'archname'}-$Config{'osvers'}" or
185         die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
186
187 \$VERSION = "$VERSION";
188 \@ISA = qw(Exporter);
189
190 EDQ
191    
192     my $len = 0;
193     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
194     map { $len = length if length > $len } @err;
195
196     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
197     $j =~ s/(.{50,70})\s/$1\n\t/g;
198     print $j,"\n";
199
200 print <<'ESQ';
201 %EXPORT_TAGS = (
202     POSIX => [qw(
203 ESQ
204
205     my $k = join(" ", grep { exists $err{$_} } 
206         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
207         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
208         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
209         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
210         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
211         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
212         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
213         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
214         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
215         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
216         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
217         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
218         EUSERS EWOULDBLOCK EXDEV));
219
220     $k =~ s/(.{50,70})\s/$1\n\t/g;
221     print "\t",$k,"\n    )]\n);\n\n";
222
223     foreach $err (@err) {
224         printf "sub %s () { %d }\n",,$err,$err{$err};
225     }
226
227     print <<'ESQ';
228
229 sub TIEHASH { bless [] }
230
231 sub FETCH {
232     my ($self, $errname) = @_;
233     my $proto = prototype("Errno::$errname");
234     if (defined($proto) && $proto eq "") {
235         no strict 'refs';
236         return $! == &$errname;
237     }
238     require Carp;
239     Carp::confess("No errno $errname");
240
241
242 sub STORE {
243     require Carp;
244     Carp::confess("ERRNO hash is read only!");
245 }
246
247 *CLEAR = \&STORE;
248 *DELETE = \&STORE;
249
250 sub NEXTKEY {
251     my($k,$v);
252     while(($k,$v) = each %Errno::) {
253         my $proto = prototype("Errno::$k");
254         last if (defined($proto) && $proto eq "");
255         
256     }
257     $k
258 }
259
260 sub FIRSTKEY {
261     my $s = scalar keys %Errno::;
262     goto &NEXTKEY;
263 }
264
265 sub EXISTS {
266     my ($self, $errname) = @_;
267     my $proto = prototype($errname);
268     defined($proto) && $proto eq "";
269 }
270
271 tie %!, __PACKAGE__;
272
273 1;
274 __END__
275
276 =head1 NAME
277
278 Errno - System errno constants
279
280 =head1 SYNOPSIS
281
282     use Errno qw(EINTR EIO :POSIX);
283
284 =head1 DESCRIPTION
285
286 C<Errno> defines and conditionally exports all the error constants
287 defined in your system C<errno.h> include file. It has a single export
288 tag, C<:POSIX>, which will export all POSIX defined error numbers.
289
290 C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
291 value only if C<$!> is set to that value, eg
292
293     use Errno;
294     
295     unless (open(FH, "/fangorn/spouse")) {
296         if ($!{ENOENT}) {
297             warn "Get a wife!\n";
298         } else {
299             warn "This path is barred: $!";
300         } 
301     } 
302
303 =head1 AUTHOR
304
305 Graham Barr <gbarr@pobox.com>
306
307 =head1 COPYRIGHT
308
309 Copyright (c) 1997-8 Graham Barr. All rights reserved.
310 This program is free software; you can redistribute it and/or modify it
311 under the same terms as Perl itself.
312
313 =cut
314
315 ESQ
316
317 }