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