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