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