Reduce Errno memory usage by around 55%.

[perl5.git] / ext / Errno / Errno_pm.PL

diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL
index a09f9f6..e0e328f 100644 (file)
--- a/ext/Errno/Errno_pm.PL
+++ b/ext/Errno/Errno_pm.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
 use Config;
 use strict;
 
-our $VERSION = "1.09_01";
+our $VERSION = "1.12";
 
 my %err = ();
 my %wsa = ();
@@ -13,7 +13,8 @@ my $IsSymbian = exists $ENV{SDK} && -d "$ENV{SDK}\\epoc32";
 my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian;
 
 unlink "Errno.pm" if -f "Errno.pm";
-open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
+unlink "Errno.tmp" if -f "Errno.tmp";
+open OUT, ">Errno.tmp" or die "Cannot open Errno.tmp: $!";
 select OUT;
 my $file;
 my @files = get_files();
@@ -39,6 +40,9 @@ else {
 }
 write_errno_pm();
 unlink "errno.c" if -f "errno.c";
+close OUT or die "Error closing Errno.tmp: $!";
+select STDOUT;
+rename "Errno.tmp", "Errno.pm" or die "Cannot rename Errno.tmp to Errno.pm: $!";
 
 sub process_file {
     my($file) = @_;
@@ -134,8 +138,16 @@ sub get_files {
     } elsif ($Config{archname} eq 'epoc') {
        # Watch out for cross compiling for EPOC (usually done on linux)
        $file{'/usr/local/epocemx/epocsdk/include/libc/sys/errno.h'} = 1;
+    } elsif ($Config{archname} eq 'arm-riscos') {
+       # Watch out for cross compiling for RISC OS
+       my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
+       if ($dep =~ /(\S+errno\.h)/) {
+            $file{$1} = 1;
+       }
     } elsif ($^O eq 'linux' &&
-            $Config{gccversion} ne '' # might be using, say, Intel's icc
+             $Config{gccversion} ne '' && 
+             $Config{gccversion} !~ /intel/i
+             # might be using, say, Intel's icc
             ) {
        # Some Linuxes have weird errno.hs which generate
        # no #file or #line directives
@@ -147,7 +159,7 @@ sub get_files {
        # we might miss out on compiler-specific ones
        $file{"$ENV{GUSI}include:sys:errno.h"} = 1;
 
-    } elsif ($^O eq 'beos') {
+    } elsif ($^O eq 'beos' || $^O eq 'haiku') {
        # hidden in a special place
        $file{'/boot/develop/headers/posix/errno.h'} = 1;
 
@@ -327,7 +339,7 @@ EOF
 #
 
 package Errno;
-our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD);
+our (\@ISA,\$VERSION);
 use Exporter ();
 use Config;
 use strict;
@@ -340,17 +352,36 @@ use strict;
 \$VERSION = eval \$VERSION;
 \@ISA = qw(Exporter);
 
+my %err;
+
+BEGIN {
+    %err = (
 EDQ
    
-    my $len = 0;
     my @err = sort { $err{$a} <=> $err{$b} } keys %err;
-    map { $len = length if length > $len } @err;
 
-    my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
-    $j =~ s/(.{50,70})\s/$1\n\t/g;
-    print $j,"\n";
+    foreach $err (@err) {
+       print "\t$err => $err{$err},\n";
+    }
 
 print <<'ESQ';
+    );
+    # Generate proxy constant subroutines for all the values.
+    # We assume at this point that our symbol table is empty.
+    # Doing this before defining @EXPORT_OK etc means that even if a platform is
+    # crazy enough to define EXPORT_OK as an error constant, everything will
+    # still work, because the parser will upgrade the PCS to a real typeglob.
+    # We rely on the subroutine definitions below to update the internal caches.
+    # Don't use %each, as we don't want a copy of the value.
+    foreach my $name (keys %err) {
+        $Errno::{$name} = \$err{$name};
+    }
+}
+
+our (@EXPORT_OK, %EXPORT_TAGS);
+
+@EXPORT_OK = keys %err;
+
 %EXPORT_TAGS = (
     POSIX => [qw(
 ESQ
@@ -373,24 +404,14 @@ ESQ
     $k =~ s/(.{50,70})\s/$1\n\t/g;
     print "\t",$k,"\n    )]\n);\n\n";
 
-    foreach $err (@err) {
-       printf "sub %s () { %d }\n",,$err,$err{$err};
-    }
-
     print <<'ESQ';
-
-sub TIEHASH { bless [] }
+sub TIEHASH { bless \%err }
 
 sub FETCH {
-    my ($self, $errname) = @_;
-    my $proto = prototype("Errno::$errname");
-    my $errno = "";
-    if (defined($proto) && $proto eq "") {
-       no strict 'refs';
-       $errno = &$errname;
-        $errno = 0 unless $! == $errno;
-    }
-    return $errno;
+    my (undef, $errname) = @_;
+    return "" unless exists $err{$errname};
+    my $errno = $err{$errname};
+    return $errno == $! ? $errno : 0;
 }
 
 sub STORE {
@@ -402,29 +423,21 @@ sub STORE {
 *DELETE = \&STORE;
 
 sub NEXTKEY {
-    my($k,$v);
-    while(($k,$v) = each %Errno::) {
-       my $proto = prototype("Errno::$k");
-       last if (defined($proto) && $proto eq "");
-    }
-    $k
+    each %err;
 }
 
 sub FIRSTKEY {
-    my $s = scalar keys %Errno::;      # initialize iterator
-    goto &NEXTKEY;
+    my $s = scalar keys %err;  # initialize iterator
+    each %err;
 }
 
 sub EXISTS {
-    my ($self, $errname) = @_;
-    my $r = ref $errname;
-    my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef;
-    defined($proto) && $proto eq "";
+    my (undef, $errname) = @_;
+    exists $err{$errname};
 }
 
-tie %!, __PACKAGE__;
+tie %!, __PACKAGE__; # Returns an object, objects are true.
 
-1;
 __END__
 
 =head1 NAME