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/\(?\(\w+\)([^\)]*)\)?/$1/; # ((type)0xcafebabe) at alia
 233             $expr =~ s/((?:0x)?[0-9a-fA-F]+)[LU]+\b/$1/g; # 2147483647L et alia
 234             next if $expr =~ m/^[a-zA-Z]+$/; # skip some Win32 functions
 235             if($expr =~ m/^0[xX]/) {
 236                 $err{$name} = hex $expr;
 237             }
 238             else {
 239             $err{$name} = eval $expr;
 240         }
 241             delete $err{$name} unless defined $err{$name};
 242         }
 243         close(CPPO);
 244     }
 245
 246     # Many of the E constants (including ENOENT, which is being
 247     # used in the Perl test suite a lot), are available only as
 248     # enums in BeOS, so compiling and executing some code is about
 249     # only way to find out what the numeric Evalues are.
 250
 251     if ($^O eq 'beos') {
 252         if (open(C, ">errno.c")) {
 253             my @zero = grep { !$err{$_} } keys %err;
 254             print C <<EOF;
 255 #include <errno.h>
 256 #include <stdio.h>
 257 int main() {
 258 EOF
 259             for (@zero) {
 260                 print C qq[printf("$_ %d\n", $_);]
 261             }
 262             print C "}\n";
 263             close C;
 264             system("cc -o errno errno.c");
 265             unlink("errno.c");
 266             if (open(C, "./errno|")) {
 267                 while (<C>) {
 268                     if (/^(\w+) (-?\d+)$/) { $err{$1} = $2 }
 269                 }
 270                 close(C);
 271             } else {
 272                 die "failed to execute ./errno: $!\n";
 273             }
 274             unlink("errno");
 275         } else {
 276             die "failed to create errno.c: $!\n";
 277         }
 278     }
 279
 280     # Write Errno.pm
 281
 282     print <<"EDQ";
 283 #
 284 # This file is auto-generated. ***ANY*** changes here will be lost
 285 #
 286
 287 package Errno;
 288 our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD);
 289 use Exporter ();
 290 use Config;
 291 use strict;
 292
 293 "\$Config{'archname'}-\$Config{'osvers'}" eq
 294 "$Config{'archname'}-$Config{'osvers'}" or
 295         die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
 296
 297 \$VERSION = "$VERSION";
 298 \$VERSION = eval \$VERSION;
 299 \@ISA = qw(Exporter);
 300
 301 EDQ
 302
 303     my $len = 0;
 304     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
 305     map { $len = length if length > $len } @err;
 306
 307     my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
 308     $j =~ s/(.{50,70})\s/$1\n\t/g;
 309     print $j,"\n";
 310
 311 print <<'ESQ';
 312 %EXPORT_TAGS = (
 313     POSIX => [qw(
 314 ESQ
 315
 316     my $k = join(" ", grep { exists $err{$_} }
 317         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 318         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 319         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 320         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 321         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 322         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 323         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 324         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 325         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 326         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 327         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 328         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 329         EUSERS EWOULDBLOCK EXDEV));
 330
 331     $k =~ s/(.{50,70})\s/$1\n\t/g;
 332     print "\t",$k,"\n    )]\n);\n\n";
 333
 334     foreach $err (@err) {
 335         printf "sub %s () { %d }\n",,$err,$err{$err};
 336     }
 337
 338     print <<'ESQ';
 339
 340 sub TIEHASH { bless [] }
 341
 342 sub FETCH {
 343     my ($self, $errname) = @_;
 344     my $proto = prototype("Errno::$errname");
 345     my $errno = "";
 346     if (defined($proto) && $proto eq "") {
 347         no strict 'refs';
 348         $errno = &$errname;
 349         $errno = 0 unless $! == $errno;
 350     }
 351     return $errno;
 352 }
 353
 354 sub STORE {
 355     require Carp;
 356     Carp::confess("ERRNO hash is read only!");
 357 }
 358
 359 *CLEAR = \&STORE;
 360 *DELETE = \&STORE;
 361
 362 sub NEXTKEY {
 363     my($k,$v);
 364     while(($k,$v) = each %Errno::) {
 365         my $proto = prototype("Errno::$k");
 366         last if (defined($proto) && $proto eq "");
 367     }
 368     $k
 369 }
 370
 371 sub FIRSTKEY {
 372     my $s = scalar keys %Errno::;       # initialize iterator
 373     goto &NEXTKEY;
 374 }
 375
 376 sub EXISTS {
 377     my ($self, $errname) = @_;
 378     my $proto = prototype($errname);
 379     defined($proto) && $proto eq "";
 380 }
 381
 382 tie %!, __PACKAGE__;
 383
 384 1;
 385 __END__
 386
 387 =head1 NAME
 388
 389 Errno - System errno constants
 390
 391 =head1 SYNOPSIS
 392
 393     use Errno qw(EINTR EIO :POSIX);
 394
 395 =head1 DESCRIPTION
 396
 397 C<Errno> defines and conditionally exports all the error constants
 398 defined in your system C<errno.h> include file. It has a single export
 399 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 400
 401 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
 402 non-zero value only if C<$!> is set to that value. For example:
 403
 404     use Errno;
 405
 406     unless (open(FH, "/fangorn/spouse")) {
 407         if ($!{ENOENT}) {
 408             warn "Get a wife!\n";
 409         } else {
 410             warn "This path is barred: $!";
 411         }
 412     }
 413
 414 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
 415 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
 416 constant is available on the system.
 417
 418 =head1 CAVEATS
 419
 420 Importing a particular constant may not be very portable, because the
 421 import will fail on platforms that do not have that constant.  A more
 422 portable way to set C<$!> to a valid value is to use:
 423
 424     if (exists &Errno::EFOO) {
 425         $! = &Errno::EFOO;
 426     }
 427
 428 =head1 AUTHOR
 429
 430 Graham Barr <gbarr@pobox.com>
 431
 432 =head1 COPYRIGHT
 433
 434 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 435 This program is free software; you can redistribute it and/or modify it
 436 under the same terms as Perl itself.
 437
 438 =cut
 439
 440 ESQ
 441
 442 }