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