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