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.111";
   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             # This file could be a temporay file created by cppstdin
  35             # so only warn under -w, and return
  36             warn "Cannot open '$file'" if $^W;
  37             return;
  38         }
  39     }
  40     while(<FH>) {
  41         $err{$1} = 1
  42             if /^\s*#\s*define\s+(E\w+)\s+/;
  43    }
  44    close(FH);
  45 }
  46
  47 sub get_files {
  48     my %file = ();
  49     # VMS keeps its include files in system libraries (well, except for Gcc)
  50     if ($^O eq 'VMS') {
  51         if ($Config{vms_cc_type} eq 'decc') {
  52             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
  53         } elsif ($Config{vms_cc_type} eq 'vaxc') {
  54             $file{'Sys$Library:vaxcdef.tlb'} = 1;
  55         } elsif ($Config{vms_cc_type} eq 'gcc') {
  56             $file{'gnu_cc_include:[000000]errno.h'} = 1;
  57         }
  58     } elsif ($^O eq 'os390') {
  59         # OS/390 C compiler doesn't generate #file or #line directives
  60         $file{'/usr/include/errno.h'} = 1;
  61     } else {
  62         open(CPPI,"> errno.c") or
  63             die "Cannot open errno.c";
  64
  65         print CPPI "#include <errno.h>\n";
  66
  67         close(CPPI);
  68
  69         # invoke CPP and read the output
  70         if ($^O eq 'MSWin32') {
  71             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
  72                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
  73         } else {
  74             my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
  75             open(CPPO,"$cpp < errno.c |") or
  76                 die "Cannot exec $cpp";
  77         }
  78
  79         my $pat;
  80         if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
  81             $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
  82         }
  83         else {
  84             $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
  85         }
  86         while(<CPPO>) {
  87             $file{$1} = 1 if /$pat/o;
  88         }
  89         close(CPPO);
  90     }
  91     return keys %file;
  92 }
  93
  94 sub write_errno_pm {
  95     my $err;
  96
  97     # create the CPP input
  98
  99     open(CPPI,"> errno.c") or
 100         die "Cannot open errno.c";
 101
 102     print CPPI "#include <errno.h>\n";
 103
 104     foreach $err (keys %err) {
 105         print CPPI '"',$err,'" [[',$err,']]',"\n";
 106     }
 107
 108     close(CPPI);
 109
 110     # invoke CPP and read the output
 111
 112     if ($^O eq 'VMS') {
 113         my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
 114         $cpp =~ s/sys\$input//i;
 115         open(CPPO,"$cpp  errno.c |") or
 116           die "Cannot exec $Config{cppstdin}";
 117     } elsif ($^O eq 'MSWin32') {
 118         open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 119             die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 120     } else {
 121         my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
 122         open(CPPO,"$cpp < errno.c |")
 123             or die "Cannot exec $cpp";
 124     }
 125
 126     %err = ();
 127
 128     while(<CPPO>) {
 129         my($name,$expr);
 130         next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
 131         next if $name eq $expr;
 132         $err{$name} = eval $expr;
 133     }
 134     close(CPPO);
 135
 136     # Write Errno.pm
 137
 138     print <<"EDQ";
 139 #
 140 # This file is auto-generated. ***ANY*** changes here will be lost
 141 #
 142
 143 package Errno;
 144 use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
 145 use Exporter ();
 146 use Config;
 147 use strict;
 148
 149 \$Config{'myarchname'} eq "$Config{'myarchname'}" or
 150         die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})";
 151
 152 \$VERSION = "$VERSION";
 153 \@ISA = qw(Exporter);
 154
 155 EDQ
 156
 157     my $len = 0;
 158     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
 159     map { $len = length if length > $len } @err;
 160
 161     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
 162     $j =~ s/(.{50,70})\s/$1\n\t/g;
 163     print $j,"\n";
 164
 165 print <<'ESQ';
 166 %EXPORT_TAGS = (
 167     POSIX => [qw(
 168 ESQ
 169
 170     my $k = join(" ", grep { exists $err{$_} }
 171         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 172         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 173         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 174         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 175         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 176         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 177         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 178         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 179         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 180         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 181         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 182         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 183         EUSERS EWOULDBLOCK EXDEV));
 184
 185     $k =~ s/(.{50,70})\s/$1\n\t/g;
 186     print "\t",$k,"\n    )]\n);\n\n";
 187
 188     foreach $err (@err) {
 189         printf "sub %s () { %d }\n",,$err,$err{$err};
 190     }
 191
 192     print <<'ESQ';
 193
 194 sub TIEHASH { bless [] }
 195
 196 sub FETCH {
 197     my ($self, $errname) = @_;
 198     my $proto = prototype("Errno::$errname");
 199     if (defined($proto) && $proto eq "") {
 200         no strict 'refs';
 201         return $! == &$errname;
 202     }
 203     require Carp;
 204     Carp::confess("No errno $errname");
 205 }
 206
 207 sub STORE {
 208     require Carp;
 209     Carp::confess("ERRNO hash is read only!");
 210 }
 211
 212 *CLEAR = \&STORE;
 213 *DELETE = \&STORE;
 214
 215 sub NEXTKEY {
 216     my($k,$v);
 217     while(($k,$v) = each %Errno::) {
 218         my $proto = prototype("Errno::$k");
 219         last if (defined($proto) && $proto eq "");
 220
 221     }
 222     $k
 223 }
 224
 225 sub FIRSTKEY {
 226     my $s = scalar keys %Errno::;
 227     goto &NEXTKEY;
 228 }
 229
 230 sub EXISTS {
 231     my ($self, $errname) = @_;
 232     my $proto = prototype($errname);
 233     defined($proto) && $proto eq "";
 234 }
 235
 236 tie %!, __PACKAGE__;
 237
 238 1;
 239 __END__
 240
 241 =head1 NAME
 242
 243 Errno - System errno constants
 244
 245 =head1 SYNOPSIS
 246
 247     use Errno qw(EINTR EIO :POSIX);
 248
 249 =head1 DESCRIPTION
 250
 251 C<Errno> defines and conditionally exports all the error constants
 252 defined in your system C<errno.h> include file. It has a single export
 253 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 254
 255 C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
 256 value only if C<$!> is set to that value, eg
 257
 258     use Errno;
 259
 260     unless (open(FH, "/fangorn/spouse")) {
 261         if ($!{ENOENT}) {
 262             warn "Get a wife!\n";
 263         } else {
 264             warn "This path is barred: $!";
 265         }
 266     }
 267
 268 =head1 AUTHOR
 269
 270 Graham Barr <gbarr@pobox.com>
 271
 272 =head1 COPYRIGHT
 273
 274 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 275 This program is free software; you can redistribute it and/or modify it
 276 under the same terms as Perl itself.
 277
 278 =cut
 279
 280 ESQ
 281
 282 }