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