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