ext/Errno/Errno_pm.PL

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