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