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