[p5sagit/p5-mst-13.2.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{'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	1	use ExtUtils::MakeMaker;
	2	use Config;
	3	use strict;
	4
	5	use vars qw($VERSION);
	6
6ad8d9a8	7	$VERSION = "1.111";
eab60bb1	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	35	# so only warn under -w, and return
6ad8d9a8	36	warn "Cannot open '$file'" if $^W;
eab60bb1	37	return;
	38	}
	39	}
	40	while(<FH>) {
	41	$err{$1} = 1
dcbf900d	42	if /^\s#\sdefine\s+(E\w+)\s+/;
eab60bb1	43	}
	44	close(FH);
	45	}
	46
def887e8	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	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	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	79	} elsif ($^O eq 'vmesa') {
	80	# OS/390 C compiler doesn't generate #file or #line directives
	81	$file{'../../vmesa/errno.h'} = 1;
eab60bb1	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	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	96	open(CPPO,"$cpp < errno.c \|") or
	97	die "Cannot exec $cpp";
	98	}
eab60bb1	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	106	}
eab60bb1	107	while(<CPPO>) {
2449e420	108	if ($^O eq 'os2' or $^O eq 'MSWin32') {
0196e43b	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	118	}
	119	close(CPPO);
	120	}
	121	return keys %file;
	122	}
	123
	124	sub write_errno_pm {
	125	my $err;
	126
def887e8	127	# quick sanity check
	128
	129	die "No error definitions found" unless keys %err;
	130
eab60bb1	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	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	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	156	open(CPPO,"$cpp < errno.c \|")
dcbf900d	157	or die "Cannot exec $cpp";
eab60bb1	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
	183	\$Config{'myarchname'} eq "$Config{'myarchname'}" or
	184	die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})";
	185
	186	\$VERSION = "$VERSION";
	187	\@ISA = qw(Exporter);
	188
	189	EDQ
	190
	191	my $len = 0;
	192	my @err = sort { $err{$a} <=> $err{$b} } keys %err;
	193	map { $len = length if length > $len } @err;
	194
	195	my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
	196	$j =~ s/(.{50,70})\s/$1\n\t/g;
	197	print $j,"\n";
	198
	199	print <<'ESQ';
	200	%EXPORT_TAGS = (
	201	POSIX => [qw(
	202	ESQ
	203
	204	my $k = join(" ", grep { exists $err{$_} }
	205	qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
	206	EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
	207	ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
	208	EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
	209	EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
	210	EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
	211	ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
	212	ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
	213	ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
	214	EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
	215	ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
	216	ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
	217	EUSERS EWOULDBLOCK EXDEV));
	218
	219	$k =~ s/(.{50,70})\s/$1\n\t/g;
	220	print "\t",$k,"\n )]\n);\n\n";
	221
222	foreach $err (@err) {
223	printf "sub %s () { %d }\n",,$err,$err{$err};
224	}
225
226	print <<'ESQ';
227
228	sub TIEHASH { bless [] }
229
230	sub FETCH {
231	my ($self, $errname) = @_;
232	my $proto = prototype("Errno::$errname");
233	if (defined($proto) && $proto eq "") {
234	no strict 'refs';
235	return $! == &$errname;
236	}
237	require Carp;
238	Carp::confess("No errno $errname");
239	}
240
241	sub STORE {
242	require Carp;
243	Carp::confess("ERRNO hash is read only!");
244	}
245
246	*CLEAR = \&STORE;
247	*DELETE = \&STORE;
248
249	sub NEXTKEY {
250	my($k,$v);
251	while(($k,$v) = each %Errno::) {
252	my $proto = prototype("Errno::$k");
253	last if (defined($proto) && $proto eq "");
254
255	}
256	$k
257	}
258
259	sub FIRSTKEY {
260	my $s = scalar keys %Errno::;
261	goto &NEXTKEY;
262	}
263
264	sub EXISTS {
265	my ($self, $errname) = @_;
266	my $proto = prototype($errname);
267	defined($proto) && $proto eq "";
268	}
269
270	tie %!, __PACKAGE__;
271
272	1;
273	__END__
274
275	=head1 NAME
276
277	Errno - System errno constants
278
279	=head1 SYNOPSIS
280
281	use Errno qw(EINTR EIO :POSIX);
282
283	=head1 DESCRIPTION
284
285	C<Errno> defines and conditionally exports all the error constants
286	defined in your system C<errno.h> include file. It has a single export
287	tag, C<:POSIX>, which will export all POSIX defined error numbers.
288
289	C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
290	value only if C<$!> is set to that value, eg
291
292	use Errno;
293
294	unless (open(FH, "/fangorn/spouse")) {
295	if ($!{ENOENT}) {
296	warn "Get a wife!\n";
297	} else {
298	warn "This path is barred: $!";
299	}
300	}
301
302	=head1 AUTHOR
303
304	Graham Barr <gbarr@pobox.com>
305
306	=head1 COPYRIGHT
307
308	Copyright (c) 1997-8 Graham Barr. All rights reserved.
309	This program is free software; you can redistribute it and/or modify it
310	under the same terms as Perl itself.
311
312	=cut
313
314	ESQ
315
316	}