ext/Errno/Errno_pm.PL

   1 use ExtUtils::MakeMaker;
   2 use Config;
   3 use strict;
   4
   5 our $VERSION = "1.15";
   6
   7 my %err = ();
   8 my %wsa = ();
   9
  10 # Symbian cross-compiling environment.
  11 my $IsSymbian = exists $ENV{SDK} && -d "$ENV{SDK}\\epoc32";
  12
  13 my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian;
  14
  15 unlink "Errno.pm" if -f "Errno.pm";
  16 unlink "Errno.tmp" if -f "Errno.tmp";
  17 open OUT, ">Errno.tmp" or die "Cannot open Errno.tmp: $!";
  18 select OUT;
  19 my $file;
  20 my @files = get_files();
  21 if ($Config{gccversion} ne '' && $^O eq 'MSWin32') {
  22     # MinGW complains "warning: #pragma system_header ignored outside include
  23     # file" if the header files are processed individually, so include them
  24     # all in .c file and process that instead.
  25     open INCS, '>includes.c' or
  26         die "Cannot open includes.c";
  27     foreach $file (@files) {
  28         next if $file eq 'errno.c';
  29         next unless -f $file;
  30         print INCS qq[#include "$file"\n];
  31     }
  32     close INCS;
  33     process_file('includes.c');
  34     unlink 'includes.c';
  35 }
  36 else {
  37     foreach $file (@files) {
  38         process_file($file);
  39     }
  40 }
  41 write_errno_pm();
  42 unlink "errno.c" if -f "errno.c";
  43 close OUT or die "Error closing Errno.tmp: $!";
  44 select STDOUT;
  45 rename "Errno.tmp", "Errno.pm" or die "Cannot rename Errno.tmp to Errno.pm: $!";
  46
  47 sub process_file {
  48     my($file) = @_;
  49
  50     # for win32 perl under cygwin, we need to get a windows pathname
  51     if ($^O eq 'MSWin32' && $Config{cc} =~ /\B-mno-cygwin\b/ &&
  52         defined($file) && !-f $file) {
  53         chomp($file = `cygpath -w "$file"`);
  54     }
  55
  56     return unless defined $file and -f $file;
  57 #    warn "Processing $file\n";
  58
  59     local *FH;
  60     if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
  61         unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
  62             warn "Cannot open '$file'";
  63             return;
  64         }
  65     } elsif ($Config{gccversion} ne ''
  66              # OpenSTEP has gcc 2.7.2.1 which recognizes but
  67              # doesn't implement the -dM flag.
  68              && $^O ne 'openstep' && $^O ne 'next' && $^O ne 'darwin'
  69              ) {
  70         # With the -dM option, gcc outputs every #define it finds
  71         unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
  72             warn "Cannot open '$file'";
  73             return;
  74         }
  75     } else {
  76         unless(open(FH,"< $file")) {
  77             # This file could be a temporary file created by cppstdin
  78             # so only warn under -w, and return
  79             warn "Cannot open '$file'" if $^W;
  80             return;
  81         }
  82     }
  83
  84     while(<FH>) {
  85         $err{$1} = 1
  86             if /^\s*#\s*define\s+(E\w+)\s+/;
  87         if ($IsMSWin32) {
  88             $wsa{$1} = 1
  89                 if /^\s*#\s*define\s+WSA(E\w+)\s+/;
  90         }
  91     }
  92
  93     close(FH);
  94 }
  95
  96 my $cppstdin;
  97
  98 sub default_cpp {
  99     unless (defined $cppstdin) {
 100         use File::Spec;
 101         $cppstdin = $Config{cppstdin};
 102         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
 103                                                 File::Spec->updir,
 104                                                 "cppstdin");
 105         my $cppstdin_is_wrapper =
 106             ($cppstdin eq 'cppstdin'
 107                 and -f $upup_cppstdin
 108                     and -x $upup_cppstdin);
 109         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
 110     }
 111     return "$cppstdin $Config{cppflags} $Config{cppminus}";
 112 }
 113
 114 sub get_files {
 115     my %file = ();
 116     # VMS keeps its include files in system libraries (well, except for Gcc)
 117     if ($^O eq 'VMS') {
 118         if ($Config{vms_cc_type} eq 'decc') {
 119             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
 120         } elsif ($Config{vms_cc_type} eq 'vaxc') {
 121             $file{'Sys$Library:vaxcdef.tlb'} = 1;
 122         } elsif ($Config{vms_cc_type} eq 'gcc') {
 123             $file{'gnu_cc_include:[000000]errno.h'} = 1;
 124         }
 125     } elsif ($^O eq 'os390') {
 126         # OS/390 C compiler doesn't generate #file or #line directives
 127         $file{'/usr/include/errno.h'} = 1;
 128     } elsif ($^O eq 'vmesa') {
 129         # OS/390 C compiler doesn't generate #file or #line directives
 130         $file{'../../vmesa/errno.h'} = 1;
 131     } elsif ($Config{archname} eq 'epoc') {
 132         # Watch out for cross compiling for EPOC (usually done on linux)
 133         $file{'/usr/local/epocemx/epocsdk/include/libc/sys/errno.h'} = 1;
 134     } elsif ($Config{archname} eq 'arm-riscos') {
 135         # Watch out for cross compiling for RISC OS
 136         my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
 137         if ($dep =~ /(\S+errno\.h)/) {
 138              $file{$1} = 1;
 139         }
 140     } elsif ($^O eq 'linux' &&
 141               $Config{gccversion} ne '' &&
 142               $Config{gccversion} !~ /intel/i
 143               # might be using, say, Intel's icc
 144              ) {
 145         # Some Linuxes have weird errno.hs which generate
 146         # no #file or #line directives
 147         my $linux_errno_h = -e '/usr/include/errno.h' ?
 148             '/usr/include/errno.h' : '/usr/local/include/errno.h';
 149         $file{$linux_errno_h} = 1;
 150     } elsif ($^O eq 'beos' || $^O eq 'haiku') {
 151         # hidden in a special place
 152         $file{'/boot/develop/headers/posix/errno.h'} = 1;
 153
 154     } elsif ($^O eq 'vos') {
 155         # avoid problem where cpp returns non-POSIX pathnames
 156         $file{'/system/include_library/errno.h'} = 1;
 157     } elsif ($IsSymbian) {
 158         my $SDK = $ENV{SDK};
 159         $SDK =~ s!\\!/!g;
 160         $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1;
 161     } else {
 162         open(CPPI,"> errno.c") or
 163             die "Cannot open errno.c";
 164
 165         if ($^O eq 'NetWare') {
 166             print CPPI "#include <nwerrno.h>\n";
 167         } else {
 168             print CPPI "#include <errno.h>\n";
 169             if ($IsMSWin32) {
 170                 print CPPI "#define _WINSOCKAPI_\n"; # don't drag in everything
 171                 print CPPI "#include <winsock.h>\n";
 172             }
 173         }
 174
 175         close(CPPI);
 176
 177         # invoke CPP and read the output
 178         if ($IsMSWin32 || $^O eq 'NetWare') {
 179             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 180                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 181         } else {
 182             my $cpp = default_cpp();
 183             open(CPPO,"$cpp < errno.c |") or
 184                 die "Cannot exec $cpp";
 185         }
 186
 187         my $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
 188         while(<CPPO>) {
 189             if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') {
 190                 if (/$pat/o) {
 191                    my $f = $1;
 192                    $f =~ s,\\\\,/,g;
 193                    $file{$f} = 1;
 194                 }
 195             }
 196             else {
 197                 $file{$1} = 1 if /$pat/o;
 198             }
 199         }
 200         close(CPPO);
 201     }
 202     return keys %file;
 203 }
 204
 205 sub write_errno_pm {
 206     my $err;
 207
 208     # quick sanity check
 209
 210     die "No error definitions found" unless keys %err;
 211
 212     # create the CPP input
 213
 214     open(CPPI,"> errno.c") or
 215         die "Cannot open errno.c";
 216
 217     if ($^O eq 'NetWare') {
 218         print CPPI "#include <nwerrno.h>\n";
 219         }
 220     else {
 221         print CPPI "#include <errno.h>\n";
 222     }
 223     if ($IsMSWin32) {
 224         print CPPI "#include <winsock.h>\n";
 225         foreach $err (keys %wsa) {
 226             print CPPI "#if defined($err) && $err >= 100\n";
 227             print CPPI "#undef $err\n";
 228             print CPPI "#endif\n";
 229             print CPPI "#ifndef $err\n";
 230             print CPPI "#define $err WSA$err\n";
 231             print CPPI "#endif\n";
 232             $err{$err} = 1;
 233         }
 234     }
 235
 236     foreach $err (keys %err) {
 237         print CPPI '"',$err,'" [[',$err,']]',"\n";
 238     }
 239
 240     close(CPPI);
 241
 242     unless ($^O eq 'beos') {    # trust what we have / get later
 243     # invoke CPP and read the output
 244
 245         if ($^O eq 'VMS') {
 246             my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
 247             $cpp =~ s/sys\$input//i;
 248             open(CPPO,"$cpp  errno.c |") or
 249                 die "Cannot exec $Config{cppstdin}";
 250         } elsif ($IsMSWin32 || $^O eq 'NetWare') {
 251             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 252                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 253         } elsif ($IsSymbian) {
 254             my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc -";
 255             open(CPPO,"$cpp < errno.c |")
 256                 or die "Cannot exec $cpp";
 257         } else {
 258             my $cpp = default_cpp();
 259             open(CPPO,"$cpp < errno.c |")
 260                 or die "Cannot exec $cpp";
 261         }
 262
 263         %err = ();
 264
 265         while(<CPPO>) {
 266             my($name,$expr);
 267             next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
 268             next if $name eq $expr;
 269             $expr =~ s/\(?\([a-z_]\w*\)([^\)]*)\)?/$1/i; # ((type)0xcafebabe) at alia
 270             $expr =~ s/((?:0x)?[0-9a-fA-F]+)[LU]+\b/$1/g; # 2147483647L et alia
 271             next if $expr =~ m/^[a-zA-Z]+$/; # skip some Win32 functions
 272             if($expr =~ m/^0[xX]/) {
 273                 $err{$name} = hex $expr;
 274             }
 275             else {
 276             $err{$name} = eval $expr;
 277         }
 278             delete $err{$name} unless defined $err{$name};
 279         }
 280         close(CPPO);
 281     }
 282
 283     # Many of the E constants (including ENOENT, which is being
 284     # used in the Perl test suite a lot), are available only as
 285     # enums in BeOS, so compiling and executing some code is about
 286     # only way to find out what the numeric Evalues are. In fact above, we
 287     # didn't even bother to get the values of the ones that have numeric
 288     # values, since we can get all of them here, anyway.
 289
 290     if ($^O eq 'beos') {
 291         if (open(C, ">errno.c")) {
 292             my @allerrs = keys %err;
 293             print C <<EOF;
 294 #include <errno.h>
 295 #include <stdio.h>
 296 int main() {
 297 EOF
 298             for (@allerrs) {
 299                 print C qq[printf("$_ %d\n", $_);]
 300             }
 301             print C "}\n";
 302             close C;
 303             system("cc -o errno errno.c");
 304             unlink("errno.c");
 305             if (open(C, "./errno|")) {
 306                 while (<C>) {
 307                     if (/^(\w+) (-?\d+)$/) { $err{$1} = $2 }
 308                 }
 309                 close(C);
 310             } else {
 311                 die "failed to execute ./errno: $!\n";
 312             }
 313             unlink("errno");
 314         } else {
 315             die "failed to create errno.c: $!\n";
 316         }
 317     }
 318
 319     # escape $Config{'archname'}
 320     my $archname = $Config{'archname'};
 321     $archname =~ s/([@%\$])/\\\1/g;
 322
 323     # Write Errno.pm
 324
 325     print <<"EDQ";
 326 # -*- buffer-read-only: t -*-
 327 #
 328 # This file is auto-generated. ***ANY*** changes here will be lost
 329 #
 330
 331 package Errno;
 332 require Exporter;
 333 use Config;
 334 use strict;
 335
 336 "\$Config{'archname'}-\$Config{'osvers'}" eq
 337 "$archname-$Config{'osvers'}" or
 338         die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
 339
 340 our \$VERSION = "$VERSION";
 341 \$VERSION = eval \$VERSION;
 342 our \@ISA = 'Exporter';
 343
 344 my %err;
 345
 346 BEGIN {
 347     %err = (
 348 EDQ
 349
 350     my @err = sort { $err{$a} <=> $err{$b} }
 351         grep { $err{$_} =~ /-?\d+$/ } keys %err;
 352
 353     foreach $err (@err) {
 354         print "\t$err => $err{$err},\n";
 355     }
 356
 357 print <<'ESQ';
 358     );
 359     # Generate proxy constant subroutines for all the values.
 360     # Well, almost all the values. Unfortunately we can't assume that at this
 361     # point that our symbol table is empty, as code such as if the parser has
 362     # seen code such as C<exists &Errno::EINVAL>, it will have created the
 363     # typeglob.
 364     # Doing this before defining @EXPORT_OK etc means that even if a platform is
 365     # crazy enough to define EXPORT_OK as an error constant, everything will
 366     # still work, because the parser will upgrade the PCS to a real typeglob.
 367     # We rely on the subroutine definitions below to update the internal caches.
 368     # Don't use %each, as we don't want a copy of the value.
 369     foreach my $name (keys %err) {
 370         if ($Errno::{$name}) {
 371             # We expect this to be reached fairly rarely, so take an approach
 372             # which uses the least compile time effort in the common case:
 373             eval "sub $name() { $err{$name} }; 1" or die $@;
 374         } else {
 375             $Errno::{$name} = \$err{$name};
 376         }
 377     }
 378 }
 379
 380 our @EXPORT_OK = keys %err;
 381
 382 our %EXPORT_TAGS = (
 383     POSIX => [qw(
 384 ESQ
 385
 386     my $k = join(" ", grep { exists $err{$_} }
 387         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 388         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 389         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 390         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 391         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 392         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 393         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 394         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 395         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 396         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 397         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 398         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 399         EUSERS EWOULDBLOCK EXDEV));
 400
 401     $k =~ s/(.{50,70})\s/$1\n\t/g;
 402     print "\t",$k,"\n    )]\n);\n\n";
 403
 404     print <<'ESQ';
 405 sub TIEHASH { bless \%err }
 406
 407 sub FETCH {
 408     my (undef, $errname) = @_;
 409     return "" unless exists $err{$errname};
 410     my $errno = $err{$errname};
 411     return $errno == $! ? $errno : 0;
 412 }
 413
 414 sub STORE {
 415     require Carp;
 416     Carp::confess("ERRNO hash is read only!");
 417 }
 418
 419 *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
 420
 421 sub NEXTKEY {
 422     each %err;
 423 }
 424
 425 sub FIRSTKEY {
 426     my $s = scalar keys %err;   # initialize iterator
 427     each %err;
 428 }
 429
 430 sub EXISTS {
 431     my (undef, $errname) = @_;
 432     exists $err{$errname};
 433 }
 434
 435 tie %!, __PACKAGE__; # Returns an object, objects are true.
 436
 437 __END__
 438
 439 =head1 NAME
 440
 441 Errno - System errno constants
 442
 443 =head1 SYNOPSIS
 444
 445     use Errno qw(EINTR EIO :POSIX);
 446
 447 =head1 DESCRIPTION
 448
 449 C<Errno> defines and conditionally exports all the error constants
 450 defined in your system C<errno.h> include file. It has a single export
 451 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 452
 453 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
 454 non-zero value only if C<$!> is set to that value. For example:
 455
 456     use Errno;
 457
 458     unless (open(FH, "/fangorn/spouse")) {
 459         if ($!{ENOENT}) {
 460             warn "Get a wife!\n";
 461         } else {
 462             warn "This path is barred: $!";
 463         }
 464     }
 465
 466 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
 467 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
 468 constant is available on the system.
 469
 470 =head1 CAVEATS
 471
 472 Importing a particular constant may not be very portable, because the
 473 import will fail on platforms that do not have that constant.  A more
 474 portable way to set C<$!> to a valid value is to use:
 475
 476     if (exists &Errno::EFOO) {
 477         $! = &Errno::EFOO;
 478     }
 479
 480 =head1 AUTHOR
 481
 482 Graham Barr <gbarr@pobox.com>
 483
 484 =head1 COPYRIGHT
 485
 486 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 487 This program is free software; you can redistribute it and/or modify it
 488 under the same terms as Perl itself.
 489
 490 =cut
 491
 492 # ex: set ro:
 493 ESQ
 494
 495 }