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 }