ext/Errno/Errno_pm.PL

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