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