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