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

use ExtUtils::MakeMaker;
use Config;
use strict;

use vars qw($VERSION);

$VERSION = "1.111";

my %err = ();

unlink "Errno.pm" if -f "Errno.pm";
open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
select OUT;
my $file;
foreach $file (get_files()) {
    process_file($file);
}
write_errno_pm();
unlink "errno.c" if -f "errno.c";

sub process_file {
    my($file) = @_;

    return unless defined $file;

    local *FH;
    if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
	unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
            warn "Cannot open '$file'";
            return;
	}     
    } else {
	unless(open(FH,"< $file")) {
	    # This file could be a temporay file created by cppstdin
	    # so only warn under -w, and return
            warn "Cannot open '$file'" if $^W;
            return;
	}
    }
    while(<FH>) {
	$err{$1} = 1
	    if /^\s*#\s*define\s+(E\w+)\s+/;
   }
   close(FH);
}

sub get_files {
    my %file = ();
    # VMS keeps its include files in system libraries (well, except for Gcc)
    if ($^O eq 'VMS') {
	if ($Config{vms_cc_type} eq 'decc') {
	    $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
	} elsif ($Config{vms_cc_type} eq 'vaxc') {
	    $file{'Sys$Library:vaxcdef.tlb'} = 1;
	} elsif ($Config{vms_cc_type} eq 'gcc') {
	    $file{'gnu_cc_include:[000000]errno.h'} = 1;
	}
    } elsif ($^O eq 'os390') {
	# OS/390 C compiler doesn't generate #file or #line directives
	$file{'/usr/include/errno.h'} = 1;
    } elsif ($^O eq 'vmesa') {
	# OS/390 C compiler doesn't generate #file or #line directives
	$file{'../../vmesa/errno.h'} = 1;
    } else {
	open(CPPI,"> errno.c") or
	    die "Cannot open errno.c";

	print CPPI "#include <errno.h>\n";

	close(CPPI);

	# invoke CPP and read the output
	if ($^O eq 'MSWin32') {
	    open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
		die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
	} else {
	    my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
	    open(CPPO,"$cpp < errno.c |") or
		die "Cannot exec $cpp";
	}

	my $pat;
	if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
	    $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
	}
	else {
	    $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
	}
	while(<CPPO>) {
	    if ($^O eq 'os2') {
		if (/$pat/o) {
		   my $f = $1;
		   $f =~ s,\\\\,/,g;
		   $file{$f} = 1;
		}
	    }
	    else {
		$file{$1} = 1 if /$pat/o;
	    }
	}
	close(CPPO);
    }
    return keys %file;
}

sub write_errno_pm {
    my $err;

    # create the CPP input

    open(CPPI,"> errno.c") or
	die "Cannot open errno.c";

    print CPPI "#include <errno.h>\n";

    foreach $err (keys %err) {
	print CPPI '"',$err,'" [[',$err,']]',"\n";
    }

    close(CPPI);

    # invoke CPP and read the output

    if ($^O eq 'VMS') {
	my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
	$cpp =~ s/sys\$input//i;
	open(CPPO,"$cpp  errno.c |") or
          die "Cannot exec $Config{cppstdin}";
    } elsif ($^O eq 'MSWin32') {
	open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
	    die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
    } else {
	my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
	open(CPPO,"$cpp < errno.c |")
	    or die "Cannot exec $cpp";
    }

    %err = ();

    while(<CPPO>) {
	my($name,$expr);
	next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
	next if $name eq $expr;
	$err{$name} = eval $expr;
    }
    close(CPPO);

    # Write Errno.pm

    print <<"EDQ";
#
# This file is auto-generated. ***ANY*** changes here will be lost
#

package Errno;
use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
use Exporter ();
use Config;
use strict;

\$Config{'myarchname'} eq "$Config{'myarchname'}" or
	die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})";

\$VERSION = "$VERSION";
\@ISA = qw(Exporter);

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";

print <<'ESQ';
%EXPORT_TAGS = (
    POSIX => [qw(
ESQ

    my $k = join(" ", grep { exists $err{$_} } 
	qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
	EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
	ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
	EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
	EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
	EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
	ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
	ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
	ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
	EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
	ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
	ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
	EUSERS EWOULDBLOCK EXDEV));

    $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 FETCH {
    my ($self, $errname) = @_;
    my $proto = prototype("Errno::$errname");
    if (defined($proto) && $proto eq "") {
	no strict 'refs';
        return $! == &$errname;
    }
    require Carp;
    Carp::confess("No errno $errname");
} 

sub STORE {
    require Carp;
    Carp::confess("ERRNO hash is read only!");
}

*CLEAR = \&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
}

sub FIRSTKEY {
    my $s = scalar keys %Errno::;
    goto &NEXTKEY;
}

sub EXISTS {
    my ($self, $errname) = @_;
    my $proto = prototype($errname);
    defined($proto) && $proto eq "";
}

tie %!, __PACKAGE__;

1;
__END__

=head1 NAME

Errno - System errno constants

=head1 SYNOPSIS

    use Errno qw(EINTR EIO :POSIX);

=head1 DESCRIPTION

C<Errno> defines and conditionally exports all the error constants
defined in your system C<errno.h> include file. It has a single export
tag, C<:POSIX>, which will export all POSIX defined error numbers.

C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
value only if C<$!> is set to that value, eg

    use Errno;
    
    unless (open(FH, "/fangorn/spouse")) {
        if ($!{ENOENT}) {
            warn "Get a wife!\n";
        } else {
            warn "This path is barred: $!";
        } 
    } 

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1997-8 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

ESQ

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