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