ext/Errno/Errno_pm.PL

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