ext/Errno/Errno_pm.PL

   1 use ExtUtils::MakeMaker;
   2 use Config;
   3 use strict;
   4
   5 our $VERSION = "1.25";
   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) at 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. ***ANY*** changes here will be lost
 284 #
 285
 286 package Errno;
 287 require Exporter;
 288 use strict;
 289
 290 EDQ
 291
 292     # Errno only needs Config to make sure it hasn't changed platforms.
 293     # If someone set $ENV{PERL_BUILD_EXPAND_CONFIG_VARS} at build time,
 294     # they've already declared perl doesn't need to worry about this risk.
 295     if(!$ENV{'PERL_BUILD_EXPAND_CONFIG_VARS'}) {
 296         print <<"CONFIG_CHECK_END";
 297 use Config;
 298 "\$Config{'archname'}-\$Config{'osvers'}" eq
 299 "$archname-$Config{'osvers'}" or
 300         die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
 301
 302 CONFIG_CHECK_END
 303 }
 304
 305     print <<"EDQ";
 306 our \$VERSION = "$VERSION";
 307 \$VERSION = eval \$VERSION;
 308 our \@ISA = 'Exporter';
 309
 310 my %err;
 311
 312 BEGIN {
 313     %err = (
 314 EDQ
 315
 316     my @err = sort { $err{$a} <=> $err{$b} || $a cmp $b }
 317         grep { $err{$_} =~ /-?\d+$/ } keys %err;
 318
 319     foreach $err (@err) {
 320         print "\t$err => $err{$err},\n";
 321     }
 322
 323 print <<'ESQ';
 324     );
 325     # Generate proxy constant subroutines for all the values.
 326     # Well, almost all the values. Unfortunately we can't assume that at this
 327     # point that our symbol table is empty, as code such as if the parser has
 328     # seen code such as C<exists &Errno::EINVAL>, it will have created the
 329     # typeglob.
 330     # Doing this before defining @EXPORT_OK etc means that even if a platform is
 331     # crazy enough to define EXPORT_OK as an error constant, everything will
 332     # still work, because the parser will upgrade the PCS to a real typeglob.
 333     # We rely on the subroutine definitions below to update the internal caches.
 334     # Don't use %each, as we don't want a copy of the value.
 335     foreach my $name (keys %err) {
 336         if ($Errno::{$name}) {
 337             # We expect this to be reached fairly rarely, so take an approach
 338             # which uses the least compile time effort in the common case:
 339             eval "sub $name() { $err{$name} }; 1" or die $@;
 340         } else {
 341             $Errno::{$name} = \$err{$name};
 342         }
 343     }
 344 }
 345
 346 our @EXPORT_OK = keys %err;
 347
 348 our %EXPORT_TAGS = (
 349     POSIX => [qw(
 350 ESQ
 351
 352     my $k = join(" ", grep { exists $err{$_} }
 353         qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
 354         EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
 355         ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
 356         EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
 357         EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
 358         EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
 359         ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
 360         ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
 361         ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
 362         EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
 363         ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
 364         ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
 365         EUSERS EWOULDBLOCK EXDEV));
 366
 367     $k =~ s/(.{50,70})\s/$1\n\t/g;
 368     print "\t",$k,"\n    )],\n";
 369
 370     if ($IsMSWin32) {
 371         print "    WINSOCK => [qw(\n";
 372         $k = join(" ", grep { /^WSAE/ } keys %err);
 373         $k =~ s/(.{50,70})\s/$1\n\t/g;
 374         print "\t",$k,"\n    )],\n";
 375     }
 376
 377     print ");\n\n";
 378
 379     print <<'ESQ';
 380 sub TIEHASH { bless \%err }
 381
 382 sub FETCH {
 383     my (undef, $errname) = @_;
 384     return "" unless exists $err{$errname};
 385     my $errno = $err{$errname};
 386     return $errno == $! ? $errno : 0;
 387 }
 388
 389 sub STORE {
 390     require Carp;
 391     Carp::confess("ERRNO hash is read only!");
 392 }
 393
 394 *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
 395
 396 sub NEXTKEY {
 397     each %err;
 398 }
 399
 400 sub FIRSTKEY {
 401     my $s = scalar keys %err;   # initialize iterator
 402     each %err;
 403 }
 404
 405 sub EXISTS {
 406     my (undef, $errname) = @_;
 407     exists $err{$errname};
 408 }
 409
 410 tie %!, __PACKAGE__; # Returns an object, objects are true.
 411
 412 __END__
 413
 414 =head1 NAME
 415
 416 Errno - System errno constants
 417
 418 =head1 SYNOPSIS
 419
 420     use Errno qw(EINTR EIO :POSIX);
 421
 422 =head1 DESCRIPTION
 423
 424 C<Errno> defines and conditionally exports all the error constants
 425 defined in your system F<errno.h> include file. It has a single export
 426 tag, C<:POSIX>, which will export all POSIX defined error numbers.
 427
 428 On Windows, C<Errno> also defines and conditionally exports all the
 429 Winsock error constants defined in your system F<WinError.h> include
 430 file. These are included in a second export tag, C<:WINSOCK>.
 431
 432 C<Errno> also makes C<%!> magic such that each element of C<%!> has a
 433 non-zero value only if C<$!> is set to that value. For example:
 434
 435     use Errno;
 436
 437     unless (open(FH, "/fangorn/spouse")) {
 438         if ($!{ENOENT}) {
 439             warn "Get a wife!\n";
 440         } else {
 441             warn "This path is barred: $!";
 442         }
 443     }
 444
 445 If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
 446 returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
 447 constant is available on the system.
 448
 449 =head1 CAVEATS
 450
 451 Importing a particular constant may not be very portable, because the
 452 import will fail on platforms that do not have that constant.  A more
 453 portable way to set C<$!> to a valid value is to use:
 454
 455     if (exists &Errno::EFOO) {
 456         $! = &Errno::EFOO;
 457     }
 458
 459 =head1 AUTHOR
 460
 461 Graham Barr <gbarr@pobox.com>
 462
 463 =head1 COPYRIGHT
 464
 465 Copyright (c) 1997-8 Graham Barr. All rights reserved.
 466 This program is free software; you can redistribute it and/or modify it
 467 under the same terms as Perl itself.
 468
 469 =cut
 470
 471 # ex: set ro:
 472 ESQ
 473
 474 }