| 1 | use ExtUtils::MakeMaker; |
| 2 | use Config; |
| 3 | use strict; |
| 4 | |
| 5 | our $VERSION = "1.38"; |
| 6 | |
| 7 | my %err = (); |
| 8 | |
| 9 | my $IsMSWin32 = $^O eq 'MSWin32'; |
| 10 | |
| 11 | unlink "Errno.pm" if -f "Errno.pm"; |
| 12 | unlink "Errno.tmp" if -f "Errno.tmp"; |
| 13 | open OUT, '>', 'Errno.tmp' or die "Cannot open Errno.tmp: $!"; |
| 14 | select OUT; |
| 15 | my $file; |
| 16 | my @files = get_files(); |
| 17 | if ($Config{gccversion} ne '' && $^O eq 'MSWin32') { |
| 18 | # MinGW complains "warning: #pragma system_header ignored outside include |
| 19 | # file" if the header files are processed individually, so include them |
| 20 | # all in .c file and process that instead. |
| 21 | open INCS, '>', 'includes.c' or |
| 22 | die "Cannot open includes.c"; |
| 23 | foreach $file (@files) { |
| 24 | next if $file eq 'errno.c'; |
| 25 | next unless -f $file; |
| 26 | print INCS qq[#include "$file"\n]; |
| 27 | } |
| 28 | close INCS; |
| 29 | process_file('includes.c'); |
| 30 | unlink 'includes.c'; |
| 31 | } |
| 32 | else { |
| 33 | foreach $file (@files) { |
| 34 | process_file($file); |
| 35 | } |
| 36 | } |
| 37 | write_errno_pm(); |
| 38 | unlink "errno.c" if -f "errno.c"; |
| 39 | close OUT or die "Error closing Errno.tmp: $!"; |
| 40 | select STDOUT; |
| 41 | rename "Errno.tmp", "Errno.pm" or die "Cannot rename Errno.tmp to Errno.pm: $!"; |
| 42 | |
| 43 | sub process_file { |
| 44 | my($file) = @_; |
| 45 | |
| 46 | # for win32 perl under cygwin, we need to get a windows pathname |
| 47 | if ($^O eq 'MSWin32' && $Config{cc} =~ /\B-mno-cygwin\b/ && |
| 48 | defined($file) && !-f $file) { |
| 49 | chomp($file = `cygpath -w "$file"`); |
| 50 | } |
| 51 | |
| 52 | return unless defined $file and -f $file; |
| 53 | # warn "Processing $file\n"; |
| 54 | |
| 55 | local *FH; |
| 56 | if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) { |
| 57 | unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) { |
| 58 | warn "Cannot open '$file'"; |
| 59 | return; |
| 60 | } |
| 61 | } elsif ($Config{gccversion} ne '' && $^O ne 'darwin' ) { |
| 62 | # With the -dM option, gcc outputs every #define it finds |
| 63 | unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) { |
| 64 | warn "Cannot open '$file'"; |
| 65 | return; |
| 66 | } |
| 67 | } else { |
| 68 | unless(open(FH, '<', $file)) { |
| 69 | # This file could be a temporary file created by cppstdin |
| 70 | # so only warn under -w, and return |
| 71 | warn "Cannot open '$file'" if $^W; |
| 72 | return; |
| 73 | } |
| 74 | } |
| 75 | |
| 76 | my $pat; |
| 77 | if ($IsMSWin32) { |
| 78 | $pat = '^\s*#\s*define\s+((?:WSA)?E\w+)\s+'; |
| 79 | } |
| 80 | else { |
| 81 | $pat = '^\s*#\s*define\s+(E\w+)\s+'; |
| 82 | } |
| 83 | while(<FH>) { |
| 84 | $err{$1} = 1 |
| 85 | if /$pat/; |
| 86 | } |
| 87 | |
| 88 | close(FH); |
| 89 | } |
| 90 | |
| 91 | my $cppstdin; |
| 92 | |
| 93 | sub default_cpp { |
| 94 | unless (defined $cppstdin) { |
| 95 | use File::Spec; |
| 96 | $cppstdin = $Config{cppstdin}; |
| 97 | my $upup_cppstdin = File::Spec->catfile(File::Spec->updir, |
| 98 | File::Spec->updir, |
| 99 | "cppstdin"); |
| 100 | my $cppstdin_is_wrapper = |
| 101 | ($cppstdin eq 'cppstdin' |
| 102 | and -f $upup_cppstdin |
| 103 | and -x $upup_cppstdin); |
| 104 | $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper; |
| 105 | } |
| 106 | return "$cppstdin $Config{cppflags} $Config{cppminus}"; |
| 107 | } |
| 108 | |
| 109 | sub get_files { |
| 110 | my @file; |
| 111 | # When cross-compiling we may store a path for gcc's "sysroot" option: |
| 112 | my $sysroot = $Config{sysroot} || ''; |
| 113 | my $linux_errno_h; |
| 114 | if ($^O eq 'linux') { |
| 115 | # Some Linuxes have weird errno.hs which generate |
| 116 | # no #file or #line directives |
| 117 | ($linux_errno_h) = grep { -e $_ } map { "$_/errno.h" } |
| 118 | "$sysroot/usr/include", "$sysroot/usr/local/include", |
| 119 | split / / => $Config{locincpth}; |
| 120 | } |
| 121 | |
| 122 | # VMS keeps its include files in system libraries |
| 123 | if ($^O eq 'VMS') { |
| 124 | push(@file, 'Sys$Library:DECC$RTLDEF.TLB'); |
| 125 | } elsif ($^O eq 'os390') { |
| 126 | # OS/390 C compiler doesn't generate #file or #line directives |
| 127 | # and it does not tag the header as 1047 (EBCDIC), so make a local |
| 128 | # copy and tag it |
| 129 | my $cp = `cp /usr/include/errno.h ./errno.h`; |
| 130 | my $chtag = `chtag -t -cIBM-1047 ./errno.h`; |
| 131 | push(@file, './errno.h'); |
| 132 | } elsif ($Config{archname} eq 'arm-riscos') { |
| 133 | # Watch out for cross compiling for RISC OS |
| 134 | my $dep = `echo "#include <errno.h>" | gcc -E -M -`; |
| 135 | if ($dep =~ /(\S+errno\.h)/) { |
| 136 | push(@file, $1); |
| 137 | } |
| 138 | } elsif ($^O eq 'linux' && |
| 139 | $Config{gccversion} ne '' && |
| 140 | $Config{gccversion} !~ /intel/i && |
| 141 | # might be using, say, Intel's icc |
| 142 | $linux_errno_h |
| 143 | ) { |
| 144 | push(@file, $linux_errno_h); |
| 145 | } elsif ($^O eq 'haiku') { |
| 146 | # hidden in a special place |
| 147 | push(@file, '/boot/system/develop/headers/posix/errno.h'); |
| 148 | |
| 149 | } elsif ($^O eq 'vos') { |
| 150 | # avoid problem where cpp returns non-POSIX pathnames |
| 151 | push(@file, '/system/include_library/errno.h'); |
| 152 | } else { |
| 153 | open(CPPI, '>', 'errno.c') or |
| 154 | die "Cannot open errno.c"; |
| 155 | |
| 156 | print CPPI "#include <errno.h>\n"; |
| 157 | if ($IsMSWin32) { |
| 158 | print CPPI qq[#include "../../win32/include/sys/errno2.h"\n]; |
| 159 | } |
| 160 | |
| 161 | close(CPPI); |
| 162 | |
| 163 | # invoke CPP and read the output |
| 164 | if ($IsMSWin32) { |
| 165 | open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or |
| 166 | die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; |
| 167 | } else { |
| 168 | my $cpp = default_cpp(); |
| 169 | open(CPPO,"$cpp < errno.c |") or |
| 170 | die "Cannot exec $cpp"; |
| 171 | } |
| 172 | |
| 173 | my $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"'; |
| 174 | while(<CPPO>) { |
| 175 | if ($^O eq 'os2' or $IsMSWin32) { |
| 176 | if (/$pat/o) { |
| 177 | my $f = $1; |
| 178 | $f =~ s,\\\\,/,g; |
| 179 | push(@file, $f); |
| 180 | } |
| 181 | } |
| 182 | else { |
| 183 | push(@file, $1) if /$pat/o; |
| 184 | } |
| 185 | } |
| 186 | close(CPPO); |
| 187 | } |
| 188 | return uniq(@file); |
| 189 | } |
| 190 | |
| 191 | # |
| 192 | # |
| 193 | sub uniq |
| 194 | { |
| 195 | # At this point List::Util::uniq appears not to be usable so |
| 196 | # roll our own. |
| 197 | # |
| 198 | # Returns a list with unique values, while keeping the order |
| 199 | # |
| 200 | return do { my %seen; grep { !$seen{$_}++ } @_ }; |
| 201 | } |
| 202 | |
| 203 | sub write_errno_pm { |
| 204 | my $err; |
| 205 | |
| 206 | # quick sanity check |
| 207 | |
| 208 | die "No error definitions found" unless keys %err; |
| 209 | |
| 210 | # create the CPP input |
| 211 | |
| 212 | open(CPPI, '>', 'errno.c') or |
| 213 | die "Cannot open errno.c"; |
| 214 | |
| 215 | print CPPI "#include <errno.h>\n"; |
| 216 | |
| 217 | if ($IsMSWin32) { |
| 218 | print CPPI qq[#include "../../win32/include/sys/errno2.h"\n]; |
| 219 | } |
| 220 | |
| 221 | foreach $err (keys %err) { |
| 222 | print CPPI '"',$err,'" [[',$err,']]',"\n"; |
| 223 | } |
| 224 | |
| 225 | close(CPPI); |
| 226 | |
| 227 | { # BeOS (support now removed) did not enter this block |
| 228 | # invoke CPP and read the output |
| 229 | |
| 230 | my $inhibit_linemarkers = ''; |
| 231 | if ($Config{gccversion} =~ /\A(\d+)\./ and $1 >= 5) { |
| 232 | # GCC 5.0 interleaves expanded macros with line numbers breaking |
| 233 | # each line into multiple lines. RT#123784 |
| 234 | $inhibit_linemarkers = ' -P'; |
| 235 | } |
| 236 | |
| 237 | if ($^O eq 'VMS') { |
| 238 | my $cpp = "$Config{cppstdin} $Config{cppflags}" . |
| 239 | $inhibit_linemarkers . " $Config{cppminus}"; |
| 240 | $cpp =~ s/sys\$input//i; |
| 241 | open(CPPO,"$cpp errno.c |") or |
| 242 | die "Cannot exec $Config{cppstdin}"; |
| 243 | } elsif ($IsMSWin32) { |
| 244 | my $cpp = "$Config{cpprun} $Config{cppflags}" . |
| 245 | $inhibit_linemarkers; |
| 246 | open(CPPO,"$cpp errno.c |") or |
| 247 | die "Cannot run '$cpp errno.c'"; |
| 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'}, $Config{'osvers'} |
| 275 | my ($archname, $osvers) = @Config{'archname', 'osvers'}; |
| 276 | $_ = quotemeta for $archname, $osvers; |
| 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 | use Exporter 'import'; |
| 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-$osvers" or |
| 301 | die "Errno architecture ($archname-$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 | |
| 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/ } sort 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 | # This is the true return value |
| 395 | *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space |
| 396 | |
| 397 | sub NEXTKEY { |
| 398 | each %err; |
| 399 | } |
| 400 | |
| 401 | sub FIRSTKEY { |
| 402 | my $s = scalar keys %err; # initialize iterator |
| 403 | each %err; |
| 404 | } |
| 405 | |
| 406 | sub EXISTS { |
| 407 | my (undef, $errname) = @_; |
| 408 | exists $err{$errname}; |
| 409 | } |
| 410 | |
| 411 | sub _tie_it { |
| 412 | tie %{$_[0]}, __PACKAGE__; |
| 413 | } |
| 414 | |
| 415 | __END__ |
| 416 | |
| 417 | =head1 NAME |
| 418 | |
| 419 | Errno - System errno constants |
| 420 | |
| 421 | =head1 SYNOPSIS |
| 422 | |
| 423 | use Errno qw(EINTR EIO :POSIX); |
| 424 | |
| 425 | =head1 DESCRIPTION |
| 426 | |
| 427 | C<Errno> defines and conditionally exports all the error constants |
| 428 | defined in your system F<errno.h> include file. It has a single export |
| 429 | tag, C<:POSIX>, which will export all POSIX defined error numbers. |
| 430 | |
| 431 | On Windows, C<Errno> also defines and conditionally exports all the |
| 432 | Winsock error constants defined in your system F<WinError.h> include |
| 433 | file. These are included in a second export tag, C<:WINSOCK>. |
| 434 | |
| 435 | C<Errno> also makes C<%!> magic such that each element of C<%!> has a |
| 436 | non-zero value only if C<$!> is set to that value. For example: |
| 437 | |
| 438 | my $fh; |
| 439 | unless (open($fh, "<", "/fangorn/spouse")) { |
| 440 | if ($!{ENOENT}) { |
| 441 | warn "Get a wife!\n"; |
| 442 | } else { |
| 443 | warn "This path is barred: $!"; |
| 444 | } |
| 445 | } |
| 446 | |
| 447 | If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}> |
| 448 | returns C<"">. You may use C<exists $!{EFOO}> to check whether the |
| 449 | constant is available on the system. |
| 450 | |
| 451 | Perl automatically loads C<Errno> the first time you use C<%!>, so you don't |
| 452 | need an explicit C<use>. |
| 453 | |
| 454 | =head1 CAVEATS |
| 455 | |
| 456 | Importing a particular constant may not be very portable, because the |
| 457 | import will fail on platforms that do not have that constant. A more |
| 458 | portable way to set C<$!> to a valid value is to use: |
| 459 | |
| 460 | if (exists &Errno::EFOO) { |
| 461 | $! = &Errno::EFOO; |
| 462 | } |
| 463 | |
| 464 | =head1 AUTHOR |
| 465 | |
| 466 | Graham Barr <gbarr@pobox.com> |
| 467 | |
| 468 | =head1 COPYRIGHT |
| 469 | |
| 470 | Copyright (c) 1997-8 Graham Barr. All rights reserved. |
| 471 | This program is free software; you can redistribute it and/or modify it |
| 472 | under the same terms as Perl itself. |
| 473 | |
| 474 | =cut |
| 475 | |
| 476 | # ex: set ro: |
| 477 | ESQ |
| 478 | |
| 479 | } |