[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 temporary 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);
}

my $cppstdin;

sub default_cpp {
    unless (defined $cppstdin) {
	use File::Spec;
	$cppstdin = $Config{cppstdin};
	my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
						File::Spec->updir,
						"cppstdin");
	my $cppstdin_is_wrapper =
	    ($cppstdin eq 'cppstdin'
		and -f $upup_cppstdin
		    and -x $upup_cppstdin);
	$cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
    }
    return "$cppstdin $Config{cppflags} $Config{cppminus}";
}

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 = default_cpp();
	    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' or $^O eq 'MSWin32') {
		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;

    # quick sanity check

    die "No error definitions found" unless keys %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 = default_cpp();
	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{'archname'}-\$Config{'osvers'}" eq
"$Config{'archname'}-$Config{'osvers'}" or
	die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'-\$Config{'osvers'})";

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