ext/Errno/Errno_pm.PL

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