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