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