ext/Errno/Errno_pm.PL

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