ext/Errno/Errno_pm.PL

   1 use ExtUtils::MakeMaker;
   2 use Config;
   3 use strict;
   4
   5 our $VERSION = "1.09_00";
   6
   7 my %err = ();
   8 my %wsa = ();
   9
  10 unlink "Errno.pm" if -f "Errno.pm";
  11 open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
  12 select OUT;
  13 my $file;
  14 foreach $file (get_files()) {
  15     process_file($file);
  16     if ($^O eq 'MSWin32') {
  17       $file =~ s/errno/winsock/;
  18       process_file($file);
  19     }
  20 }
  21 write_errno_pm();
  22 unlink "errno.c" if -f "errno.c";
  23
  24 sub process_file {
  25     my($file) = @_;
  26
  27     return unless defined $file and -f $file;
  28 #   warn "Processing $file\n";
  29
  30     local *FH;
  31     if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
  32         unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
  33             warn "Cannot open '$file'";
  34             return;
  35         }
  36     } elsif ($Config{gccversion} ne ''
  37              # OpenSTEP has gcc 2.7.2.1 which recognizes but
  38              # doesn't implement the -dM flag.
  39              && $^O ne 'openstep' && $^O ne 'next' && $^O ne 'darwin'
  40              ) {
  41         # With the -dM option, gcc outputs every #define it finds
  42         unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
  43             warn "Cannot open '$file'";
  44             return;
  45         }
  46     } else {
  47         unless(open(FH,"< $file")) {
  48             # This file could be a temporary file created by cppstdin
  49             # so only warn under -w, and return
  50             warn "Cannot open '$file'" if $^W;
  51             return;
  52         }
  53     }
  54
  55     if ($^O eq 'MacOS') {
  56         while(<FH>) {
  57             $err{$1} = $2
  58                 if /^\s*#\s*define\s+(E\w+)\s+(\d+)/;
  59         }
  60     } else {
  61         while(<FH>) {
  62             $err{$1} = 1
  63                 if /^\s*#\s*define\s+(E\w+)\s+/;
  64             if ($^O eq 'MSWin32') {
  65                 $wsa{$1} = 1
  66                     if /^\s*#\s*define\s+WSA(E\w+)\s+/;
  67             }
  68         }
  69     }
  70     close(FH);
  71 }
  72
  73 my $cppstdin;
  74
  75 sub default_cpp {
  76     unless (defined $cppstdin) {
  77         use File::Spec;
  78         $cppstdin = $Config{cppstdin};
  79         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
  80                                                 File::Spec->updir,
  81                                                 "cppstdin");
  82         my $cppstdin_is_wrapper =
  83             ($cppstdin eq 'cppstdin'
  84                 and -f $upup_cppstdin
  85                     and -x $upup_cppstdin);
  86         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
  87     }
  88     return "$cppstdin $Config{cppflags} $Config{cppminus}";
  89 }
  90
  91 sub get_files {
  92     my %file = ();
  93     # VMS keeps its include files in system libraries (well, except for Gcc)
  94     if ($^O eq 'VMS') {
  95         if ($Config{vms_cc_type} eq 'decc') {
  96             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
  97         } elsif ($Config{vms_cc_type} eq 'vaxc') {
  98             $file{'Sys$Library:vaxcdef.tlb'} = 1;
  99         } elsif ($Config{vms_cc_type} eq 'gcc') {
 100             $file{'gnu_cc_include:[000000]errno.h'} = 1;
 101         }
 102     } elsif ($^O eq 'os390') {
 103         # OS/390 C compiler doesn't generate #file or #line directives
 104         $file{'/usr/include/errno.h'} = 1;
 105     } elsif ($^O eq 'vmesa') {
 106         # OS/390 C compiler doesn't generate #file or #line directives
 107         $file{'../../vmesa/errno.h'} = 1;
 108     } elsif ($Config{archname} eq 'epoc') {
 109         # Watch out for cross compiling for EPOC (usually done on linux)
 110         $file{'/usr/local/epocemx/epocsdk/include/libc/sys/errno.h'} = 1;
 111     } elsif ($^O eq 'linux' &&
 112              $Config{gccversion} ne '' # might be using, say, Intel's icc
 113              ) {
 114         # Some Linuxes have weird errno.hs which generate
 115         # no #file or #line directives
 116         $file{'/usr/include/errno.h'} = 1;
 117     } elsif ($^O eq 'MacOS') {
 118         # note that we are only getting the GUSI errno's here ...
 119         # we might miss out on compiler-specific ones
 120         $file{"$ENV{GUSI}include:sys:errno.h"} = 1;
 121
 122     } elsif ($^O eq 'beos') {
 123         # hidden in a special place
 124         $file{'/boot/develop/headers/posix/errno.h'} = 1;
 125
 126     } else {
 127         open(CPPI,"> errno.c") or
 128             die "Cannot open errno.c";
 129
 130         if ($^O eq 'NetWare') {
 131                 print CPPI "#include <nwerrno.h>\n";
 132         } else {
 133                 print CPPI "#include <errno.h>\n";
 134         }
 135
 136         close(CPPI);
 137
 138         # invoke CPP and read the output
 139         if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 140             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 141                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 142         } else {
 143             my $cpp = default_cpp();
 144             open(CPPO,"$cpp < errno.c |") or
 145                 die "Cannot exec $cpp";
 146         }
 147
 148         my $pat;
 149         if (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) {
 150             $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
 151         }
 152         else {
 153             $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
 154         }
 155         while(<CPPO>) {
 156             if ($^O eq 'os2' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
 157                 if (/$pat/o) {
 158                    my $f = $1;
 159                    $f =~ s,\\\\,/,g;
 160                    $file{$f} = 1;
 161                 }
 162             }
 163             else {
 164                 $file{$1} = 1 if /$pat/o;
 165             }
 166         }
 167         close(CPPO);
 168     }
 169     return keys %file;
 170 }
 171
 172 sub write_errno_pm {
 173     my $err;
 174
 175     # quick sanity check
 176
 177     die "No error definitions found" unless keys %err;
 178
 179     # create the CPP input
 180
 181     open(CPPI,"> errno.c") or
 182         die "Cannot open errno.c";
 183
 184     if ($^O eq 'NetWare') {
 185         print CPPI "#include <nwerrno.h>\n";
 186         }
 187     else {
 188         print CPPI "#include <errno.h>\n";
 189     }
 190     if ($^O eq 'MSWin32') {
 191         print CPPI "#include <winsock.h>\n";
 192         foreach $err (keys %wsa) {
 193             print CPPI "#ifndef $err\n";
 194             print CPPI "#define $err WSA$err\n";
 195             print CPPI "#endif\n";
 196             $err{$err} = 1;
 197         }
 198     }
 199
 200     foreach $err (keys %err) {
 201         print CPPI '"',$err,'" [[',$err,']]',"\n";
 202     }
 203
 204     close(CPPI);
 205
 206     unless ($^O eq 'MacOS') {   # trust what we have
 207     # invoke CPP and read the output
 208
 209         if ($^O eq 'VMS') {
 210             my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
 211             $cpp =~ s/sys\$input//i;
 212             open(CPPO,"$cpp  errno.c |") or
 213                 die "Cannot exec $Config{cppstdin}";
 214         } elsif ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 215             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 216                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 217         } else {
 218             my $cpp = default_cpp();
 219             open(CPPO,"$cpp < errno.c |")
 220                 or die "Cannot exec $cpp";
 221         }
 222
 223         %err = ();
 224
 225         while(<CPPO>) {
 226             my($name,$expr);
 227             next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
 228             next if $name eq $expr;
 229             $expr =~ s/(\d+)[LU]+\b/$1/g; # 2147483647L et alia
 230             $err{$name} = eval $expr;
 231         }
 232         close(CPPO);
 233     }
 234
 235     # Many of the E constants (including ENOENT, which is being
 236     # used in the Perl test suite a lot), are available only as
 237     # enums in BeOS, so compiling and executing some code is about
 238     # only way to find out what the numeric Evalues are.
 239
 240     if ($^O eq 'beos') {
 241         if (open(C, ">errno.c")) {
 242             my @zero = grep { !$err{$_} } keys %err;
 243             print C <<EOF;
 244 #include <errno.h>
 245 #include <stdio.h>
 246 int main() {
 247 EOF
 248             for (@zero) {
 249                 print C qq[printf("$_ %d\n", $_);]
 250             }
 251             print C "}\n";
 252             close C;
 253             system("cc -o errno errno.c");
 254             unlink("errno.c");
 255             if (open(C, "./errno|")) {
 256                 while (<C>) {
 257                     if (/^(\w+) (-?\d+)$/) { $err{$1} = $2 }
 258                 }
 259                 close(C);
 260             } else {
 261                 die "failed to execute ./errno: $!\n";
 262             }
 263             unlink("errno");
 264         } else {
 265             die "failed to create errno.c: $!\n";
 266         }
 267     }
 268
 269     # Write Errno.pm
 270
 271     print <<"EDQ";
 272 #
 273 # This file is auto-generated. ***ANY*** changes here will be lost
 274 #
 275
 276 package Errno;
 277 our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD);
 278 use Exporter ();
 279 use Config;
 280 use strict;
 281
 282 "\$Config{'archname'}-\$Config{'osvers'}" eq
 283 "$Config{'archname'}-$Config{'osvers'}" or
 284         die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
 285
 286 \$VERSION = "$VERSION";
 287 \@ISA = qw(Exporter);
 288
 289 EDQ
 290
 291     my $len = 0;
 292     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
 293     map { $len = length if length > $len } @err;
 294
 295     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
 296     $j =~ s/(.{50,70})\s/$1\n\t/g;
 297     print $j,"\n";
 298
 299 print <<'ESQ';
 300 %EXPORT_TAGS = (
 301     POSIX => [qw(
 302 ESQ
 303
 304     my $k = join(" ", grep { exists $err{$_} }
 305         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 306         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 307         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 308         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 309         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 310         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 311         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 312         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 313         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 314         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 315         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 316         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 317         EUSERS EWOULDBLOCK EXDEV));
 318
 319     $k =~ s/(.{50,70})\s/$1\n\t/g;
 320     print "\t",$k,"\n    )]\n);\n\n";
 321
 322     foreach $err (@err) {
 323         printf "sub %s () { %d }\n",,$err,$err{$err};
 324     }
 325
 326     print <<'ESQ';
 327
 328 sub TIEHASH { bless [] }
 329
 330 sub FETCH {
 331     my ($self, $errname) = @_;
 332     my $proto = prototype("Errno::$errname");
 333     my $errno = "";
 334     if (defined($proto) && $proto eq "") {
 335         no strict 'refs';
 336         $errno = &$errname;
 337         $errno = 0 unless $! == $errno;
 338     }
 339     return $errno;
 340 }
 341
 342 sub STORE {
 343     require Carp;
 344     Carp::confess("ERRNO hash is read only!");
 345 }
 346
 347 *CLEAR = \&STORE;
 348 *DELETE = \&STORE;
 349
 350 sub NEXTKEY {
 351     my($k,$v);
 352     while(($k,$v) = each %Errno::) {
 353         my $proto = prototype("Errno::$k");
 354         last if (defined($proto) && $proto eq "");
 355     }
 356     $k
 357 }
 358
 359 sub FIRSTKEY {
 360     my $s = scalar keys %Errno::;       # initialize iterator
 361     goto &NEXTKEY;
 362 }
 363
 364 sub EXISTS {
 365     my ($self, $errname) = @_;
 366     my $proto = prototype($errname);
 367     defined($proto) && $proto eq "";
 368 }
 369
 370 tie %!, __PACKAGE__;
 371
 372 1;
 373 __END__
 374
 375 =head1 NAME
 376
 377 Errno - System errno constants
 378
 379 =head1 SYNOPSIS
 380
 381     use Errno qw(EINTR EIO :POSIX);
 382
 383 =head1 DESCRIPTION
 384
 385 C<Errno> defines and conditionally exports all the error constants
 386 defined in your system C<errno.h> include file. It has a single export
 387 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 388
 389 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
 390 non-zero value only if C<$!> is set to that value. For example:
 391
 392     use Errno;
 393
 394     unless (open(FH, "/fangorn/spouse")) {
 395         if ($!{ENOENT}) {
 396             warn "Get a wife!\n";
 397         } else {
 398             warn "This path is barred: $!";
 399         }
 400     }
 401
 402 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
 403 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
 404 constant is available on the system.
 405
 406 =head1 CAVEATS
 407
 408 Importing a particular constant may not be very portable, because the
 409 import will fail on platforms that do not have that constant.  A more
 410 portable way to set C<$!> to a valid value is to use:
 411
 412     if (exists &Errno::EFOO) {
 413         $! = &Errno::EFOO;
 414     }
 415
 416 =head1 AUTHOR
 417
 418 Graham Barr <gbarr@pobox.com>
 419
 420 =head1 COPYRIGHT
 421
 422 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 423 This program is free software; you can redistribute it and/or modify it
 424 under the same terms as Perl itself.
 425
 426 =cut
 427
 428 ESQ
 429
 430 }