ext/Errno/Errno_pm.PL

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