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