ext/Errno/Errno_pm.PL

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