ext/Errno/Errno_pm.PL

   1 use ExtUtils::MakeMaker;
   2 use Config;
   3 use strict;
   4
   5 our $VERSION = "1.20_04";
   6
   7 my %err = ();
   8
   9 # Symbian cross-compiling environment.
  10 my $IsSymbian = exists $ENV{SDK} && -d "$ENV{SDK}\\epoc32";
  11
  12 my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian;
  13
  14 unlink "Errno.pm" if -f "Errno.pm";
  15 unlink "Errno.tmp" if -f "Errno.tmp";
  16 open OUT, ">Errno.tmp" or die "Cannot open Errno.tmp: $!";
  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 close OUT or die "Error closing Errno.tmp: $!";
  43 select STDOUT;
  44 rename "Errno.tmp", "Errno.pm" or die "Cannot rename Errno.tmp to Errno.pm: $!";
  45
  46 sub process_file {
  47     my($file) = @_;
  48
  49     # for win32 perl under cygwin, we need to get a windows pathname
  50     if ($^O eq 'MSWin32' && $Config{cc} =~ /\B-mno-cygwin\b/ &&
  51         defined($file) && !-f $file) {
  52         chomp($file = `cygpath -w "$file"`);
  53     }
  54
  55     return unless defined $file and -f $file;
  56 #    warn "Processing $file\n";
  57
  58     local *FH;
  59     if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
  60         unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
  61             warn "Cannot open '$file'";
  62             return;
  63         }
  64     } elsif ($Config{gccversion} ne '' && $^O ne 'darwin' ) {
  65         # With the -dM option, gcc outputs every #define it finds
  66         unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
  67             warn "Cannot open '$file'";
  68             return;
  69         }
  70     } else {
  71         unless(open(FH,"< $file")) {
  72             # This file could be a temporary file created by cppstdin
  73             # so only warn under -w, and return
  74             warn "Cannot open '$file'" if $^W;
  75             return;
  76         }
  77     }
  78
  79     while(<FH>) {
  80         $err{$1} = 1
  81             if /^\s*#\s*define\s+(E\w+)\s+/;
  82     }
  83
  84     close(FH);
  85 }
  86
  87 my $cppstdin;
  88
  89 sub default_cpp {
  90     unless (defined $cppstdin) {
  91         use File::Spec;
  92         $cppstdin = $Config{cppstdin};
  93         my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
  94                                                 File::Spec->updir,
  95                                                 "cppstdin");
  96         my $cppstdin_is_wrapper =
  97             ($cppstdin eq 'cppstdin'
  98                 and -f $upup_cppstdin
  99                     and -x $upup_cppstdin);
 100         $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
 101     }
 102     return "$cppstdin $Config{cppflags} $Config{cppminus}";
 103 }
 104
 105 sub get_files {
 106     my %file = ();
 107     # VMS keeps its include files in system libraries (well, except for Gcc)
 108     if ($^O eq 'VMS') {
 109         if ($Config{vms_cc_type} eq 'decc') {
 110             $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
 111         } elsif ($Config{vms_cc_type} eq 'vaxc') {
 112             $file{'Sys$Library:vaxcdef.tlb'} = 1;
 113         } elsif ($Config{vms_cc_type} eq 'gcc') {
 114             $file{'gnu_cc_include:[000000]errno.h'} = 1;
 115         }
 116     } elsif ($^O eq 'os390') {
 117         # OS/390 C compiler doesn't generate #file or #line directives
 118         $file{'/usr/include/errno.h'} = 1;
 119     } elsif ($Config{archname} eq 'arm-riscos') {
 120         # Watch out for cross compiling for RISC OS
 121         my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
 122         if ($dep =~ /(\S+errno\.h)/) {
 123              $file{$1} = 1;
 124         }
 125     } elsif ($^O eq 'linux' &&
 126               $Config{gccversion} ne '' &&
 127               $Config{gccversion} !~ /intel/i
 128               # might be using, say, Intel's icc
 129              ) {
 130     # When cross-compiling we may store a path for gcc's "sysroot" option:
 131     my $sysroot = $Config{sysroot} || '';
 132         # Some Linuxes have weird errno.hs which generate
 133         # no #file or #line directives
 134         my ($linux_errno_h) = grep { -e $_ } map { "$_/errno.h" }
 135             "$sysroot/usr/include", "$sysroot/usr/local/include",
 136             split / / => $Config{locincpth} or
 137                 die "Cannot find errno.h";
 138         $file{$linux_errno_h} = 1;
 139     } elsif ($^O eq 'haiku') {
 140         # hidden in a special place
 141         $file{'/boot/develop/headers/posix/errno.h'} = 1;
 142
 143     } elsif ($^O eq 'vos') {
 144         # avoid problem where cpp returns non-POSIX pathnames
 145         $file{'/system/include_library/errno.h'} = 1;
 146     } elsif ($IsSymbian) {
 147         my $SDK = $ENV{SDK};
 148         $SDK =~ s!\\!/!g;
 149         $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1;
 150     } else {
 151         open(CPPI,"> errno.c") or
 152             die "Cannot open errno.c";
 153
 154         if ($^O eq 'NetWare') {
 155             print CPPI "#include <nwerrno.h>\n";
 156         } else {
 157             print CPPI "#include <errno.h>\n";
 158             if ($IsMSWin32) {
 159                 print CPPI qq[#include "../../win32/include/sys/errno2.h"\n];
 160             }
 161         }
 162
 163         close(CPPI);
 164
 165         # invoke CPP and read the output
 166         if ($IsMSWin32 || $^O eq 'NetWare') {
 167             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 168                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 169         } else {
 170             my $cpp = default_cpp();
 171             open(CPPO,"$cpp < errno.c |") or
 172                 die "Cannot exec $cpp";
 173         }
 174
 175         my $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
 176         while(<CPPO>) {
 177             if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') {
 178                 if (/$pat/o) {
 179                    my $f = $1;
 180                    $f =~ s,\\\\,/,g;
 181                    $file{$f} = 1;
 182                 }
 183             }
 184             else {
 185                 $file{$1} = 1 if /$pat/o;
 186             }
 187         }
 188         close(CPPO);
 189     }
 190     return keys %file;
 191 }
 192
 193 sub write_errno_pm {
 194     my $err;
 195
 196     # quick sanity check
 197
 198     die "No error definitions found" unless keys %err;
 199
 200     # create the CPP input
 201
 202     open(CPPI,"> errno.c") or
 203         die "Cannot open errno.c";
 204
 205     if ($^O eq 'NetWare') {
 206         print CPPI "#include <nwerrno.h>\n";
 207         }
 208     else {
 209         print CPPI "#include <errno.h>\n";
 210     }
 211     if ($IsMSWin32) {
 212         print CPPI qq[#include "../../win32/include/sys/errno2.h"\n];
 213     }
 214
 215     foreach $err (keys %err) {
 216         print CPPI '"',$err,'" [[',$err,']]',"\n";
 217     }
 218
 219     close(CPPI);
 220
 221     {   # BeOS (support now removed) did not enter this block
 222     # invoke CPP and read the output
 223
 224         if ($^O eq 'VMS') {
 225             my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
 226             $cpp =~ s/sys\$input//i;
 227             open(CPPO,"$cpp  errno.c |") or
 228                 die "Cannot exec $Config{cppstdin}";
 229         } elsif ($IsMSWin32 || $^O eq 'NetWare') {
 230             open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
 231                 die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
 232         } elsif ($IsSymbian) {
 233             my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc -";
 234             open(CPPO,"$cpp < errno.c |")
 235                 or die "Cannot exec $cpp";
 236         } else {
 237             my $cpp = default_cpp();
 238             open(CPPO,"$cpp < errno.c |")
 239                 or die "Cannot exec $cpp";
 240         }
 241
 242         %err = ();
 243
 244         while(<CPPO>) {
 245             my($name,$expr);
 246             next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
 247             next if $name eq $expr;
 248             $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)([^\)]*)\)?/$1/i; # ((type)0xcafebabe) at alia
 249             $expr =~ s/((?:0x)?[0-9a-fA-F]+)[luLU]+\b/$1/g; # 2147483647L et alia
 250             next if $expr =~ m/^[a-zA-Z]+$/; # skip some Win32 functions
 251             if($expr =~ m/^0[xX]/) {
 252                 $err{$name} = hex $expr;
 253             }
 254             else {
 255                 $err{$name} = eval $expr;
 256             }
 257             delete $err{$name} unless defined $err{$name};
 258         }
 259         close(CPPO);
 260     }
 261
 262     # escape $Config{'archname'}
 263     my $archname = $Config{'archname'};
 264     $archname =~ s/([@%\$])/\\$1/g;
 265
 266     # Write Errno.pm
 267
 268     print <<"EDQ";
 269 # -*- buffer-read-only: t -*-
 270 #
 271 # This file is auto-generated. ***ANY*** changes here will be lost
 272 #
 273
 274 package Errno;
 275 require Exporter;
 276 use Config;
 277 use strict;
 278
 279 "\$Config{'archname'}-\$Config{'osvers'}" eq
 280 "$archname-$Config{'osvers'}" or
 281         die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
 282
 283 our \$VERSION = "$VERSION";
 284 \$VERSION = eval \$VERSION;
 285 our \@ISA = 'Exporter';
 286
 287 my %err;
 288
 289 BEGIN {
 290     %err = (
 291 EDQ
 292
 293     my @err = sort { $err{$a} <=> $err{$b} || $a cmp $b }
 294         grep { $err{$_} =~ /-?\d+$/ } keys %err;
 295
 296     foreach $err (@err) {
 297         print "\t$err => $err{$err},\n";
 298     }
 299
 300 print <<'ESQ';
 301     );
 302     # Generate proxy constant subroutines for all the values.
 303     # Well, almost all the values. Unfortunately we can't assume that at this
 304     # point that our symbol table is empty, as code such as if the parser has
 305     # seen code such as C<exists &Errno::EINVAL>, it will have created the
 306     # typeglob.
 307     # Doing this before defining @EXPORT_OK etc means that even if a platform is
 308     # crazy enough to define EXPORT_OK as an error constant, everything will
 309     # still work, because the parser will upgrade the PCS to a real typeglob.
 310     # We rely on the subroutine definitions below to update the internal caches.
 311     # Don't use %each, as we don't want a copy of the value.
 312     foreach my $name (keys %err) {
 313         if ($Errno::{$name}) {
 314             # We expect this to be reached fairly rarely, so take an approach
 315             # which uses the least compile time effort in the common case:
 316             eval "sub $name() { $err{$name} }; 1" or die $@;
 317         } else {
 318             $Errno::{$name} = \$err{$name};
 319         }
 320     }
 321 }
 322
 323 our @EXPORT_OK = keys %err;
 324
 325 our %EXPORT_TAGS = (
 326     POSIX => [qw(
 327 ESQ
 328
 329     my $k = join(" ", grep { exists $err{$_} }
 330         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 331         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 332         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 333         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 334         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 335         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 336         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 337         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 338         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 339         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 340         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 341         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 342         EUSERS EWOULDBLOCK EXDEV));
 343
 344     $k =~ s/(.{50,70})\s/$1\n\t/g;
 345     print "\t",$k,"\n    )]\n);\n\n";
 346
 347     print <<'ESQ';
 348 sub TIEHASH { bless \%err }
 349
 350 sub FETCH {
 351     my (undef, $errname) = @_;
 352     return "" unless exists $err{$errname};
 353     my $errno = $err{$errname};
 354     return $errno == $! ? $errno : 0;
 355 }
 356
 357 sub STORE {
 358     require Carp;
 359     Carp::confess("ERRNO hash is read only!");
 360 }
 361
 362 *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
 363
 364 sub NEXTKEY {
 365     each %err;
 366 }
 367
 368 sub FIRSTKEY {
 369     my $s = scalar keys %err;   # initialize iterator
 370     each %err;
 371 }
 372
 373 sub EXISTS {
 374     my (undef, $errname) = @_;
 375     exists $err{$errname};
 376 }
 377
 378 tie %!, __PACKAGE__; # Returns an object, objects are true.
 379
 380 __END__
 381
 382 =head1 NAME
 383
 384 Errno - System errno constants
 385
 386 =head1 SYNOPSIS
 387
 388     use Errno qw(EINTR EIO :POSIX);
 389
 390 =head1 DESCRIPTION
 391
 392 C<Errno> defines and conditionally exports all the error constants
 393 defined in your system C<errno.h> include file. It has a single export
 394 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 395
 396 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
 397 non-zero value only if C<$!> is set to that value. For example:
 398
 399     use Errno;
 400
 401     unless (open(FH, "/fangorn/spouse")) {
 402         if ($!{ENOENT}) {
 403             warn "Get a wife!\n";
 404         } else {
 405             warn "This path is barred: $!";
 406         }
 407     }
 408
 409 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
 410 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
 411 constant is available on the system.
 412
 413 =head1 CAVEATS
 414
 415 Importing a particular constant may not be very portable, because the
 416 import will fail on platforms that do not have that constant.  A more
 417 portable way to set C<$!> to a valid value is to use:
 418
 419     if (exists &Errno::EFOO) {
 420         $! = &Errno::EFOO;
 421     }
 422
 423 =head1 AUTHOR
 424
 425 Graham Barr <gbarr@pobox.com>
 426
 427 =head1 COPYRIGHT
 428
 429 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 430 This program is free software; you can redistribute it and/or modify it
 431 under the same terms as Perl itself.
 432
 433 =cut
 434
 435 # ex: set ro:
 436 ESQ
 437
 438 }