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 }