This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix small memleak on -e, don't try to find_script() when e_script
[perl5.git] / ext / Errno / Errno_pm.PL
CommitLineData
eab60bb1
GS
1#!perl
2use ExtUtils::MakeMaker;
3use Config;
4use strict;
5
6use vars qw($VERSION);
7
8$VERSION = "1.08";
9
10my %err = ();
11
12unlink "Errno.pm" if -f "Errno.pm";
13open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
14select OUT;
15my $file;
16foreach $file (get_files()) {
17 process_file($file);
18}
19write_errno_pm();
20unlink "errno.c" if -f "errno.c";
21
22sub 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
76287dce 41 if /^\s*#\s*define\s+(E\w+)\s+/;
eab60bb1
GS
42 }
43 close(FH);
44}
45
46sub 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 {
76287dce 75 $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
eab60bb1
GS
76 }
77 while(<CPPO>) {
78 $file{$1} = 1 if /$pat/o;
79 }
80 close(CPPO);
81 }
82 return keys %file;
83}
84
85sub 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}";
76287dce
HM
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";
eab60bb1
GS
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
132package Errno;
133use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
134use Exporter ();
135use Config;
136use 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
144EDQ
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
154print <<'ESQ';
155%EXPORT_TAGS = (
156 POSIX => [qw(
157ESQ
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
183sub TIEHASH { bless [] }
184
185sub 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
196sub STORE {
197 require Carp;
198 Carp::confess("ERRNO hash is read only!");
199}
200
201*CLEAR = \&STORE;
202*DELETE = \&STORE;
203
204sub 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
214sub FIRSTKEY {
215 my $s = scalar keys %Errno::;
216 goto &NEXTKEY;
217}
218
219sub EXISTS {
220 my ($self, $errname) = @_;
221 my $proto = prototype($errname);
222 defined($proto) && $proto eq "";
223}
224
225tie %!, __PACKAGE__;
226
2271;
228__END__
229
230=head1 NAME
231
232Errno - System errno constants
233
234=head1 SYNOPSIS
235
236 use Errno qw(EINTR EIO :POSIX);
237
238=head1 DESCRIPTION
239
240C<Errno> defines and conditionally exports all the error constants
241defined in your system C<errno.h> include file. It has a single export
242tag, C<:POSIX>, which will export all POSIX defined error numbers.
243
244C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
245value 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
259Graham Barr <gbarr@pobox.com>
260
261=head1 COPYRIGHT
262
263Copyright (c) 1997-8 Graham Barr. All rights reserved.
264This program is free software; you can redistribute it and/or modify it
265under the same terms as Perl itself.
266
267=cut
268
269ESQ
270
271}